tvfrob.1
<DEFINE MAKE.QUESTIONS ("AUX" TYPE (OUTCHAN ,OUTCHAN) (TVS ,TVSPACE2)
(TVA ,TVASS) (TVS1 ,TVSPACE1) ITM VEC NEW
COMPLEX?)
#DECL ((QUTCHAN) <CHANNEL FIX [9 STRING]> (TVS TVS1) SPACE (TVA) ASYLUM
(VEC) VECTOR (ITM) <LIST [REST FIX]> (NEW) <OR FALSE FIX>
(COMPLEX?) <OR ATOM FALSE>)
<SET-STATUS ,$SMAKE>
<REPEAT (Q QUES HIQ QNUM (COAUTH 0))
#DECL ((Q) <OR FALSE LIST> (QUES) VECTOR (HIQ) <OR FALSE MANIAC> (QNUM) FIX
(COAUTH) <OR FIX <LIST [REST STRING]>>)
<AND ,FLUSH <FLUSH-EM>>
<ARESET .TVS>
<PROG ()
<SET TYPE
<READER ,QTYPES
<TP "Question type: ">
'["" ""]
'["SYM"]
,VERBOSE>>
<AND .TYPE
<==? <2 .TYPE> ,$TCOAUTH>
<SET COAUTH <BUFLEX <STRING <GETBUF "Other authors: ">>>>
<AGAIN>>>
<COND (<NOT .TYPE> <RETURN>) (<SET TYPE <2 .TYPE>>)>
<COND (<0? .TYPE> <RETURN>)>
<SET-STATUS ,$SMAKE .TYPE>
<SET COMPLEX? <N==? .TYPE ,$TSIMPLE>>
<COND
(<SET Q <APPLY <NTH ,MAKERS .TYPE>>>
<SET QUES <AVECTOR .TVS 0 0 0 0 0 0 0 0 !.Q>>
<PUT .QUES ,QAUTH <ACOPY .TVS ,PLAYER>>
<PUT .QUES ,QTYPE .TYPE>
<COND (.COMPLEX?
<PROG (TMP)
<COND (<SET TMP <DATA-RESERVE .TVA 1>>
<PUT .QUES ,QSCORE .TMP>)
(T <AGAIN>)>>
<PUT .QUES
,QCAT
<REPEAT (BAR)
#DECL ((BAR) <OR SYMBOL FALSE>)
<COND (<SET BAR
<READER ,CATS
<TP "Category: ">
""
["SYM"]
,VERBOSE>>
<RETURN <2 .BAR>>)>>>
<PUT .QUES
,QVAL
<REPEAT (SC)
#DECL ((SC) <OR FALSE FIX FLOAT>)
<COND (<AND <SET SC
<READER []
<TP "Value: ">
'[
"
Enter the value of this question (maximum 2.0)"
""]
'["FIX" "FLOAT"]
,VERBOSE>>
<L=? .SC 2>
<G=? .SC 0>>
<RETURN <FLOAT .SC>>)>>>)>
<CRLF>
<PUT .QUES ,QCOAUTH <ACOPY .TVS .COAUTH>>
<PUT .QUES
,QQNUM
<SET QNUM <CHTYPE <DATA-READW .TVA ,HIQNUM> FIX>>>
<DATA-PRINTW .TVA ,HIQNUM <+ .QNUM 1>>
<PUT <SET FOOV ,TTUV> 1 .QNUM>
<PUT-LOC <+ ,PG ,BABBLE-HIQ> .FOOV>
<COND
(<SET NEW <CHAIN-APPEND .TVA .TVS .QUES ,HIQLOC>>
<COND (.COMPLEX?
<DATA-PRINTW
.TVA
<+ ,1STCAT <NTH .QUES ,QCAT>>
<+ <NTH .QUES ,QVAL>
<CHTYPE <DATA-READW .TVA <+ ,1STCAT <NTH .QUES ,QCAT>>>
FLOAT>>>
<DATA-PRINTW .TVA
,TOTSCR
<+ <NTH .QUES ,QVAL>
<CHTYPE <DATA-READW .TVA ,TOTSCR> FLOAT>>>
<AND <SET HIQ <DATA-OPEN "PRINT" .TVA <+ ,LUBLK ,QASKED>>>
<SET VEC <DATA-IREAD .TVA .HIQ <ARESET .TVS1>>>
<SET ITM <NTH .VEC <NTH .QUES ,QCAT>>>
<SET ITM <PUTREST <ALIST .TVS1 <NTH .QUES ,QQNUM>> .ITM>>
<PUT .VEC
<NTH .QUES ,QCAT>
<PUTREST <ALIST .TVS1 .NEW> .ITM>>
<DATA-IPRINT .TVA .HIQ .TVS1 .VEC>
<DATA-CLOSE .TVA .HIQ>>)>
<CRLF>
<PRINC "Question is #">
<PRIN1 .QNUM>)
(<PERR "Can't make new question, MAKE.QUESTION" .QUES>)>)
(<CRLF> <PRINC "ERROR - "> <PRINC <1 .Q>> <CRLF>)>>>
<DEFINE MAKE.MATCH ("OPTIONAL" UPDATE "AUX" C1 C2 TBL KEY HDR)
#DECL ((C1 C2) <OR FALSE <LIST [REST STRING]>> (KEY) <OR FALSE LIST>
(TBL) SYMTABLE (UPDATE) VECTOR (HDR) STRING)
<PROG ()
<COND (<AND <SET HDR <GETBUF "Heading: ">>
<NOT <QUESTIONABLE? .HDR>>
<SET C1 <GRAB-BUNCH "Column A #">>
<SET C2 <GRAB-BUNCH "Column B #">>>
<SET TBL <MAKESST "TBL" <UNTASTEFUL-CODE .C2>>>
<COND (<SET KEY <GRAB-ANSWERS .C1 .TBL>>
(.C1 .C2 .KEY <GETBUF "Comment: "> .HDR))>)
(T '#FALSE ("Question aborted"))>>>
<DEFINE GRAB-ANSWERS (C1 TBL "AUX" (CURSPACE ,TVSPACE2) LST)
#DECL ((C1) <SPECIAL <LIST [REST STRING]>> (TBL) SYMTABLE
(LST) <OR LIST FALSE> (CURSPACE) <SPECIAL SPACE>)
<SET LST
<MAPF ,ALLIST
<FUNCTION (MCHOICE "AUX" CA)
#DECL ((MCHOICE) STRING (CA) <OR FALSE SYMBOL>)
<SETG MATCH .MCHOICE>
<PRINC "
For ">
<PRINC .MCHOICE>
<COND (<SET CA
<READER .TBL
"which is the correct match? "
'["" ""]
'["SYM"]
,VERBOSE>>
<MAPRET <ACOPY .CURSPACE <2 .CA>>>)
(<MAPLEAVE
#FALSE ("No correct answer given")>)>>
.C1>>
<GUNASSIGN MATCH>
.LST>
<DEFINE MAKE.TF ("OPTIONAL" UPDATE)
#DECL ((UPDATE) VECTOR)
<COND (<ASSIGNED? UPDATE> <MAKE.MC T .UPDATE>)
(<MAKE.MC T>)>>
<DEFINE MAKE.REGULAR ("OPTIONAL" UPDATE "AUX" Q A (CURSPACE ,TVSPACE2) HINTS)
#DECL ((Q A) <OR FALSE STRING> (UPDATE HINTS) VECTOR
(CURSPACE) <SPECIAL SPACE>)
<COND
(<EMPTY? <SET Q
<GETBUF "Question: "
""
<COND (<ASSIGNED? UPDATE>
<NTH .UPDATE <+ ,QQUES 1>>)>>>>
'#FALSE ("Question aborted"))
(<QUESTIONABLE? .Q> '#FALSE ("Empty question"))
(<AND
<SET HINTS
<MAPF ,ALVECTOR
<FUNCTION ("AUX" HINT NVALUE)
#DECL ((HINT) STRING (NVALUE) <OR FALSE FLOAT>)
<COND (<AND <SET HINT <GETBUF "Hint: " "">>
<NOT <QUESTIONABLE? .HINT>>
<PROG ()
<COND (<OR <G=? <SET NVALUE
<READER []
"Fractional credit "
""
'["FLOAT"]
,VERBOSE>>
1.000>
<L=? .NVALUE 0.000>>
<CRLF>
<PRINC "Out of range">
<AGAIN>)>
.NVALUE>>
<MAPRET .HINT .NVALUE>)
(<MAPSTOP>)>>>>
<>>)
(<EMPTY?
<SET A
<PROG ((aprompt .Q))
#DECL ((aprompt) <SPECIAL STRING>)
<GETBUF "Answer: "
""
<COND (<ASSIGNED? UPDATE>
<COND (<G=? <LENGTH .UPDATE> <+ ,QQUES 2>>
<NTH .UPDATE <+ ,QQUES 2>>)
("")>)>>>>>
(.Q <ALSTRING>))
(<QUESTIONABLE? .A> (.Q <ALSTRING>))
(ELSE (.Q .A .HINTS))>>
<DEFINE GRAB-BUNCH (STR "AUX" FROB FROBS (IDX 1) (TVS ,TVSPACE2))
#DECL ((STR) STRING (FROB) STRING (FROBS) LIST (IDX) FIX)
<COND
(<NOT <EMPTY? <SET FROB <GETBUF <STRING .STR "1: ">>>>>
<SET FROBS <ALIST .TVS .FROB>>
<REPEAT ((CRUFT .FROBS))
<SET FROB
<GETBUF <STRING .STR
<UNPARSE <SET IDX <+ .IDX 1>>>
": ">>>
<COND (<QUESTIONABLE? .FROB> <RETURN .FROBS>)>
<SET CRUFT <REST <PUTREST .CRUFT <ALIST .TVS .FROB>>>>>)
('#FALSE ("Question aborted"))>>
<DEFINE MAKE.MC ("OPTIONAL" (T/F <>) UPDATE
"AUX" QUESTION ANSWER ANSWERS CORRECT.ANSWER TBL)
#DECL ((QUESTION ANSWER) STRUCTURED (T/F) <OR 'T VECTOR FALSE>
(ANSWERS) <OR FALSE <LIST [REST STRING]>> (UPDATE) VECTOR)
<AND <TYPE? .T/F VECTOR> <SET UPDATE .T/F> <SET T/F <>>>
<PROG ()
<SET QUESTION
<GETBUF "Question: "
""
<COND (<ASSIGNED? UPDATE>
<NTH .UPDATE <+ ,QQUES 1>>)>>>
<COND (<EMPTY? .QUESTION> <RETURN '#FALSE ("Question aborted")>)
(<QUESTIONABLE? .QUESTION>
<RETURN '#FALSE ("Empty QUESTION")>)>
<COND (.T/F
<SET ANSWERS
(<ASTRING ,TVSPACE2 "True">
<ASTRING ,TVSPACE2 "False">)>)
(T
<COND (<SET ANSWERS <GRAB-BUNCH "Answer#">>
<COND (<L? <LENGTH .ANSWERS> 2>
<RETURN '#FALSE ("Too few choices")>)>)
(<RETURN '#FALSE ("Question aborted")>)>)>
<SET CORRECT.ANSWER
<READER <SET TBL <MAKESST "FJB" <UNTASTEFUL-CODE .ANSWERS>>>
<TP "Correct answer is ">
'["" ""]
'["SYM"]
,VERBOSE>>
<COND (.CORRECT.ANSWER
(.QUESTION
<GETBUF "Comment: " .QUESTION>
<2 .CORRECT.ANSWER>
!.ANSWERS))
('#FALSE ("No correct answer given"))>>>
<SETG MAKERS
[,COMMAND
,MAKE.REGULAR
,MAKE.MATCH
,MAKE.MC
,MAKE.TF
,QUIT
,MAKE.REGULAR]>
<SETG SCORED? <>>
<GDECL (SCORED?) <OR ATOM FALSE>>
<DEFINE ASK.QUESTIONS ("AUX" QUESTION? QUESTION (OUTCHAN .OUTCHAN))
#DECL ((QUESTION?) <SPECIAL <OR VECTOR FALSE>> (QUESTION) VECTOR
(OUTCHAN) CHANNEL)
<UNWIND
<REPEAT ()
<TERPRI>
<COND (,FLUSH <FLUSH-EM>)
(<SET QUESTION? <GETNEXTQ>>
<SET-STATUS ,$SASK <NTH .QUESTION? ,QQNUM>>
<SET QUESTION .QUESTION?>
<ARESET ,TVSPACE2>
<COND (<OR <=? ,PLAYER <NTH .QUESTION ,QAUTH>>
<AND <N==? <NTH .QUESTION ,QCOAUTH> 0>
<MEMBER ,PLAYER <NTH .QUESTION ,QCOAUTH>>>>)
(<APPLY <NTH ,ASKERS <NTH .QUESTION ,QTYPE>>
.QUESTION>)>
<PROGRESS>
<SETG SCORED? <>>
<COND (<OR ,KEEPASKING
<PROG topask ()
#DECL ((topask) <SPECIAL ACTIVATION>)
<TRUE? "More "
"Y/N"
'(!"Y !"y)
'(!"N !"n)
<ASCII 22>>>>)
(<RETURN>)>)
(T <RETURN <>>)>>
<COND (,SCORED? <SET SCORED? <>> <PROGRESS>)>>>
<DEFINE GETNEXTQ ("AUX" (QHI <+ ,QNEXT ,LUBLK>) (TVA ,TVASS) (TVS ,TVSPACE)
(QNM <THISQ>) Q)
#DECL ((QHI QNM) FIX (TVS) SPACE (TVA) ASYLUM (Q) <OR FALSE VECTOR>)
<PROG ()
<COND (<N==? .QNM 0>
<COND (<SET Q <DATA-AREAD .TVA .QNM <ARESET .TVS>>>
<PQHEADER .Q>
.Q)
(<PROGRESS> <AGAIN>)>)>>>
<DEFINE PQHEADER (Q)
#DECL ((Q) VECTOR)
<CRLF>
<PRINC "Question #">
<PRIN1 <NTH .Q ,QQNUM>>
<PRINC " by ">
<PRINC <NTH .Q ,QAUTH>>
<COND (<N==? <NTH .Q ,QCOAUTH> 0>
<PRINC " with ">
<MAPF <>
<FUNCTION (X) <PRINC .X> <PRINC " ">>
<NTH .Q ,QCOAUTH>>)>
<COND (<==? <NTH .Q ,QTYPE> 7> <PRINC " Worthless">)
(<PRINC " Category: ">
<PRINC <NTH <2 ,CATS> <- <* 2 <NTH .Q ,QCAT>> 1>>>
<PRINC " Worth: ">
<PRIN1 <NTH .Q ,QVAL>>
<PRINC " points">)>
<CRLF>
<CRLF>>
<DEFINE THISQ ("AUX" (TVA ,TVASS) (QHI <+ ,LUBLK ,QNEXT>))
<CHTYPE <DATA-READW .TVA <CHTYPE <DATA-READW .TVA .QHI> FIX>>
FIX>>
<DEFINE PROGRESS ("AUX" (QHI <+ ,QNEXT ,LUBLK>) (TVA ,TVASS)
(QNM <CHTYPE <DATA-READW .TVA .QHI> FIX>) QNXT)
#DECL ((QHI QNM QNXT) FIX (TVA) ASYLUM)
<COND (<0? <SET QNXT <CHTYPE <DATA-READW .TVA .QNM> FIX>>>)
(<DATA-PRINTW .TVA .QHI .QNXT>
<PROG ((LOC <+ ,PG ,BABBLE-START ,TINDEX>) (TBUV ,TBUV))
#DECL ((LOC) FIX (TBUV) <UVECTOR [4 FIX]>)
<COND (<DHLOCK .LOC>
<GET-LOC .LOC .TBUV>
<PUT .TBUV
2
<PUTBITS <2 .TBUV>
<BITS 18 0>
<GETLASTQ ,LUBLK>>>
<PUT-LOC .LOC .TBUV>
<DUNLOCK .LOC>)
(<SLEEP 2> <AGAIN>)>>)>>
<DEFINE ASK.MC (Q
"AUX" (RQ <REST .Q ,QQUES>) ANSWER ANSNUM CORRECT
(TVS ,TVSPACE2) (SEEN 0))
#DECL ((Q RQ) VECTOR (SEEN ANSNUM CORRECT) FIX (TVS) SPACE)
<UNWIND
<PROG ()
<SET CORRECT <3 .RQ>>
<PUT <2 <2 ,ALLSYMS>> 2 <UNTASTEFUL-CODE <REST .RQ 3>>>
<PRINC <1 .RQ>>
<MSTPOSSYM!-ICALSYM "" 0 <2 ,ALLSYMS>>
<SET ANSWER
<READER ,ALLSYMS
<TP "Take your pick: ">
'["" ""]
'["SYM"]
,VERBOSE>>
<CRLF>
<AND .ANSWER <SET ANSNUM <2 .ANSWER>>>
<INT-LEVEL 20>
<SET SEEN 1>
<COND (<==? .ANSNUM .CORRECT>
<PRINC "Right! ">
<ADDSCORE ,PLAYER .Q <NTH .Q ,QVAL>>
<SET SEEN 0>)
(T
<COND (<NOT .ANSWER> <PRINC "Chicken! ">)
(<PRINC "Wrong! ">)>
<PRINC "The correct answer is ">
<PRINC <NTH <REST .RQ 3> .CORRECT>>
<PRINC !".>
<ADDSCORE ,PLAYER .Q 0>
<SET SEEN 0>)>
<SETG SCORED? T>
<INT-LEVEL 0>
<AND <ANSWER?>
<CRLF>
<NOT <QUESTIONABLE? <2 .RQ>>>
<PRINC "Comment: ">
<PRINC <2 .RQ>>
<CRLF>>
<SEND-PLAYER
<NTH .Q ,QAUTH>
<ANS-VEC .Q
<COND (<==? .ANSNUM .CORRECT> <ASTRING .TVS " won.">)
(<NOT .ANSWER> <ASTRING .TVS ,IDUNNO>)
(<ASTRING .TVS
" lost with "
<REST <MEMBER ". " <1 .ANSWER>> 2>>)>>>
<CRLF>>
<COND (<1? .SEEN>
<COND (<==? .ANSNUM .CORRECT> <ADDSCORE ,PLAYER .Q <QVAL .Q>>)
(T <ADDSCORE ,PLAYER .Q 0>)>
<SETG SCORED? T>)>>>
<SETG IDUNNO " gave up.">
<DEFINE ASK.REGULAR (Q
"AUX" (RQ <REST .Q ,QQUES>) ANSWER (TVA ,TVASS)
(CURSPACE ,TVSPACE1) (TVS ,TVSPACE2) (SEEN 0)
(HVAL -1.000) (HNUM 0))
#DECL ((Q RQ) VECTOR (ANSWER) STRING (TVA) ASYLUM (TVS) SPACE (SEEN HNUM) FIX
(HVAL) FLOAT (CURSPACE) <SPECIAL SPACE>)
<UNWIND
<PROG ((QVAL <QVAL .Q>)
(HINTS <COND (<LENGTH? .RQ 2> '[]) (<3 .RQ>)>))
#DECL ((HINTS) VECTOR (QVAL) <OR FLOAT FIX>)
<PRINC <1 .RQ>>
<PROG ()
<SET ANSWER
<GETBUF
<ASTRING <ARESET .CURSPACE>
<MAPR ,ALSTRING
<FUNCTION (X)
<COND (<==? .X .HINTS> <MAPSTOP>)
(<TYPE? <1 .X> STRING>
<MAPRET "Hint: " <1 .X> "
">)
(<MAPRET>)>>
<TOP .HINTS>>
<COND (<EMPTY? .HINTS> "
Your answer: ")
(<ASTRING .CURSPACE
"
Your answer [Hint for "
<UNPARSE <* .QVAL <2 .HINTS>>>
" points] : ">)>>
<1 .RQ>>>
<COND (<AND <QUESTIONABLE? .ANSWER> <NOT <EMPTY? .HINTS>>>
<CRLF>
<SET HNUM <+ .HNUM 1>>
<SET HVAL <* <2 .HINTS> .QVAL>>
<SET HINTS <REST .HINTS 2>>
<AGAIN>)>>
<COND (<N==? <LENGTH .RQ> 1>
<AND <ANSWER?>
<SET SEEN 1>
<CRLF>
<PRINC "Answer is: ">
<PRINC <2 .RQ>>
<CRLF>>)>
<INT-LEVEL 20>
<COND (<QUESTIONABLE? .ANSWER>
<ADDSCORE ,PLAYER .Q 0.000>
<SEND-PLAYER <NTH .Q ,QAUTH>
<ANS-VEC .Q <ASTRING .TVS " gave up."> .SEEN>>)
(T
<SEND-PLAYER <NTH .Q ,QAUTH>
<ANS-VEC .Q .ANSWER .SEEN .HNUM .HVAL>>)>
<SETG SCORED? T>
<INT-LEVEL 0>
<CRLF>>
<COND (<1? .SEEN>
<COND (<QUESTIONABLE? .ANSWER> <ADDSCORE ,PLAYER .Q 0.000>)
(T <SEND-PLAYER <QAUTH .Q> <ANS-VEC .Q .ANSWER .SEEN>>)>
<SETG SCORED? T>)>>>
<DEFINE ASK.SIMPLE (Q
"AUX" (RQ <REST .Q ,QQUES>) ANSWER (TVS ,TVSPACE2)
(SEEN 0))
#DECL ((Q RQ) VECTOR (ANSWER) STRING (TVS) SPACE (SEEN) FIX)
<COND
(,IGNORE-SIMPLE)
(<PRINC <1 .RQ>>
<COND (<N==? <LENGTH .RQ> 1>
<AND <ANSWER?>
<SET SEEN 1>
<CRLF>
<PRINC "Answer is: ">
<PRINC <2 .RQ>>
<CRLF>
<SET ANSWER <GETBUF "Nonsense: " <1 .RQ>>>
<COND (<NOT <QUESTIONABLE? .ANSWER>>
<SEND-PLAYER <NTH .Q ,QAUTH>
<ANS-VEC .Q .ANSWER .SEEN>>)>>)
(T
<CRLF>
<SET ANSWER <GETBUF "Nonsense: " <1 .RQ>>>
<COND (<NOT <QUESTIONABLE? .ANSWER>>
<SEND-PLAYER <NTH .Q ,QAUTH>
<ANS-VEC .Q .ANSWER .SEEN>>)>)>
<CRLF>)>>
<DEFINE ANS-VEC (Q "TUPLE" STUFF "AUX" (TVS ,TVSPACE2))
#DECL ((Q) VECTOR (STUFF) TUPLE (TVS) SPACE)
<AVECTOR .TVS
<THISQ>
<NTH .Q ,QTYPE>
<ACOPY .TVS ,PLAYER>
!.STUFF>>
<SETG MATBL <MAKEGST "FROB" [0 T]>>
<SETG MBTBL <MAKESST "FROB" []>>
<SETG MATCH-SYMBOL <CHTYPE ["" 0] SYMBOL>>
<SETG MATCH-SYM ["SYM" "DEF" ,MATCH-SYMBOL]>
<GDECL (MATCH-SYMBOL)
SYMBOL
(MATCH-SYM)
<VECTOR STRING STRING SYMBOL>>
<DEFINE GRAB-MATCH ("AUX" (A ,MATBL) (B ,MBTBL) (S ,MATCH-SYMBOL)
(CURSPACE ,TVSPACE2) (QUIT-D '["" -1])
(AVEC <REST <2 .A> 2>) (SYM ,MATCH-SYM))
#DECL ((A B) SYMTABLE (CURSPACE) <SPECIAL SPACE>
(SYM AVEC QUIT-D) VECTOR (S) SYMBOL)
<PUT .S 2 .AVEC>
<PUT .S 1 <1 .AVEC>>
<REPEAT (ACH BCH TEMP MSTR (TACH <REST <2 .A> 2>))
#DECL ((ACH BCH TEMP) <OR FALSE <PRIMTYPE VECTOR>>
(TACH) <VECTOR ANY ANY> (MSTR) STRING)
<GUNASSIGN MATCH>
<COND (<AND <SET ACH <READER .A "
Match " "" .SYM ,VERBOSE>>
<N==? <2 <SET ACH <2 .ACH>>> -1>>
<SETG MATCH <MEMQ !". <1 .ACH>>>
<COND (<SET BCH <READER .B "with " "" '["SYM"] ,VERBOSE>>
<PUT .ACH 2 <2 .BCH>>
<SET MSTR <MEMQ <ASCII 46> <1 .ACH>>>
<PUT .MSTR 2 <ASCII 91>>
<PUT .MSTR 3 <ASCII <+ 48 </ <2 .BCH> 10>>>>
<AND <==? <3 .MSTR> <ASCII 48>>
<PUT .MSTR 2 <ASCII 32>>
<PUT .MSTR 3 <ASCII 91>>>
<PUT .MSTR 4 <ASCII <+ 48 <MOD <2 .BCH> 10>>>>
<PUT .MSTR 5 <ASCII 93>>)>
<COND (<SET TEMP <MEMQ 0 .TACH>>
<PUT .S 2 <SET TEMP <BACK .TEMP>>>
<PUT .S 1 <1 .TEMP>>)
(T <PUT .S 1 ""> <PUT .S 2 .QUIT-D>)>)
(<RETURN <MAPF ,ALLIST
<FUNCTION (X)
<COND (<TYPE? .X FIX> .X)
(<MAPRET>)>>
<REST <2 ,MATBL> 2>>>)>>>
<DEFINE ASK.MATCH (Q
"AUX" (RQ <REST .Q ,QQUES>) (TVS ,TVSPACE2) LOSER EACH TBL
SCORE)
#DECL ((Q RQ) VECTOR (TVS) SPACE (LOSER) <OR LIST FALSE>
(EACH SCORE) FLOAT (TBL) SYMTABLE)
<CRLF>
<MATCH-PRINT .RQ>
<PUT ,MBTBL 2 <UNTASTEFUL-CODE <2 .RQ>>>
<PUT ,MATBL 2 <UNTASTEFUL-CODE <1 .RQ> T>>
<SET LOSER <GRAB-MATCH>>
<SET EACH </ <NTH .Q ,QVAL> <FLOAT <LENGTH .LOSER>>>>
<INT-LEVEL 20>
<ADDSCORE ,PLAYER
.Q
<SET SCORE
<MAPF ,+
<FUNCTION (X Y)
<COND (<N==? .X .Y> 0.000) (.EACH)>>
.LOSER
<3 .RQ>>>>
<SETG SCORED? T>
<INT-LEVEL 0>
<PRINC "
Score of ">
<PRIN1 .SCORE>
<AND <ANSWER?>
<PRINC "
Correct matchings:">
<MATCH-PRINT .RQ T <> <>>
<CRLF>
<NOT <QUESTIONABLE? <4 .RQ>>>
<PRINC "Comment: ">
<PRINC <4 .RQ>>>
<AND <NOT .LOSER> <SET LOSER <CHTYPE <ALIST .TVS> FALSE>>>
<SEND-PLAYER <NTH .Q ,QAUTH> <ANS-VEC .Q .SCORE .LOSER>>>
<DEFINE MATCH-PRINT (RQ "OPTIONAL" (CORRECT <>) C3 (PRINT-HEAD T))
#DECL ((RQ) VECTOR (CORRECT) <OR 'T FALSE> (C3) <OR FALSE LIST>)
<COND
(<OR <NOT .CORRECT> <AND .CORRECT <SET C3 <3 .RQ>>>>
<CRLF>
<COND (.PRINT-HEAD <PRINC <5 .RQ>> <CRLF>)>
<PRINC "
Column A Column B
">
<REPEAT ((C1 <1 .RQ>) (C2 <2 .RQ>) (IDX 1))
#DECL ((C1 C2) LIST (IDX) FIX)
<COND (<AND <EMPTY? .C1> <EMPTY? .C2> <RETURN>>)
(<EMPTY? .C1>
<AND .CORRECT <RETURN>>
<FORMAT <1 .C2> 36 .IDX>
<SET C2 <REST .C2>>)
(<EMPTY? .C2>
<PRIN1 .IDX>
<PRINC ". ">
<PRINC <1 .C1>>
<SET C1 <REST .C1>>)
(T
<FORMAT <1 .C1> 0 .IDX>
<FORMAT <COND (.CORRECT
<COND (<0? <1 .C3>> "--gave up--")
(<NTH <2 .RQ> <1 .C3>>)>)
(<1 .C2>)>
36
.IDX>
<SET C1 <REST .C1>>
<SET C2 <REST .C2>>)>
<AND .CORRECT <SET C3 <REST .C3>>>
<SET IDX <+ .IDX 1>>
<CRLF>>)
(<PRINC "
Gave up.">)>>
<DEFINE FORMAT (STR NUM "OPTIONAL" IDX)
#DECL ((STR) STRING (NUM IDX) FIX)
<COND (<0? .NUM>) (<INDENT-TO .NUM>)>
<AND <ASSIGNED? IDX> <PRINC .IDX> <PRINC ". ">>
<COND (<G? <LENGTH .STR> 33> <PRINC .STR> <CRLF>)
(<PRINC .STR>)>>
<SETG ASKERS
[,TIME
,ASK.REGULAR
,ASK.MATCH
,ASK.MC
,ASK.MC
,TIME
,ASK.SIMPLE]>
<DEFINE GRADE.STUFF ()
<SET-STATUS ,$SGRADE>
<DATA-PRINTW ,TVASS <+ ,LUBLK ,LASTGRD> <DSKDATE>>
<REPEAT ()
<AND ,FLUSH <FLUSH-EM>>
<COND (<CHAIN-FOLLOW ,READERS ,ANEXT ,ALAST>) (<RETURN>)>>>
<DEFINE READ.MAIL ()
<SET-STATUS ,$SREAD>
<REPEAT ()
<AND ,FLUSH <FLUSH-EM>>
<COND (<CHAIN-FOLLOW ,MREADERS ,MNEXT ,MLAST>) (<RETURN>)>>>
<DEFINE PRINT.MAIL (ML)
#DECL ((ML) VECTOR)
<PRINC "
Message from ">
<PRINC <3 .ML>>
<PDSKDATE <SETG LASTMAIL <4 .ML>>>
<CRLF>
<PRINC <1 .ML>>>
<SETG MREADERS [,PRINT.MAIL]>
<DEFINE READ.COMM (A "AUX" Q.A)
#DECL ((A Q.A) VECTOR)
<SET Q.A <QPRINT .A>>
<PRINC " awarded ">
<PRIN1 <4 .A>>
<PRINC " points out of ">
<PRIN1 <QVAL .Q.A>>
<COND (<QUESTIONABLE? <5 .A>> <PRINC ".">)
(<PRINC " and said
'"> <PRINC <5 .A>> <PRINC "'">)>>
<DEFINE READ.SANS (A "AUX" Q.A)
#DECL ((A Q.A) VECTOR)
<SET Q.A <QPRINT .A>>
<PRINC " said
'">
<PRINC <NTH .A ,ARESP>>
<PRINC <ASCII 39>>>
<DEFINE READ.MATCH (A "AUX" Q.A KEY)
#DECL ((A Q.A) VECTOR (KEY) <OR FALSE <LIST [REST FIX]>>)
<SET Q.A <QPRINT .A T>>
<PRINC " scored ">
<PRIN1 <NTH .A ,ARESP>>
<PRINC " points ">
<COND (<SET KEY <5 .A>>
<PUT .Q.A <+ ,QQUES 3> .KEY>
<MATCH-PRINT <REST .Q.A ,QQUES> T <> <>>)
(<PRINC " by giving up.">)>
<CRLF>>
<DEFINE READ.MC (A "AUX" Q.A)
#DECL ((A Q.A) VECTOR)
<SET Q.A <QPRINT .A>>
<PRINC <NTH .A ,ARESP>>
<CRLF>>
<DEFINE READ.REGULAR (A
"AUX" Q.A (TVS ,TVSPACE2) (TVS1 ,TVSPACE) (LBK ,LUBLK)
COMM (TVA ,TVASS) (GAVE-UP <>) TEMP)
#DECL ((A Q.A) <SPECIAL VECTOR> (TVS TVS1) SPACE (COMM) STRING
(LBK TEMP) FIX (TVA) ASYLUM (GAVE-UP) <OR ATOM FALSE>)
<SET Q.A <QPRINT .A>>
<COND (<AND <NOT <LENGTH? .A ,ASEEN>>
<N==? <SET TEMP <NTH .A ,AHNUM>> 0>>
<PRINC ", with ">
<PRIN1 .TEMP>
<PRINC <COND (<1? .TEMP> " hint, ") (T " hints, ")>>)>
<COND (<=? <NTH .A ,ARESP> ,IDUNNO>
<PRINC ,IDUNNO>
<SET GAVE-UP T>)
(<PRINC " said :
"> <PRINC <NTH .A ,ARESP>>)>
<ARESET .TVS>
<CRLF>
<AND <G=? <LENGTH .A> ,ASEEN>
<==? <NTH .A ,ASEEN> 1>
<PRINC "[Answer seen] ">>
<SET COMM <GETBUF "Comment: " <NTH .A ,ARESP>>>
<REPEAT ((SCORE 0)
(MARKING
<COND (<AND <NOT <LENGTH? .A ,ASEEN>> <N==? <AHNUM .A> 0>>
<NTH .A ,AHVAL>)
(<NTH .Q.A ,QVAL>)>))
#DECL ((SCORE) <OR FIX FALSE FLOAT>
(MARKING) <SPECIAL <OR FLOAT FIX>>)
<COND (<OR .GAVE-UP
<AND <AND <PRINC "Score (out of ">
<PRIN1 .MARKING>
<PRINC ")">
<SET SCORE
<READER '[]
" : "
'["" ""]
'["FIX" "FLOAT"]
,VERBOSE>>
<G=? .SCORE 0>
<L=? .SCORE .MARKING>>
<CRLF>
<ADDSCORE <NTH .A ,AAUTH> .Q.A .SCORE>>>
<OR <AND .GAVE-UP <QUESTIONABLE? .COMM>>
<SEND-PLAYER <NTH .A ,AAUTH>
<AVECTOR .TVS
<NTH .A ,AQUES>
,$TLOSE
<ACOPY .TVS ,PLAYER>
.SCORE
.COMM>>>
<RETURN>)
(<NOT .SCORE>
<CHAIN-APPEND .TVA .TVS1 .A <+ .LBK ,ALAST>>
<PRINC "
Grading postponed.">
<RETURN>)
(<PRINC "
Illegal score (above VALUE or below 0)
">)>>>
<SETG READERS
[,READ.COMM
,READ.REGULAR
,READ.MATCH
,READ.MC
,READ.MC
,TIME
,READ.SANS]>
<DEFINE QPRINT (A
"OPTIONAL" (MATCH-ANS <>)
"AUX" (TVA ,TVASS) (TVS ,TVSPACE) Q QR)
#DECL ((A QR) VECTOR (TVS) SPACE (TVA) ASYLUM
(MATCH-ANS) <OR ATOM FALSE>)
<COND (<SET Q <DATA-AREAD .TVA <NTH .A ,AQUES> .TVS>>
<CRLF>
<SET QR <REST .Q ,QQUES>>
<CRLF>
<PRINC "Re: Question #">
<PRIN1 <NTH .Q ,QQNUM>>
<CRLF>
<COND (<NOT .MATCH-ANS>
<COND (<==? <NTH .Q ,QTYPE> 3> <MATCH-PRINT .QR>)
(<PRINC <1 .QR>>)>
<CRLF>)
(<PRINC <5 .QR>> <CRLF> <CRLF>)>
<PRINC <NTH .A ,AAUTH>>
.Q)
(<PERR "Can't read QUESTION, QPRINT" <NTH .A ,AQUES>>)>>
<DEFINE UPDATE.QUESTION ("OPTIONAL" (COMPLEX? T)
"AUX" QUES Q (TVS <ARESET ,TVSPACE2>) (TVA ,TVASS) NEW
SYM QTOP)
#DECL ((QUES) <OR FALSE VECTOR> (Q) <OR FALSE LIST> (TVS) SPACE
(TVA) ASYLUM (NEW) <OR MANIAC FALSE> (QTOP) VECTOR
(SYM) <OR FALSE SYMBOL> (COMPLEX?) <OR ATOM FALSE>)
<SET-STATUS ,$SUPDATE>
<COND (<COND (.COMPLEX? <SET SYM <GET.QUESTION>>)
(T <SET SYM <GET.SIMPLE>>)>
<SET QUES <DATA-AREAD .TVA <2 .SYM> <ARESET ,TVSPACE>>>
<SET-STATUS ,$SUPDATE <NTH .QUES ,QQNUM>>
<COND (<SET Q <APPLY <NTH ,MAKERS <NTH .QUES ,QTYPE>> .QUES>>
<SET QTOP <SUBSTRUC .QUES 0 ,QQUES>>
<SET QUES <AVECTOR .TVS 0 0 0 0 0 0 0 0 !.Q>>
<MAPR <>
<FUNCTION (X Y)
#DECL ((X Y) VECTOR)
<PUT .X 1 <ACOPY .TVS <1 .Y>>>>
.QUES
.QTOP>
<PROG (LOSS)
#DECL ((LOSS) <OR MANIAC <FALSE FIX>>)
<COND (<SET LOSS
<DATA-APRINT .TVA <2 .SYM> .TVS .QUES>>)
(<MEMQ <1 .LOSS> '(5 6)>
<STALL <1 .LOSS>>
<AGAIN>)
(<PERR "Can't PRINT UPDATE, UPDATE.QUESTION"
.LOSS>)>>)>)>>
<DEFINE PRINT-QUESTION (QUES
"AUX" (QTYPE <QTYPE .QUES>) (RQ <REST .QUES ,QQUES>)
CORRECT (QVAL <QVAL .QUES>))
#DECL ((QUES) <VECTOR FIX FIX FIX STRING ANY FIX ANY ANY ANY [REST ANY]>
(QVAL) <OR FIX FLOAT> (QTYPE CORRECT) FIX (RQ) VECTOR)
<COND (<OR <==? .QTYPE ,$TSIMPLE> <==? .QTYPE ,$TLONG>>
<PRINC <1 .RQ>>
<COND (<NOT <LENGTH? .RQ 2>>
<MAPR <>
<FUNCTION (HINTS)
#DECL ((HINTS) <VECTOR [REST
<OR STRING FLOAT>]>)
<COND (<TYPE? <1 .HINTS> STRING>
<CRLF>
<PRINC "Hint [for ">
<PRIN1 <* <2 .HINTS> .QVAL>>
<PRINC " points]: ">
<PRINC <1 .HINTS>>)>>
<3 .RQ>>
<CRLF>)>
<COND (<N==? <LENGTH .RQ> 1>
<CRLF>
<PRINC "Answer: ">
<PRINC <2 .RQ>>)>)
(<OR <==? .QTYPE ,$TMC> <==? .QTYPE ,$TTF>>
<SET CORRECT <3 .RQ>>
<PUT <2 <2 ,ALLSYMS>> 2 <UNTASTEFUL-CODE <REST .RQ 3>>>
<PRINC <1 .RQ>>
<MSTPOSSYM!-ICALSYM "" 0 <2 ,ALLSYMS>>
<CRLF>
<PRINC "Correct answer is ">
<PRINC <NTH <REST .RQ 3> .CORRECT>>
<PRINC ".">
<CRLF>
<COND (<NOT <QUESTIONABLE? <2 .RQ>>>
<PRINC "Comment: ">
<PRINC <2 .RQ>>
<CRLF>)>)
(<==? .QTYPE ,$TMATCH>
<MATCH-PRINT .RQ>
<CRLF>
<PRINC "Correct matchings:">
<MATCH-PRINT .RQ T <> <>>
<COND (<NOT <QUESTIONABLE? <4 .RQ>>>
<PRINC "Comment: ">
<PRINC <4 .RQ>>)>)>>
<DEFINE PRINT.SIMPLE ("AUX" (TVA ,TVASS) (TVS ,TVSPACE) SYML)
#DECL ((TVA) ASYLUM (TVS) SPACE (SYML) <OR FALSE <LIST [REST SYMBOL]>>)
<COND (<SET SYML <GET.SIMPLE T>>
<CRLF>
<MAPF <>
<FUNCTION (X "AUX" QUES)
#DECL ((X) SYMBOL (QUES) VECTOR)
<SET QUES <DATA-AREAD .TVA <2 .X> <ARESET .TVS>>>
<PQHEADER .QUES>
<PRINT-QUESTION .QUES>
<CRLF>>
.SYML>)>>
<DEFINE MATCH-HACK (X) .X>