@program agelock.muf
1 1000 d
i
( Age locking system
  (C) 2003 Alynna Trypnotk
  Release Terms: GNU GPL v2, http://www.gnu.org/licenses/gpl.html
  Use anywhere, dont remove credits, return improvements to 
   alynna@animaltracks.net
)
$author Alynna
$version 1.0
$note Locks rooms and exits to certain ages.
$include $lib/alynna
$libdef is18?
$libdef is13?
$libdef is9?
$libdef date2days
$libdef month2days
$libdef year2days
$libdef since1900
$libdef yearsago
$libdef centuryfix
$def setlock "_/lok" swap setprop
$def birthday "/@/bday" getpropstr
$def thisyear date -3 rotate pop pop
lvar param
lvar temp
lvar birthtime
lvar currenttime

: years2days ( i -- f )
365.25 *                                                   ( years to days without leap years )
; PUBLIC years2days
 
: month2days ( i -- f )
 dup  1 = if pop   0.0 exit then
 dup  2 = if pop  31.0 exit then
 dup  3 = if pop  59.0 exit then
 dup  4 = if pop  90.0 exit then
 dup  5 = if pop 120.0 exit then
 dup  6 = if pop 151.0 exit then
 dup  7 = if pop 181.0 exit then
 dup  8 = if pop 212.0 exit then
 dup  9 = if pop 243.0 exit then
 dup 10 = if pop 273.0 exit then
 dup 11 = if pop 303.0 exit then
 dup 12 = if pop 334.0 exit then
; PUBLIC month2days
 
: since1900 ( s -- i )
var mo   var day   var yr
"/" explode pop 
tofloat mo ! 
tofloat day ! 
tofloat yr !
yr @ 1900.0 - years2days
mo @ month2days +
day @ +
; PUBLIC since1900

: centuryfix
var target target !
thisyear 2005 < if
target @ birthday "[01][0-9]/[0123][0-9]/[0-9][0-9]" smatch if 
target @ birthday "/" rsplit atoi thisyear 100 / 1 - 100 * + intostr "/" swap strcat strcat
target @ "/@/bday" rot setprop
then then
; PUBLIC centuryfix

: yearsago ( i -- s )
date -3 rotate pop pop swap - "%m/%d/" systime timefmt swap intostr strcat 
; PUBLIC yearsago

: is18? ( d -- i )
var target target !
target @ centuryfix
target @ birthday strlen 10 = not if 0 exit then                   
target @ birthday since1900 18 yearsago since1900 < if 1 else 0 then
; PUBLIC is18?

: is13? ( d -- i )
var target target !
target @ birthday strlen 10 = not if 0 exit then                   
target @ birthday since1900 13 yearsago since1900 < if 1 else 0 then
; PUBLIC is13?

: is9? ( d -- i )
var target target !
target @ birthday strlen 10 = not if 0 exit then                   
target @ birthday since1900 9 yearsago since1900 < if 1 else 0 then
; PUBLIC is9?

: main
var target
var age
depth 1 = if param ! then
me @ "W" flag? if 
 1 exit                                                 ( Wizzes always pass the agelock )
 then
me @ birthday strlen 10 = not if                        ( Hmm, is the birthday format valid? )
 "Your birthday is not set, or not set properly.   Please set your birthday with @birthday." "Agelock" pretty tellme
 0 exit                                                 ( Scream if not ) 
 then                   
 
command @ "@agelock" smatch if
 param @ "=" explode 2 = not if "Format: @agelock <target>=<age>" "Agelock" pretty tellme exit then
 resolve target ! atoi age !
 target @ int 0 < if "Invalid or ambiguous target." "Agelock" pretty tellme exit then
 me @ target @ controls not if "^RED^Permission denied.^NORMAL^" tellme exit then
 age @ not if "Invalid age." "Agelock" pretty tellme exit then
 target @ room? target @ exit? or not if "Target must be a room or an exit." "Agelock" pretty tellme exit then
 target @ room? if
  target @ "_agelock" age @ tostr setprop
  target @ "_arrive/_agelock" prog setprop
  str "^GREEN^Room " target @ unparseobj " agelocked.^NORMAL^" cat tellme
 then
 target @ exit? if
  target @ "_agelock" age @ tostr setprop
  target @ "$lock/age" setlock pop
  str "^GREEN^Exit " target @ unparseobj " agelocked.^NORMAL^" cat tellme
 then
 then

command @ "@ageunlock" smatch if
 param @ not if "Format: @ageunlock <target>" "Agelock" pretty tellme exit then
 resolve target !
 target @ int 0 < if "Invalid or ambiguous target." "Agelock" pretty tellme exit then
 me @ target @ controls not if "^RED^Permission denied.^NORMAL^" tellme exit then
 target @ room? target @ exit? or not if "Target must be a room or an exit." "Agelock" pretty tellme exit then
 target @ room? if
  target @ "_agelock" 0 setprop
  target @ "_arrive/_agelock" 0 setprop
  str "^GREEN^Room " target @ unparseobj " ageunlocked.^NORMAL^" cat tellme
 then
 target @ exit? if
  target @ "_agelock" age @ tostr setprop
  target @ "$lock/age" setlock pop
  str "^GREEN^Exit " target @ unparseobj " ageunlocked.^NORMAL^" cat tellme
 then
 then

command @ "Queued Event." smatch if 
me @ birthday since1900 trig "_agelock" getpropstr toint yearsago since1900 < not if
 me @ me @ getlink moveto
 str "You were too young to be there, the minimum age is " trig "_agelock" getprop ".  You were sent HOME." cat "Agelock" pretty tellme exit
 then 
then

me @ birthday since1900 18 yearsago since1900 < not if
me @ birthday since1900 me @ location "@rating" envprop swap pop toint yearsago since1900 < not if
 me @ "@rating" envprop swap pop var! rating
 me @ me @ getlink moveto
 str "You were too young to be there, the minimum age is " rating @ ".  You were sent HOME." cat "Agelock" pretty tellme exit
 then
then

me @ birthday since1900 trig "_agelock" getpropstr toint yearsago since1900 < if
 1 exit                                                 ( If old enough, let them through )
 then
0                                                       ( Or not... )

;
.
c
q