; -*-Midas-*-

title BDAY - Happy Birthday Demon.

a=1
b=2
c=3
d=4
e=5
t=6
tt=7

ct=13				; counter
ent=14				; current entry
siz=15				; size of current entry
n=16				; pointer into NAMES
p=17				; pdl ptr

; Channels
lsrch==1			; for LSRTNS
urkch==2			; for CRASH
out=8				; normal output

; Instructions
call=:pushj p,
return=:popj p,
jcall==:jrst
tyo=:.iot out,

; Flags (in 0)
flags==0
%fnick==1_17.			; nickname used
%fname==1_16.			; name used
%fntur==1_15.			; not a turist

define syscall name,args
	.call [setz ? sixbit /name/ ? args(400000)]
termin

define princ &string&
	move t,[440700,,[ascii string]]
	movei tt,.length string
	.call siot
	 call crash
termin

define terpri
	tyo [^M]
	tyo [^J]
termin

define save locs
irp loc,,[locs]
	push p,loc
termin
termin

define restore locs
irp loc,rest,[locs]
	restore [rest]
	pop p,loc
.istop
termin
termin

lpdl==100.
.vector pdl(lpdl)

lbuffer==500.
.vector buffer(lbuffer)		; buffer for small strings
.scalar bufptr			; pointer to start of free string space
.scalar bufct			; count of space free in buffer

.scalar today			; todays month and day

n.flags==0			; name table entry format
n.uname==1
n.name==2
n.length==3
ln==4
lnames==ln*100.			; room for 100. people
.vector names(lnames)		; name table
.scalar nnames			; number of entries

go:	.core ffpage
	 call crash
	move p,[-lpdl,,pdl-1]
	move t,[440700,,buffer]
	movem t,bufptr
	movei t,lbuffer*5
	movem t,bufct
	call datime"timget
	camn a,[-1]
	 call crash
	and a,[datime"tm%day\datime"tm%mon]
	movem a,today
	movei a,lsrch
	move b,[ffpage-400,,ffpage]
	call lsrtns"lsrmap
	 call crash
	.close lsrch,
	move b,lsrtns"lsradr
	move b,lsrtns"hdrdta(b)
	call lsrtns"lsrget
	 call crash
	move ent,b
	movei n,names
	setzm nnames

loop:	hlrz siz,(ent)
	jumpe siz,report
	movei a,lsrtns"i$brth
	call item
	 jrst next
	move d,a
	call datime"engdat
	 jrst next
	and a,[datime"tm%day\datime"tm%mon]
	came a,today
	 jrst next
	tro %fnick\%fname\%fntur
	movei a,lsrtns"i$grp
	call item
	 jrst nogrp
	ildb b,a
	cain b,"T
	 trz %fntur
nogrp:	movei a,lsrtns"i$unam
	call item
	 call crash
	aos nnames
	movem a,n.uname(n)
	movei a,lsrtns"i$nick
	call item
	 jrst nonick
	call search
	 jrst nonick
	jumpe e,win
	cain e,54		; comma
	 jrst win
nonick:	trz %fnick
	movei a,lsrtns"i$name
	call item
	 jrst noname
	move b,bufptr
	call lsrtns"lsrnam
	 jrst noname
	move a,bufptr
	call search
	 jrst noname
	caie e,40		; space
	 jrst noname
	movem b,bufptr
	movni t,1(d)
	addb t,bufct
	caige t,200.		; room for 200. characters?
	 call crash
	jrst win

noname:	trz %fname
	move a,n.uname(n)
	call zlen
	move d,tt
win:	movem flags,n.flags(n)
	movem a,n.name(n)
	movem d,n.length(n)
	addi n,ln
	cail n,names+lnames
	 call crash
next:	add ent,siz
	jrst loop

; A (arg, val): ascii string
; B (val): bp to terminating character.
; D (val): count of letters
; E (val): terminating character
; Skips if at least two letters found
search:	move b,a
	setzi d,
srch1:	ildb e,b
	cail e,"a
	 caile e,"z
	  skipa
	   aoja d,srch1
	cail e,"A
	 caile e,"Z
	  skipa
	   aoja d,srch1
	cail e,"0
	 caile e,"9
	  skipa
	   aoja d,srch1
	cail d,2
	 aos (p)
	return

report:	call open
	princ "HIPY-PAPY-BTHUTHDTH-THUTHDA-BTHUTHDY"
	call subject
	princ "Today's Birthdays"
	call text
	movei n,names
	skiple ct,nnames
	 jrst rprt0
	princ "No birthdays today!"
	terpri
	call close
	call die

rprtlp: addi n,ln
	terpri
rprt0:	sojl ct,wish
	move a,n.uname(n)
	call zprint
	princ "	("
	move t,n.name(n)
	move tt,n.length(n)
	.call siot
	 call crash
	princ ")"
	move flags,n.flags(n)
	trnn %fntur
	 jrst [	princ " T"
		jrst .+1]
	trne %fnick
	 jrst rprtlp
	trne %fname
	 jrst [	princ " +"
		jrst rprtlp]
	princ " *"
	jrst rprtlp

wish:	call close
	skipn wishsw
	 call die
	movei n,names
	skipa ct,nnames
wishlp:	 addi n,ln
	sojl ct,wishz
	move flags,n.flags(n)
	trnn %fntur
	 jrst wishlp
	call open
	move a,n.uname(n)
	call zprint
	call subject
	princ "Happy Birthday!"
	call text
	princ "Happy birthday to you,
Happy birthday to you,
Happy birthday dear "
	move t,n.name(n)
	move tt,n.length(n)
	.call siot
	 call crash
	princ ",
Happy birthday to you.
"
	call close
	jrst wishlp

wishz:	call die

open:	syscall open,[[.uao,,out] ? [sixbit /dsk/]
		[sixbit /_bday_/] ? [sixbit /output/] ? outdir]
	 call crash
	princ "FROM-PROGRAM:BDAY
AUTHOR:DRAGON
HEADER-FORCE:RFC733
RCPT:"
	return

subjec:	princ "
SUBJECT:"
	return

text:	princ "
TEXT;-1
"
	return

close:	syscall renmwo,[movei out ? [sixbit /mail/] ? [sixbit />/]]
	 call crash
	.close out,
	return

datime"$$inf==1
datime"$$out==1
.insrt dsk:syseng;datime

; A (arg): time word
datprt:	move d,bufptr
	call datime"datasc
	move a,bufptr
	jcall zprint

lsrtns"$$ulnm==0
lsrtns"$$ulnp==0
lsrtns"$$ovly==0
.insrt dsk:syseng;lsrtns

; A (arg): item number
; A (val): asciz string
item:	move b,ent
	call lsrtns"lsritm
	 return
hop:	aos (p)
cpopj:	return

; A (arg, val): asciz string
zprint:	call zlen
	move t,a
	.call siot
	 call crash
	return

; A (arg, val): asciz string
; TT (val): its length
zlen:	setzi tt,
	move e,a
lngth1:	ildb t,e
	jumpe t,cpopj
	aoja tt,lngth1

.scalar crashx,bchn,bchnst,losepc

; AAAIIIIEEEEE!!!!!!
crash:	skipe debug
	 jrst crash1
	.core ffpage
	 call die		; ???
	.suset [.rbchn,,bchn]
	syscall status,[move bchn ? movem bchnst]
	 jfcl
	syscall open,[[.uio,,urkch] ? [sixbit /dsk/]
			[sixbit /bday/] ? [sixbit />/] ? [sixbit /crash/]]
	 call die		; ???
	setz crashx
	push p,0		; PDUMP misses the flags...
	syscall pdump,[movei %jself ? movei urkch ? crashx]
	 call die		; ???
	.iot urkch,[jrst crashr]
	.iot urkch,[jrst crashr]
	.close urkch,
	call die

crashr:	pop p,0
crash1:	pop p,losepc
	sos losepc
	sos losepc
	syscall lose,[movei 0 ? losepc]
	 .lose %lssys

die:	skipe debug
	 .value
	.logout 1,

siot:	setz
	sixbit /siot/
	movei out
	move t
	setz tt

monlen:	31. ? 29. ? 31. ? 30. ? 31. ? 30.
	31. ? 31. ? 30. ? 31. ? 30. ? 31.

cnstnt:
constants
variables

outdir:	sixbit /.mail./		; directory to write mail queue files
debug:	0			; Non-0 => dubug mode
wishsw:	-1			; Non-0 => actually send messages

ffpage==:<<.-1>_-10.>+1
ffaddr=:ffpage_10.

end go