github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-26 10:12:37 +00:00
Code Issues Releases Wiki Activity
Files
3f7e7f91d5e10424ee773bad310fccbec85509d6
PDP-10.its/src/games/wa.10
Eric Swenson 088ec2d6d9 Added NGAME and games invoked by it.
2018-05-20 12:49:09 -07:00

6902 lines
221 KiB
Plaintext
Raw Blame History

;;; The functions have been organized into different modules
;;; as described in the paper about the Wumpus-Advisor.
;;; To help clarify the boundaries between the different
;;; functions and their respective domains, global variables
;;; and functions have been given prefixes to denote what
;;; tasks they are related to. In some cases it was not clear
;;; exactly what the prefix should have been, and so one
;;; was assigned somewhat arbitrarily. (This applies to the
;;; grey area between tasks). The reader can use the prefix as
;;; a general guide to the purpose of the different functions.
;;;
;;; WE_ This prefix indicates that the function
;;; is part of the highest level executive.
;;;
;;; WG_ This prefix is for functions dealing strictly with the
;;; game of the Wumpus itself.
;;;
;;; G_ This prefix is for general purpose routines that are used
;;; by many different modules and which expand LISP's capabilities.
;;;
;;; D_ This prefix is for the database maintenance routines.
;;;
;;; WA_ This prefix indicates that the function is considered
;;; to be part of the Wumpus-Advisor module.
;;;
;;; X_ This prefix is for the routines of the Wumpus Expert.
;;;
;;; C_ This prefix is for functions of the Move-Comparer
;;; module.
;;;
;;; PS_ This prefix is for the routines of the Psychologist module.
;;;
;;; S_ This is the prefix for the Student Model (a subset of the
;;; data base routines?).
;;;
;;; E_ This prefix is for functions of the English-Generation
;;; module.
;;;
;;; A__ Look again, this is not a function. It is an array.
;;; All arrays have the prefix of the module which
;;; maintains them preceded by an "A". (A prefix prefix?)
;;;
;;; L__ is the prefix prefix for variables which are circular lists.
;;;
;;; A "_" at the end of a prefix indicates that this slot may
;;; be used to further specify a sub-module within the given
;;; module.
;;;
;;; If the standard prefix is followed by an "R", then that
;;; function is a reference function, intended mainly to supply
;;; information to other modules.
;;;
;;; If the standard prefix is followed by a "V" then this is
;;; a variable which is set/used by a function of the same name.
;;;
;;; If the standard prefix is followed by a "T", then this
;;; function performs some tests before performing the expected tasks.
;;;
;;; Note that the three dangers are represented by numbers for
;;; efficiency, zero for bats, one for pits, and two for Wumpii.
;;;
;;; The information about the warren is stored in arrays.
;;; Danger specific information is keyed by: CAVE, ITEM, and DANGER.
;;; ITEMs are as follows
;;; 0 ... WG-DANGER
;;; 1 ... XD-MORE-THAN
;;; 2 ... XD-WHY-MORE-THAN
;;; 3 ... XD-LESS-THAN
;;; 4 ... XD-WHY-LESS-THAN
;;; 5 ... XD-EXACTLY
;;; 6 ... XD-WHY-EXACTLY
;;; 7 ... XS-MEMBER
;;; 8 ... XP-REDUNDANT
;;; 9 ... XP-PROB
;;; 10 .. XP-WHY-PROB
;;; 11 .. XP-P11
;;; 12 .. XP-WHY-P12
;;; 13 .. XP-P13
;;; 14 .. XP-P14
;;; 15 .. XP-WHY-P11
;;; 16 .. XS-NUM
;;; 17 .. CX-PROB
;;;
;;; Other information about caves is keyed by: CAVE and ITEM.
;;; ITEMs are as follows:
;;; 0 ... WG-NEIGHBORS
;;; 1 ... WG-WARNINGS
;;; 2 ... XD-VISITED
;;; 3 ... XX-COST
;;; 4 ... XX-GAIN
;;; 5 ... XX-INDEX
;;; 6 ... XX-DANGERS
(DECLARE (MUZZLED T))
(DECLARE (FIXNUM CAVE DANGER RULE O-CAVE O-DIST I J ORIGIN DIST B-MOVE W-MOVE))
(DECLARE (FLONUM PROB))
(DECLARE (*LEXPR SAVE WE-TELL-INFO-WORK WAW-GIVE-ROUTE GP-UNION
GC-MEMBER GC-AVERAGE WE-EXPL-RULE GCI-CREATE))
(DECLARE (*EXPR SC-HELP ENDPAGE CLOSE DEFAULTF MERGEF))
(DECLARE (ARRAY* (NOTYPE AEG-NUMBER 1. AXS-CHANGED-SETS 1. AEG-DANGER-SING 1.
AEG-DANGER-PLUR 1. ASL-WORK-ON-RULES 1. AXR-FOUND-N 1.
AXS-EXACT-CAVES 1. AXS-PARTIAL-SETS 1. AXS-COMPLETE-SETS 1.
APS-RULE-ARRAY 1. AEG-WARNING-PRES 1. AWE-EXPL-RULES 1.
AEG-WARNING-PAST 1. AEG-ENCOUNTER 1. AWA-TOLD-RULES 1.
ASL-PNUM-DANGERS 2. AEG-TELL-AVOID 2. ASL-PHASE-RULES 2.
ASL-NEXT-RULES 2. ADB-DCAVE 2. ADB-CAVE 2. ASKC-RULES 2.
ASC-INITIALIZED 1. ADB-TELL-DANGER 2. ADB-TELL-WARNING 2.)
(FIXNUM ADB-NUM-DANGERS 1. ADB-WARNING-DIST 1.
AXR-NUM-IDENTIFIED 1. ASL-PHASE 1.
ADB-DIST-START 1. ASK-WDRULES 3.)
(FLONUM AXX-EST-NUM-DANGERS 1. AXP-PROB12 1. ASK-DRULES 3.)))
(DEFUN BEGIN NIL
(or (boundp we-version)(di-database))
(SUSPEND)(*SS-INITIALIZE) (RESTART))
(DEFUN RESTART NIL
(DECLARE (SPECIAL *SS-ACTIVE G-SILENT))
(or (boundp we-version)(di-database))
(DI-INITIALIZE)
(WE-SESSION-LOOP)
(DB-END-SESSION)
(G-RISAY '(|I am returning you to top level|))
(quit)
'TRUTH)
(DEFUN NOLINK NIL (*RSET T) (NOUUO T) (SSTATUS UUOLINKS))
;;; WE-SESSION-LOOP is the highest level loop of the executive.
;;;It cycles the player through the different games.
(DEFUN WE-SESSION-LOOP NIL
(DECLARE (SPECIAL DB-NUMWINS WE-NORESTART DB-NUMLOSSES DB-HISTORY))
(PROG NIL
AGAIN(COND ((DB-DEFINE-GAME) NIL) (T (GO END)))
(DB-INIT-NEWGAME)
LOOP (COND
((WE-GAME-LOOP)
(SETQ DB-NUMWINS (1+ DB-NUMWINS) DB-HISTORY (CONS 1. DB-HISTORY)))
(WE-NORESTART
(SETQ DB-NUMLOSSES (1+ DB-NUMLOSSES) DB-HISTORY (CONS 0. DB-HISTORY)))
(T
(SETQ DB-NUMLOSSES (1+ DB-NUMLOSSES) DB-HISTORY (CONS 0. DB-HISTORY))
(G-RSAY
'(|Would you like to take back your last move? |))
(COND ((GQ-EVAL (G-READ 'NEW-GAME))
(GO LOOP)))))
END (DB-END-GAME)
(G-RSAY (APPEND '(|Your record is|)
(EG-NUMBER DB-NUMWINS)
'(|wins and|)
(EG-NUMBER DB-NUMLOSSES)
'(|losses. |)))
(G-RSAY '(|Would you like to play again? |))
(COND ((GQ-EVAL (G-READ 'NEW-GAME)) (GO AGAIN)))))
;;; WE-GAME-LOOP is the executive that cycles through
;;;the different moves of the game.
(DEFUN WE-GAME-LOOP NIL
(DECLARE (SPECIAL WE-DONE WE-RETURN WE-MOVE WE-LAST-MOVE
XD-VISITED-CAVES WG-HERE WE-DONE WE-MOVE-NUM))
(DO ((WE-DONE NIL) (WE-RETURN NIL))
(WE-DONE WE-RETURN)
(WA-SAYSTATUS)
(G-RSAY '(|What now? |))
(WE-ERR-CHECK '(WA-UPDATE WG-HERE))
(SETQ WE-MOVE (G-READ 'MOVE))
(G-TERPRI)
(G-TERPRI)
(COND ((EQ WE-MOVE 'SHOOT)
(WE-SHOOT)
(SETQ WE-MOVE-NUM (1+ WE-MOVE-NUM)))
((WE-CHECK-MOVE WE-MOVE))
((WE-ERR-CHECK '(WA-ANALYZE WE-MOVE)))
(T (SETQ WE-LAST-MOVE WG-HERE)
(SC-UPDATE-RECEPTIVITY WE-MOVE)
(COND ((NOT (MEMBER WE-MOVE XD-VISITED-CAVES))
(SETQ WE-MOVE-NUM (1+ WE-MOVE-NUM))))
(WG-MOVETO WE-MOVE)))))
;;; WE-CHECK-MOVE is the function which insures that the move is a legal move.
;;;It returns nil if the move is a good move.
(DEFUN WE-CHECK-MOVE (MOVE)
(DECLARE (SPECIAL WAD-KNOWNAREA WG-HERE WE-NORESTART WE-DONE
DB-NUM-CAVES))
(COND
((EQ MOVE 'ROUTE) (WE-GIVE-ROUTE) T)
((EQ MOVE 'INFO)
(WA-UPDATE-FRINGE WG-HERE)
(WE-TELL-INFO)
T)
((EQ MOVE 'VISITED)
(WA-UPDATE-FRINGE WG-HERE)
(WE-TELL-VISITED)
T)
((EQ MOVE 'QUIT)
(SETQ WE-NORESTART T)
(SETQ WE-DONE T))
((NOT (FIXP MOVE))
(G-RSAY '(|Please enter one of the following:|))
(G-RISAY '(|A neighboring cave number. |))
(G-RISAY '(|SHOOT, if you would like to shoot an arrow. |))
(G-RISAY
'(|VISITED, if you would like to know the|
|caves we have visited. |))
(G-RISAY
'(|INFO, if you would like to know about a|
|cave that we have already visited. |))
(G-RISAY '(|ROUTE, if you would like a route to a cave. |))
(G-RISAY
'(|(SAVE), if you would like to send some comments to my programmer. |))
(G-RISAY '(|QUIT, if you would like to quit this game. |))
T)
((GP-CAVE-CHECK MOVE) T)
((= MOVE WG-HERE) T)
((MEMBER MOVE (WGR-NEIGHBORS WG-HERE)) NIL)
((MEMBER MOVE WAD-KNOWNAREA)
(G-RSAY (LIST '|We can not go directly to cave|
MOVE
'|from cave|
WG-HERE
'|. |))
T)
(T (G-RSAY (LIST '|We can not get to cave|
MOVE
'|from here. |))
T)))
;;; WE-TELL-VISITED tells the user what caves he has visited.
(DEFUN WE-TELL-VISITED NIL
(DECLARE (SPECIAL XD-VISITED-CAVES))
(G-RSAY (APPEND '(|We have visited|)
(EG-INSERT-AND '|cave| XD-VISITED-CAVES)
'(|. |))))
;;; WE-TELL-INFO tells the player about a cave that
;;;has been previously visited.
(DEFUN WE-TELL-INFO NIL
(DECLARE (SPECIAL XD-VISITED-CAVES))
(PROG (RESPONSE)
(WE-TELL-INFO-WORK)
LOOP (G-RSAY
'(|Would you like to find out about another cave? |))
(SETQ RESPONSE (G-READ 'NO))
(COND ((MEMBER RESPONSE XD-VISITED-CAVES)
(WE-TELL-INFO-WORK RESPONSE)
(GO LOOP))
((GQ-EVAL RESPONSE) (WE-TELL-INFO)))))
;;; WE-TELL-INFO-WORK does the actual work of WE-TELL-INFO.
(DEFUN WE-TELL-INFO-WORK NARGS
(PROG (CAVE)
(COND
((= (ARG NIL) 0.)
(G-RSAY '(|What cave would you like to know about? |))
(SETQ CAVE (G-READ 'CAVE)))
(T (SETQ CAVE (ARG 1.))))
(G-TERPRI)
(COND
((GP-CAVE-CHECK CAVE))
((NOT (XDR-VISITEDP CAVE))
(G-RSAY (APPEND '(|We have not yet visited cave|)
(LIST CAVE '|. |))))
(T
(G-RSAY (APPEND '(|The neighbors of cave|)
(LIST CAVE)
(EG-INSERT-AND '|is cave|
(WGR-NEIGHBORS CAVE))
'(|. |)))
(G-RSAY
(APPEND
'(|It has|)
(EG-INSERT-AND
'|warning|
(MAPCAR
(FUNCTION
(LAMBDA (X)
(IMPLODE
(APPEND '(34.)
(EXPLODEN (CAR (ADB-TELL-WARNING 2. X)))
'(34.)))))
(WGR-WARNINGS CAVE)))
'(|. |)))))
(G-TERPRI)))
;;; WE-GIVE-ROUTE gives routes to the player.
(DEFUN WE-GIVE-ROUTE NIL
(DECLARE (SPECIAL WG-HERE WAD-FRINGE))
(WAD-UPDATE-DIST WG-HERE)
(PROG (RESPONSE)
(WAW-GIVE-ROUTE)
LOOP (G-RSAY
'(|Would you like to give another destination? |))
(SETQ RESPONSE (G-READ 'NO))
(COND ((AND (MEMBER RESPONSE WAD-FRINGE)
(NOT (MEMBER RESPONSE
(WGR-NEIGHBORS WG-HERE))))
(WAW-GIVE-ROUTE RESPONSE)
(GO LOOP))
((GQ-EVAL RESPONSE) (WE-GIVE-ROUTE)))))
;;;....WE-SHOOT is the shoot function used by the WUMPUS-ADVISOR.
(DEFUN WE-SHOOT NIL
(DECLARE (SPECIAL WE-SHOT WG-HERE WE-DONE))
(WA-UPDATE-FRINGE WG-HERE)
(G-RSAY '(|Into which cave would you like to shoot? |))
(SETQ WE-SHOT (G-READ 'SHOOT))
(COND ((GP-CAVE-CHECK WE-SHOT))
((= WE-SHOT WG-HERE)
(G-RSAY '(|You have just shot yourself! |))
(SETQ WE-DONE T))
((NOT (MEMBER WE-SHOT (WGR-NEIGHBORS WG-HERE)))
(G-RSAY (LIST '|You cant't shoot from cave|
WG-HERE
'|to|
WE-SHOT
'|. |)))
((WE-ERR-CHECK '(WA-SHOOT-ANALYZE WE-SHOT)))
(T (SC-UPDATE-RECEPTIVITY (LIST 'SHOOT WE-SHOT))
(WG-SHOOT WE-SHOT))))
;;; WE-NOTE-DANGER is called anytime a danger is encountered.
(DEFUN WE-NOTE-DANGER (DANGER)
(DECLARE (SPECIAL WE-MOVE))
(WA-TELL-DANGER DANGER)
(COND (WE-MOVE (*SXD-MARK-DANGER WE-MOVE DANGER)
(XD-MARK-DANGER WE-MOVE DANGER)
(SETQ WE-MOVE NIL))))
;;;********* The following routines are debugging routines. ********
;;; WE-ERR-CHECK is intended to catch errors before the student
;;;is made aware of them.
(DEFUN WE-ERR-CHECK (LIST)
(DECLARE (SPECIAL WEV-ERROR DB-DEBUG))
(PROG (TEMP)
(COND (WEV-ERROR NIL)
(DB-DEBUG (RETURN (EVAL LIST)))
((EQ (ERRSET (SETQ TEMP (EVAL LIST)) NIL) NIL)
(WE-ERROR LIST)
(RETURN NIL))
(T (RETURN TEMP)))))
;;; WE-ERROR is called whenever the Wumpus Advisor discovers an error.
(DEFUN WE-ERROR (FUNC)
(DECLARE (SPECIAL DB-NAME WEV-ERROR WE-DONE WE-RETURN))
(G-TSAY (LIST '|Bug at| FUNC '!))
(COND
((NOT WEV-ERROR)
(G-RISAY (LIST DB-NAME
'|, I am feeling very sick. I have called|
'|my doctor, but I don't think I will be|
'|able to finish this game. Would you like|
'|to finish this game alone? |))
(COND ((NOT (GQ-EVAL (G-READ 'NO)))
(SETQ WE-DONE T WE-RETURN T)))))
(SETQ WEV-ERROR T)
(SAVE FUNC)
'(|Blah! |))
;;; SAVE saves all relevant imformation about the game.
(DEFUN SAVE NARGS
(DECLARE (SPECIAL DB-UNAME WE-VERSION WE-GAME-HIST DB-TIME
DB-USER-ID WE-LAST-SESSION WE-THIS-SESSION
DB-OLD-USER-FILE DB-DEBUG))
(PROG (TEMP MESSAGE)
(COND
((= (ARG NIL) 0.)
(G-RSAY
'(|Please enter your impression of what|
|the problem is. End your comments|
|with two semicolons (followed by a|
|space). For example.... |))
(G-RISAY '(|The problem is ... ;;|))
(G-TERPRI)
(SETQ MESSAGE (G-READ-RESPONSE)))
(T (SETQ MESSAGE (ARG 1.))))
(SETQ TEMP (STATUS CRUNIT))
(G-APPEND-FILE (LIST 'bugs8 DB-USER-ID 'second 'ejs))
(SETQ ^R T ^W T)
(PRIN1 (LIST DB-TIME
DB-DEBUG
WE-GAME-HIST
WE-VERSION
WE-LAST-SESSION
WE-THIS-SESSION
DB-OLD-USER-FILE
MESSAGE))
(APPLY 'UFILE (LIST 'bugs8 DB-USER-ID 'second 'ejs))
(SETQ ^R NIL ^W NIL)
(APPLY 'CRUNIT TEMP)
(COND ((= (ARG NIL) 0.)
(G-TSAY '(|*** Save finished. ***|))))))
;;; WE-RECREATE is used to recreate a game situation that has been
;;;saved. It assumes that BEGIN has been called at least once.
(DEFUN WE-RECREATE NIL
(DECLARE (SPECIAL FILE INFO HER-VERSION USER-FILE MESSAGE DB-TIME
WEV-RECREATE WE-VERSION G-DOUBLESPACE WE-LAST-SESSION
WE-THIS-SESSION))
(PROG (FILE INFO HER-VERSION USER-FILE MESSAGE)
(SETQ G-DOUBLESPACE NIL)
(G-RSAY '(|What file would you like for me to read? |))
(SETQ FILE (G-READ NIL))
(APPLY 'UREAD FILE)
(SETQ ^Q T
INFO (READ))
(MAPC 'SET
'(DB-TIME DB-DEBUG WEV-RECREATE HER-VERSION
WE-LAST-SESSION WE-THIS-SESSION USER-FILE
MESSAGE)
INFO)
(SF-STORE-USER-FILE USER-FILE)
;;; Note that the moves were stored in reverse order.
(SETQ WEV-RECREATE (REVERSE WEV-RECREATE))
(G-RSAY (LIST '|She was playing on version|
HER-VERSION
'|. |))
(G-RSAY (LIST '|I am version|
WE-VERSION
'|. |))
(G-RSAY (APPEND '(|Her message was:|)
(LIST MESSAGE)
'(|. |)))
(DB-DEFINE-GAME)
(DB-INIT-NEWGAME)
(G-RSAY '(|Would you like for me to make the moves? |))
(COND ((GQ-EVAL (READ)))
(T (G-RSAY (APPEND '(|Her moves were;|)
WEV-RECREATE))
(SETQ WEV-RECREATE NIL)))
(WE-GAME-LOOP)))
;;; WE-*COMMANDS tells the user the different * commands that are available.
(DEFUN WE-*COMMANDS NIL
(G-RSAY '(|The following commands are available:|))
(G-RISAY '(|*? to print this out. |))
(G-RISAY '(|*MODEL to see the Student Knowledge Model. |))
(G-RISAY '(|*VARIABLE to see the Student Model variables. |))
(G-RISAY
'(|*NOTUTOR to keep the Advisor from tutoring the student. |))
(G-RISAY
'(|*TUTOR to turn on the Wumpus Advisor's tutor (this is the default). |))
(G-RISAY
'(|*SEQUENCE to go through the standard sequence of warrens. |))
(G-RISAY
'(|*COMMENT to have Wusor print out pedagaogical comments. |))
(G-RISAY
'(|*NOCOMMENT to turn off the pedagogical commands. |))
(G-RISAY
'(|*INDEX to get the expert's evaluation of the fringe caves. |))
(G-RISAY
'(|*PROB (followed by a cave and a danger's initial) gives|
|the probability that a particular danger is in a cave. |))
(G-RISAY
'(|*RULES (followed by a cave and a danger's initial) gives|
|the rules used in computing a probability for a cave. |))
(G-RISAY
'(|*EXPL-RULES explains the meaning of various rules.|))
(G-RISAY
'(|*EXPLAIN (followed by a cave and a danger's initial)|
|explains a probability for a cave. |))
(G-RISAY '(|*CHEAT to get the location of the dangers. |))
(G-RISAY
'(|*NUMB causes Wusor to output the interaction number. |))
(G-RISAY '(|*NONUMB turns off these interaction numbers. |))
(G-RISAY '(|*DEBUG to output any error messages, etc.. |))
(G-RISAY '(|*NODEBUG to turn off the debugging features. |))
(G-RISAY
'(|*EXEC to allow the evaluation of S-expressions. |)))
;;; WE-CHEAT This function prints out where the bats, pits, and Wumpus are.
(DEFUN WE-CHEAT NIL
(DECLARE (SPECIAL DB-NUM-CAVES))
(G-RSAY '(| Cave Neighbors Wumpus Pit Bat|))
(DO ((CAVNUM 0. (1+ CAVNUM)))
((> CAVNUM (1- DB-NUM-CAVES)))
(G-RSAY (LIST '| | CAVNUM))
(G-PSAY (WGR-NEIGHBORS CAVNUM) 8.)
(DO ((DANGER 2. (1- DANGER))
(CURSOR 22. (+ CURSOR 5.)))
((< DANGER 0.))
(G-PSAY (COND ((WGR-DANGERP CAVNUM DANGER) '(Y))
(T '(N)))
CURSOR))))
;;; WE-WRITE-INDEX outputs the experts work for the caves it is sent.
(DEFUN WE-WRITE-INDEX (CAVE-LIST)
(COND
((NULL CAVE-LIST)
(G-RISAY
'(|A "*" after the cave number indicates that these figures|
|reflect shooting into the cave before visiting it.|))
(G-RSAY '(|Cave Cost Gain Index|)))
(T (WE-WRITE-INDEX (CDR CAVE-LIST))
(G-RSAY (LIST '| |
(GP-MAKN (CAR CAVE-LIST)
(COND ((XPR-SHOOTP (CAR CAVE-LIST))
'*)
(T '| |)))))
(G-PSAY (LIST (XXR-COST (CAR CAVE-LIST))) 8.)
(G-PSAY (LIST (XXR-GAIN (CAR CAVE-LIST))) 22.)
(G-PSAY (LIST (XXR-INDEX (CAR CAVE-LIST))) 36.))))
;;; WE-PROB explains the prob for a cave.
(DEFUN WE-PROB NIL
(PROG (CAVE DANGER)
(SETQ CAVE (WE-GET-CAVE) DANGER (WE-GET-DANGER))
(G-RISAY (APPEND '(|The probability of|)
(AEG-DANGER-SING DANGER)
(LIST '|being in cave|
CAVE
'|is|)
(LIST (XPR-PROB CAVE DANGER)
'|. |)))))
;;; WE-RULES gives the rules used in the computation of the probability.
(DEFUN WE-RULES NIL
(PROG (CAVE DANGER)
(SETQ CAVE (WE-GET-CAVE) DANGER (WE-GET-DANGER))
(G-RISAY
(APPEND
'(|The rules used in the computation of the probability of|)
(AEG-DANGER-SING DANGER)
(LIST '|in cave| CAVE)
(EG-INSERT-AND '|is rule|
(CXR-PROB CAVE DANGER))
'(|. |)))))
;;; WE-EXPL-RULES explains a series of rules.
(DEFUN WE-EXPL-RULES NIL
(PROG (RESPONSE)
(WE-EXPL-RULE)
LOOP (G-RSAY
'(|Would you like to find out about another rule? |))
(SETQ RESPONSE (G-READ 'NO))
(COND ((GP-NUM-TEST RESPONSE 20.)
(WE-EXPL-RULE RESPONSE)
(GO LOOP))
((GQ-EVAL RESPONSE) (WE-EXPL-RULES)))))
;;; WE-EXPL-RULE does the actaul explanations.
(DEFUN WE-EXPL-RULE NARGS
(PROG (RESPONSE)
(COND ((= (ARG NIL) 0.)
(G-RSAY '(|Please a rule number (0 to 15). |))
(SETQ RESPONSE (G-READ 0.)))
(T (SETQ RESPONSE (ARG 1.))))
(COND ((GP-NUM-TEST RESPONSE 16.)
(G-RSAY (AWE-EXPL-RULES RESPONSE)))
(T (G-RSAY (LIST '|There is no rule|
RESPONSE
'|. |))))))
;;; WE-EXPLAIN explains the probability for a given danger and cave.
(DEFUN WE-EXPLAIN NIL
(PROG (CAVE DANGER)
(SETQ CAVE (WE-GET-CAVE) DANGER (WE-GET-DANGER))
(G-RISAY (APPEND (EXR-PROB CAVE DANGER NIL)
'(|. |)))
(WA-MARK-RULES '|explain|)))
;;; WE-GET-CAVE gets a cave number from the player.
(DEFUN WE-GET-CAVE NIL
(DECLARE (SPECIAL DB-NUM-CAVES))
(PROG (RESPONSE)
(COND ((GP-NUM-TEST (SETQ RESPONSE (G-SREAD 'CAVE))
DB-NUM-CAVES)
(RETURN RESPONSE))
(T (G-RSAY '(|Please enter a cave number. |))
(RETURN (WE-GET-CAVE))))))
;;; WE-GET-DANGER gets the danegr from the player.
(DEFUN WE-GET-DANGER NIL
(PROG (RESPONSE)
(COND
((EQ (SETQ RESPONSE (G-SREAD 'B)) 'B)
(RETURN 0.))
((EQ RESPONSE 'P) (RETURN 1.))
((EQ RESPONSE 'W) (RETURN 2.))
(T
(G-RSAY
'(|Please enter a danger's initial (B, P, or W). |))
(RETURN (WE-GET-DANGER))))))
;;; WE-EXECUTE allows a debugger to execute commands
;;;without stopping the game.
(DEFUN WE-EXECUTE NIL
(PROG (VAR)
(G-RSAY '(|Please enter an S-Expression. |))
(COND ((SETQ VAR (G-READ NIL))
(G-RSAY (ERRSET (EVAL VAR) T))
(WE-EXECUTE)))))
;;;************* The Wumpus Advisor Routines. ************
;;; WA-ANALYZE analyzes the players desire to move to CAVE.
;;;A retrun value of NIL indicates that the player should be
;;;allowed to go ahead with the move.
(DEFUN WA-ANALYZE (MOVE)
(DECLARE (SPECIAL WAM-NEXT-MOVE WA-CAN-BACKTRACK WE-LAST-MOVE
SL-REPEAT SL-TUTOR))
(PS-UPDATE-MODEL MOVE)
(COND (WAM-NEXT-MOVE (WAM-TRANSPOSE-MOVE MOVE))
((EQUAL MOVE WE-LAST-MOVE)
(SETQ WA-CAN-BACKTRACK (1+$ WA-CAN-BACKTRACK))
NIL)
((NOT SL-TUTOR) NIL)
((WAW-ROUTE-CHECK MOVE))
((XDR-VISITEDP MOVE) NIL)
((SL-ADVISEP MOVE) NIL)
((< WA-CAN-BACKTRACK SL-REPEAT) (WA-BACKTRACK MOVE))
((WA-CHECK-BETTER MOVE) (GQ-GO-AHEAD MOVE))
((WA-SHOOT-CHECK MOVE))))
;;; WA-SHOOT-ANALYZE analyzes the players desire shoot into CAVE.
;;;A return value of NIL indicates that the player should be
;;;allowed to go ahead with the shot.
(DEFUN WA-SHOOT-ANALYZE (CAVE)
(DECLARE (SPECIAL WG-ARROWS LWA-CRULES DB-NAME))
(COND
((XPR-SHOOTP CAVE) (PS-MARK-SHOT CAVE) NIL)
((SL-ADVISEP (LIST 'SHOOT CAVE)) NIL)
((GC-MEMBER LWA-CRULES 9. 1.) NIL)
((CMR-SAFEP CAVE '(2.))
(G-RISAY
(APPEND (EXR-PROB CAVE 2. NIL)
'(|, and, if we shoot an arrow into cave|)
(LIST CAVE)
'(|, it could ricochet back and kill us. |)))
(PS-UNMARK-SHOT CAVE)
(WA-TOLD-RULE 15. 2.)
(WA-NOTE-ADVICE -1. (LIST 'SHOOT CAVE) 9.)
(WA-MARK-RULES 9.)
(GQ-SHOOT-ANYWAY CAVE))
((> (XPR-PROB CAVE 2.) 0.3) NIL)
((NOT (WGR-EXTRA-ARROWS))
(G-RISAY
(APPEND
'(|As we only have|)
(EG-NUMBER WG-ARROWS)
(EGT-PLURAL '(|arrow|) WG-ARROWS)
'(|left,|)
(LIST DB-NAME)
'(|, it might be wise to save this|
|arrow until we are more certain|
|of the location of|)
(AEG-DANGER-SING 2.)
'(|. |)))
(WA-NOTE-ADVICE -1. (LIST 'SHOOT CAVE) 9.)
(GQ-SHOOT-ANYWAY CAVE))
((> (XPR-PROB CAVE 2.) 0.21) NIL)
((SLR-OK-RULESP (CXR-PROB CAVE 2.) 2.)
(G-RISAY
(APPEND
(EXR-PROB CAVE 2. NIL)
(LIST '|,| DB-NAME)
'(|, and a missed arrow is more dangerous than that. |)))
(PS-UNMARK-SHOT CAVE)
(WA-NOTE-ADVICE -1. (LIST 'SHOOT CAVE) 9.)
(WA-MARK-RULES 9.)
(GQ-SHOOT-ANYWAY CAVE))
((> (XPR-PROB CAVE 2.) 0.15) NIL)
(T
(G-RISAY
(APPEND
(LIST DB-NAME)
'(|, it is unlikely that cave|)
(LIST CAVE '|contains|)
(AEG-DANGER-SING 2.)
'(|, and we are more likely to be|
|killed by a missed arrow richocheting|
|through the warren. |)))
(PS-UNMARK-SHOT CAVE)
(WA-NOTE-ADVICE -1. (LIST 'SHOOT CAVE) 9.)
(GQ-SHOOT-ANYWAY CAVE))))
;;;....WA-SAYSTATUS outputs the game info as appropriate.
(DEFUN WA-SAYSTATUS NIL
(DECLARE (SPECIAL WEV-ERROR WG-HERE))
(G-RSAY (LIST '|We are now at cave|
WG-HERE
'|. |))
(G-RSAY (APPEND '(|The neighboring caves are|)
(EG-INSERT-AND '|cave|
(WGR-NEIGHBORS WG-HERE))
'(|. |)))
(COND ((NOT WEV-ERROR)
(MAPC (FUNCTION (LAMBDA (X)
(DECLARE (SPECIAL WG-HERE))
(*SXD-MARK-NOWARNING WG-HERE X)
(XD-MARK-NOWARNING WG-HERE X)))
(GP-REMOVE-LIST '(0. 1. 2.)
(MAPC 'WA-NOTE-WARNING
(WGR-WARNINGS WG-HERE))))
(*SXD-MARK-VISITED WG-HERE '(0. 1. 2.))
(XD-MARK-VISITED WG-HERE '(0. 1. 2.)))
(T (MAPC 'WA-NOTE-WARNING
(WGR-WARNINGS WG-HERE))))
(G-TERPRI))
;;; WA-UPDATE updates the database as necessary for each move.
(DEFUN WA-UPDATE (CAVE)
(DECLARE (SPECIAL XX-CHANGED WAD-FRINGE WE-MOVE))
(COND ((OR (MEMBER CAVE WAD-FRINGE)
;;; This is in case we are picked up by bats.
(NOT WE-MOVE))
(SETQ XX-CHANGED T)
(WA-UPDATE-FRINGE CAVE)))
(XX-UPDATE))
;;; WA-UPDATE-FRINGE updates the fringe, dist caves, and best-moves.
(DEFUN WA-UPDATE-FRINGE (CAVE)
(DECLARE (SPECIAL WAW-GIVEN-ROUTE))
(WAD-UPDATE-DIST CAVE)
(XX-UPDATE-MOVES)
(SETQ WAW-GIVEN-ROUTE NIL))
;;; WA-TELL-DANGER tells the player he has encountered a danger.
(DEFUN WA-TELL-DANGER (DANGER)
(G-RSAY (ADB-TELL-DANGER (ASK-WDRULES 17. 0. DANGER) DANGER))
(COND ((< (ASK-WDRULES 17. 0. DANGER) 2.)
(STORE (ASK-WDRULES 17. 0. DANGER)
(1+ (ASK-WDRULES 17. 0. DANGER))))))
;;; WA-NOTE-WARNING tells the player when he receives a warning.
(DEFUN WA-NOTE-WARNING (DANGER)
(DECLARE (SPECIAL WEV-ERROR WG-HERE))
(COND ((NOT WEV-ERROR) (XD-MARK-WARNING WG-HERE DANGER)))
(*SXD-MARK-WARNING WG-HERE DANGER)
(G-RSAY (ADB-TELL-WARNING (ASK-WDRULES 16. 0. DANGER) DANGER))
(COND ((< (ASK-WDRULES 16. 0. DANGER) 2.)
(STORE (ASK-WDRULES 16. 0. DANGER)
(1+ (ASK-WDRULES 16. 0. DANGER))))))
;;; WA-BACKTRACK tells the student about backtracking if
;;;it is appropriate. (i.e. there is a good example).
(DEFUN WA-BACKTRACK (MOVE)
(DECLARE (SPECIAL BETTER-MOVE XD-VISITED-CAVES WG-HERE))
(PROG (BETTER-CAVE BETTER-MOVE TEMP)
(COND
((NOT (XXR-DANGERS MOVE)))
((SETQ
BETTER-CAVE
(GM-FIRST-TRUE
(FUNCTION
(LAMBDA (X)
(DECLARE (SPECIAL BETTER-MOVE WG-HERE))
(COND
((WGR-WARNINGS X) NIL)
((SETQ
BETTER-MOVE
(GM-FIRST-TRUE
(FUNCTION (LAMBDA (Y)
(DECLARE (SPECIAL WAD-FRINGE WG-HERE))
(AND (MEMBER Y WAD-FRINGE)
(NOT (MEMBER Y (WGR-NEIGHBORS WG-HERE))))))
(WGR-NEIGHBORS X)))))))
XD-VISITED-CAVES))
;;; If controls gets to here, there was
;;;a BETTER-MOVE (and BETTER-CAVE).
(WA-TELL-BACKTRACK MOVE BETTER-CAVE BETTER-MOVE TEMP)
(RETURN (COND ((GQ-GO-AHEAD MOVE))
(T (WA-UPDATE-FRINGE WG-HERE) NIL)))))))
;;; WA-TELL-BACKTRACK actually tells the player
;;;of the advantages of backtracking.
(DEFUN WA-TELL-BACKTRACK (MOVE BETTER-CAVE BETTER-MOVE TEMP)
(DECLARE (SPECIAL WA-TOLD-BACKTRACK DB-NAME))
(MAPC 'WA-TOLD-RULE
'(1. 1. 1.)
'(0. 1. 2.))
(WA-NOTE-ADVICE BETTER-MOVE MOVE 8.)
(COND
(WA-TOLD-BACKTRACK (G-RISAY (LIST DB-NAME '|,|)))
((SETQ WA-TOLD-BACKTRACK T)
(G-RSAY (LIST DB-NAME
'|, did you know that we can backtrack|
'|to caves that we have already visited? |))
(COND ((GQ-EVAL (G-READ 'NO))
(G-RISAY '(|Oh,... well then|)))
(T (G-RISAY '(|Well we can, so|))))))
(G-SAY
(APPEND '(|why not go back to cave|)
(LIST BETTER-CAVE)
'(|where we didn't get any warnings at all. |)
'(|From there we can safely go to cave|)
(LIST BETTER-MOVE)
'(|without risking|)
(EG-DANGERS (XXR-DANGERS MOVE))
'(|. |)
(COND ((SETQ TEMP (EGT-TELL-AVOID (XXR-DANGERS MOVE)))
(APPEND TEMP '(|. |))))))
(WA-MARK-RULES 8.)
(*SS-TOLD-MOVE BETTER-MOVE MOVE 8.))
;;; WA-CHECK-BETTER sees if their is a better move that is
;;;explainable. If so, it tells the student about it and
;;;asks the student if he wants to go ahead with his move.
(DEFUN WA-CHECK-BETTER (MOVE)
(DECLARE (SPECIAL MOVE DB-NUM-CRULES LWA-CRULES SL-MODE WG-HERE XX-BEST-MOVES))
(PROG (BETTER-MOVES DANGERS)
(WA-UPDATE-FRINGE WG-HERE)
(COND
((SETQ
BETTER-MOVES
(GM-ALL-TRUE
(FUNCTION (LAMBDA (X)
(DECLARE (SPECIAL MOVE LWA-BAD-MOVES LWA-GOOD-MOVES))
(AND (NOT (GC-MEMBER LWA-GOOD-MOVES
X))
(NOT (GC-MEMBER LWA-BAD-MOVES
X))
(XXR-BETTER-MOVEP X MOVE))))
XX-BEST-MOVES))
;;; If control gets to here there were better moves.
(G-RSAY '(|Hummmm. |))
(G-TSAY
(APPEND
'(|*** Better moves which I have not|
|mentioned to the student recently are|)
(EG-INSERT-AND '|cave| BETTER-MOVES)
'(|. ***|)))
(SETQ DANGERS (XXR-DANGERS MOVE))
;;; Here we compute whether or not it is acceptable
;;;to explain a given combination rule according
;;;to how recently said rule was last explained.
(DO ((I 0. (1+ I)))
((> I DB-NUM-CRULES))
(STORE (ASKC-RULES I 2.)
(OR SL-MODE
(NOT (GC-MEMBER LWA-CRULES
I
(ASKC-RULES I 1.))))))
(COND ((WA-CHECK-C6 (CAR XX-BEST-MOVES) MOVE)
(RETURN T))
((AND (ASKC-RULES 5. 2.)
(NOT (XSR-MEMBER MOVE 2.))
(WA-CHECK-C5 BETTER-MOVES MOVE))
(RETURN T))
((AND (ASKC-RULES 7. 2.)
(WA-CHECK-C7 BETTER-MOVES MOVE))
(RETURN T))
((NOT DANGERS) NIL)
((WA-CRULES BETTER-MOVES
MOVE
DANGERS
NIL
DANGERS)
(RETURN T)))))))
;;; WA-CRULES implements rules C0 thru C4. They are combined
;;;together as for each cave, at most one rule can apply. It
;;;looks at the best move first, if for some reason that move
;;;can not be explained, it looks at the next move and so on.
;;;S-DANGERS contains those dangers which could be the identical.
;;;To insure that all possibilities are tried, it both chooses
;;;the first danger in O-DANGERS and doesn't choose it until
;;;there are no more caves in O-DANGERS. Then it begins its
;;;checks. At this point O-DANGERS is reset to those dangers
;;;which H-MOVE possesses, but the selected move does not (supposedly).
(DEFUN WA-CRULES (BETTER-MOVES H-MOVE H-DANGERS S-DANGERS O-DANGERS)
(COND ((NULL BETTER-MOVES) NIL)
;;; Choose all possibilities.
(O-DANGERS (OR (WA-CRULES BETTER-MOVES
H-MOVE
H-DANGERS
(CONS (CAR O-DANGERS)
S-DANGERS)
(CDR O-DANGERS))
(WA-CRULES BETTER-MOVES
H-MOVE
H-DANGERS
S-DANGERS
(CDR O-DANGERS))))
;;; Does C0 apply?
((AND (NULL S-DANGERS)
(CMR-SAFEP (CAR BETTER-MOVES) '(0. 1. 2.)))
;;; If inappropriate to speak, return NIL (no speak).
(COND ((ASKC-RULES 0. 2.)
(WA-TELL-C0 (CAR BETTER-MOVES)
H-MOVE
H-DANGERS))))
;;; Does C1 apply?
((AND (NULL S-DANGERS)
(ASKC-RULES 1. 2.)
(SLC-KNOWS-RULEP 0.)
(CMR-BETTER-PROBSP (CAR BETTER-MOVES)
H-MOVE
H-DANGERS)
(CMR-SAFEP (CAR BETTER-MOVES)
(GP-REMOVE-LIST '(0. 1. 2.)
H-DANGERS)))
(WA-TELL-C1 (CAR BETTER-MOVES) H-MOVE H-DANGERS))
;;; Does C4 apply?
((AND (NULL S-DANGERS)
(ASKC-RULES 4. 2.)
(NOT (MEMBER 0. H-DANGERS))
(EQUAL (XXR-DANGERS (CAR BETTER-MOVES))
'(0.)))
(WA-TELL-C4 (CAR BETTER-MOVES) H-MOVE H-DANGERS NIL))
;;; We have tried all possibilities for this cave,
;;;so try next cave.
((NULL S-DANGERS)
(WA-CRULES (CDR BETTER-MOVES)
H-MOVE
H-DANGERS
NIL
H-DANGERS))
;;; Does C2 apply?
((AND (CMR-SAME-DANGERSP H-MOVE
(CAR BETTER-MOVES)
S-DANGERS)
(SETQ O-DANGERS (GP-REMOVE-LIST H-DANGERS
S-DANGERS))
(CMR-SAFEP (CAR BETTER-MOVES)
(GP-REMOVE-LIST '(0. 1. 2.)
S-DANGERS)))
;;; If inappropriate to speak, return NIL (no speak).
(COND ((ASKC-RULES 2. 2.)
(WA-TELL-C2 (CAR BETTER-MOVES)
H-MOVE
S-DANGERS
O-DANGERS))))
;;; Does C3 apply? (Note that O-DANGERS is set with
;;;a value only if S-DANGERS were O.K.)
((AND O-DANGERS
(ASKC-RULES 3. 2.)
(SLC-KNOWS-RULEP 1.)
(SLC-KNOWS-RULEP 2.)
(CMR-BETTER-PROBSP (CAR BETTER-MOVES)
H-MOVE
(GP-REMOVE-LIST H-DANGERS
S-DANGERS))
(CMR-SAFEP (CAR BETTER-MOVES)
(GP-REMOVE-LIST '(0. 1. 2.)
(APPEND S-DANGERS
H-DANGERS))))
(WA-TELL-C3 (CAR BETTER-MOVES)
H-MOVE
S-DANGERS
O-DANGERS))
;;; Does C4 apply, but with dangers in common.
((AND O-DANGERS
(ASKC-RULES 4. 2.)
(NOT (MEMBER 0. H-DANGERS))
(GP-EQUIV (XXR-DANGERS (CAR BETTER-MOVES))
(CONS 0. S-DANGERS)))
(WA-TELL-C4 (CAR BETTER-MOVES)
H-MOVE
O-DANGERS
S-DANGERS))))
;;; WA-TELL-C0 does the actual explanation of C0.
(DEFUN WA-TELL-C0 (B-MOVE H-MOVE H-DANGERS)
(DECLARE (SPECIAL DB-NAME))
(G-RISAY
(APPEND (LIST DB-NAME)
'(|, we don't need to risk|)
(EG-DANGERS H-DANGERS)
(LIST '|in cave| H-MOVE '|as cave|)
(LIST B-MOVE '|is safe. |)
(EXR-SAFE-CAVE B-MOVE
(CMR-EXPLAIN-DANGER B-MOVE
B-MOVE
H-DANGERS))
(COND ((GP-TEST H-DANGERS)
(APPEND (LIST '|. Likewise, cave|
B-MOVE)
'(|is safe from the other dangers|))))
'(|. |)))
(WA-TOLD-MOVE B-MOVE H-MOVE 0.))
;;; WA-TELL-C1 does the actual explanation of C1 if appropriate.
(DEFUN WA-TELL-C1 (B-MOVE H-MOVE H-DANGERS)
(DECLARE (SPECIAL DB-NAME))
(G-RISAY
(APPEND
(LIST DB-NAME)
'(|, it isn't necessary to take such large risks with|)
(EG-DANGERS H-DANGERS)))
(WA-COMP-PROBS B-MOVE H-MOVE H-DANGERS)
(WA-TOLD-MOVE (WA-COMP-CHECK B-MOVE) H-MOVE 1.))
;;; WA-TELL-C2 does the actual explanation of C2.
(DEFUN WA-TELL-C2 (B-MOVE H-MOVE S-DANGERS O-DANGERS)
(DECLARE (SPECIAL DB-NAME))
(G-RISAY
(APPEND
(LIST DB-NAME)
'(|, I can see why we are risking|)
(EG-DANGERS S-DANGERS)
'(|, but we don't need to risk|)
(EG-DANGERS O-DANGERS)
'(|. |)
(EXR-SAFE-CAVE B-MOVE
(CMR-EXPLAIN-DANGER B-MOVE B-MOVE O-DANGERS))
(COND ((GP-TEST O-DANGERS)
(APPEND (LIST '|. Likewise, cave| B-MOVE)
'(|is safe from the other dangers|))))
(EG-THEREFORE)
'(|we might want to explore cave|)
(LIST B-MOVE '|instead of cave| H-MOVE '|. |)))
(WA-TOLD-MOVE B-MOVE H-MOVE 2.))
;;; WA-TELL-C3 does the actual explanation of C3 if appropriate.
(DEFUN WA-TELL-C3 (B-MOVE H-MOVE S-DANGERS O-DANGERS)
(DECLARE (SPECIAL DB-NAME))
(G-RISAY
(APPEND '(|I can see why we are risking|)
(EG-DANGERS S-DANGERS)
(LIST '|,| DB-NAME)
'(|, but we don't need to take such large risks with|)
(EG-DANGERS O-DANGERS)))
(WA-COMP-PROBS B-MOVE H-MOVE O-DANGERS)
(WA-TOLD-MOVE (WA-COMP-CHECK B-MOVE) H-MOVE 3.))
;;; WA-TELL-C4 explains instances of C4 to the student.
(DEFUN WA-TELL-C4 (B-MOVE H-MOVE O-DANGERS S-DANGERS)
(DECLARE (SPECIAL LWA-TELL-C4 DB-NAME))
(COND
(S-DANGERS (G-RISAY (APPEND (LIST DB-NAME)
'(|I can see why we are risking|)
(EG-DANGERS S-DANGERS)
'(|, but|))))
(T (G-RISAY (EVAL (GC-NEXT LWA-TELL-C4)))))
(G-SAY (APPEND '(|I would rather risk bats in cave|)
(LIST B-MOVE '|than|)
(EG-DANGERS O-DANGERS)
(LIST '|in cave| H-MOVE '|. |)))
(WA-TOLD-MOVE B-MOVE H-MOVE 4.))
;;; WA-CHECK-C5 checks if C5 applies and explains if appropriate.
(DEFUN WA-CHECK-C5 (BETTER-MOVES H-MOVE)
(COND ((NULL BETTER-MOVES) NIL)
((AND (NOT (XSR-GET-MEMBER-SETS (CAR BETTER-MOVES) 2.))
(XSR-MEMBER (CAR BETTER-MOVES) 2.)
(SLR-OK-RULESP (CXR-VALUE (CAR BETTER-MOVES)) 2.))
(WA-TELL-C5 (CAR BETTER-MOVES) H-MOVE))
(T (WA-CHECK-C5 (CDR BETTER-MOVES) H-MOVE))))
;;; WA-TELL-C5 tells the player about C5, etc..
(DEFUN WA-TELL-C5 (B-MOVE H-MOVE)
(DECLARE (SPECIAL DB-NAME))
(G-RISAY
(APPEND (LIST '|cave| B-MOVE)
'(|is a very good cave to explore,|)
(LIST DB-NAME '|, as we know that|)
(EXT-CAVE-SET (CAAR (XSR-MEMBER B-MOVE 2.))
2.
T
(CADAR (XSR-MEMBER B-MOVE 2.)))
(EG-THEREFORE)
'(|if we visit cave|)
(LIST B-MOVE)
'(|we will gain information about the location of|)
(AEG-DANGER-SING 2.)
'(|. |)))
(WA-TOLD-MOVE B-MOVE H-MOVE 5.))
;;; WA-COMP-PROBS makes a comparison of two probs for DANGERS.
(DEFUN WA-COMP-PROBS (BETTER WORSE DANGERS)
(DECLARE (SPECIAL BETTER WHY-BETTER WHY-WORSE DB-NAME))
(PROG (T-DANGER WHY-BETTER WHY-WORSE)
;;; First insure that there will actually be a comparison.
(SETQ
DANGERS
(GM-ALL-TRUE
(FUNCTION (LAMBDA (X) (DECLARE (SPECIAL BETTER))
(NOT (GP-EQ (XPR-PROB BETTER X)
0.0))))
DANGERS)
T-DANGER
(CAR (CMR-EXPLAIN-DANGER BETTER WORSE DANGERS)))
(WA-SET-WHY BETTER WORSE T-DANGER)
(G-SAY
(APPEND
'(|. |)
(EC-EXPL-PROBS BETTER WHY-BETTER WORSE WHY-WORSE T-DANGER)
(COND ((GP-TEST DANGERS)
(APPEND '(|. Likewise cave|)
(LIST BETTER)
'(|involves less risk from|)
(EG-DANGERS (GP-DELETE T-DANGER
DANGERS)))))
(EG-THEREFORE)
(LIST '|,| DB-NAME)
(LIST '|, we might want to explore cave| BETTER)
'(|instead. |)))))
;;; WA-SET-WHY chooses the appropriate rationale for the explanation
(DEFUN WA-SET-WHY (BETTER WORSE DANGER)
(DECLARE (SPECIAL CX-COMPARE CX-WHY-BETTER CX-WHY-WORSE
WHY-BETTER WHY-WORSE))
(COND ((AND (EQUAL CX-COMPARE (LIST BETTER WORSE))
(NOT (SLR-OK-RULESP (APPEND (XPR-WHY-PROB WORSE DANGER)
(XPR-WHY-PROB BETTER DANGER))
DANGER)))
(SETQ WHY-BETTER CX-WHY-BETTER
WHY-WORSE CX-WHY-WORSE))
(T (SETQ WHY-BETTER (CAR (XPR-WHY-PROB BETTER DANGER))
WHY-WORSE (CAR (XPR-WHY-PROB WORSE DANGER))))))
;;; WA-COMP-CHECK returns the appropriate good move. Depending
;;;on whether P15 was in the explanation.
(DEFUN WA-COMP-CHECK (MOVE)
(COND ((AND (XPR-SHOOTP MOVE) (MEMBER 15. (AWA-TOLD-RULES 2.)))
(LIST 'SHOOT MOVE))
(T MOVE)))
;;; WA-SHOOT-CHECK advises the player-to shoot-when appropriate.
(DEFUN WA-SHOOT-CHECK (MOVE)
(DECLARE (SPECIAL DB-NAME))
(COND
((XPR-SHOOTP MOVE)
(G-RISAY
(APPEND '(|As it is|)
(EG-PROBABLE (XPR-GET-P14 MOVE 2.) NIL)
(LIST '|that cave| MOVE '|contains|)
(AEG-DANGER-SING 2.)
(LIST '|,| DB-NAME)
'(|, you might want to shoot an arrow into cave|)
(LIST MOVE)
(COND ((GP-EQ (XPR-GET-P14 MOVE 2.) 1.0)
'(|. |))
(T '(|before we visit it. |)))))
(PS-MARK-NO-SHOT MOVE)
(WA-NOTE-ADVICE (LIST 'SHOOT MOVE) MOVE 9.)
(WA-MARK-RULES 9.)
(G-RSAY (LIST '|Would you like to shoot an arrow into cave|
MOVE
'|instead? |))
(COND ((GQ-EVAL (G-READ 'DECIDE-NO))
(WG-SHOOT MOVE)
T)
((GQ-GO-AHEAD MOVE))))))
;;; WA-CHECK-C6 checks to see if C6 is applicable, and, if so, it
;;;makes the appropriate explanation.
(DEFUN WA-CHECK-C6 (BEST H-MOVE)
(DECLARE (SPECIAL WA-TOLD-C6 DB-NAME))
(COND
((MEMBER BEST WA-TOLD-C6) NIL)
((AND (ASKC-RULES 6. 2.)
(EQUAL (XXR-DANGERS BEST) '(0.))
(> (XPR-PROB BEST 0.) 0.5))
(G-RISAY
(APPEND
(LIST DB-NAME)
'(|, we seem to be surrounded by dangers. |
|It seems that bats are our best bet as|
|they might carry us to a safer|
|section of the warren. |)
(EXR-CAVE-PROB BEST 0. NIL)
'(|, and so cave|)
(LIST BEST)
'(|looks like a good move to me. |)))
(SETQ WA-TOLD-C6 (GP-CONS BEST WA-TOLD-C6))
(WA-TOLD-MOVE BEST H-MOVE 6.))))
;;; WA-CHECK-C7 determines if C7 is applicable.
(DEFUN WA-CHECK-C7 (B-CAVES H-MOVE)
(COND ((NULL B-CAVES) NIL)
((AND (XPR-SHOOTP (CAR B-CAVES))
(SLR-OK-RULESP (CXR-PROB (CAR B-CAVES) 2.) 2.))
(WA-TELL-C7 (CAR B-CAVES) H-MOVE))
((WA-CHECK-C7 (CDR B-CAVES) H-MOVE))))
;;; WA-TELL-C7 advises the palyer to shoot into CAVE instead
;;;of visiting another cave.
(DEFUN WA-TELL-C7 (CAVE H-MOVE)
(DECLARE (SPECIAL DB-NAME))
(G-RISAY (APPEND (LIST '|Well,| DB-NAME '|,|)
((GP-MAKN 'EXR-PROB (CADR (XPR-WHY-PROB CAVE 2.)))
CAVE
2.
NIL)
'(|, and I would advise that we shoot into cave|)
(LIST CAVE '|. |)))
(WA-TOLD-MOVE (LIST 'SHOOT CAVE) H-MOVE 7.))
;;; WA-TOLD-MOVE marks that student has been told BETTER-MOVE.
(DEFUN WA-TOLD-MOVE (BETTER-MOVE H-MOVE RULE)
(SKC-TOLD-RULE RULE)
(WA-MARK-RULES RULE)
(WA-NOTE-ADVICE BETTER-MOVE H-MOVE RULE)
(*SS-TOLD-MOVE BETTER-MOVE H-MOVE RULE)
T)
;;; WA-NOTE-ADVICE notes that the advice has been given.
(DEFUN WA-NOTE-ADVICE (BETTER WORSE RULE)
(DECLARE (SPECIAL LWA-CRULES LWA-GOOD-MOVES LWA-BAD-MOVES
LWA-MOVE-NUMS WE-MOVE-NUM))
(GC-PUT LWA-CRULES RULE)
(GC-PUT LWA-GOOD-MOVES BETTER)
(GC-PUT LWA-BAD-MOVES WORSE)
(GC-PUT LWA-MOVE-NUMS WE-MOVE-NUM))
;;; WA-TOLD-RULE marks that the user will be told a rule.
;;;It is called by the English routines, which is somewhat
;;;kludge like, but .....
(DEFUN WA-TOLD-RULE (RULE DANGER)
(DECLARE (SPECIAL WAV-TOLD-RULE))
(SETQ WAV-TOLD-RULE T)
(STORE (AWA-TOLD-RULES DANGER)
(GP-CONS RULE (AWA-TOLD-RULES DANGER))))
;;; WA-MARK-RULES actually marks the rules and explains them.
(DEFUN WA-MARK-RULES (RULE)
(DECLARE (SPECIAL WAV-TOLD-RULE))
(COND
(WAV-TOLD-RULE
(G-TSAY
(APPEND
'(|*** I have used:|)
(EG-INSERT-AND
NIL
(DO ((I 0. (1+ I)) (VAL NIL))
((> I 2.) VAL)
(COND ((AWA-TOLD-RULES I)
(SC-ADVISED (AWA-TOLD-RULES I) I)
(SETQ VAL
(CONS (EG-TOLD-RULES (AWA-TOLD-RULES I)
I)
VAL))))))
'(|in explaining combination rule|)
(LIST RULE)
'(|. ***|)))
(DO ((I 0. (1+ I)))
((> I 2.))
(DO ((LIST (AWA-TOLD-RULES I) (CDR LIST)))
((NULL LIST))
(*SSK-TOLD-RULE (CAR LIST) I)
(SK-TOLD-RULE (CAR LIST) I))
(STORE (AWA-TOLD-RULES I) NIL)))
(T
(G-TSAY
(APPEND '(|*** I have told the student combination rule|)
(LIST RULE)
'(|. ***|)))))
(SETQ WAV-TOLD-RULE NIL))
;;; ****** Wumpus Advisor Routines concerned with Distance, etc*****
;;; The following routines keep track of which caves
;;;can be reached in a given number of moves using the most direct
;;;route. wAs a side-effect they also keep track of which caves
;;;are in the known-area, which caves are on the fringe area, etc.
;;; WAD-GET-DIST returns all the caves that can be reached in DIST
;;;moves by the player if he takes the most direct route. The
;;;starting point is at DIST 0 and is the last fringe cave the
;;;player visited (usually).
(DEFUN WAD-GET-DIST (DIST) (EVAL (GP-MAKN 'WAD-DIST- DIST)))
;;; WAD-UPDATE-DIST is the function which ensures that the distances
;;;are correct before each move. It must be called prior to any
;;;extensive analysis.
(DEFUN WAD-UPDATE-DIST (ORIGIN)
(DECLARE (SPECIAL WAW-ROUTE XD-VISITED-CAVES WAD-FRINGE WAD-KNOWNAREA))
(DO ((DIST 0. (1+ DIST))
(START (LIST ORIGIN))
(KNOWN NIL (WAD-GET-DIST DIST))
(NEW (LIST ORIGIN) (GP-DIST-AREA START 1.))
(FRINGE NIL
(GP-UNION FRINGE
(GP-REMOVE-LIST NEW XD-VISITED-CAVES))))
((NULL START)
(SET (GP-MAKN 'WAD-DIST- DIST) NIL)
(SETQ WAD-KNOWNAREA KNOWN)
(SETQ WAD-FRINGE FRINGE)
(SETQ WAW-ROUTE (LIST ORIGIN)))
(SETQ START (GP-INTERSECTION (GP-REMOVE-LIST NEW KNOWN)
XD-VISITED-CAVES))
(SET (GP-MAKN 'WAD-DIST- DIST) (GP-UNION NEW KNOWN))))
;;;********* Wumpus Advisor Routines dealing with routes. **********
;;; WAW-ROUTE-CHECK checks to insure that the player does not spend an
;;;inordinate amount of time in the visited area.
(DEFUN WAW-ROUTE-CHECK (MOVE)
(DECLARE (SPECIAL WAW-ROUTE WAD-FRINGE))
(COND ((MEMBER MOVE WAD-FRINGE) NIL)
((MEMBER MOVE WAW-ROUTE) (WAW-CORRECT-ROUTE MOVE))
(T (SETQ WAW-ROUTE (CONS MOVE WAW-ROUTE)) NIL)))
;;; WAW-CORRECT-ROUTE notifies the student that he is wandering
;;;and asks the student if he would like a route to a cave.
(DEFUN WAW-CORRECT-ROUTE (MOVE)
(DECLARE (SPECIAL LWAW-TELL-WANDER WG-HERE))
(G-RISAY (EVAL (GC-NEXT LWAW-TELL-WANDER)))
(G-SAY '(|, would you like a route to a cave? |))
(COND ((GQ-EVAL (G-READ 'NO))
(WA-UPDATE-FRINGE WG-HERE)
(WAW-GIVE-ROUTE)
T)
(T (WA-UPDATE-FRINGE MOVE) NIL)))
;;; WAW-GIVE-ROUTE explains the best route to a destination
;;;supplied by the student or (ARG 1).
(DEFUN WAW-GIVE-ROUTE NARGS
(DECLARE (SPECIAL WAW-GIVEN-ROUTE WG-HERE WAD-KNOWNAREA DB-NAME))
(PROG (ROUTE DESTINATION)
(COND ((= (ARG NIL) 0.)
(G-RSAY '(|What cave would you like to go to? |))
(SETQ DESTINATION (G-READ 'CAVE)))
(T (SETQ DESTINATION (ARG 1.))))
(COND ((GP-CAVE-CHECK DESTINATION))
((= DESTINATION WG-HERE)
(G-RSAY '(|We're already there! |)))
((MEMBER DESTINATION (WGR-NEIGHBORS WG-HERE))
(G-RSAY (LIST '|Just move to cave|
DESTINATION
'|. |)))
((MEMBER DESTINATION WAD-KNOWNAREA)
(SETQ WAW-GIVEN-ROUTE (CONS DESTINATION
WAW-GIVEN-ROUTE)
ROUTE (WAW-FIND-ROUTE DESTINATION 0.))
(G-RSAY (APPEND '(|To get to cave|)
(LIST DESTINATION)
'(|,|)
(LIST DB-NAME)
'(|, we could move to|)
(EG-INSERT-AND '|cave|
(CDR ROUTE))
'(|. |))))
(T (G-RSAY (LIST '|We have not explored enough|
'|to develop a route to cave|
DESTINATION
'|from cave|
WG-HERE
'|. |))))))
;;; WAW-FIND-ROUTE finds a route to the given destination and returns it.
(DEFUN WAW-FIND-ROUTE (DESTINATION DIST)
(DECLARE (SPECIAL DIST DB-ROUTE))
(COND
((MEMBER DESTINATION (WAD-GET-DIST DIST))
(SETQ DB-ROUTE (LIST DESTINATION)))
(T
(SETQ DB-ROUTE (WAW-FIND-ROUTE DESTINATION (1+ DIST)))
(SETQ
DB-ROUTE
(CONS
(GM-FIRST-TRUE
(FUNCTION (LAMBDA (X) (DECLARE (SPECIAL DIST))
(MEMBER X (WAD-GET-DIST DIST))))
(XDR-VISITED-NEIGHBORS (CAR DB-ROUTE)))
DB-ROUTE)))))
;;;********** Wumpus Advisor Routines to Modify the Game *********
;;; WAM-TRANSPOSE-MOVE transposes the player's move if necessary.
(DEFUN WAM-TRANSPOSE-MOVE (MOVE)
(DECLARE (SPECIAL WAM-NEXT-MOVE WG-HERE))
(COND ((= WAM-NEXT-MOVE MOVE))
((MEMBER WAM-NEXT-MOVE (WGR-NEIGHBORS WG-HERE))
(WGM-TRANSPOSE WAM-NEXT-MOVE MOVE))
((NOT (WGR-SAFEP MOVE))
(DO ((CAVES (WGR-NEIGHBORS WG-HERE) (CDR CAVES)))
((NULL CAVES))
(COND ((WGR-SAFEP (CAR CAVES))
(G-TSAY '(|*** I transposing the player's|
|move to avoid a danger. ***|))
(WGM-TRANSPOSE (CAR CAVES) MOVE)
(SETQ CAVES NIL))))))
(SETQ WAM-NEXT-MOVE NIL))
;;; WAM-MODIFY-GAME does the initial modification of the game.
(DEFUN WAM-MODIFY-GAME NIL
(DECLARE (SPECIAL WAM-NEXT-MOVE DB-PHASE WG-HERE DB-NUM-CAVES TEST-PHASE))
(SETQ WAM-NEXT-MOVE -1.)
(DO ((WORK-LIST (LIST DB-PHASE (1- DB-PHASE) (1+ DB-PHASE))
(CDR WORK-LIST))
(TEST-PHASE))
((NULL WORK-LIST))
(SETQ TEST-PHASE (CAR WORK-LIST))
(DO ((T-CAVE (RANDOM DB-NUM-CAVES) (GP-RANDEL O-CAVES))
(O-CAVES (GP-ORDLST DB-NUM-CAVES)))
((OR (NULL T-CAVE) (= TEST-PHASE -1.) (= TEST-PHASE 5.)))
(COND ((OR (NOT (WGR-SAFEP T-CAVE)) (WAM-BAD-CAVE T-CAVE))
(SETQ O-CAVES (DELETE T-CAVE O-CAVES)))
((WAM-OK-NEIGHBORS T-CAVE
(CAR (WGR-WARNINGS T-CAVE))
(WGR-NEIGHBORS T-CAVE))
(G-TSAY (LIST '|*** I am altering the game to|
'|create a situation appropriate|
'|for a player of phase|
TEST-PHASE
'|. ***|))
(SETQ O-CAVES NIL WG-HERE T-CAVE))
(T (SETQ O-CAVES (DELETE T-CAVE O-CAVES)))))
(COND ((NOT (= WAM-NEXT-MOVE -1.)) (SETQ WORK-LIST NIL)))))
;;; WAM-BAD-CAVE checks out if CAVE is not a good starting cave.
(DEFUN WAM-BAD-CAVE (CAVE)
(DECLARE (SPECIAL TEST-PHASE))
(COND ((> TEST-PHASE 3.) (MEMBER 2. (WGR-WARNINGS CAVE)))
((< TEST-PHASE 1.) (WGR-WARNINGS CAVE))
((EQUAL '(0.) (WGR-WARNINGS CAVE)) NIL)
((EQUAL '(1.) (WGR-WARNINGS CAVE)) NIL)
(T T)))
;;; WAM-OK-NEIGHBORS checks out to insure that there is an
;;;acceptable neighbor.
(DEFUN WAM-OK-NEIGHBORS (CAVE WARNING W-CAVES)
(DECLARE (SPECIAL WAM-NEXT-MOVE))
(COND ((NULL W-CAVES) NIL)
((WAM-OK-WORK CAVE WARNING (CAR W-CAVES))
(SETQ WAM-NEXT-MOVE (CAR W-CAVES)))
((WAM-OK-NEIGHBORS CAVE WARNING (CDR W-CAVES)))))
;;; WAM-OK-WORK does the actual checking for a particular neighbor.
(DEFUN WAM-OK-WORK (CAVE WARNING NEIGHBOR)
(DECLARE (SPECIAL TEST-PHASE))
(COND ((NOT (WGR-SAFEP NEIGHBOR)) NIL)
((< TEST-PHASE 1.) (GP-INTERSECTION (WGR-WARNINGS NEIGHBOR) '(0. 1.)))
((> TEST-PHASE 3.) T)
;;; Throw out caves with bad geometry.
;;; Phases 1 and 3 require a neighbor in common.
((AND (OR (= TEST-PHASE 1.) (= TEST-PHASE 3.))
(NOT (GP-INTERSECTION (WGR-NEIGHBORS CAVE)
(WGR-NEIGHBORS NEIGHBOR))))
NIL)
;;; Phase 2 requires a neighbor have a smaller cave-set.
((AND (= TEST-PHASE 2.)
(NOT (< (LENGTH (WGR-NEIGHBORS NEIGHBOR))
(LENGTH (WGR-NEIGHBORS CAVE)))))
NIL)
((= TEST-PHASE 1.)
(EQUAL (WGR-WARNINGS NEIGHBOR)
(GP-DELETE WARNING '(0. 1.))))
;;; Hence we must have Phases 2 or 3.
(T (EQUAL (LIST WARNING) (WGR-WARNINGS NEIGHBOR)))))
;;;************** The Wumpus Expert Routines *************
;;; The logical rules are broken down into eight major
;;;categories. The four probability rules are also shown.
;;; For efficiency each rule that is to be taught has been
;;;aasigned a unique number (as shown after the rule memonic.)
;;;These numbers are used to access the arrays of the student-model.
;;;The last three entries are mainly entries in the student-model.
;;;
;;; L0 (0) A cave can be marked as "zero away" if it was
;;; visited and found to contain a "DANGER".
;;;
;;; L1 (1) A cave can be marked as "more than zero away"
;;; if it was safely visited.
;;;
;;; L2 (2) If the player shoots an arrow into a cave and
;;; does not kill the Wumpus, then that cave can
;;; be marked as "more than zero away" (Wumpus).
;;;
;;; L3 (3) If a cave is visited and there is not a warning,
;;; then that cave is "more than N away" where N
;;; is the distance that the warning propagates.
;;;
;;; L4 (4) If a cave is visited and there is a warning, then
;;; that cave is "less than (N+1) away".
;;;
;;; L5 (5) If a cave is marked "more than N away" then all
;;; of its neighbors must be at least "more than (N-1)
;;; away".
;;;
;;; L6 (6) If all of a caves neighbors are at least "more than
;;; (N-1) away", then it must be "more than N away".
;;;
;;; L7 (7) If a cave is "more than (N-1) away" and "less than
;;; (N+1) away", then it is "N away".
;;;
;;; L8 (8) When the algorithm is creating cave-sets and it
;;; encounters a cave which would be N caves away but
;;; which is also "more than N away", then that cave
;;; can not have any contributions to the cave-set.
;;;
;;; L9 (9) If a cave was found to contain a danger (through
;;; visitation), then it does not contain a danger of
;;; higher priority.
;;;
;;; L10 (10) Certain caves can be marked as "more than zero away"
;;; based on consideration of the different cave-sets.
;;;
;;; P11 (11) An estimationof the probability for a given cave is
;;; 1/N, where N is the number of caves in the smallest
;;; cave-set of which said cave is a member.
;;;
;;; P12 (12) For cases where there are two cave-sets, one of which
;;; is a subset of the other, there is no evidence at all
;;; with respect to the caves in the super-set, but not
;;; in the subset (as the caves in the subset completely
;;; explain the warning.) so the probability should be
;;; reduced to some consistent value.
;;;
;;; P13 (13) If a cave is a member of two cave-sets, then its
;;; probability should be increased above that assigned by P11.
;;;
;;; P14 (14) In cases where P13 is applied, the other members of said
;;; cave-sets should heve their probabilities reduced.
;;;
;;; P15 (15) This for those situations where the probability
;;; for the Wumpus being in a cave exceeds the probability
;;; for an arrow killing the player.
;;;
;;; R16 (16) This is for telling the student of warnings and
;;; their meanings.
;;;
;;; R17 (17) This is for telling the student about encounters
;;; with dangers.
;;;
;;; R18 (18) This is to advise the player to avoid dangers.
;;;
;;; For the exact formulas used for the probablity rules,
;;;see the paper about the Wumpus-Advisor.
;;;
;;; XX-UPDATE is the executive of the expert routines and
;;;evaluates the different moves.
(DEFUN XX-UPDATE NIL
(DECLARE (SPECIAL XX-CHANGED WAD-FRINGE))
(XX-UPDATE-WORK '(0. 1. 2.))
(COND (XX-CHANGED (XX-COMBINE-PROB WAD-FRINGE)
(XX-UPDATE-MOVES)
(SETQ XX-CHANGED NIL))))
;;; XX-UPDATE-WORK computes the different probabilities for each danger.
(DEFUN XX-UPDATE-WORK (DANGER-LIST)
(DECLARE (SPECIAL XX-CHANGED))
(PROG (DANGER)
(COND
((NULL DANGER-LIST))
((AXS-CHANGED-SETS (CAR DANGER-LIST))
(SETQ XX-CHANGED T)
(XX-UPDATE-WORK (CDR DANGER-LIST))
(SETQ DANGER (CAR DANGER-LIST))
(XR-COUNT-NUM
(GP-INTERSECTION (AXS-CHANGED-SETS DANGER)
(AXS-COMPLETE-SETS DANGER))
(AXS-COMPLETE-SETS DANGER)
DANGER)
(XP-RESET-PROB (AXS-CHANGED-SETS DANGER) NIL DANGER)
;;; This is to reset CHANGED-SETS as the
;;;probabilities have been updated.
(STORE (AXS-CHANGED-SETS DANGER) NIL))
(T (XX-UPDATE-WORK (CDR DANGER-LIST))))))
;;; XX-MARK-SAFE is called whenever a cave is found by the database
;;;routines to be safe.
(DEFUN XX-MARK-SAFE (CAVE DANGER)
;;; These calls are necessary else the new
;;;probs would never be calculated.
(XP-PUT-P11 CAVE -1.0 DANGER)
(XP-PUT-WHY-P11 CAVE NIL DANGER)
(XP-PUT-WHY-P12 CAVE NIL DANGER)
(XP-PUT-P13 CAVE -1.0 DANGER)
(XP-PUT-P14 CAVE -1.0 DANGER))
;;; XX-COMBINE-PROB combines the probabilities and calculates the INDEX.
(DEFUN XX-COMBINE-PROB (WORK-CAVES)
(DECLARE (SPECIAL CAVE XX-BAT-KILL))
(PROG (CAVE)
(COND
((NULL WORK-CAVES))
(T
(SETQ CAVE (CAR WORK-CAVES))
(XX-COMBINE-PROB (CDR WORK-CAVES))
(XX-PUT-DANGERS
CAVE
(GM-ALL-TRUE
(FUNCTION (LAMBDA (X)
(DECLARE (SPECIAL CAVE))
(OR (AND (= X 2.)
(XPR-SHOOTP CAVE))
(GP-LT 0.0
(XPR-PROB CAVE X)))))
'(0. 1. 2.)))
(XX-PUT-COST
CAVE
(COND ((XPR-SHOOTP CAVE) (XPR-PROB CAVE 2.))
(T (-$ 1.0
(XX-MULT-PROB CAVE
'(0. 1. 2.)
(LIST XX-BAT-KILL
1.0
1.0))))))
(XX-PUT-GAIN CAVE
(+$ (*$ (XX-VALUE-MOVE CAVE)
(XX-MULT-PROB CAVE
'(0. 1. 2.)
'(1.0 1.0 1.0)))
(*$ (XX-VALUE-BAT)
(XPR-PROB CAVE 0.)
(XX-MULT-PROB CAVE
'(1. 2.)
'(1.0 1.0)))
(COND ((XPR-SHOOTP CAVE)
(*$ 5.0 (XPR-GET-P14 CAVE 2.)))
(T 0.0))))
(XX-PUT-INDEX CAVE
(COND ((XDR-VISITEDP CAVE) -1.0)
((GP-EQ 0.0 (XXR-COST CAVE))
(*$ 10000.0 (XXR-GAIN CAVE)))
(T (//$ (XXR-GAIN CAVE)
(XXR-COST CAVE)))))))))
;;; XX-MULT-PROB multiplies (1-P*V) for each danger sent.
(DEFUN XX-MULT-PROB (CAVE DANGERS VALUES)
(COND ((NULL DANGERS) 1.0)
(T (*$ (XX-MULT-PROB CAVE (CDR DANGERS) (CDR VALUES))
(-$ 1.0
(*$ (CAR VALUES)
(XPR-PROB CAVE (CAR DANGERS))))))))
;;; XX-VALUE-MOVE returns the expected value from visiting a cave.
;;; Note that the two following routines presume a normal value of 1.0
;;;for caves that are visited safely.
(DEFUN XX-VALUE-MOVE (CAVE)
(COND ((XDR-VISITEDP CAVE) 0.0)
((XSR-MEMBER CAVE 2.) 1.1)
(T 1.0)))
;;; XX-VALUE-BAT returns the expected value from being picked up
;;;by bats.
(DEFUN XX-VALUE-BAT NIL
(DECLARE (SPECIAL XD-VISITED-CAVES DB-NUM-CAVES))
(//$ (-$ (FLOAT DB-NUM-CAVES)
(FLOAT (LENGTH XD-VISITED-CAVES))
(AXX-EST-NUM-DANGERS 1.)
(AXX-EST-NUM-DANGERS 2.))
(-$ (FLOAT DB-NUM-CAVES) (AXX-EST-NUM-DANGERS 0.))))
;;; XX-INIT-DANGER-EST initializes the array AXX-EST-NUM-DANGER
;;;and sets XX-BAT-KILL.
(DEFUN XX-INIT-DANGER-EST NIL
(DECLARE (SPECIAL XX-BAT-KILL DB-NUM-CAVES))
(DO ((I 2. (1- I)) (NOT-PROB 1.0))
((< I 0.)
(SETQ XX-BAT-KILL
(//$ (+$ (AXX-EST-NUM-DANGERS 1.)
(AXX-EST-NUM-DANGERS 2.))
(-$ (FLOAT DB-NUM-CAVES)
(AXX-EST-NUM-DANGERS 0.)))))
(STORE (AXX-EST-NUM-DANGERS I)
(*$ NOT-PROB (FLOAT (ADB-NUM-DANGERS I))))
(SETQ NOT-PROB
(*$ NOT-PROB
(//$ (FLOAT (- DB-NUM-CAVES (ADB-NUM-DANGERS I)))
(FLOAT DB-NUM-CAVES))))))
;;; XX-UPDATE-MOVES orders moves according to INDEX/DIST.
(DEFUN XX-UPDATE-MOVES NIL
(DECLARE (SPECIAL WAD-FRINGE XX-BEST-MOVES))
(SETQ XX-BEST-MOVES (XX-INSERT (CDR WAD-FRINGE)
(LIST (CAR WAD-FRINGE)))))
;;; XX-INSERT orders the moves according to index.
(DEFUN XX-INSERT (CAVE-LIST RESULT)
(COND ((NULL CAVE-LIST) RESULT)
;;; does it go at the start?
((GP-LT (XXR-INDEX (CAR RESULT)) (XXR-INDEX (CAR CAVE-LIST)))
(XX-INSERT (CDR CAVE-LIST)
(CONS (CAR CAVE-LIST) RESULT)))
;;; are we at the end?
((NULL (CDR RESULT))
(XX-INSERT (CDR CAVE-LIST)
(GP-INSERT RESULT (CAR CAVE-LIST))))
;;; does it go right here?
((GP-LT (XXR-INDEX (CADR RESULT))
(XXR-INDEX (CAR CAVE-LIST)))
(XX-INSERT (CDR CAVE-LIST)
(GP-INSERT RESULT (CAR CAVE-LIST))))
;;; no, so try the next slot.
(T (XX-INSERT (LIST (CAR CAVE-LIST)) (CDR RESULT))
(XX-INSERT (CDR CAVE-LIST) RESULT))))
;;; XXR-INDEX returns the expert's index for CAVE.
(DEFUN XXR-INDEX (CAVE) (ADB-CAVE CAVE 5.))
;;; XX-PUT-INDEX puts the INDEX into the arrays.
(DEFUN XX-PUT-INDEX (CAVE VALUE) (STORE (ADB-CAVE CAVE 5.) VALUE))
;;; XXR-COST gives the COST.
(DEFUN XXR-COST (CAVE) (ADB-CAVE CAVE 3.))
;;; XX-PUT-COST puts the COST into the arrays.
(DEFUN XX-PUT-COST (CAVE VALUE) (STORE (ADB-CAVE CAVE 3.) VALUE))
;;; XXR-GAIN returns the GAIN.
(DEFUN XXR-GAIN (CAVE) (ADB-CAVE CAVE 4.))
;;; XX-PUT-GAIN puts the GAIN into the arrays.
(DEFUN XX-PUT-GAIN (CAVE VALUE) (STORE (ADB-CAVE CAVE 4.) VALUE))
;;; XXR-DANGERS retruns those dangers which are
;;;currently applicable for CAVE.
(DEFUN XXR-DANGERS (CAVE) (ADB-CAVE CAVE 6.))
;;; XX-PUT-DANGERS puts the DANGERS into the arrays.
(DEFUN XX-PUT-DANGERS (CAVE VALUE) (STORE (ADB-CAVE CAVE 6.) VALUE))
;;; XXR-BETTER-MOVEP returns BETTER if it is in fact the better move.
(DEFUN XXR-BETTER-MOVEP (BETTER WORSE)
(COND ((GP-LT (XXR-INDEX WORSE) (XXR-INDEX BETTER)) BETTER)))
;;; XXR-WHY-MORE-THAN returns the preferred reason
;;;for a "more than" class.
(DEFUN XXR-WHY-MORE-THAN (CAVE DIST DANGER)
(COND ((AND (= DIST 0.) (XDR-VISITEDP CAVE)) 1.)
(T (CAR (XDR-WHY-MORE-THAN CAVE DANGER)))))
;;; XXT-GET-NODIST-SET returns the NODIST set ommiting
;;;the L10 caves DEPENDING depending on TEST.
(DEFUN XXT-GET-NODIST-SET (O-CAVE DIST DANGER TEST)
(COND ((NOT TEST)
(XSR-GET-NODIST-SET O-CAVE DIST DANGER))
(T (DO ((CAVES (XSR-GET-NODIST-SET O-CAVE DIST DANGER)
(CDR CAVES))
(VAL))
((NULL CAVES) VAL)
(COND ((= (XXR-WHY-MORE-THAN (CAR CAVES)
DIST
DANGER)
10.)
NIL)
(T (SETQ VAL (CONS (CAR CAVES) VAL))))))))
;;;******* The Data Base Routines of the Expert. ********
;;;*********** This is Stage 1 of the Algorithm ************
;;; Along with classifying the caves under "XD" properties,
;;;these routines also mark the justification under "XW"
;;;properties. Note that the outer routines are called as
;;;the player is notified of the dangers and warnings.
;;;(This simplifies the logic of the expert.)
;;;
;;; XD-MARK-DANGER marks a danger whenever it has been visited.
;;;It implements L0 and L9.
(DEFUN XD-MARK-DANGER (CAVE DANGER)
(DECLARE (SPECIAL CAVE))
;;; This implements L9.
(MAPC
(FUNCTION (LAMBDA (X)
(XD-PUT-MORE-THAN CAVE 0. '(9.) X)))
(GP-REMOVE-LIST '(0. 1. 2.) (GP-ORDLST (1+ DANGER))))
(XD-PUT-WHY-EXACTLY CAVE '(0.) DANGER)
(XD-PUT-EXACTLY CAVE 0. DANGER)
(XS-CREATE-CAVE-SET CAVE 0. DANGER))
;;; XD-MARK-VISITED updates the data base after a cave
;;;has been visited (safely). It implements L1.
(DEFUN XD-MARK-VISITED (CAVE DANGER-LIST)
(DECLARE (SPECIAL CAVE DANGER-LIST XD-VISITED-CAVES DB-MOVES))
(PROG (DANGER)
(SETQ DANGER (CAR DANGER-LIST))
(COND ((XDR-VISITEDP CAVE)
(XD-PUT-VISITED CAVE
(CONS DB-MOVES
(XDR-VISITEDP CAVE))))
((NULL DANGER-LIST)
(XD-PUT-VISITED CAVE
(CONS DB-MOVES
(XDR-VISITEDP CAVE)))
(SETQ XD-VISITED-CAVES
(CONS CAVE XD-VISITED-CAVES)))
(T (XD-MARK-VISITED CAVE (CDR DANGER-LIST))
(XD-PUT-MORE-THAN CAVE 0. '(1.) DANGER)
;;; The next two calls are in case
;;;they were missed earlier because the
;;;cave had not been visited.
(XD-PROPAGATE-DIST (WGR-NEIGHBORS CAVE)
CAVE
(1- (XDR-MORE-THAN CAVE
DANGER))
DANGER)
(XD-CHECK-NEIGHBORS (LIST CAVE) DANGER)
(XS-CAVE-CHECK CAVE
(XDR-MORE-THAN CAVE DANGER)
DANGER)
(XS-NEIGHBOR-CHECK (WGR-NEIGHBORS CAVE)
DANGER)))))
;;; XD-MARK-SHOT is called after an unsuccessful shot.
;;;It implements L2.
(DEFUN XD-MARK-SHOT (CAVE)
(DECLARE (SPECIAL XX-CHANGED WAD-FRINGE))
(SETQ XX-CHANGED T)
(XD-PUT-MORE-THAN CAVE 0. '(2.) 2.)
(COND ((NOT (WGR-EXTRA-ARROWS)) (XP-SET-PROB WAD-FRINGE 2.))))
;;; XD-MARK-NOWARNING is called whenever a warning is received.
;;;It implements L3.
(DEFUN XD-MARK-NOWARNING (CAVE DANGER)
(XD-PUT-MORE-THAN CAVE
(ADB-WARNING-DIST DANGER)
'(3.)
DANGER))
;;; XD-MARK-WARNING is called whenever a warning is received and
;;;implements rule L4.
(DEFUN XD-MARK-WARNING (CAVE DANGER)
(XD-PUT-WHY-LESS-THAN CAVE '(4.) DANGER)
(XD-PUT-LESS-THAN CAVE (1+ (ADB-WARNING-DIST DANGER)) DANGER)
(XD-EXACT-CHECK CAVE DANGER))
;;; XD-MARK-SAFE-L10 marks that a cave is safe because of L10.
(DEFUN XD-MARK-SAFE-L10 (CAVE-LIST CAUSE DANGER)
(COND ((NULL CAVE-LIST))
(T (XD-MARK-SAFE-L10 (CDR CAVE-LIST) CAUSE DANGER)
(XD-PUT-MORE-THAN (CAR CAVE-LIST)
0.
(LIST 10. CAUSE)
DANGER))))
;;; XD-PROPAGATE-DIST checks to see if a DIST can be
;;;propagated. It implements L5.
(DEFUN XD-PROPAGATE-DIST (CAVE-LIST CAVE DIST DANGER)
(COND ((NULL CAVE-LIST))
(T (XD-PROPAGATE-DIST (CDR CAVE-LIST) CAVE DIST DANGER)
(XD-PUT-MORE-THAN (CAR CAVE-LIST)
DIST
(LIST 5. CAVE)
DANGER))))
;;; XD-PUT-MORE-THAN actually adds the DIST specified and performs
;;;the requisite checks. (Calling other routines as necessary.)
(DEFUN XD-PUT-MORE-THAN (CAVE DIST REASON DANGER)
(COND ((> DIST (XDR-MORE-THAN CAVE DANGER))
(COND ((= (XDR-MORE-THAN CAVE DANGER) -1.)
(XX-MARK-SAFE CAVE DANGER)))
(XD-MARK-MORE-THAN CAVE DIST DANGER)
(XD-PUT-WHY-MORE-THAN CAVE REASON DANGER)
(XD-EXACT-CHECK CAVE DANGER)
;;; Don't propagate L6.
(COND ((= (CAR REASON) 6.) NIL)
(T (XD-PROPAGATE-DIST (XDR-KNOWN-NEIGHBORS CAVE)
CAVE
(1- DIST)
DANGER)))
(XD-CHECK-NEIGHBORS (XDR-KNOWN-NEIGHBORS CAVE) DANGER)
(XS-CAVE-CHECK CAVE DIST DANGER))
;;; This is to have the simplest rule possible under reason.
((AND (> DIST -1.)
(= DIST (XDR-MORE-THAN CAVE DANGER))
(< (CAR REASON)
(CAR (XDR-WHY-MORE-THAN CAVE DANGER))))
(XD-PUT-WHY-MORE-THAN CAVE REASON DANGER))))
;;; XD-CHECK-NEIGHBORS sees if L6 applies to any of the caves it is sent.
(DEFUN XD-CHECK-NEIGHBORS (CAVE-LIST DANGER)
(COND ((NULL CAVE-LIST))
((XDR-VISITEDP (CAR CAVE-LIST))
(XD-CHECK-NEIGHBORS (CDR CAVE-LIST) DANGER)
(DO ((WORST 100.
(MIN WORST
(XDR-MORE-THAN (CAR LIST) DANGER)))
(LIST (WGR-NEIGHBORS (CAR CAVE-LIST)) (CDR LIST)))
((NULL LIST)
;;; It is useless to have a "more than" greater than N.
(COND ((> (ADB-WARNING-DIST DANGER) WORST)
(XD-PUT-MORE-THAN (CAR CAVE-LIST)
(1+ WORST)
'(6.)
DANGER))))))
(T (XD-CHECK-NEIGHBORS (CDR CAVE-LIST) DANGER))))
;;; XD-EXACT-CHECK is called anytime a new property is assigned
;;;to see if L7 applies.
(DEFUN XD-EXACT-CHECK (CAVE DANGER)
(COND
((> (XDR-EXACTLY CAVE DANGER) -1.) NIL)
((> (+ 3. (XDR-MORE-THAN CAVE DANGER))
(XDR-LESS-THAN CAVE DANGER))
(XD-PUT-WHY-EXACTLY CAVE '(7.) DANGER)
(XS-CREATE-CAVE-SET
CAVE
(XD-PUT-EXACTLY CAVE
(1+ (XDR-MORE-THAN CAVE DANGER))
DANGER)
DANGER))))
;;; XDR-VISITEDP is a predicate which returns the move
;;;numbers in which a cave was visited in this game.
(DEFUN XDR-VISITEDP (CAVE) (ADB-CAVE CAVE 2.))
;;; XD-PUT-VISITED puts the move numbers into the arrays.
(DEFUN XD-PUT-VISITED (CAVE VALUE) (STORE (ADB-CAVE CAVE 2.) VALUE))
;;; XDR-VISITED-NEIGHBORS returns all of the neighbors of the cave
;;;that have been visited.
(DEFUN XDR-VISITED-NEIGHBORS (CAVE)
(GM-ALL-TRUE 'XDR-VISITEDP (WGR-NEIGHBORS CAVE)))
;;; XDR-KNOWN-NEIGHBORS returns all the neighbors of the given
;;;cave that the student knows about.
(DEFUN XDR-KNOWN-NEIGHBORS (CAVE)
(COND ((XDR-VISITEDP CAVE) (WGR-NEIGHBORS CAVE))
(T (XDR-VISITED-NEIGHBORS CAVE))))
;;; XDR-EXACTLY returns the EXACTLY distance (if applicable).
(DEFUN XDR-EXACTLY (CAVE DANGER) (ADB-DCAVE CAVE 5. DANGER))
;;; XD-PUT-EXACTLY puts the EXACTLY value into the arrays.
(DEFUN XD-PUT-EXACTLY (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 5. DANGER) VALUE))
;;; XDR-WHY-EXACTLY returns why a cvae is classified as EXACTLY.
(DEFUN XDR-WHY-EXACTLY (CAVE DANGER) (ADB-DCAVE CAVE 6. DANGER))
;;; XD-PUT-WHY-EXACTLY puts the reason for the EXACTLY value
;;;into the arrays.
(DEFUN XD-PUT-WHY-EXACTLY (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 6. DANGER) VALUE))
;;; XDR-MORE-THAN returns the dist that is assigned to CAVE
;;;under the property of "more than". (It is a utility routine.)
(DEFUN XDR-MORE-THAN (CAVE DANGER) (ADB-DCAVE CAVE 1. DANGER))
;;; XD-MARK-MORE-THAN puts the MORE-THAN value into the arrays.
(DEFUN XD-MARK-MORE-THAN (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 1. DANGER) VALUE))
;;; XDR-WHY-MORE-THAN returns the justification for the "more than" value.
(DEFUN XDR-WHY-MORE-THAN (CAVE DANGER) (ADB-DCAVE CAVE 2. DANGER))
;;; XD-PUT-WHY-MORE-THAN puts the reason for the MORE-THAN value
;;;into the arrays.
(DEFUN XD-PUT-WHY-MORE-THAN (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 2. DANGER) VALUE))
;;; XDR-LESS-THAN gets the LESS-THAN value from the arrays.
(DEFUN XDR-LESS-THAN (CAVE DANGER) (ADB-DCAVE CAVE 3. DANGER))
;;; XD-PUT-LESS-THAN puts the LESS-THAN value into the arrays.
(DEFUN XD-PUT-LESS-THAN (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 3. DANGER) VALUE))
;;; XDR-WHY-LESS-THAN gets the reason for the LESS-THAN value
;;;from the arrays.
(DEFUN XDR-WHY-LESS-THAN (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 4. DANGER) VALUE))
;;; XD-PUT-WHY-LESS-THAN puts the reason for the
;;;LESS-THAN value into the arrays.
(DEFUN XD-PUT-WHY-LESS-THAN (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 4. DANGER) VALUE))
;;;********* Expert Routines which update the Cave-Sets. ********
;;; As the database used by these routines is not quite
;;;self-explanatory (to me), a brief blurb is added to help out.
;;;
;;; XS-NUM is used for caves which are "N away" and contains the
;;; current estimate/actual number of caves in the cave-set.
;;;
;;; XS-DIST-SET is used for caves that are "N away" and contains
;;; the end node caves of the expansion toward the cave-set.
;;; A cave at dist N would be the originating cave, and the caves
;;; at dist 0 would be members of the cave-set. The idea is
;;; to expand until there are only caves at dist zero, but this
;;; can not always be done as in some cases the neighbors of
;;; a cave are not known.
;;;
;;; XS-NODIST-SET contains those caves which were previously members
;;; of the DIST-SET at the given dist, but were disqualified
;;; because of its "more than N away" classification. This list
;;; is kept to aid in the development of explanations.
;;;
;;; XS-MEMBER is used for caves that have been put onto a DIST-SET.
;;; It contains the originating cave and the dist.
;;;
;;; XS-CREATE-CAVE-SET is called whenever an exact-cave is found.
;;;It creates the particulsar cave-set.
(DEFUN XS-CREATE-CAVE-SET (CAVE DIST DANGER)
(XS-ADD-TO-LIST CAVE (LIST CAVE) DIST DANGER))
;;; XS-ADD-TO-LIST adds caves onto the DIST-SET at the given DIST.
;;;In general, O-CAVE is the originating cave, and M-CAVE is
;;;the member cave.
(DEFUN XS-ADD-TO-LIST (O-CAVE ADD-CAVES DIST DANGER)
(PROG (M-CAVE)
(SETQ M-CAVE (CAR ADD-CAVES))
(COND
((NULL M-CAVE))
;;; check to see if the cave has already been added.
((MEMBER M-CAVE (XSR-TOTAL-DIST-SET O-CAVE DIST DANGER))
(XS-ADD-TO-LIST O-CAVE (CDR ADD-CAVES) DIST DANGER))
(T
(XS-ADD-TO-LIST O-CAVE (CDR ADD-CAVES) DIST DANGER)
(XS-PUT-MEMBER M-CAVE
(GP-CONS (LIST O-CAVE DIST)
(XSR-MEMBER M-CAVE DANGER))
DANGER)
(XS-PUT-DIST-SET O-CAVE
(GP-CONS M-CAVE
(XSR-GET-DIST-SET O-CAVE
DIST
DANGER))
DIST
DANGER)
(XS-PUT-TOTAL-SET O-CAVE
(GP-CONS M-CAVE
(XSR-TOTAL-DIST-SET O-CAVE
DIST
DANGER))
DIST
DANGER)
(XS-PUT-NUM O-CAVE
(+ (XS-NUM-EST DIST)
(XSR-GET-NUM O-CAVE DANGER))
DANGER)
(XS-CAVE-CHECK-WORK M-CAVE
(LIST (LIST O-CAVE DIST))
(XDR-MORE-THAN M-CAVE DANGER)
DANGER)
(XS-MARK-CHANGED O-CAVE DANGER)))))
;;; XS-CAVE-CHECK checks out if a given cave should still be
;;;on the DIST-SETs that it is on.
(DEFUN XS-CAVE-CHECK (CAVE DIST DANGER)
(XS-CAVE-CHECK-WORK CAVE (XSR-MEMBER CAVE DANGER) DIST DANGER))
;;; XS-CAVE-CHECK-WORK checks to see if the cave should still
;;;be on individual DIST-SETs.
(DEFUN XS-CAVE-CHECK-WORK (M-CAVE WORK-LIST DIST DANGER)
(PROG (O-CAVE O-DIST)
(COND ((NULL WORK-LIST) (RETURN T)))
(XS-CAVE-CHECK-WORK M-CAVE (CDR WORK-LIST) DIST DANGER)
(SETQ O-CAVE (CAAR WORK-LIST) O-DIST (CADAR WORK-LIST))
(COND
((> (1+ DIST) O-DIST)
;;; These functions implement L8.
(XS-PUT-NODIST-SET
O-CAVE
(GP-CONS M-CAVE
(XSR-GET-NODIST-SET O-CAVE O-DIST DANGER))
O-DIST
DANGER)
(XS-REMOVE-CAVE M-CAVE O-CAVE O-DIST DANGER)
(XS-MARK-CHANGED O-CAVE DANGER))
;;; If we have dist 0 then don't propagate further.
((< O-DIST 1.))
((XDR-VISITEDP M-CAVE)
(XS-ADD-TO-LIST
O-CAVE
(GP-REMOVE-LIST (WGR-NEIGHBORS M-CAVE)
(XSR-TOTAL-DIST-SET O-CAVE
O-DIST
DANGER))
(1- O-DIST)
DANGER)
(XS-REMOVE-CAVE M-CAVE O-CAVE O-DIST DANGER)
(XS-MARK-CHANGED O-CAVE DANGER))
(T (XS-ADD-TO-LIST O-CAVE
(XDR-KNOWN-NEIGHBORS M-CAVE)
(1- O-DIST)
DANGER)))))
;;; XS-REMOVE-CAVE is a function to do some of the tasks of
;;;removing a cave from the DIST-SET.
(DEFUN XS-REMOVE-CAVE (M-CAVE O-CAVE O-DIST DANGER)
(COND ((MEMBER M-CAVE
(XSR-TOTAL-DIST-SET O-CAVE O-DIST DANGER))
(XS-PUT-DIST-SET O-CAVE
(DELETE M-CAVE
(XSR-GET-DIST-SET O-CAVE
O-DIST
DANGER))
O-DIST
DANGER)
(XS-PUT-NUM O-CAVE
(- (XSR-GET-NUM O-CAVE DANGER)
(XS-NUM-EST O-DIST))
DANGER)
(XS-PUT-MEMBER M-CAVE
(DELETE (LIST O-CAVE O-DIST)
(XSR-MEMBER M-CAVE DANGER))
DANGER))))
;;; XS-MARK-CHANGED marks that a cave-set has been changed.
(DEFUN XS-MARK-CHANGED (CAVE DANGER)
(STORE (AXS-CHANGED-SETS DANGER)
(GP-CONS CAVE (AXS-CHANGED-SETS DANGER)))
(COND ((XSR-COMPLETE-CAVE-SETP CAVE DANGER)
(STORE (AXS-PARTIAL-SETS DANGER)
(GP-DELETE CAVE (AXS-PARTIAL-SETS DANGER)))
(STORE (AXS-COMPLETE-SETS DANGER)
(GP-CONS CAVE (AXS-COMPLETE-SETS DANGER))))
(T (STORE (AXS-PARTIAL-SETS DANGER)
(GP-CONS CAVE (AXS-PARTIAL-SETS DANGER))))))
;;; XS-NEIGHBOR-CHECK is to propagate cave-sets around caves
;;;that have not been visited. It is only essential when the
;;;warning propagates more than two caves, but it can be
;;;helpful in explanations when the warning propagates two caves.
(DEFUN XS-NEIGHBOR-CHECK (CAVE-LIST DANGER)
(COND ((NULL CAVE-LIST))
(T (XS-NEIGHBOR-CHECK (CDR CAVE-LIST) DANGER)
(COND ((XDR-VISITEDP (CAR CAVE-LIST)))
(T (XS-CAVE-CHECK (CAR CAVE-LIST)
(XDR-MORE-THAN (CAR CAVE-LIST)
DANGER)
DANGER))))))
;;; XS-NUMEST estimates the size of the cave-set for a given distance.
(DEFUN XS-NUM-EST (DIST)
;;;This is a cheap hack that works for now.
(EXPT 2. DIST))
;;; XSR-GET-CAVE-SET reurns the cave-set attached to CAVE.
(DEFUN XSR-GET-CAVE-SET (CAVE DANGER)
(XSR-GET-DIST-SET CAVE 0. DANGER))
;;; XSR-GET-MEMBER-SETS returns the originating caves of the
;;;cave-sets of which M-CAVE is a member.
(DEFUN XSR-GET-MEMBER-SETS (M-CAVE DANGER)
(DO ((WORK-LIST (XSR-MEMBER M-CAVE DANGER) (CDR WORK-LIST))
(O-CAVE)
(O-DIST)
(VALUE NIL))
((NULL WORK-LIST) VALUE)
(SETQ O-CAVE (CAAR WORK-LIST)
O-DIST (CADAR WORK-LIST))
(COND ((= O-DIST 0.) (SETQ VALUE (CONS O-CAVE VALUE))))))
;;; XSR-OTHER-CAVES returns the caves which have not been removed
;;;at DIST and then the probability that they are not applicable.
(DEFUN XSR-OTHER-CAVES (O-CAVE DIST REDUCED-SET DANGER)
(DO ((I (XDR-EXACTLY O-CAVE DANGER) (1- I))
(CAVES)
(VALUE)
(NUM 0.))
((NOT (> I DIST))
(LIST VALUE
(//$ (FLOAT (LENGTH REDUCED-SET))
(FLOAT (+ NUM (LENGTH REDUCED-SET))))))
(SETQ CAVES (XSR-GET-DIST-SET O-CAVE I DANGER)
VALUE (GP-UNION CAVES VALUE)
NUM (+ NUM
(* (LENGTH CAVES) (XS-NUM-EST (- I DIST)))))))
;;; XSR-REDUCED-SET returns those caves which were propagated.
(DEFUN XSR-REDUCED-SET (O-CAVE DIST DANGER)
(GP-REMOVE-LIST (XSR-TOTAL-DIST-SET O-CAVE DIST DANGER)
(XSR-GET-NODIST-SET O-CAVE DIST DANGER)))
;;; XSR-TOTAL-DIST-SET returns all caves at DIST.
(DEFUN XSR-TOTAL-DIST-SET (CAVE DIST DANGER)
(ADB-DCAVE CAVE (XSR-PROP-NUM 0. DIST DANGER) DANGER))
;;; XS-PUT-TOTAL-SET puts the TOTAL-SET.
(DEFUN XS-PUT-TOTAL-SET (CAVE VALUE DIST DANGER)
(STORE (ADB-DCAVE CAVE (XSR-PROP-NUM 0. DIST DANGER) DANGER)
VALUE))
;;; XSR-GET-DIST-SET gets the DIST-SET because of the complicated access
;;;procedure.
(DEFUN XSR-GET-DIST-SET (CAVE DIST DANGER)
(ADB-DCAVE CAVE (XSR-PROP-NUM 1. DIST DANGER) DANGER))
;;; XS-PUT-DIST-SET putprops the DIST-SET because of the lengthy access
;;;procedure.
(DEFUN XS-PUT-DIST-SET (CAVE VALUE DIST DANGER)
(STORE (ADB-DCAVE CAVE (XSR-PROP-NUM 1. DIST DANGER) DANGER)
VALUE))
;;; XSR-GET-NODIST-SET gets the NODIST-SET because of the lengthy access
;;;procedure.
(DEFUN XSR-GET-NODIST-SET (CAVE DIST DANGER)
(ADB-DCAVE CAVE (XSR-PROP-NUM 2. DIST DANGER) DANGER))
;;; XS-PUT-NODIST-SET putprops the NODIST-SET because of the lengthy access
;;;procedure.
(DEFUN XS-PUT-NODIST-SET (CAVE VALUE DIST DANGER)
(STORE (ADB-DCAVE CAVE (XSR-PROP-NUM 2. DIST DANGER) DANGER)
VALUE))
;;; XSR-PROP-NUM returns the appropriate property number for the arrays.
(DEFUN XSR-PROP-NUM (TYPE-DIST DIST DANGER)
(DECLARE (SPECIAL DB-TOTAL-DIST DB-NUM-DPROP))
(+ DB-NUM-DPROP
(* TYPE-DIST DB-TOTAL-DIST)
(ADB-DIST-START DANGER)
DIST))
;;; XSR-COMPLETE-CAVE-SETP returns T if the CAVE-SET
;;;attached to CAVE is complete.
(DEFUN XSR-COMPLETE-CAVE-SETP (CAVE DANGER)
(DO ((DIST (XDR-EXACTLY CAVE DANGER) (1- DIST))
(DONE NIL)
(VALUE NIL))
(DONE VALUE)
(COND ((= DIST -1.) (SETQ DONE T))
((< DIST 1.) (SETQ DONE T VALUE T))
((XSR-GET-DIST-SET CAVE DIST DANGER)
(SETQ DONE T)))))
;;; XSR-GET-NUM returns the size of the cave-set
;;;(sometimes an estimate.)
(DEFUN XSR-GET-NUM (CAVE DANGER) (ADB-DCAVE CAVE 16. DANGER))
;;; XS-PUT-NUM puts NUM into the arrays.
(DEFUN XS-PUT-NUM (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 16. DANGER) VALUE))
;;; XSR-MEMBER returns the ORIGIN/DIST pairs.
(DEFUN XSR-MEMBER (CAVE DANGER) (ADB-DCAVE CAVE 7. DANGER))
;;; XS-PUT-MEMBER puts the MEMBER value into the arrays.
(DEFUN XS-PUT-MEMBER (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 7. DANGER) VALUE))
;;;******** This is the Second Stage of the Algorithm. *********
;;; XR-COUNT-NUM checks for groups of cave-sets that would
;;;require certain caves to be safe.
(DEFUN XR-COUNT-NUM (CHANGED-SETS COMPLETE-SETS DANGER)
(DECLARE (SPECIAL DANGER))
(COND ((< (LENGTH COMPLETE-SETS) (ADB-NUM-DANGERS DANGER)))
((NULL CHANGED-SETS))
(T (XR-COUNT-NUM (CDR CHANGED-SETS) COMPLETE-SETS DANGER)
(COND ((AXR-FOUND-N DANGER)
(XR-CHECK-SETS (AXR-FOUND-N DANGER)
COMPLETE-SETS
COMPLETE-SETS
DANGER)))
(XR-CHECK-SETS (LIST (CAR CHANGED-SETS))
(GP-DELETE (CAR CHANGED-SETS)
COMPLETE-SETS)
COMPLETE-SETS
DANGER))))
;;; XR-CHECK-SETS does the actual searching and marking safe.
;;; Notice that it also keeps track of how many of the dangers
;;;have been identified.
(DEFUN XR-CHECK-SETS (GOT-SETS CHOOSE-FROM COMPLETE-SETS DANGER)
(COND ((> (1+ (LENGTH GOT-SETS)) (ADB-NUM-DANGERS DANGER))
;;; We have chosen N caves, now test them.
(XR-CHECK-SET GOT-SETS COMPLETE-SETS DANGER))
;;; Check to see if there anymore caves to choose from.
;;;If not, then check the ones we have.
((NULL CHOOSE-FROM)
(XR-CHECK-SET GOT-SETS COMPLETE-SETS DANGER))
;;; The algorithm does a binary branch and tries BOTH
;;;choosing the first choice and not choosing it.
(T (XR-CHECK-SETS GOT-SETS
(CDR CHOOSE-FROM)
COMPLETE-SETS
DANGER)
(XR-CHECK-SETS (CONS (CAR CHOOSE-FROM) GOT-SETS)
(CDR CHOOSE-FROM)
COMPLETE-SETS
DANGER))))
;;; XR-CHECK-SET checks to see if the GOT-SETS it is sent have
;;;no intersection, and if so it takes appropriate action.
(DEFUN XR-CHECK-SET (GOT-SETS COMPLETE-SETS DANGER)
(DECLARE (SPECIAL DANGER))
(DO
((REST-OF GOT-SETS (CDR REST-OF))
(UNION NIL
(GP-UNION UNION
(XSR-GET-CAVE-SET (CAR REST-OF) DANGER)))
(TOTAL 0.
(+ TOTAL
(LENGTH (XSR-GET-CAVE-SET (CAR REST-OF) DANGER)))))
((OR (< (LENGTH UNION) TOTAL) (NULL REST-OF))
(COND
((< (LENGTH UNION) TOTAL))
((= (LENGTH GOT-SETS) (ADB-NUM-DANGERS DANGER))
(STORE (AXR-NUM-IDENTIFIED DANGER)
(ADB-NUM-DANGERS DANGER))
(STORE (AXR-FOUND-N DANGER) GOT-SETS)
(XD-MARK-SAFE-L10
(GP-REMOVE-LIST
(APPLY
'GP-UNION
(MAPCAR
(FUNCTION (LAMBDA (X) (XSR-GET-CAVE-SET X DANGER)))
(APPEND COMPLETE-SETS (AXS-PARTIAL-SETS DANGER))))
UNION)
GOT-SETS
DANGER))
;;; This is to keep track of how many dangers have been identified.
((> (LENGTH GOT-SETS) (AXR-NUM-IDENTIFIED DANGER))
(STORE (AXR-NUM-IDENTIFIED DANGER) (LENGTH GOT-SETS)))))))
;;;********** Probability Routines of the Expert. *************
;;;********** This is the Third Stage of the Algorithm. *************
;;; XP-RESET-PROB is the main function of the probability routines.
;;;It returns all those caves whose probabilities have been changed
;;;by either P12 or P14. Note that RESET-CAVES starts as NIL and is
;;;all the caves that P13 changes.
(DEFUN XP-RESET-PROB (CHANGED-SETS RESET-CAVES DANGER)
(DECLARE (SPECIAL XP-P12-CHANGED))
(PROG (PROB CAVE CAVE-SET NEW-RESET CHECK-CAVES)
(COND
((NULL CHANGED-SETS)
(XP-P12-CALC DANGER)
(SETQ NEW-RESET
(GP-UNION XP-P12-CHANGED
(XP-P14 RESET-CAVES NIL DANGER)))
;;; We have considered XP-P12-CHANGED caves.
(SETQ XP-P12-CHANGED NIL)
(XP-SET-PROB NEW-RESET DANGER)
(RETURN NEW-RESET))
(T (SETQ CAVE (CAR CHANGED-SETS)
CAVE-SET (XSR-GET-CAVE-SET CAVE DANGER))
(SETQ PROB
(//$ 1.0 (FLOAT (XSR-GET-NUM CAVE DANGER))))
(XP-P11 CAVE CAVE-SET PROB DANGER)
(SETQ CHECK-CAVES
(XP-P12 CAVE
(AXS-COMPLETE-SETS DANGER)
DANGER))
(SETQ RESET-CAVES
(GP-UNION (XP-P13 (APPEND CHECK-CAVES CAVE-SET)
DANGER)
RESET-CAVES))
(RETURN (XP-RESET-PROB (CDR CHANGED-SETS)
RESET-CAVES
DANGER))))))
;;; XP-SET-PROB puts the preferred probability on
;;;the caves property list.
(DEFUN XP-SET-PROB (WORK-CAVES DANGER)
(PROG (CAVE PROB TEMP)
(COND ((NULL WORK-CAVES) (RETURN NIL))
(T (XP-SET-PROB (CDR WORK-CAVES) DANGER)))
(SETQ CAVE (CAR WORK-CAVES)
PROB (XPR-GET-P14 CAVE DANGER))
(XP-PUT-WHY-PROB
CAVE
(COND ((< PROB 0.0)
(XP-PUT-PROB CAVE NIL DANGER)
(COND ((XPR-WHY-P12 CAVE DANGER) '(12.))))
((GP-EQ PROB
(SETQ TEMP (XPR-GET-P11 CAVE DANGER)))
(XP-PUT-PROB CAVE TEMP DANGER)
'(11.))
((GP-EQ PROB
(SETQ TEMP (XPR-GET-P13 CAVE DANGER)))
(XP-PUT-PROB CAVE TEMP DANGER)
'(13.))
(T (XP-PUT-PROB CAVE PROB DANGER) '(14.)))
DANGER)
(COND ((AND (= DANGER 2.)
(> (XPR-PROB CAVE 2.) 0.25)
(WGR-EXTRA-ARROWS))
(XP-PUT-WHY-PROB CAVE
(GP-CONS 15.
(XPR-WHY-PROB CAVE 2.))
2.)
(XP-PUT-PROB CAVE
(*$ 0.3333
(-$ 1.0 (XPR-PROB CAVE 2.)))
2.)))))
;;; XP-P11 puts the new P11 value if applicable.
(DEFUN XP-P11 (O-CAVE ADD-LIST PROB DANGER)
(COND ((NULL ADD-LIST))
(T (XP-P11 O-CAVE (CDR ADD-LIST) PROB DANGER)
(COND ((< (XPR-GET-P11 (CAR ADD-LIST) DANGER) PROB)
(XP-PUT-P11 (CAR ADD-LIST) PROB DANGER)
(XP-PUT-WHY-P11 (CAR ADD-LIST)
O-CAVE
DANGER))))))
;;; XP-P12 marks those caves to which P12 applies. It also
;;;returns those caves which P13 ought to check.
(DEFUN XP-P12 (O-CAVE COMPLETE-SETS DANGER)
;;;This is to see if O-CAVE is a superset of any complete-set.
(XP-P12-WORK (GP-DELETE O-CAVE COMPLETE-SETS)
(LIST O-CAVE)
DANGER)
(COND
((MEMBER O-CAVE COMPLETE-SETS)
;;; This is to see if it is subset of another cave-set.
(XP-P12-WORK (LIST O-CAVE)
(GP-DELETE O-CAVE
(APPEND (AXS-PARTIAL-SETS DANGER)
COMPLETE-SETS))
DANGER))))
;;; XP-P12-WORK does the searching for caves to which P12 applies.
;;;It also finds cave-sets that are redundant and/or unnecessary.
;;;It keeps a list of those caves which it has changed in XP-P12-CHANGED.
(DEFUN XP-P12-WORK (SUBSET-CAVES SUPERSET-CAVES DANGER)
(PROG (SUBSET SUPERSET RESULT)
(COND
((AND SUBSET-CAVES SUPERSET-CAVES)
(SETQ RESULT
(APPEND (XP-P12-WORK (CDR SUBSET-CAVES)
SUPERSET-CAVES
DANGER)
(XP-P12-WORK SUBSET-CAVES
(CDR SUPERSET-CAVES)
DANGER)))
(SETQ SUBSET (XSR-GET-CAVE-SET (CAR SUBSET-CAVES)
DANGER))
(SETQ SUPERSET
(XSR-GET-CAVE-SET (CAR SUPERSET-CAVES) DANGER))
(COND
;;; Ensure that SUBSET is a good cave-set.
((XPR-REDUNDANTP (CAR SUBSET-CAVES) DANGER))
;;; If anything is returned, SUBSET is not a subset.
((GP-REMOVE-LIST SUBSET SUPERSET) (RETURN RESULT))
(T
(RETURN (APPEND RESULT
(XP-P12-MARK (GP-REMOVE-LIST SUPERSET
SUBSET)
(CAR SUBSET-CAVES)
(CAR SUPERSET-CAVES)
DANGER)))))))))
;;; XP-P12-MARK marks caves to which P12 aplies and marks
;;;redundant cave-sets.
(DEFUN XP-P12-MARK (MARK-CAVES SUB-CAVE SUPER-CAVE DANGER)
(DECLARE (SPECIAL XP-P12-CHANGED))
(COND ((NULL MARK-CAVES)
(XP-PUT-REDUNDANT SUPER-CAVE SUB-CAVE DANGER))
(T (XP-P12-MARK (CDR MARK-CAVES)
SUB-CAVE
SUPER-CAVE
DANGER)
(SETQ XP-P12-CHANGED (GP-CONS (CAR MARK-CAVES)
XP-P12-CHANGED))
(XP-PUT-P13 (CAR MARK-CAVES) -1.0 DANGER)
(XP-PUT-P14 (CAR MARK-CAVES) -1.0 DANGER)
(XP-PUT-WHY-P12 (CAR MARK-CAVES)
(GP-CONS (LIST SUB-CAVE SUPER-CAVE)
(XPR-WHY-P12 (CAR MARK-CAVES)
DANGER))
DANGER)))
MARK-CAVES)
;;; XP-P12-CALC calculates the probability for all P12 caves at this move.
(DEFUN XP-P12-CALC (DANGER)
(DECLARE (SPECIAL XD-VISITED-CAVES DB-NUM-CAVES))
(PROG (IDENTIFIED UNIDENTIFIED SAFE)
(SETQ IDENTIFIED (AXR-NUM-IDENTIFIED DANGER))
(SETQ UNIDENTIFIED (- (ADB-NUM-DANGERS DANGER)
IDENTIFIED))
(SETQ SAFE (LENGTH XD-VISITED-CAVES))
(STORE (AXP-PROB12 DANGER)
(//$ (FLOAT UNIDENTIFIED)
(FLOAT (COND ((= (+ SAFE IDENTIFIED)
DB-NUM-CAVES)
1.)
(T (- DB-NUM-CAVES
SAFE
IDENTIFIED))))))))
;;; XP-P13 resets the probabilities for P13. It returns
;;;the caves which it changes.
(DEFUN XP-P13 (CHANGE-LIST DANGER)
(COND
((NULL CHANGE-LIST) NIL)
(T
(DO
((CAVE (CAR CHANGE-LIST))
(CAVE-SETS (XPR-GOOD-MEMBER-SETS (CAR CHANGE-LIST) DANGER)
(CDR CAVE-SETS))
(SAFE-PROB 1.0)
(FINAL-PROB 0.0))
((NULL CAVE-SETS)
(SETQ FINAL-PROB (-$ 1.0 SAFE-PROB))
;;; If the probability hasn't changed, don't do anything.
(COND ((OR (NULL (XPR-GOOD-MEMBER-SETS CAVE DANGER))
(GP-EQ FINAL-PROB (XPR-GET-P13 CAVE DANGER)))
(XP-P13 (CDR CHANGE-LIST) DANGER))
(T (XP-PUT-P13 CAVE FINAL-PROB DANGER)
(GP-CONS CAVE
(XP-P13 (CDR CHANGE-LIST) DANGER)))))
(SETQ SAFE-PROB
(*$ SAFE-PROB
(-$ 1.0
(//$ 1.0
(FLOAT (XSR-GET-NUM (CAR CAVE-SETS)
DANGER))))))))))
;;; XP-P14 updates the P14 probabilities.
;;;Note that it returns all those caves which it has recalculated.
(DEFUN XP-P14 (RESET-CAVES CALC-CAVES DANGER)
(DECLARE (SPECIAL DANGER))
(COND ((NULL RESET-CAVES)
(XP-P14-CALC CALC-CAVES DANGER)
CALC-CAVES)
(T (XP-P14 (CDR RESET-CAVES)
(GP-UNION (XP-P14-PROPAGATES (CAR RESET-CAVES)
DANGER)
CALC-CAVES)
DANGER))))
;;; XP-P14-PROPAGATES returns those caves which are
;;;related to CAVE in P14 calculations.
(DEFUN XP-P14-PROPAGATES (CAVE DANGER)
(APPLY 'GP-UNION
(MAPCAR
(FUNCTION (LAMBDA (X) (XSR-GET-CAVE-SET X DANGER)))
(XPR-GOOD-MEMBER-SETS CAVE DANGER))))
;;; XP-P14-CALC does the actual calculations of P14.
(DEFUN XP-P14-CALC (CALC-CAVES DANGER)
(PROG (CAVE MEMBER-SETS)
(COND
((NULL CALC-CAVES))
((NOT (SETQ CAVE
(CAR CALC-CAVES)
MEMBER-SETS
(XPR-GOOD-MEMBER-SETS CAVE DANGER)))
(XP-P14-CALC (CDR CALC-CAVES) DANGER))
(T
(XP-P14-CALC (CDR CALC-CAVES) DANGER)
(XP-PUT-P14 CAVE
(-$ (XPR-GET-P13 CAVE DANGER)
(*$ (//$ 1.0
(FLOAT (LENGTH MEMBER-SETS)))
(XP-P14-SUM-PROB CAVE
MEMBER-SETS
DANGER)))
DANGER)
;;; Do not allow P14 to reduce probs too much.
(COND ((< (XPR-GET-P14 CAVE DANGER)
(AXP-PROB12 DANGER))
(XP-PUT-P14 CAVE
(+$ 1.0E-3 (AXP-PROB12 DANGER))
DANGER)))))))
;;; XP-P14-SUM-PROB does the inner sum of formula in paper.
(DEFUN XP-P14-SUM-PROB (CAVE MEMBER-SETS DANGER)
(COND ((NULL MEMBER-SETS) 0.0)
;;; If the cave-set has only one member, P14 does not apply.
((= (XSR-GET-NUM (CAR MEMBER-SETS) DANGER) 1.)
(XP-P14-SUM-PROB CAVE (CDR MEMBER-SETS) DANGER))
(T (DO ((WORK-CAVES (XPR-P13-CHANGED (CAR MEMBER-SETS)
DANGER)
(CDR WORK-CAVES))
(SUM 0.0)
;;; Remember that the algorithm passes over the cave itself.
(PROB -1.0
(COND ((EQUAL (CAR WORK-CAVES) CAVE) -1.0)
((CAR WORK-CAVES)
(XPR-GET-P13 (CAR WORK-CAVES)
DANGER))
(T 2.0)))
(N (FLOAT (XSR-GET-NUM (CAR MEMBER-SETS)
DANGER))))
((= PROB 2.0)
(+$ (*$ SUM (//$ 1.0 (1-$ N)))
(XP-P14-SUM-PROB CAVE
(CDR MEMBER-SETS)
DANGER)))
(COND ((GP-EQ PROB -1.0))
(T (SETQ SUM (-$ (+$ SUM PROB)
(//$ 1.0 N)))))))))
;;; XPR-GOOD-MEMBER-SETS returns all good cave-sets.
(DEFUN XPR-GOOD-MEMBER-SETS (CAVE DANGER)
(DO ((MEMBER-SETS (XSR-GET-MEMBER-SETS CAVE DANGER)
(CDR MEMBER-SETS))
(VALUE))
((NULL MEMBER-SETS) VALUE)
(COND ((XPR-REDUNDANTP (CAR MEMBER-SETS) DANGER))
(T (SETQ VALUE (CONS (CAR MEMBER-SETS) VALUE))))))
;;; XPR-REDUNDANTP returns the SUPER-SET which this
;;;cave-set redundant.
(DEFUN XPR-REDUNDANTP (CAVE DANGER) (ADB-DCAVE CAVE 8. DANGER))
;;; XP-PUT-REDUNDANT puts the SUPER-SET into the arrays.
(DEFUN XP-PUT-REDUNDANT (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 8. DANGER) VALUE))
;;; XPR-PROB returns the preferred probability.
(DEFUN XPR-PROB (CAVE DANGER)
(COND ((> (XDR-MORE-THAN CAVE DANGER) -1.) 0.0)
((ADB-DCAVE CAVE 9. DANGER))
(T (XPR-GET-P12 CAVE DANGER))))
;;; XP-PUT-PROB puts the appropriate value into the array.
(DEFUN XP-PUT-PROB (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 9. DANGER) VALUE))
;;; XPR-WHY-PROB returns the probability rule(s)
;;;that were applied. (P12 if no others)
(DEFUN XPR-WHY-PROB (CAVE DANGER)
(COND ((> (XDR-MORE-THAN CAVE DANGER) -1.) NIL)
((ADB-DCAVE CAVE 10. DANGER))
((AXR-FOUND-N DANGER)
(XD-MARK-SAFE-L10 (LIST CAVE)
(AXR-FOUND-N DANGER)
DANGER)
NIL)
(T '(12.))))
;;; XP-PUT-WHY-PROB puts the probability rules into the arrays.
(DEFUN XP-PUT-WHY-PROB (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 10. DANGER) VALUE))
;;; XPR-GET-P11 returns the probability according to P11.
;;;It is -1.0 if P11 does not apply at all.
(DEFUN XPR-GET-P11 (CAVE DANGER) (ADB-DCAVE CAVE 11. DANGER))
;;; XP-PUT-P11 puts the probability for P11.
(DEFUN XP-PUT-P11 (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 11. DANGER) VALUE))
;;; XPR-WHY-P11 returns the cave which caused the P11 probability.
(DEFUN XPR-WHY-P11 (CAVE DANGER) (ADB-DCAVE CAVE 15. DANGER))
;;; XP-PUT-WHY-P11 puts the reason for a P11 prob (originating cave).
(DEFUN XP-PUT-WHY-P11 (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 15. DANGER) VALUE))
;;; XPR-GET-P12 returns the probability for P12 (otherwise -1.0).
(DEFUN XPR-GET-P12 (CAVE DANGER)
(COND ((AND (< (XDR-MORE-THAN CAVE DANGER) 0.)
(NOT (XPR-GOOD-MEMBER-SETS CAVE DANGER)))
;;;This is to insure the correct reason
;;;is marked for a prob of zero.
(COND ((AXR-FOUND-N DANGER)
(XD-MARK-SAFE-L10 (LIST CAVE)
(AXR-FOUND-N DANGER)
DANGER)
0.0)
(T (AXP-PROB12 DANGER))))
(T -1.0)))
;;; XPR-WHY-P12 returns the caves responsible for a
;;;P12 classification.
(DEFUN XPR-WHY-P12 (CAVE DANGER) (ADB-DCAVE CAVE 12. DANGER))
;;; XP-PUT-WHY-P12 puts why there is a classification of P12.
(DEFUN XP-PUT-WHY-P12 (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 12. DANGER) VALUE))
;;; XPR-GET-P13 returns the probability of P13 (otherwise -1.0).
(DEFUN XPR-GET-P13 (CAVE DANGER) (ADB-DCAVE CAVE 13. DANGER))
;;; XP-PUT-P13 puts the prob of P13.
(DEFUN XP-PUT-P13 (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 13. DANGER) VALUE))
;;; XPR-P13-CHANGED returns those members of a
;;;cave-set which have been reset by P13.
(DEFUN XPR-P13-CHANGED (O-CAVE DANGER)
(DECLARE (SPECIAL DANGER))
(GM-ALL-TRUE (FUNCTION (LAMBDA (X) (DECLARE (SPECIAL DANGER))
(> (XPR-GET-P13 X DANGER)
(XPR-GET-P11 X DANGER))))
(XSR-GET-CAVE-SET O-CAVE DANGER)))
;;; XPR-GET-P14 returns the probability of P14 (otherwise -1.0).
(DEFUN XPR-GET-P14 (CAVE DANGER) (ADB-DCAVE CAVE 14. DANGER))
;;; XP-PUT-P14 puts the prob for P14.
(DEFUN XP-PUT-P14 (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 14. DANGER) VALUE))
;;; XPR-SHOOTP determines if it would be better to shoot
;;;into a given cave before visiting it.
(DEFUN XPR-SHOOTP (CAVE)
(AND (XPR-WHY-PROB CAVE 2.)
(= (CAR (XPR-WHY-PROB CAVE 2.)) 15.)))
;;; ************ The Move Comparer Routines. ************
;;; CMR-SAFEP returns true if a cave is acceptably safe.
(DEFUN CMR-SAFEP (CAVE DANGERS)
(COND ((NULL DANGERS) T)
((< (XDR-MORE-THAN CAVE (CAR DANGERS)) 0.) NIL)
((SLR-OK-RULESP (CXR-PROB CAVE (CAR DANGERS))
(CAR DANGERS))
(CMR-SAFEP CAVE (CDR DANGERS)))))
;;; CMR-KNOWS-SAME determines if the two moves are the same or
;;;that the player recognized them as the same or worse.
(DEFUN CMR-KNOWS-SAME (B-MOVE W-MOVE DANGERS)
(COND ((NULL DANGERS) T)
((OR (CMR-SAME-DANGERSP W-MOVE B-MOVE (LIST (CAR DANGERS)))
(SLR-KNOWS-RULESP (CXR-BETTER W-MOVE B-MOVE (CAR DANGERS))
(CAR DANGERS)))
(CMR-KNOWS-SAME B-MOVE W-MOVE (CDR DANGERS)))))
;;; CMR-SAME-DANGERSP determines if two caves are identical with
;;;respect to DANGER (returns T) or if the player should have
;;;recognized that they were equivalent (returns the rules involved).
(DEFUN CMR-SAME-DANGERSP (CAVE1 CAVE2 DANGERS)
(COND ((NULL DANGERS) T)
((NOT (GP-EQ (XPR-PROB CAVE1 (CAR DANGERS))
(XPR-PROB CAVE2 (CAR DANGERS))))
NIL)
((GP-EQUIV (CXR-PROB CAVE1 (CAR DANGERS))
(CXR-PROB CAVE2 (CAR DANGERS)))
(CMR-SAME-DANGERSP CAVE1 CAVE2 (CDR DANGERS)))
((AND (SLR-KNOWS-RULESP
(GP-UNION (CXR-PROB CAVE1 (CAR DANGERS))
(CXR-PROB CAVE2 (CAR DANGERS)))
(CAR DANGERS))
(CMR-SAME-DANGERSP CAVE1 CAVE2 (CDR DANGERS)))
(GP-UNION (CXR-PROB CAVE1 (CAR DANGERS))
(CXR-PROB CAVE2 (CAR DANGERS))))))
;;; CMR-BETTER-PROBSP returns T if BETTER actually is better
;;;and the explanation is acceptable (for DANGERS).
(DEFUN CMR-BETTER-PROBSP (BETTER WORSE DANGERS)
(COND ((NULL DANGERS) T)
((CMR-BETTER-PROBP BETTER WORSE (CAR DANGERS))
(CMR-BETTER-PROBSP BETTER WORSE (CDR DANGERS)))))
;;; CMR-BETTER-PROBP returns T if BETTER is better
;;;for acceptable reasons.
(DEFUN CMR-BETTER-PROBP (BETTER WORSE DANGER)
(COND ((GP-LT (XPR-PROB BETTER DANGER) (XPR-PROB WORSE DANGER))
(SLR-OK-RULESP (CXR-BETTER BETTER WORSE DANGER)
DANGER))))
;;; CMR-C5-TEST tests to insure that all the PROBS
;;;are as bad or worse for DANGERS.
(DEFUN CMR-C5-TEST (W-MOVE H-MOVE DANGERS)
(COND ((NULL DANGERS) T)
((OR (CMR-SAME-DANGERSP W-MOVE
H-MOVE
(LIST (CAR DANGERS)))
(CMR-BETTER-PROBP W-MOVE H-MOVE (CAR DANGERS)))
(CMR-C5-TEST W-MOVE H-MOVE (CDR DANGERS)))))
;;; CMR-EXPLAIN-DANGER returns those dangers for which the player
;;is not expected to know how to calculate the prob.
(DEFUN CMR-EXPLAIN-DANGER (CAVE1 CAVE2 DANGERS)
(DO ((WORK-ON DANGERS (CDR WORK-ON))
(DANGER)
(OK-DANGERS))
((NULL WORK-ON)
(COND ((NULL OK-DANGERS) (SETQ OK-DANGERS DANGERS)))
(COND ((MEMBER 2. OK-DANGERS) '(2.))
((MEMBER 1. OK-DANGERS) '(1.))
(T '(0.))))
(SETQ DANGER (CAR WORK-ON))
(COND ((GP-EQ (XPR-PROB CAVE2 DANGER) 1.0)
(SETQ WORK-ON NIL
OK-DANGERS (LIST DANGER)))
((NOT (AND (SLR-KNOWS-RULESP (CXR-PROB CAVE1 DANGER) DANGER)
(SLR-KNOWS-RULESP (CXR-PROB CAVE2 DANGER) DANGER)))
(SETQ OK-DANGERS (CONS DANGER OK-DANGERS))))))
;;; CXR-BETTER returns the rules for why B-CAVE is better.
(DEFUN CXR-BETTER (B-CAVE W-CAVE DANGER)
(DECLARE (SPECIAL CX-COMPARE CX-WHY-BETTER CX-WHY-WORSE))
(SETQ CX-COMPARE (LIST B-CAVE W-CAVE))
;;; As in paper, we must check for cases where default
;;;assumptions of unsafe apply, i.e. when better is absolutely
;;;safe or worse is absolute danger. When both special cases
;;;apply, a tricky hack is used (a rare case).
(COND ((AND (GP-EQ (XPR-PROB W-CAVE DANGER) 1.0)
(GP-EQ (XPR-PROB B-CAVE DANGER) 0.0))
(SETQ CX-COMPARE NIL)
(COND ((< (LENGTH (CXR-PROB B-CAVE DANGER))
(LENGTH (CXR-PROB W-CAVE DANGER)))
(CXR-PROB B-CAVE DANGER))
(T (CXR-PROB W-CAVE DANGER))))
((GP-EQ (XPR-PROB B-CAVE DANGER) 0.0)
(SETQ CX-COMPARE NIL)
(CXR-PROB B-CAVE DANGER))
((GP-EQ (XPR-PROB W-CAVE DANGER) 1.0)
(SETQ CX-COMPARE NIL)
(CXR-PROB W-CAVE DANGER))
((GP-LT (XPR-GET-P11 B-CAVE DANGER)
(XPR-GET-P11 W-CAVE DANGER))
(SETQ CX-WHY-BETTER 11.
CX-WHY-WORSE 11.)
(CX-PROB11 (LIST B-CAVE W-CAVE) DANGER NIL))
((> (XPR-GET-P12 B-CAVE DANGER) -1.0)
(SETQ CX-WHY-BETTER 12.
CX-WHY-WORSE 11.)
(CXR-PROB B-CAVE DANGER))
((GP-LT (XPR-GET-P11 B-CAVE DANGER)
(XPR-GET-P13 W-CAVE DANGER))
(SETQ CX-WHY-BETTER 11.
CX-WHY-WORSE 13.)
(CX-PROB11 (LIST B-CAVE)
DANGER
(CX-PROB13 (LIST W-CAVE)
DANGER
NIL)))
((GP-LT (XPR-GET-P14 B-CAVE DANGER)
(XPR-GET-P11 W-CAVE DANGER))
(SETQ CX-WHY-BETTER 14.
CX-WHY-WORSE 11.)
(CX-PROB14 (LIST B-CAVE)
DANGER
(CX-PROB11 (LIST W-CAVE)
DANGER
NIL)))
(T (SETQ CX-COMPARE NIL)
(GP-UNION (CXR-PROB B-CAVE DANGER)
(CXR-PROB W-CAVE DANGER)))))
;;; CXR-PROB is the interface routine for CX-PROB.
(DEFUN CXR-PROB (CAVE DANGER)
(DECLARE (SPECIAL WE-MOVE-NUM))
(COND ((NOT (= (CAR (ADB-DCAVE CAVE 17. DANGER)) WE-MOVE-NUM))
(STORE (ADB-DCAVE CAVE 17. DANGER)
(CONS WE-MOVE-NUM (CX-PROB CAVE DANGER NIL)))))
(CDR (ADB-DCAVE CAVE 17. DANGER)))
;;; CX-PROB returns the rules necessary to explain
;;;the prob that was used by the expert.
(DEFUN CX-PROB (CAVE DANGER REASONS)
((GP-MAKN 'CX-PROB (CAR (XPR-WHY-PROB CAVE DANGER)))
(LIST CAVE)
DANGER
REASONS))
;;; CXR-CAVE-SET returns the rules involved with
;;;the list of cave-sets (originating caves).
(DEFUN CXR-CAVE-SET (WORK-LIST DANGER REASONS)
(CX-CAVE-SET WORK-LIST DANGER REASONS NIL))
;;; CX-CAVE-SET, this interfacing is to prevent
;;;endless repititions of L10s.
(DEFUN CX-CAVE-SET (WORK-LIST DANGER REASONS L10-SW)
(COND
((NULL WORK-LIST) REASONS)
(T (SETQ REASONS
(CX-CAVE-SET (CDR WORK-LIST) DANGER REASONS L10-SW))
(DO ((O-CAVE (CAR WORK-LIST))
(VALUE (CXR-EXACTLY (CAR WORK-LIST) DANGER REASONS))
(DIST (XDR-EXACTLY (CAR WORK-LIST) DANGER) (1- DIST))
(TEMP))
((< DIST 1.)
(CXR-MORE-THAN (XXT-GET-NODIST-SET O-CAVE
0.
DANGER
L10-SW)
0.
DANGER
VALUE))
(COND ((SETQ TEMP
(XSR-GET-NODIST-SET O-CAVE DIST DANGER))
(SETQ VALUE
(CXR-MORE-THAN TEMP
DIST
DANGER
(GP-CONS 8. VALUE)))))))))
;;; CXR-MORE-THAN returns the rules that were necessary
;;;to justify a "more than" class.
(DEFUN CXR-MORE-THAN (WORK-CAVES DIST DANGER REASONS)
(PROG (CAVE REASON)
(COND ((NULL WORK-CAVES) (RETURN REASONS)))
(SETQ REASONS (CXR-MORE-THAN (CDR WORK-CAVES)
DIST
DANGER
REASONS)
CAVE (CAR WORK-CAVES)
REASON (XXR-WHY-MORE-THAN CAVE DIST DANGER))
(RETURN
(COND ((> DIST (XDR-MORE-THAN CAVE DANGER))
(WE-ERROR (LIST 'CXR-MORE-THAN
CAVE
DIST
DANGER))
REASONS)
((= DIST -1.) REASONS)
((= REASON 5.)
(COND ((AND (= (XDR-MORE-THAN CAVE DANGER) 0.)
(> (ADB-WARNING-DIST DANGER) 1.))
(SETQ REASONS (GP-CONS 19. REASONS))))
(CXR-MORE-THAN (CDR (XDR-WHY-MORE-THAN CAVE
DANGER))
(1+ DIST)
DANGER
(GP-CONS 5. REASONS)))
((= REASON 6.)
(CXR-MORE-THAN (WGR-NEIGHBORS CAVE)
(1- DIST)
DANGER
(GP-CONS 6. REASONS)))
((= REASON 10.)
(CX-CAVE-SET (CADR (XDR-WHY-MORE-THAN CAVE
DANGER))
DANGER
(GP-CONS 10. REASONS)
T))
(T (GP-CONS REASON REASONS))))))
;;; CXR-EXACTLY returns the reasons for an EXACTLY classification.
(DEFUN CXR-EXACTLY (CAVE DANGER REASONS)
(COND ((= (CAR (XDR-WHY-EXACTLY CAVE DANGER)) 0.)
(GP-CONS 0. REASONS))
(T (CXR-MORE-THAN (LIST CAVE)
(XDR-MORE-THAN CAVE DANGER)
DANGER
(GP-UNION '(7. 4.) REASONS)))))
;;; CXR-VALUE returns the reasons for an increased cave-value.
(DEFUN CXR-VALUE (CAVE)
(CXR-EXACTLY (CAAR (XSR-MEMBER CAVE 2.)) 2. NIL))
;;; CX-PROBNIL adds why the given caves are safe. (no rule)
(DEFUN CX-PROBNIL (CAVE-LIST DANGER REASONS)
(COND ((NULL CAVE-LIST) REASONS)
((GP-LT 0.0 (XPR-PROB (CAR CAVE-LIST) DANGER))
(CX-PROBNIL (CDR CAVE-LIST)
DANGER
(CX-PROB12 (LIST (CAR CAVE-LIST))
DANGER
REASONS)))
(T (CX-PROBNIL (CDR CAVE-LIST)
DANGER
(CXR-MORE-THAN (LIST (CAR CAVE-LIST))
0.
DANGER
REASONS)))))
;;; CX-PROB11 gathers the reasons for a PROB11 probability.
(DEFUN CX-PROB11 (CAVE-LIST DANGER REASONS)
(COND
((NULL CAVE-LIST) REASONS)
;;; If L0 applied, P11 is not necessary to justify PROB.
((AND (GP-EQ (XPR-GET-P11 (CAR CAVE-LIST) DANGER) 1.0)
(EQUAL (XPR-WHY-P11 (CAR CAVE-LIST) DANGER) (CAR CAVE-LIST)))
(GP-CONS 0. REASONS))
(T (CX-PROB11 (CDR CAVE-LIST)
DANGER
(CXR-CAVE-SET (LIST (XPR-WHY-P11 (CAR CAVE-LIST)
DANGER))
DANGER
(GP-CONS 11. REASONS))))))
;;; CX-PROB12 returns the reasons for PROB12.
(DEFUN CX-PROB12 (CAVE-LIST DANGER REASONS)
(COND
((NULL CAVE-LIST) REASONS)
(T
(CX-PROB12 (CDR CAVE-LIST)
DANGER
(CXR-CAVE-SET (APPLY 'APPEND
(XPR-WHY-P12 (CAR CAVE-LIST)
DANGER))
DANGER
(GP-CONS 12. REASONS))))))
;;; CX-PROB13 adds on the reasons for a P13 prob.
(DEFUN CX-PROB13 (WORK-LIST DANGER REASONS)
(COND
((NULL WORK-LIST) REASONS)
(T (SETQ REASONS (CX-PROB13 (CDR WORK-LIST) DANGER REASONS))
(COND ((XPR-WHY-P12 (CAR WORK-LIST) DANGER)
(SETQ REASONS
(CX-PROB12 (LIST (CAR WORK-LIST))
DANGER
REASONS))))
(CXR-CAVE-SET (XPR-GOOD-MEMBER-SETS (CAR WORK-LIST) DANGER)
DANGER
(GP-CONS 13. REASONS)))))
;;; CX-PROB14 adds on the reasons for a P14 prob.
(DEFUN CX-PROB14 (CAVE-LIST DANGER REASONS)
(DO ((CAVE-SETS (XPR-GOOD-MEMBER-SETS (CAR CAVE-LIST) DANGER)
(CDR CAVE-SETS))
(VALUE (GP-CONS 14. REASONS)))
((NULL CAVE-SETS)
(COND ((CDR CAVE-LIST)
(CX-PROB14 (CDR CAVE-LIST) DANGER VALUE))
(T VALUE)))
(SETQ VALUE
(CXR-CAVE-SET (LIST (CAR CAVE-SETS)) DANGER VALUE)
VALUE
(CX-PROB13 (XPR-P13-CHANGED (CAR CAVE-SETS) DANGER)
DANGER
VALUE))))
;;; CX-PROB15 adds on the reasons for PROB15.
(DEFUN CX-PROB15 (CAVE-LIST DANGER REASONS)
(COND
((NULL CAVE-LIST) REASONS)
(T (CX-PROB15 (CDR CAVE-LIST)
DANGER
((GP-MAKN 'CX-PROB
(CADR (XPR-WHY-PROB (CAR CAVE-LIST)
DANGER)))
(LIST (CAR CAVE-LIST))
DANGER
(GP-CONS 15. REASONS))))))
;;; ************ Psychologist Functions *********
;;; PS-UPDATE-MODEL compares moves and updates the student model.
(DEFUN PS-UPDATE-MODEL (MOVE)
(DECLARE (SPECIAL DB-MOVES))
(PROG (WORSE-CAVES DANGERS)
(SETQ DB-MOVES (1+ DB-MOVES))
(COND ((XDR-VISITEDP MOVE)
(MAPC (FUNCTION (LAMBDA (X) (SK-MARK-RULE 1. X)))
'(0. 1. 2.))
(RETURN NIL)))
(COND ((SETQ WORSE-CAVES (PS-WORSE-CAVES MOVE)))
(T (GO END)))
(G-TSAY
(APPEND
'(|*** Moves which the student seems to|
|have correctly identified as worse|)
(EG-INSERT-AND '|is cave| WORSE-CAVES)
'(|. ***|)))
(SETQ DANGERS (XXR-DANGERS MOVE))
;;; Is it possible that C5 applies?
(COND ((XSR-MEMBER MOVE 2.)
(PS-C5 WORSE-CAVES MOVE DANGERS)))
(COND ((NULL DANGERS) (PS-C0 WORSE-CAVES MOVE NIL))
((= (LENGTH DANGERS) 1.)
(PS-C1 WORSE-CAVES MOVE (CAR DANGERS) NIL)
(PS-C2 WORSE-CAVES MOVE DANGERS NIL))
(T (PS-C2 WORSE-CAVES MOVE DANGERS NIL)
(PS-C3 WORSE-CAVES
MOVE
DANGERS
NIL
DANGERS
WORSE-CAVES)))
END (PS-DEGRADE-MODEL MOVE)
(SC-UPDATE-MODEL)))
;;; PS-WORSE-CAVES returns those caves which the player
;;;is thought to have found some fault with.
(DEFUN PS-WORSE-CAVES (MOVE)
(DECLARE (SPECIAL MOVE WAW-ROUTE WAW-GIVEN-ROUTE LWA-GOOD-MOVES XX-BEST-MOVES))
(PROG (DIST FRINGE-CAVES)
(SETQ DIST (LENGTH (WAW-FIND-ROUTE MOVE 0.))
DIST (+ DIST DIST -3. (- (LENGTH WAW-ROUTE))))
(COND ((GC-MEMBER LWA-GOOD-MOVES MOVE) (RETURN NIL))
;;; If the player asked for a route to this cave,
;;;he is presumed to have identified all worse caves.
((MEMBER MOVE WAW-GIVEN-ROUTE)
(RETURN (PS-WORSE-WORK MOVE XX-BEST-MOVES)))
((< DIST 1.) (RETURN NIL)))
(SETQ FRINGE-CAVES (GP-INTERSECTION XX-BEST-MOVES
(WAD-GET-DIST DIST)))
(RETURN (PS-WORSE-WORK MOVE FRINGE-CAVES))))
;;; PS-WORSE-WORK actually figures out which are worse.
(DEFUN PS-WORSE-WORK (MOVE OTHERS)
(DECLARE (SPECIAL LWA-BAD-MOVES))
(COND ((NULL OTHERS) NIL)
((AND (NOT (GC-MEMBER LWA-BAD-MOVES (CAR OTHERS)))
(XXR-BETTER-MOVEP MOVE (CAR OTHERS)))
(CONS (CAR OTHERS) (PS-WORSE-WORK MOVE (CDR OTHERS))))
(T (PS-WORSE-WORK MOVE (CDR OTHERS)))))
;;; PS-C0 marks rules as appropriate for C0.
(DEFUN PS-C0 (WORSE-MOVES B-MOVE MARKED)
(PROG (W-MOVE W-DANGERS W-DANGER)
(COND ((NULL WORSE-MOVES)
(COND (MARKED (SKC-MARK-RULE 0.)))
(RETURN NIL)))
(SETQ W-MOVE (CAR WORSE-MOVES)
W-DANGERS (XXR-DANGERS W-MOVE)
W-DANGER (CAR W-DANGERS))
(COND ((AND W-DANGER
(OR (CDR W-DANGERS)
(MEMBER W-DANGER MARKED)))
(PS-C0 (CDR WORSE-MOVES) B-MOVE MARKED))
(W-DANGER (PS-TEST-MARK (CXR-BETTER B-MOVE
(CAR WORSE-MOVES)
W-DANGER)
W-MOVE
0.
W-DANGER)
(PS-C0 (CDR WORSE-MOVES)
B-MOVE
(CONS W-DANGER MARKED))))))
;;; PS-C1 marks rules as appropriate for C1.
(DEFUN PS-C1 (WORSE-MOVES B-MOVE B-DANGER MARKED)
(PROG (W-MOVE W-DANGERS NEW-RULES)
(COND ((NULL WORSE-MOVES)
(COND (MARKED (SKC-MARK-RULE 1.)))
(RETURN NIL)))
(SETQ W-MOVE (CAR WORSE-MOVES)
W-DANGERS (XXR-DANGERS W-MOVE))
(COND ((AND (NULL (CDR W-DANGERS))
(= (CAR W-DANGERS) B-DANGER)
(SETQ NEW-RULES
(CMR-BETTER-PROBP B-MOVE
W-MOVE
B-DANGER)))
(SETQ NEW-RULES (GP-REMOVE-LIST NEW-RULES MARKED))
(PS-TEST-MARK NEW-RULES W-MOVE 1. B-DANGER)))
(PS-C1 (CDR WORSE-MOVES)
B-MOVE
B-DANGER
(APPEND NEW-RULES MARKED))))
;;; PS-C2 marks rules as appropriate for C2.
(DEFUN PS-C2 (WORSE-MOVES B-MOVE B-DANGERS MARKED)
(PROG (W-MOVE W-DANGERS O-DANGERS O-DANGER NOT-OK)
(COND ((NULL WORSE-MOVES)
(COND (MARKED (SKC-MARK-RULE 2.)))
(RETURN NIL)))
(SETQ W-MOVE (CAR WORSE-MOVES)
W-DANGERS (XXR-DANGERS W-MOVE)
O-DANGERS (GP-REMOVE-LIST W-DANGERS B-DANGERS)
NOT-OK (GP-REMOVE-LIST B-DANGERS W-DANGERS)
O-DANGER (CAR O-DANGERS))
(COND ((OR (CDR O-DANGERS)
NOT-OK
(MEMBER O-DANGER MARKED)
(NOT (CMR-KNOWS-SAME B-MOVE
W-MOVE
B-DANGERS)))
(PS-C2 (CDR WORSE-MOVES)
B-MOVE
B-DANGERS
MARKED))
(T (PS-TEST-MARK (CXR-BETTER B-MOVE W-MOVE O-DANGER)
W-MOVE
2.
O-DANGER)
(PS-C2 (CDR WORSE-MOVES)
B-MOVE
B-DANGERS
(CONS O-DANGER MARKED))))))
;;; PS-C3 marks rules as appropriate for C3.
(DEFUN PS-C3 (WORSE-MOVES B-MOVE B-DANGERS MARKED DANGER-LIST
OW-MOVES)
(PROG (W-MOVE W-DANGERS NEW-RULES C-DANGER R-DANGERS)
(COND ((NOT (OR DANGER-LIST WORSE-MOVES))
(COND (MARKED (SKC-MARK-RULE 3.)))
(RETURN NIL))
((NULL WORSE-MOVES)
(PS-C3 OW-MOVES
B-MOVE
B-DANGERS
(COND (MARKED '(T)))
(CDR DANGER-LIST)
OW-MOVES)
(RETURN NIL)))
(SETQ W-MOVE (CAR WORSE-MOVES)
W-DANGERS (XXR-DANGERS W-MOVE)
C-DANGER (CAR DANGER-LIST)
R-DANGERS (GP-DELETE C-DANGER B-DANGERS))
(COND ((AND (GP-EQUIV W-DANGERS B-DANGERS)
C-DANGER
R-DANGERS
(SETQ NEW-RULES
(CMR-BETTER-PROBP B-MOVE
W-MOVE
C-DANGER))
(CMR-KNOWS-SAME B-MOVE W-MOVE R-DANGERS))
(SETQ NEW-RULES (GP-REMOVE-LIST NEW-RULES MARKED))
(PS-TEST-MARK NEW-RULES W-MOVE 3. C-DANGER)))
(PS-C3 (CDR WORSE-MOVES)
B-MOVE
B-DANGERS
(APPEND NEW-RULES MARKED)
DANGER-LIST
OW-MOVES)))
;;; PS-C5 updates if C5 has applied.
(DEFUN PS-C5 (WORSE-CAVES H-MOVE H-DANGERS)
(COND ((NULL WORSE-CAVES))
((AND (NOT (XSR-MEMBER (CAR WORSE-CAVES) 2.))
(NOT (XPR-SHOOTP H-MOVE))
(CMR-C5-TEST (CAR WORSE-CAVES) H-MOVE '(0. 1. 2.))
(PS-TEST-MARK (CXR-VALUE H-MOVE)
(CAR WORSE-CAVES)
5.
2.))
(SKC-MARK-RULE 5.))
(T (PS-C5 (CDR WORSE-CAVES) H-MOVE H-DANGERS))))
;;; PS-MARK-SHOT notes that the player wisely
;;;chose to shoot into a cave.
(DEFUN PS-MARK-SHOT (CAVE)
(SK-MARK-RULES
(PS-EXPL-MARK-SHOT (SLR-OK-RULESP (CXR-PROB CAVE 2.) 2.)
CAVE)
2.))
;;; PS-EXPL-MARK-SHOT explains that said rules were marked.
(DEFUN PS-EXPL-MARK-SHOT (RULES CAVE)
(COND
(RULES
(G-TSAY
(APPEND '(|*** By shooting into cave|)
(LIST CAVE)
'(|, the student has indicated a knowledge of|)
(EG-TOLD-RULES RULES 2.)
'(|. ***|)))))
RULES)
;;; PS-EXPL-MARK explains why the given rules were marked.
(DEFUN PS-TEST-MARK (RULES W-MOVE C-RULE DANGER)
(COND
((NULL RULES) NIL)
((SLR-OK-RULESP RULES DANGER)
(G-TSAY (APPEND '(|*** According to combination rule|)
(LIST C-RULE)
'(|, I am marking|)
(EG-TOLD-RULES RULES DANGER)
'(|because his move is better than cave|)
(LIST W-MOVE '|. ***|)))
(SK-MARK-RULES RULES DANGER)
RULES)))
;;; PS-DEGRADE-MODEL is responsible for degrading
;;;the knowledge model.
(DEFUN PS-DEGRADE-MODEL (MOVE)
(DECLARE (SPECIAL MOVE PS-EXPL-SWITCH DB-COMMENT XX-BEST-MOVES))
(PROG (BETTER-MOVES PS-EXPL-SWITCH)
(COND
((SETQ
BETTER-MOVES
(GM-ALL-TRUE
(FUNCTION (LAMBDA (X) (DECLARE (SPECIAL MOVE))
(XXR-BETTER-MOVEP X MOVE)))
XX-BEST-MOVES))
;;; There were better moves. Note that PS-TEST-DEGRADE
;;;sets the values of APS-RULE-ARRAY.
(PS-TEST-DEGRADE MOVE BETTER-MOVES)
(COND ((AND PS-EXPL-SWITCH DB-COMMENT)
(G-SAY '(|. ***|)))
(PS-EXPL-SWITCH (G-TSAY '(|. ***|))))
(DO ((I 0. (1+ I)))
((> I 2.))
(PS-EXPL-UNMARK (APS-RULE-ARRAY I) I)
(SK-UNMARK-RULES (APS-RULE-ARRAY I) I)
(STORE (APS-RULE-ARRAY I) NIL))))))
;;; PS-TEST-DEGRADE determines which rules should be degraded.
(DEFUN PS-TEST-DEGRADE (MOVE B-MOVES)
(COND ((NULL B-MOVES))
(T (PS-TEST-DEGRADE MOVE (CDR B-MOVES))
(PS-DEGRADE-WORK MOVE
(CAR B-MOVES)
'(0. 1. 2.)
NIL
NIL
NIL))))
;;; PS-DEGRADE-WORK does the actual work PS-TEST-DEGRADE.
;;; C-DANGERS are the dangers left to look at.
;;; S-DANGERS are dangers which were identifiably equivalent.
;;; B-DANGERS are dangers that were better by comparing probs.
;;; R-DANGERS are dangers that were better because they were safe.
(DEFUN PS-DEGRADE-WORK (W-MOVE B-MOVE C-DANGERS S-DANGERS B-DANGERS R-DANGERS)
(DECLARE (SPECIAL PS-TEMP))
(COND ((AND (NULL C-DANGERS)
(OR B-DANGERS R-DANGERS))
(PS-EXPL-BETTER B-MOVE (APPEND B-DANGERS R-DANGERS) S-DANGERS)
(PS-STORE-DEGRADES W-MOVE B-MOVE B-DANGERS)
(PS-STORE-DEGRADES B-MOVE B-MOVE R-DANGERS)
(PS-STORE-DEGRADES W-MOVE B-MOVE S-DANGERS))
((NULL C-DANGERS))
((AND (GP-EQ 0.0 (XPR-PROB B-MOVE (CAR C-DANGERS)))
(GP-LT 0.0 (XPR-PROB W-MOVE (CAR C-DANGERS)))
(SLR-KNOWS-RULESP (CXR-PROB B-MOVE (CAR C-DANGERS))
(CAR C-DANGERS)))
(PS-DEGRADE-WORK W-MOVE
B-MOVE
(CDR C-DANGERS)
S-DANGERS
B-DANGERS
(CONS (CAR C-DANGERS) R-DANGERS)))
((AND (GP-LT (XPR-PROB B-MOVE (CAR C-DANGERS))
(XPR-PROB W-MOVE (CAR C-DANGERS)))
(SLR-KNOWS-RULESP (CXR-BETTER B-MOVE
W-MOVE
(CAR C-DANGERS))
(CAR C-DANGERS)))
(PS-DEGRADE-WORK W-MOVE
B-MOVE
(CDR C-DANGERS)
S-DANGERS
(CONS (CAR C-DANGERS) B-DANGERS)
R-DANGERS))
((SETQ PS-TEMP (CMR-SAME-DANGERSP B-MOVE W-MOVE (LIST (CAR C-DANGERS))))
(PS-DEGRADE-WORK W-MOVE
B-MOVE
(CDR C-DANGERS)
(COND ((ATOM PS-TEMP) S-DANGERS)
(T (CONS (CAR C-DANGERS) S-DANGERS)))
B-DANGERS
R-DANGERS))
(T NIL)))
;;; PS-STORE-DEGRADES stores the applicable rules into the appropriate lists.
(DEFUN PS-STORE-DEGRADES (W-MOVE B-MOVE DANGERS)
(DO ((M-DANGERS DANGERS (CDR M-DANGERS)) (M-DANGER))
((NULL M-DANGERS))
(SETQ M-DANGER (CAR M-DANGERS))
(STORE (APS-RULE-ARRAY M-DANGER)
(GP-UNION (COND ((GP-LT (XPR-PROB B-MOVE M-DANGER)
(XPR-PROB W-MOVE M-DANGER))
(CXR-BETTER B-MOVE W-MOVE M-DANGER)))
(SLR-KNOWS-RULESP
(GP-UNION (CXR-PROB B-MOVE M-DANGER)
(CXR-PROB W-MOVE M-DANGER))
M-DANGER)
(APS-RULE-ARRAY M-DANGER)))))
;;; PS-EXPL-BETTER explains when a better move has been found.
(DEFUN PS-EXPL-BETTER
(MOVE DANGERS S-DANGERS)
(DECLARE (SPECIAL PS-EXPL-SWITCH))
(G-TSAY (APPEND (COND (PS-EXPL-SWITCH '(| |))
(T (SETQ PS-EXPL-SWITCH T)
'(|*** According to my estimations, the|
|player should have identified that:/
|))) (LIST '|cave| MOVE '|involves less risk from|)
(EG-DANGERS DANGERS)
(COND (S-DANGERS (APPEND
'(|and the same danger from|)
(EG-DANGERS S-DANGERS)))))))
;;; PS-EXPL-UNMARK explains which rules were unmarked.
(DEFUN PS-EXPL-UNMARK (RULES DANGER)
(COND (RULES (G-TSAY (APPEND '(|*** I am unmarking|)
(EG-TOLD-RULES RULES DANGER)
'(|. ***|)))
T))
RULES)
;;; PS-UNMARK-SHOT notes that the player shot when he should
;;;have known it was unnecessary.
(DEFUN PS-UNMARK-SHOT (CAVE)
(COND ((XPR-SHOOTP CAVE) NIL)
((GP-EQ (XPR-PROB CAVE 2.) 0.0)
(SK-UNMARK-RULES
(PS-EXPL-UNMARK-SHOT (SLR-KNOWS-RULESP (CXR-PROB CAVE 2.) 2.)
CAVE)
2.))
(T (SK-UNMARK-RULES
(PS-EXPL-UNMARK-SHOT
(GP-UNION (SLR-KNOWS-RULESP '(11. 15.) 2.)
(SLR-KNOWS-RULESP (CXR-PROB CAVE 2.) 2.))
CAVE)
2.))))
;;; PS-EXPL-UNMARK-SHOT comments about the above function.
(DEFUN PS-EXPL-UNMARK-SHOT (RULES CAVE)
(COND
(RULES
(G-TSAY
(APPEND
'(|*** By shooting into cave|)
(LIST CAVE)
'(|the player has indicated that he has not really mastered|)
(EG-TOLD-RULES RULES 2.)
'(|. ***|)))))
RULES)
;;; PS-MARK-NO-SHOT notes that the player did not shoot when he should
;;;have known it was wise to do so.
(DEFUN PS-MARK-NO-SHOT (CAVE)
(SK-UNMARK-RULES
(PS-EXPL-MARK-NO-SHOT (SLR-KNOWS-RULESP (CXR-PROB CAVE 2.)
2.)
CAVE)
2.))
;;; PS-EXPL-MARK-NO-SHOT comments about the above function.
(DEFUN PS-EXPL-MARK-NO-SHOT (RULES CAVE)
(COND
(RULES
(G-TSAY
(APPEND
'(|*** By not shooting into cave|)
(LIST CAVE)
'(|the player has indicated that he has not really mastered|)
(EG-TOLD-RULES RULES 2.)
'(|. ***|)))))
RULES)
;;; **************** Student Model Functions *************
;;; ******* Student Model Initialization Rouitnes. ********
;;;
;;; The student knowledge array has three dimensions.
;;; They are: RULE, ITEM, and DANGER.
;;; An ITEM value of:
;;; 0 is for the number of times he has demonstrated a
;;; working knowledge of said rule (more or less).
;;; 1 is for when the player was presumed to have
;;; learned/forgotten said rule.
;;; 2 is for how often the player has been told said rule.
;;; 3 is for when the player was presumed to have heard-of
;;; said rule.
;;; SLI-FORGOT determines how large a decrement should be used.
(DEFUN SLI-FORGOT (NOW LAST)
(DECLARE (SPECIAL SL-FORGET))
(//$ (LOG (- NOW LAST -1.)) (LOG SL-FORGET)))
;;; SLI-SET-VAL sets the ASK-DRULES value appropriately.
(DEFUN SLI-SET-VAL (OLD-VALUE WHEN-VALUE INFO-TYPE DEGRADE RULE DANGER)
(DECLARE (SPECIAL WE-THIS-SESSION SL-HEARD-OF SL-REPEAT))
(STORE (ASK-DRULES RULE INFO-TYPE DANGER)
(SLI-VALUE OLD-VALUE DEGRADE))
(STORE (ASK-WDRULES RULE INFO-TYPE DANGER)
(COND (WHEN-VALUE) (T 0.)))
;;; Did the player "forget" this rule.
(COND ((NULL OLD-VALUE) NIL)
((AND (= INFO-TYPE 0.)
(SLR-KNOWS-RULEP RULE DANGER))
(SL-TEST-PHASE DANGER))
((AND (= INFO-TYPE 1.)
(SLR-HEARD-OF-RULE RULE DANGER))
NIL)
((> OLD-VALUE
(COND ((= INFO-TYPE 0.) SL-REPEAT)
(T SL-HEARD-OF)))
;;; Note that negative values indicate "forgot".
(STORE (ASK-WDRULES RULE INFO-TYPE DANGER) (- WE-THIS-SESSION)))))
;;; SLI-VALUE determines what is an acceptable value to store.
(DEFUN SLI-VALUE (VAL DEGRADE)
(COND ((NOT VAL) 0.0) ((> VAL DEGRADE) (-$ VAL DEGRADE)) (T 0.0)))
;;; SLI-LEAST-PHASE returns the lowest phase of the student.
(DEFUN SLI-LEAST-PHASE NIL
(DECLARE (SPECIAL SL-MODE))
(DO ((I 0. (1+ I)) (MIN 4.))
((> I 2.) MIN)
(COND ((EQ SL-MODE 'SUPER) (SETQ I 3.))
((< (ASL-PHASE I) MIN) (SETQ MIN (ASL-PHASE I))))))
;;; SKI-PUT-MODEL takes its argument and initializes the
;;;student-model with it.
(DEFUN SKI-PUT-MODEL (STUDENT-MODEL)
(DECLARE (SPECIAL DB-DATE DB-LAST-DATE DB-NUM-CRULES DB-NUM-RULES))
(DO ((REST-OF-MODEL STUDENT-MODEL (CDR REST-OF-MODEL))
(DEGRADE (SLI-FORGOT DB-DATE DB-LAST-DATE))
(DANGER 0. (1+ DANGER)))
((> DANGER 2.)
;;; Don't degrade more than once.
(SETQ DB-LAST-DATE DB-DATE)
(DO ((I 0. (1+ I)) (VAL (CAR REST-OF-MODEL) (CDR VAL)))
((> I DB-NUM-CRULES))
(STORE (ASKC-RULES I 0.)
(SLI-VALUE (CAR VAL) DEGRADE))))
;;; First reset the phases to zero.
(SL-RESET-PHASE 0. DANGER)
(DO ((REST-OF-RULES (CAR REST-OF-MODEL)
(CDR REST-OF-RULES))
(RULE 0. (1+ RULE)))
((> RULE DB-NUM-RULES))
(SLI-SET-VAL (CAAR REST-OF-RULES)
(CADAR REST-OF-RULES)
0.
DEGRADE
RULE
DANGER)
(SLI-SET-VAL (CADDAR REST-OF-RULES)
(CADDR (CDAR REST-OF-RULES))
1.
DEGRADE
RULE
DANGER))))
;;; SKI-GET-MODEL gets the student-model from the different arrays.
;;;It works very closely with SKI-PUT-MODEL.
(DEFUN SKI-GET-MODEL NIL
(DECLARE (SPECIAL DB-NUM-CRULES DB-NUM-RULES))
(DO
((DANGER 2. (1- DANGER))
(GOTTEN-MODEL (LIST (DO ((I DB-NUM-CRULES (1- I)) (VAL NIL))
((< I 0.) VAL)
(SETQ VAL (CONS (ASKC-RULES I 0.)
VAL))))))
((< DANGER 0.) GOTTEN-MODEL)
(SETQ
GOTTEN-MODEL
(CONS (DO ((RULE DB-NUM-RULES (1- RULE)) (GOTTEN-RULES NIL))
((< RULE 0.) GOTTEN-RULES)
(SETQ GOTTEN-RULES
(CONS (LIST (ASK-DRULES RULE 0. DANGER)
(ASK-WDRULES RULE 0. DANGER)
(ASK-DRULES RULE 1. DANGER)
(ASK-WDRULES RULE 1. DANGER))
GOTTEN-RULES)))
GOTTEN-MODEL))))
;;; *********** Wumpus Advisor Critic Routines. ***********
;;; SC-ADVISED notes that the player has been advised concerning
;;;the danger and sets ASC-INITIALIZED accordingly.
;;;ASC-INITIALIZED has four possible values. They are:
;;; 1- NIL indicating that this is a new player.
;;; 2- 'B indicating that this is a new player who
;;; is being moved back.
;;; 3- 'A indicating that the player is being advanced.
;;; 4- Number, indicating that the Critic stopped
;;; initializing on this move number.
(DEFUN SC-ADVISED (RULES DANGER)
(COND ((FIXP (ASC-INITIALIZED DANGER)) NIL)
((EQ (ASC-INITIALIZED DANGER) 'A)
(SC-STOP-INITIALIZING (CAR RULES) DANGER '(|needed advice on|)))
(T (STORE (ASC-INITIALIZED DANGER) 'B))))
;;; SC-UPDATE-RECEPTIVITY adjusts SL-RECEPTIVITY.
(DEFUN SC-UPDATE-RECEPTIVITY (MOVE)
(DECLARE (SPECIAL LWA-GOOD-MOVES LWA-BAD-MOVES DB-NUM-CAVES SL-RECEPTIVITY))
(PROG (VAL)
(SETQ VAL (COND ((AND (GP-NUM-TEST MOVE DB-NUM-CAVES)
(XDR-VISITEDP MOVE))
0.0)
((GC-MEMBER LWA-GOOD-MOVES MOVE 2.)
(SC-EXPL-RECP MOVE
'|upgrading|
'|very recently|
'|good|)
1.0)
((GC-MEMBER LWA-GOOD-MOVES MOVE 5.)
(SC-EXPL-RECP MOVE
'|upgrading|
'|recently|
'|good|)
0.5)
((GC-MEMBER LWA-BAD-MOVES MOVE 2.)
(SC-EXPL-RECP MOVE
'|degrading|
'|very recently|
'|bad|)
-1.0)
((GC-MEMBER LWA-BAD-MOVES MOVE 5.)
(SC-EXPL-RECP MOVE
'|degrading|
'|recently|
'|bad|)
-0.5)
(T 0.0)))
;;; Note that low values of SL-RECEPTIVITY
;;;allow the Advsior to speak more often.
(SETQ SL-RECEPTIVITY (-$ SL-RECEPTIVITY VAL))))
;;; SC-EXPL-RECP explains changes in the receptivity.
(DEFUN SC-EXPL-RECP (MOVE CHANGE WHEN TYPE)
(G-TSAY
(APPEND (LIST '|*** I am| CHANGE)
'(|the player's receptivity because his move to cave|)
(LIST MOVE
'|is a move that I told him was|
TYPE)
(LIST WHEN '|. ***|))))
;;; SC-MARK-RULE analyzes the marking of the given rule.
(DEFUN SC-MARK-RULE (RULE DANGER)
(DECLARE (SPECIAL SC-DECREASE-REPEAT SC-INCREASE-FORGET
WE-THIS-SESSION SL-REPEAT))
(COND ((SLR-KNOWS-RULEP RULE DANGER))
((EQ (ASC-INITIALIZED DANGER) 'B)
(SC-STOP-INITIALIZING RULE DANGER '(|seems to be learning|)))
((NOT (FIXP (ASC-INITIALIZED DANGER)))
(STORE (ASC-INITIALIZED DANGER) 'A)
(SC-KNOWS-RULE '|he is a new player|
RULE
DANGER))
;;; Note that negative values indicate that it was "forgotten".
((< (ASK-WDRULES RULE 0. DANGER)
(MIN 0. (- 75. WE-THIS-SESSION)))
(SC-KNOWS-RULE '|he seems to have remembered it|
RULE
DANGER)
(SETQ SC-INCREASE-FORGET T))
((AND (> (ASK-DRULES RULE 0. DANGER) (-$ SL-REPEAT 2.0))
(> (ASK-WDRULES RULE 0. DANGER) (ASC-INITIALIZED DANGER)))
(SETQ SC-DECREASE-REPEAT T))))
;;; SC-KNOWS-RULE notes that the player knows a rule.
(DEFUN SC-KNOWS-RULE (REASON RULE DANGER)
(DECLARE (SPECIAL SL-REPEAT))
(G-TSAY (APPEND '(|*** I am presuming that the player knows|)
(EG-TOLD-RULES (LIST RULE) DANGER)
(LIST '|since| REASON '|. ***|)))
(STORE (ASK-DRULES RULE 0. DANGER) (-$ SL-REPEAT 0.5)))
;;; SC-UNMARK-RULE analyzes the unmarking of the given rule.
(DEFUN SC-UNMARK-RULE (RULE DANGER)
(DECLARE (SPECIAL SC-DECREASE-FORGET SC-INCREASE-REPEAT
WE-THIS-SESSION SL-REPEAT))
(COND
((EQ (ASC-INITIALIZED DANGER) 'A)
(SC-STOP-INITIALIZING RULE DANGER '(|does not seem to know|)))
((NOT (MEMBER RULE
(ASL-PHASE-RULES (ASL-PHASE DANGER) DANGER))))
((NOT (FIXP (ASC-INITIALIZED DANGER)))
(STORE (ASC-INITIALIZED DANGER) 'B)
(SC-UNLEARN-RULE '|he is a new player| RULE DANGER))
((> (ASK-DRULES RULE 0. DANGER) (+$ 2.0 SL-REPEAT)))
((AND (> (ASK-WDRULES RULE 0. DANGER) (ASC-INITIALIZED DANGER))
(< (ASK-WDRULES RULE 0. DANGER) WE-THIS-SESSION))
(SC-UNLEARN-RULE
'|he seems to have forgotten it since last session|
RULE
DANGER)
(SETQ SC-DECREASE-FORGET T))
((> (ASK-WDRULES RULE 0. DANGER) (ASC-INITIALIZED DANGER))
(SETQ SC-INCREASE-REPEAT T))))
;;; SC-UNLEARN-RULE notes that the player does not know a rule.
(DEFUN SC-UNLEARN-RULE (REASON RULE DANGER)
(DECLARE (SPECIAL SL-REPEAT))
(G-TSAY
(APPEND
'(|*** I am no longer presuming that the player knows|)
(EG-TOLD-RULES (LIST RULE) DANGER)
(LIST '|because| REASON '|. ***|)))
(STORE (ASK-DRULES RULE 0. DANGER) (+$ SL-REPEAT 0.5)))
;;; SC-STOP-INITIALIZING stops the initializations.
(DEFUN SC-STOP-INITIALIZING (RULE DANGER REASON)
(DECLARE (SPECIAL WE-MOVE-NUM))
(STORE (ASC-INITIALIZED DANGER) WE-MOVE-NUM)
(G-TSAY (APPEND '(|*** I have stopped initializing the|)
'(|player's knowledge model for|)
(AEG-DANGER-SING DANGER)
'(|because he|)
REASON
(LIST '|rule| RULE '|. ***|))))
;;; SC-UPDATE-MODEL does the actual modifications of SL variables.
(DEFUN SC-UPDATE-MODEL NIL
(DECLARE (SPECIAL I SC-UREPEAT SC-LREPEAT SC-UFORGET SC-LFORGET DB-NUM-RULES
SL-REPEAT SL-FORGET SL-HEARD-OF SL-MODE DB-DEBUG SC-NOTEST
SC-DECREASE-FORGET SC-DECREASE-REPEAT SC-INCREASE-FORGET
SC-INCREASE-REPEAT))
(PROG (OLD-REPEAT NEW-REPEAT KNOWS-RULES FORGOT-RULES
NEW-RULES)
(SETQ OLD-REPEAT SL-REPEAT)
(COND
(SC-INCREASE-FORGET
(SETQ SL-FORGET (1+$ (*$ 1.1 (1-$ SL-FORGET))))
(G-TSAY
'(|*** The player does not seem as forgetful|
|as I previously thought. ***|))))
(COND
(SC-DECREASE-FORGET
(SETQ SL-FORGET (1+$ (*$ 0.9 (1-$ SL-FORGET))))
(G-TSAY
'(|*** The player seems more forgetful|
|than I previously thought. ***|))))
(COND
(SC-INCREASE-REPEAT
(SETQ SL-REPEAT (+$ SL-REPEAT 0.34))
(G-TSAY
'(|*** My previous repetition factor for the|
|student seems to have been too low. ***|))))
(COND
(SC-DECREASE-REPEAT
(SETQ SL-REPEAT (-$ SL-REPEAT 0.17))
(G-TSAY
'(|*** My previous repetition factor for the|
|student seems to have been too high. ***|))))
(SC-RESET-SWITCHES)
(COND
((NOT (= SL-REPEAT OLD-REPEAT))
(SETQ NEW-REPEAT SL-REPEAT
SL-HEARD-OF (1-$ SL-REPEAT))
(G-TSAY
(APPEND
'(|*** I am giving the player a new repetition factor of|)
(LIST NEW-REPEAT '|. ***|)))
(DO
((I 0. (1+ I)))
((> I 2.))
(SETQ
SL-REPEAT
OLD-REPEAT
KNOWS-RULES
(GM-ALL-TRUE (FUNCTION (LAMBDA (X)
(DECLARE (SPECIAL I))
(SLR-KNOWS-RULEP X
I)))
(GP-ORDLST DB-NUM-RULES))
SL-REPEAT
NEW-REPEAT
FORGOT-RULES
(GM-ALL-TRUE
(FUNCTION (LAMBDA (X) (DECLARE (SPECIAL I))
(NOT (SLR-KNOWS-RULEP X I))))
KNOWS-RULES)
NEW-RULES
(GM-ALL-TRUE (FUNCTION (LAMBDA (X)
(DECLARE (SPECIAL I))
(SLR-KNOWS-RULEP X
I)))
(GP-REMOVE-LIST (GP-ORDLST DB-NUM-RULES)
KNOWS-RULES)))
(COND
((OR FORGOT-RULES NEW-RULES)
(G-TSAY
(APPEND
'(|*** Because of the new repetition factor I am|)
(COND (FORGOT-RULES '(|no longer|))
(T '(|now|)))
'(|presuming that he knows|)
(EG-TOLD-RULES (APPEND FORGOT-RULES NEW-RULES) I)
'(|. ***|)))
(MAPC (FUNCTION (LAMBDA (X) (DECLARE (SPECIAL I))
(SL-LEARNED-RULE X I)))
NEW-RULES)
(MAPC (FUNCTION (LAMBDA (X) (DECLARE (SPECIAL I))
(SL-UNLEARN-RULE X I)))
FORGOT-RULES))))))
(COND ((OR SL-MODE DB-DEBUG SC-NOTEST) NIL)
((OR (< SL-REPEAT SC-LREPEAT)
(> SL-REPEAT SC-UREPEAT)
(< SL-FORGET SC-LFORGET)
(> SL-FORGET SC-UFORGET))
(SC-HELP '|learning model|)))))
;;; SC-RESET-SWITCHES resets the switches to NIL.
(DEFUN SC-RESET-SWITCHES NIL
(DECLARE (SPECIAL SC-DECREASE-FORGET SC-DECREASE-REPEAT SC-INCREASE-FORGET
SC-INCREASE-REPEAT))
(SETQ SC-INCREASE-FORGET NIL
SC-DECREASE-FORGET NIL
SC-INCREASE-REPEAT NIL
SC-DECREASE-REPEAT NIL))
;;; ********** Student Learning Model Routines. *********
;;; SL-LEARNED-RULE marks that the player knows the specified RULE.
(DEFUN SL-LEARNED-RULE (RULE DANGER)
(DECLARE (SPECIAL SL-LAST-LEARNED WE-MOVE-NUM WA-CAN-BACKTRACK SL-REPEAT))
(COND ((OR (NOT (FIXP (ASC-INITIALIZED DANGER)))
(< (ASK-WDRULES RULE 0. DANGER) (ASC-INITIALIZED DANGER)))
(SETQ SL-LAST-LEARNED WE-MOVE-NUM)))
(COND ((= RULE 1.) (SETQ WA-CAN-BACKTRACK (+$ SL-REPEAT 0.5))))
(STORE (ASK-WDRULES RULE 0. DANGER) WE-MOVE-NUM)
(SL-TEST-PHASE DANGER)
(COND ((= DANGER 0.) (SL-TRANS-TEST 0. 1. RULE))
((= DANGER 1.) (SL-TRANS-TEST 1. 0. RULE))))
;;; SL-TEST-PHASE tests to see if the player has learned
;;;the rules necessary to advance to the next phase.
(DEFUN SL-TEST-PHASE (DANGER)
(COND
((= (ASL-PHASE DANGER) 4.))
((SLR-KNOWS-RULESP (ASL-NEXT-RULES (ASL-PHASE DANGER) DANGER)
DANGER)
(STORE (ASL-PHASE DANGER) (1+ (ASL-PHASE DANGER)))
(G-TSAY
(APPEND
'(|*** I am advancing the student to phase|)
(LIST (ASL-PHASE DANGER))
'(|for|)
(AEG-DANGER-PLUR DANGER)
'(|as he has mastered|)
(EG-INSERT-AND '|rule|
(ASL-NEXT-RULES (1- (ASL-PHASE DANGER))
DANGER))
'(|. ***|)))
(STORE (ASL-WORK-ON-RULES DANGER)
(GP-UNION (ASL-WORK-ON-RULES DANGER)
(ASL-PHASE-RULES (ASL-PHASE DANGER)
DANGER)))
(SL-TEST-PHASE DANGER))))
;;; SL-TRANS-TEST transfers knowledge if appropriate.
(DEFUN SL-TRANS-TEST (L-DANGER O-DANGER RULE)
(COND
((AND (> (ASL-PHASE L-DANGER) 1.)
(> (ASL-PHASE O-DANGER) 1.)
(NOT (SLR-KNOWS-RULEP RULE O-DANGER)))
(G-TSAY
(APPEND '(|*** I am presuming a transfer of knowledge of|)
(EG-TOLD-RULES (LIST RULE) L-DANGER)
'(|to|)
(AEG-DANGER-PLUR O-DANGER)
'(|. ***|)))
(STORE (ASK-DRULES RULE 0. O-DANGER)
(ASK-DRULES RULE 0. L-DANGER))
(SL-LEARNED-RULE RULE O-DANGER))))
;;; SL-UNLEARN-RULE notes that the player no longer knows a rule.
(DEFUN SL-UNLEARN-RULE (RULE DANGER)
(DECLARE (SPECIAL WE-MOVE-NUM))
(PROG (NEW-PHASE)
(STORE (ASK-WDRULES RULE 0. DANGER) WE-MOVE-NUM)
(DO ((I 0. (1+ I)) (DONE))
(DONE)
(COND ((MEMBER RULE (ASL-NEXT-RULES I DANGER))
(SETQ NEW-PHASE I DONE T))
((> I 4.) (SETQ NEW-PHASE 4. DONE T))))
(COND
((< NEW-PHASE (ASL-PHASE DANGER))
(G-TSAY
(APPEND '(|*** I am moving the student back to phase|)
(EG-NUMBER NEW-PHASE)
'(|for|)
(AEG-DANGER-PLUR DANGER)
'(|as he doesn't seem to know rule|)
(LIST RULE '|. ***|)))
(SL-RESET-PHASE NEW-PHASE DANGER)))))
;;; SL-RESET-PHASE sets the phase back to the appropriate phase.
(DEFUN SL-RESET-PHASE (PHASE DANGER)
(STORE (ASL-PHASE DANGER) PHASE)
(STORE (ASL-WORK-ON-RULES DANGER)
(DO ((I 0. (1+ I)) (VAL))
((> I PHASE) VAL)
(SETQ VAL (GP-UNION (ASL-PHASE-RULES I DANGER)
VAL)))))
;;; SL-ADVISEP returns NIL if it is acceptable to advise now.
(DEFUN SL-ADVISEP (MOVE)
(DECLARE (SPECIAL SL-MODE LWA-GOOD-MOVES LWA-BAD-MOVES
LWA-MOVE-NUMS WE-MOVE-NUM SL-RECEPTIVITY))
(AND (NOT SL-MODE)
(OR (> SL-RECEPTIVITY
(-$ (FLOAT WE-MOVE-NUM)
(GC-AVERAGE LWA-MOVE-NUMS)))
(GC-MEMBER LWA-GOOD-MOVES MOVE 3.)
(GC-MEMBER LWA-BAD-MOVES MOVE 3.))))
;;; SLR-KNOWS-RULESP returns RULES if the player is
;;;thought to know these rules.
(DEFUN SLR-KNOWS-RULESP (RULES DANGER)
(COND ((NULL RULES) T)
((AND (SLR-KNOWS-RULEP (CAR RULES) DANGER)
(SLR-KNOWS-RULESP (CDR RULES) DANGER))
RULES)
(T NIL)))
;;; SLR-KNOWS-RULEP returns the given rule if the player knows it.
(DEFUN SLR-KNOWS-RULEP (RULE DANGER)
(DECLARE (SPECIAL SL-REPEAT))
(> (ASK-DRULES RULE 0. DANGER) SL-REPEAT))
;;; SLR-OK-RULESP returns T if it is OK to teach these rules.
(DEFUN SLR-OK-RULESP (RULES DANGER)
(COND ((NULL RULES) T)
((AND (MEMBER (CAR RULES) (ASL-WORK-ON-RULES DANGER))
(SLR-OK-RULESP (CDR RULES) DANGER))
RULES)
(T NIL)))
;;; SLR-HEARD-OF-RULE returns T if the player is familiar
;;;with the move.
(DEFUN SLR-HEARD-OF-RULE (RULE DANGER)
(DECLARE (SPECIAL SL-HEARD-OF))
(> (ASK-DRULES RULE 1. DANGER) SL-HEARD-OF))
;;; ********* Student Knowledge Model Routines. **********
;;; SK-MARK-RULES marks that the student has applied RULES.
(DEFUN SK-MARK-RULES (RULES DANGER)
(COND (RULES (SK-MARK-RULE (CAR RULES) DANGER)
(SK-MARK-RULES (CDR RULES) DANGER)
RULES)))
;;; SK-MARK-RULE marks that the player has applied RULE.
(DEFUN SK-MARK-RULE (RULE DANGER)
(SC-MARK-RULE RULE DANGER)
(SK-INCR-RULE RULE DANGER))
;;; SK-INCR-RULE does the actual incrementing of a rule.
(DEFUN SK-INCR-RULE (RULE DANGER)
(DECLARE (SPECIAL SL-REPEAT))
(STORE (ASK-DRULES RULE 0. DANGER)
(1+$ (ASK-DRULES RULE 0. DANGER)))
(COND ((AND (> (ASK-DRULES RULE 0. DANGER) SL-REPEAT)
(< (ASK-DRULES RULE 0. DANGER) (1+$ SL-REPEAT)))
(SL-LEARNED-RULE RULE DANGER))
((= DANGER 0.) (SK-TRANS-TEST 0. 1. RULE))
((= DANGER 1.) (SK-TRANS-TEST 1. 0. RULE))))
;;; SK-TRANS-TEST transfer knowledge if appropriate.
(DEFUN SK-TRANS-TEST (L-DANGER O-DANGER RULE)
(COND ((> RULE 15.))
((SLR-KNOWS-RULEP O-DANGER RULE))
((AND (> (ASL-PHASE L-DANGER) 1.)
(> (ASL-PHASE O-DANGER) 1.))
(STORE (ASK-DRULES RULE 0. O-DANGER)
(1+$ (ASK-DRULES RULE 0. O-DANGER))))))
;;; SK-TOLD-RULE marks that a student has been told an application
;;;of a rule.
(DEFUN SK-TOLD-RULE (RULE DANGER)
(DECLARE (SPECIAL WE-MOVE-NUM SL-HEARD-OF))
(COND ((NOT (SLR-HEARD-OF-RULE RULE DANGER))
(SK-INCR-RULE RULE DANGER)))
(STORE (ASK-DRULES RULE 1. DANGER)
(1+$ (ASK-DRULES RULE 1. DANGER)))
(COND ((AND (> (ASK-DRULES RULE 1. DANGER) SL-HEARD-OF)
(< (ASK-DRULES RULE 1. DANGER) (1+$ SL-HEARD-OF)))
(STORE (ASK-WDRULES RULE 1. DANGER) WE-MOVE-NUM))))
;;; SK-UNMARK-RULES decrements the appropriate rules by one.
(DEFUN SK-UNMARK-RULES (RULES DANGER)
(COND ((NULL RULES))
(T (SK-UNMARK-RULES (CDR RULES) DANGER)
(SK-UNMARK-RULE (CAR RULES) DANGER)
RULES)))
;;; SK-UNMARK-RULE decrements rule by one.
(DEFUN SK-UNMARK-RULE (RULE DANGER)
(DECLARE (SPECIAL SL-MODE))
(COND ((EQ SL-MODE 'SUPER))
((SLR-KNOWS-RULEP RULE DANGER)
(SC-UNMARK-RULE RULE DANGER)
(STORE (ASK-DRULES RULE 0. DANGER)
(1-$ (ASK-DRULES RULE 0. DANGER)))
(COND ((NOT (SLR-KNOWS-RULEP RULE DANGER))
(SL-UNLEARN-RULE RULE DANGER))))
(T (STORE (ASK-DRULES RULE 0. DANGER)
(1-$ (ASK-DRULES RULE 0. DANGER))))))
;;; ******** Student Model (Combination Rules). **********
;;; SLC-KNOWS-RULEP returns T if the student knows the rule.
(DEFUN SLC-KNOWS-RULEP (RULE)
(DECLARE (SPECIAL SL-REPEAT))
(> (ASKC-RULES RULE 0.) SL-REPEAT))
;;; SKC-MARK-RULE marks that the student has applied this rule.
(DEFUN SKC-MARK-RULE (RULE)
(STORE (ASKC-RULES RULE 0.) (1+$ (ASKC-RULES RULE 0.))))
;;; SKC-TOLD-RULE marks that the student has been told RULE.
(DEFUN SKC-TOLD-RULE (RULE)
(DECLARE (SPECIAL SL-HEARD-OF))
(COND ((< (ASKC-RULES RULE 0.) SL-HEARD-OF) (SKC-MARK-RULE RULE))))
;;; *********** Disc File Handling Routines. ***********
;;; SF-GET-DISC-FILE gets the file on the user off of disc.
;;;It then stores the values in the database and
;;;returns the file (if there was any).
(DEFUN SF-GET-DISC-FILE (USER-NAME)
(SF-STORE-USER-FILE (SF-READ-DISC-FILE USER-NAME)))
;;; SF-TELL-MODEL types out the current user model.
(DEFUN SF-TELL-MODEL NIL
(DECLARE (SPECIAL DB-NUM-RULES))
(G-RSAY '(|The following are the student model values. |))
(G-RSAY '(|Rule Bats Pits Wumpus|))
(DO ((I 0. (1+ I)))
((> I DB-NUM-RULES))
(G-RSAY (LIST '| | I))
(DO ((J 0. (1+ J)) (C-POS 7. (+ 16. C-POS)))
((> J 2.))
(G-PSAY (LIST (GP-MAKN (ASK-DRULES I 0. J)
(SF-SUFFIX I J)))
C-POS)))
(G-RSAY
'(|An "*" indicates that the student is presumed|
|to have learned the rule in question, and a "-"|
|indicates that this rule is deemed acceptable|
|for teaching at this time. A "+" indicates that|
|the player is deemed to have "heard of" the rule|
|in question. |)))
;;; SF-SUFFIX constructs the suffix that is appropriate.
(DEFUN SF-SUFFIX (I J)
(GP-MAKN (COND ((SLR-KNOWS-RULEP I J) '*)
((SLR-OK-RULESP (LIST I) J) '-)
(T '| |))
(COND ((SLR-HEARD-OF-RULE I J) '+)
(T '| |))))
;;; SF-TELL-VARS tells about important variables of the student file.
(DEFUN SF-TELL-VARS NIL
(DECLARE (SPECIAL SF-VAR-LIST DB-NUM-CRULES))
(G-RSAY
(APPEND
'(|The student is thought to know|)
(EG-INSERT-AND '|combination rule|
(GM-ALL-TRUE 'SLC-KNOWS-RULEP
(GP-ORDLST DB-NUM-CRULES)))
'(|. |)))
(G-TERPRI)
(G-RSAY '(|Student variable values are:|))
(MAPC (FUNCTION (LAMBDA (X) (G-RISAY (LIST X))
(G-PSAY (LIST (EVAL X)) 26.)))
SF-VAR-LIST))
;;; SF-LOAD-DEMO loads in the appropriate demo if desired.
(DEFUN SF-LOAD-DEMO NIL
(G-RSAY '(|Please enter the demo that you would like. |))
(SF-GET-DEMO))
;;; SF-GET-DEMO does most of the actual work of getting the demo.
(DEFUN SF-GET-DEMO NIL
(DECLARE (SPECIAL SL-MODE DB-NAME DB-UNAME))
(G-RISAY '(|BEGINNER, for novices who are quick learners. |))
(G-RISAY '(|NOVICE, if you have played a couple of games. |))
(G-RISAY '(|AMATEUR, for players who are fairly good. |))
(G-RISAY '(|MODERATE, if you are a moderately good player. |))
(G-RISAY '(|ADVANCED, for skilled Wumpii hunters. |))
(G-RISAY '(|EXPERT, for excellent players. |))
(G-RISAY
'(|SUPER, an interesting mode for experienced Wumpus hunters. |))
(G-RISAY
'(|NONE, for people who just realized they don't want a demo at all. |))
(SETQ SL-MODE (G-READ 'MODE) DB-UNAME SL-MODE)
(COND ((EQ SL-MODE 'NONE) (SETQ SL-MODE NIL) NIL)
((MEMBER SL-MODE
'(BEGINNER NOVICE AMATEUR MODERATE ADVANCED EXPERT SUPER))
(SF-GET-DISC-FILE DB-UNAME)
(G-RSAY '(|Please enter your first name. |))
(SETQ DB-NAME (G-LOWER-CASE (G-READ 'SYNDI) T))
T)
(T (G-RSAY '(|Please enter one of:|))
(SF-GET-DEMO))))
;;; SF-STORE-USER-FILE stores the file it is sent into the database.
(DEFUN SF-STORE-USER-FILE (USER-FILE)
(DECLARE (SPECIAL USER-MODEL SC-INITIALIZED WEV-RECREATE DB-DATE
WE-LAST-SESSION WE-THIS-SESSION SF-VAR-LIST
DB-LAST-DATE SL-MODE WE-MOVE-NUM))
(PROG (USER-MODEL)
(MAPC 'SET
(CONS 'USER-MODEL SF-VAR-LIST)
USER-FILE)
(MAPC
(FUNCTION (LAMBDA (X Y) (STORE (ASC-INITIALIZED X) Y)))
'(2. 1. 0.)
SC-INITIALIZED)
(COND ((OR WEV-RECREATE SL-MODE)
(SETQ DB-LAST-DATE DB-DATE))
((> DB-LAST-DATE DB-DATE)
(SETQ DB-LAST-DATE (- DB-LAST-DATE 360.))))
;;; This is to zero out any old values.
(SKI-PUT-MODEL NIL)
(SKI-PUT-MODEL USER-MODEL)
(COND ((EQ SL-MODE 'SUPER)
(DO ((I 0. (1+ I)))
((> I 2.))
(SL-RESET-PHASE 4. I))))
(SETQ WE-LAST-SESSION WE-MOVE-NUM
WE-THIS-SESSION (1+ WE-MOVE-NUM)
WE-MOVE-NUM (1+ WE-THIS-SESSION))
(RETURN USER-FILE)))
;;; SF-READ-DISC-FILE reads the user file as indicated by
;;;the user-name which it is sent as an argument.
;;;If it does not find any such file it returns NIL.
(DEFUN SF-READ-DISC-FILE (THE-NAME)
(PROG (ALL-FILES)
(UREAD wa plyrs8 dsk games)
(SETQ ^Q T
ALL-FILES (READ))
(RETURN (DO ((A-FILE (CAR ALL-FILES) (CAR ALL-FILES))
(A-NAME (CADAR ALL-FILES)
(CADAR ALL-FILES)))
((NULL A-FILE))
(SETQ ALL-FILES (CDR ALL-FILES))
(COND ((EQUAL A-NAME THE-NAME)
(RETURN A-FILE)))))))
;;; SF-SAVE-USER-FILE saves the user's file onto disc as updated
;;;by the current session.
(DEFUN SF-SAVE-USER-FILE NIL
(DECLARE (SPECIAL DB-UNAME))
(DO ((FILES (SF-READ-FILES) (CDR FILES))
(RESULT))
((NULL FILES)
(SF-WRITE-FILES (CONS (SF-GET-USER-FILE) RESULT)))
(COND ((EQUAL DB-UNAME (CADAR FILES))
(SETQ RESULT (APPEND RESULT (CDR FILES))
FILES NIL))
(T (SETQ RESULT (CONS (CAR FILES) RESULT))))))
;;; SF-GET-USER-FILE returns a list of all the
;;;information which composes the user file.
(DEFUN SF-GET-USER-FILE NIL
(DECLARE (SPECIAL SC-INITIALIZED SF-VAR-LIST))
(SETQ SC-INITIALIZED (MAPCAR 'ASC-INITIALIZED
'(0. 1. 2.)))
(MAPCAR 'EVAL
(CONS '(SKI-GET-MODEL) SF-VAR-LIST)))
;;; SF-READ-FILES returns the list of all user files.
(DEFUN SF-READ-FILES NIL
(UREAD wa plyrs8 dsk games)
(SETQ ^Q T)
(READ))
;;; SF-WRITE-FILES writes out the files, which it is sent
;;;sent as an argument.
(DEFUN SF-WRITE-FILES (ALL-FILES)
(SETQ ^R T ^W T)
(PRIN1 ALL-FILES)
(UFILE wa plyrs8 dsk games)
(SETQ ^W NIL ^R NIL))
;;;******** English Generation Routines ************
;;;******* English Routines which compare probs. *******
;;; EC-EXPL-PROBS makes comparisons of two probabilities.
(DEFUN EC-EXPL-PROBS (BETTER WHY-BETTER WORSE WHY-WORSE T-DANGER)
(COND ((GP-EQ (XPR-PROB WORSE T-DANGER) 1.0)
(EC-EXPL-CERTAIN WORSE T-DANGER))
((= WHY-BETTER 12.)
(EC-EXPL-PROB-12-ANY BETTER WORSE WHY-WORSE T-DANGER))
((= WHY-BETTER 14.)
(EC-EXPL-PROB-14-ANY BETTER WORSE T-DANGER))
((AND (= WHY-WORSE 13.) (NOT (= WHY-BETTER 13.)))
(EC-EXPL-PROB-ANY-13 BETTER WORSE T-DANGER))
((AND (= WHY-BETTER 11.) (= WHY-WORSE 11.))
(EC-EXPL-PROB-11-11 BETTER WORSE T-DANGER))
((= WHY-BETTER 15.)
(EC-EXPL-PROB-15-ANY BETTER WORSE T-DANGER))
(T (EC-EXPL-PROB-ANY-ANY BETTER WORSE T-DANGER))))
;;; EC-EXPL-PROB-ANY-ANY makes comparison of any two rules.
(DEFUN EC-EXPL-PROB-ANY-ANY (BETTER WORSE T-DANGER)
(APPEND '(|it is true that|)
(EXR-PROB BETTER T-DANGER NIL)
(EG-HOWEVER)
(EXR-PROB WORSE T-DANGER 'UNSAFE)))
;;; EC-EXPL-CERTAIN explains that the worse cave is
;;;certain to contain the danger.
(DEFUN EC-EXPL-CERTAIN (WORSE T-DANGER)
(EXR-PROB WORSE T-DANGER NIL))
;;; EC-EXPL-PROB-11-11 compares two probs of P11.
(DEFUN EC-EXPL-PROB-11-11 (BETTER WORSE T-DANGER)
(WA-TOLD-RULE 11. T-DANGER)
;;; The COND is necessary because of the way
;;;incomplete cave sets are explained.
(APPEND
(COND ((AND (XSR-COMPLETE-CAVE-SETP (XPR-WHY-P11 BETTER
T-DANGER)
T-DANGER)
(XSR-COMPLETE-CAVE-SETP (XPR-WHY-P11 WORSE
T-DANGER)
T-DANGER))
(APPEND '(|It is true that|)
(EXT-CAVE-SET (XPR-WHY-P11 BETTER T-DANGER)
T-DANGER T 0.)
(EG-HOWEVER)
(EXT-CAVE-SET (XPR-WHY-P11 WORSE T-DANGER)
T-DANGER T 0.)))
(T (APPEND (EXT-CAVE-SET WORSE T-DANGER T 0.)
(EG-CONVERSELY)
(EXT-CAVE-SET BETTER T-DANGER T 0.))))
(LIST '|. This makes it less likely that cave|
BETTER
'|contains|)
(AEG-DANGER-SING T-DANGER)))
;;; EC-EXPL-PROB-15-ANY compares P15 with any rule.
(DEFUN EC-EXPL-PROB-15-ANY (BETTER WORSE T-DANGER)
(APPEND (EXR-PROB15 BETTER T-DANGER 'SAFE)
(COND ((GP-EQ 0.0 (XPR-PROB BETTER T-DANGER)) NIL)
(T (APPEND '(|than if we visited cave|)
(LIST WORSE))))))
;;; EC-EXPL-PROB-ANY-13 compares P11 probs with P13 probs.
(DEFUN EC-EXPL-PROB-ANY-13 (BETTER WORSE T-DANGER)
(APPEND (EXR-PROB13 WORSE T-DANGER NIL)
'(|. |)
(EXR-CAVE-PROB BETTER T-DANGER 'SAFE)))
;;; EC-EXPL-PROB-14-ANY compares P14 to another prob.
(DEFUN EC-EXPL-PROB-14-ANY (BETTER WORSE T-DANGER)
(APPEND (EXR-PROB14 BETTER T-DANGER NIL)
'(|. |)
(EXR-CAVE-PROB WORSE T-DANGER 'UNSAFE)))
;;; EC-EXPL-PROB-12-ANY compares P12 with another prob.
(DEFUN EC-EXPL-PROB-12-ANY (BETTER WORSE WHY-WORSE T-DANGER)
(COND ((= WHY-WORSE 12.)
(WE-ERROR 'EC-EXPL-PROB-12-ANY)))
(APPEND (EXR-PROB12 BETTER T-DANGER NIL)
'(|. There is evidence of|)
(AEG-DANGER-SING T-DANGER)
(LIST '|in cave| WORSE)
'(|which makes it a more dangerous cave|)))
;;;****** English Routines Interfacing With the Expert ******
;;; EXR-SAFE-CAVE explains why a cave is safe from DANGERS.
(DEFUN EXR-SAFE-CAVE (CAVE DANGERS)
(COND
((NULL DANGERS) NIL)
(T
(APPEND (EXR-MORE-THAN CAVE 0. (CAR DANGERS))
(COND ((> (ASK-WDRULES 18. 0. (CAR DANGERS)) 2.)
(EGT-ALSO DANGERS))
(T (APPEND '(|. |)
(EG-TELL-AVOID (LIST (CAR DANGERS)))
(COND ((GP-TEST DANGERS)
'(|. |))))))
(EXR-SAFE-CAVE CAVE (CDR DANGERS))))))
;;; EXT-LIST-MORE-THAN explains why the list is more than
;;;the given DIST away from DANGER. Note that it return NIL
;;;if the student already knows all teh rules concerned,
;;;AND the GO-AHEAD switch is off.
(DEFUN EXT-LIST-MORE-THAN (CAVE-LIST DIST DANGER GO-AHEAD)
(DECLARE (SPECIAL DIST DANGER VALUE))
(PROG (KNOWS-CAVES VISITED-CAVES VALUE)
(COND
;;; By definition a cave is more than -1.
((= DIST -1.) (RETURN NIL))
((SETQ
KNOWS-CAVES
(GM-ALL-TRUE
(FUNCTION
(LAMBDA (X)
(DECLARE (SPECIAL DIST DANGER))
(AND (> (1+ (XDR-MORE-THAN X DANGER)) DIST)
(SLR-KNOWS-RULESP (CXR-MORE-THAN (LIST X)
DIST
DANGER
NIL)
DANGER))))
CAVE-LIST))
(SETQ CAVE-LIST (GP-REMOVE-LIST CAVE-LIST KNOWS-CAVES))
(SETQ VALUE (APPEND (EGT-ALL-OF DIST KNOWS-CAVES)
(EG-INSERT-AND '|cave|
KNOWS-CAVES)
(EGT-MORE-THAN DIST
DANGER
KNOWS-CAVES)))))
(COND
((NOT (OR GO-AHEAD CAVE-LIST)) (RETURN NIL))
((AND (= DIST 0.)
(SETQ VISITED-CAVES
(GM-ALL-TRUE 'XDR-VISITEDP
CAVE-LIST)))
(WA-TOLD-RULE 1. DANGER)
(SETQ CAVE-LIST (GP-REMOVE-LIST CAVE-LIST
VISITED-CAVES))
(SETQ VALUE
(APPEND (COND (VALUE (APPEND VALUE
(EGT-ALSO T))))
'(|we have safely visited|)
(EG-INSERT-AND '|cave|
VISITED-CAVES)))))
(COND ((NULL CAVE-LIST) (RETURN VALUE)))
(RETURN
(APPEND
VALUE
(GM-MAPCAN
(FUNCTION (LAMBDA (X)
(DECLARE (SPECIAL DIST DANGER
VALUE))
(APPEND (COND (VALUE (EGT-ALSO T))
(T (SETQ VALUE T)
NIL))
(EXR-MORE-THAN X
DIST
DANGER))))
CAVE-LIST)))))
;;; EXR-MORE-THAN returns the explanation for why CAVE
;;;is more than DIST away from DANGER.
(DEFUN EXR-MORE-THAN (CAVE DIST DANGER)
(DECLARE (SPECIAL CAVE))
(PROG (R-DIST REASON TEMP)
(SETQ R-DIST (XDR-MORE-THAN CAVE DANGER)
REASON (XXR-WHY-MORE-THAN CAVE DIST DANGER))
(COND ((< R-DIST DIST)
(RETURN (WE-ERROR (LIST 'EXR-MORE-THAN
CAVE
DIST
DANGER))))
((= DIST -1.) (RETURN NIL)))
(WA-TOLD-RULE REASON DANGER)
(RETURN
(APPEND (LIST '|cave| CAVE)
(EGT-MORE-THAN DIST DANGER NIL)
'(|because|)
(COND ((= REASON 1.)
'(|we have safely visited it|))
((= REASON 2.) (EX-L2 DANGER))
((= REASON 3.)
(APPEND '(|we have been there|)
'(|and we did not|)
(AEG-WARNING-PRES DANGER)))
((= REASON 5.)
(EX-L5 (LIST CAVE) DIST DIST DANGER))
((= REASON 6.)
(EX-L6 CAVE DIST DANGER TEMP))
((= REASON 9.) (EX-L9 CAVE DANGER TEMP))
((= REASON 10.) (EX-L10 CAVE DANGER)))))))
;;; EX-L2 finishes an explanation of L2.
(DEFUN EX-L2 (DANGER)
(APPEND '(|you shot an arrow there and you did not kill|)
(AEG-DANGER-SING DANGER)))
;;; EX-L5 finishes explanations for L5.
(DEFUN EX-L5 (HAVE-CAVES DIST O-DIST DANGER)
(COND ((= (XXR-WHY-MORE-THAN (CAR HAVE-CAVES) DIST DANGER) 5.)
(EX-L5 (CONS (CADR (XDR-WHY-MORE-THAN (CAR HAVE-CAVES)
DANGER))
HAVE-CAVES)
(1+ DIST)
O-DIST
DANGER))
((MEMBER DANGER (WGR-WARNINGS (CAR HAVE-CAVES)))
(WE-ERROR (LIST 'EX-L5 (CAR HAVE-CAVES) DANGER)))
(T (WA-TOLD-RULE 3. DANGER)
(COND ((AND (= O-DIST 0.)
(> (ADB-WARNING-DIST DANGER) 1.))
(SK-TOLD-RULE 19. DANGER)))
(APPEND '(|, if|)
(AEG-DANGER-SING DANGER)
'(|were|)
(COND ((< O-DIST 1.) '(|there|))
((= O-DIST 1.) '(|next to it|))
(T (APPEND '(|within|)
(EG-NUMBER DIST)
'(|caves of it|))))
'(|, we would have|)
(AEG-WARNING-PAST DANGER)
(LIST '|in cave| (CAR HAVE-CAVES))
(COND ((< (ADB-WARNING-DIST DANGER) 2.) NIL)
((SLR-HEARD-OF-RULE 5. DANGER) NIL)
(T (EG-WITHIN (LIST (CAR HAVE-CAVES))
(LAST HAVE-CAVES)
DANGER)))))))
;;; EX-L6 finishes the explanations for L6.
(DEFUN EX-L6 (CAVE DIST DANGER TEMP)
(APPEND
(EGT-ALL-OF (1- DIST) (WGR-NEIGHBORS CAVE))
'(|its|)
(EGT-PLURAL '(|neighbors|) (WGR-NEIGHBORS CAVE))
(EGT-MORE-THAN (1- DIST) DANGER T)
;;; Don't say anymore if the player knows all.
(COND ((SETQ TEMP
(EXT-LIST-MORE-THAN (WGR-NEIGHBORS CAVE)
(1- DIST)
DANGER
NIL))
(APPEND '(|. |)
TEMP
(EG-THEREFORE)
'(|cave|)
(LIST CAVE)
(EGT-MORE-THAN DIST DANGER NIL))))))
;;; EX-L9 finishes the explanation for L9.
(DEFUN EX-L9 (CAVE DANGER TEMP)
(DECLARE (SPECIAL CAVE))
(APPEND
'(|if|)
(AEG-DANGER-SING DANGER)
'(|were there we|)
(EG-SPECULATIVE (AEG-ENCOUNTER DANGER))
(AEG-DANGER-SING DANGER)
'(|before we|)
(AEG-ENCOUNTER
(SETQ TEMP
(GM-FIRST-TRUE (FUNCTION (LAMBDA (X)
(DECLARE (SPECIAL CAVE))
(WGR-DANGERP CAVE X)))
'(2. 1. 0.))))
(AEG-DANGER-SING TEMP)))
;;; EX-L10 finishes explanations for L10.
(DEFUN EX-L10 (CAVE DANGER)
(APPEND '(|we have isolated|)
(COND ((= (ADB-NUM-DANGERS DANGER) 2.)
'(|both of the|))
((GP-TEST (ADB-NUM-DANGERS DANGER))
(APPEND '(|all|)
(EG-NUMBER (ADB-NUM-DANGERS DANGER))
'(|of the|))))
(AEG-DANGER-PLUR DANGER)
'(|. |)
;;; Note that a limit of -1. flags L10.
(EXT-LIST-CAVE-SET (CADR (XDR-WHY-MORE-THAN CAVE
DANGER))
DANGER
-1.)
(EG-THEREFORE)
(LIST '|cave| CAVE)
'(|can not contain|)
(AEG-DANGER-SING DANGER)))
;;; EXT-EXACTLY returns an explanation. It is self pruning,
;;;and will return Nil when appropriate if GO-AHEAD is NIL.
;;; Note that EXT-CAVE-SET explains rule L0.
(DEFUN EXT-EXACTLY (CAVE DANGER GO-AHEAD)
(PROG (VALUE MORE-THAN EXACTLY)
(WA-TOLD-RULE 7. DANGER)
(COND ((AND (NOT GO-AHEAD)
(SLR-KNOWS-RULESP (CXR-EXACTLY CAVE
DANGER
NIL)
DANGER))
(RETURN NIL))
((NOT (XDR-WHY-EXACTLY CAVE DANGER))
(RETURN (WE-ERROR (LIST 'EXT-EXACTLY
CAVE
DANGER)))))
(SETQ MORE-THAN (XDR-MORE-THAN CAVE DANGER)
EXACTLY (XDR-EXACTLY CAVE DANGER))
(SETQ VALUE (COND ((SLR-KNOWS-RULEP 4. DANGER) NIL)
(T (EXR-LESS-THAN CAVE DANGER))))
(SETQ
VALUE
(COND ((= EXACTLY 1.) VALUE)
(VALUE (APPEND VALUE
'(|. We also know that|)
(EXT-LIST-MORE-THAN (LIST CAVE)
MORE-THAN
DANGER
T)
(EG-THEREFORE)
(LIST '|cave|
CAVE
'|is|)
(EG-N-AWAY EXACTLY)
(AEG-DANGER-SING DANGER)))
((SLR-KNOWS-RULESP (CXR-MORE-THAN (LIST CAVE)
MORE-THAN
DANGER
NIL)
DANGER)
NIL)
(T (APPEND '(|. This follows from the fact that|)
(EXT-LIST-MORE-THAN (LIST CAVE)
MORE-THAN
DANGER
T)))))
(RETURN (APPEND (LIST '|cave| CAVE)
'(|must be|)
(EG-N-AWAY EXACTLY)
(AEG-DANGER-SING DANGER)
VALUE))))
;;; EXR-LESS-THAN returns that a cave is "less-than".
(DEFUN EXR-LESS-THAN (CAVE DANGER)
(WA-TOLD-RULE 4. DANGER)
(APPEND '(|because we|)
(AEG-WARNING-PAST DANGER)
(LIST '|in cave| CAVE)
(COND ((SLR-HEARD-OF-RULE 4. DANGER) NIL)
((> (ADB-WARNING-DIST DANGER) 1.)
(APPEND '(|. This means that cave|)
(LIST CAVE '|is within|)
(EG-NUMBER (ADB-WARNING-DIST DANGER))
'(|caves of|)
(AEG-DANGER-SING DANGER))))))
;;; EXT-LIST-CAVE-SET puts together explanations for CAVE-SETS.
(DEFUN EXT-LIST-CAVE-SET (O-CAVES DANGER LIMIT)
(COND ((NULL O-CAVES) NIL)
(T (APPEND (EXT-CAVE-SET (CAR O-CAVES) DANGER T LIMIT)
(EGT-ALSO O-CAVES)
(EXT-LIST-CAVE-SET (CDR O-CAVES)
DANGER
LIMIT)))))
;;; EXT-CAVE-SET returns an explanation for the specified cave-set
;;;depending on the student's knowledge and on GO-AHEAD.
(DEFUN EXT-CAVE-SET (O-CAVE DANGER GO-AHEAD LIMIT)
(PROG (VALUE EXPLAIN-SET TOTAL-SET NODIST-SET OTHER-CAVES
PROB DIST TEMP REASONS L10-SW)
(COND ((< (SETQ DIST (XDR-EXACTLY O-CAVE DANGER)) 0.)
(RETURN (WE-ERROR (LIST 'EXT-CAVE-SET
O-CAVE
DANGER)))))
(COND ((= LIMIT -1.) (SETQ LIMIT 0. L10-SW T)))
(SETQ NODIST-SET
(XXT-GET-NODIST-SET O-CAVE LIMIT DANGER L10-SW)
TOTAL-SET
(XSR-TOTAL-DIST-SET O-CAVE LIMIT DANGER)
EXPLAIN-SET
(GP-REMOVE-LIST TOTAL-SET NODIST-SET)
TEMP
(XSR-OTHER-CAVES O-CAVE LIMIT EXPLAIN-SET DANGER)
OTHER-CAVES
(CAR TEMP)
PROB
(CADR TEMP)
VALUE
(EG-DIST-SET EXPLAIN-SET
OTHER-CAVES
PROB
NIL
LIMIT
DANGER)
REASONS
(CXR-CAVE-SET (LIST O-CAVE) DANGER NIL))
(*SS-IMPLIED-RULES REASONS DANGER)
(COND ((SLR-KNOWS-RULESP REASONS DANGER)
(COND (GO-AHEAD (RETURN VALUE)) (T (RETURN NIL))))
((= DIST 0.)
(WA-TOLD-RULE 0. DANGER)
(RETURN (APPEND VALUE
'(|because we|)
(AEG-ENCOUNTER DANGER)
(AEG-DANGER-SING DANGER)
'(|when we visited it before|))))
((AND (= (ADB-WARNING-DIST DANGER) 1.)
(SLR-KNOWS-RULESP (GP-REMOVE-LIST REASONS '(7. 4.)) DANGER))
(WA-TOLD-RULE 4. DANGER)
(WA-TOLD-RULE 7. DANGER)
(RETURN (APPEND VALUE
'(|because we|)
(AEG-WARNING-PAST DANGER)
(LIST '|in cave| O-CAVE)))))
(RETURN (APPEND VALUE
'(|. |)
(EXT-EXACTLY O-CAVE DANGER T)
(EX-DIST-SET O-CAVE
DANGER
(1- DIST)
LIMIT
L10-SW)))))
;;; EX-DIST-SET explains each given dist set.
(DEFUN EX-DIST-SET (ORIGIN DANGER DIST LIMIT L10-SW)
(PROG (REDUCED-SET TOTAL-SET NODIST-SET OTHER-CAVES PROB
TEMP)
(RETURN
(COND ((< DIST LIMIT) NIL)
(T (SETQ NODIST-SET
(XXT-GET-NODIST-SET ORIGIN
DIST
DANGER
L10-SW)
TOTAL-SET
(XSR-TOTAL-DIST-SET ORIGIN DIST DANGER)
REDUCED-SET
(GP-REMOVE-LIST TOTAL-SET NODIST-SET)
TEMP
(XSR-OTHER-CAVES ORIGIN
DIST
REDUCED-SET
DANGER)
OTHER-CAVES
(CAR TEMP)
PROB
(CADR TEMP))
(COND ((AND NODIST-SET (> DIST 0.))
(WA-TOLD-RULE 8. DANGER)))
(APPEND (EG-DIST-SET TOTAL-SET
OTHER-CAVES
PROB
(EG-THEREFORE)
DIST
DANGER)
(EG-HOWEVER)
(EXT-LIST-MORE-THAN NODIST-SET
DIST
DANGER
T)
(EG-DIST-SET REDUCED-SET
NIL
PROB
'(|. This means that|)
DIST
DANGER)
(EX-DIST-SET ORIGIN
DANGER
(1- DIST)
LIMIT
L10-SW)))))))
;;; EXR-PROB returns an explanation for PROB with BIAS.
(DEFUN EXR-PROB (CAVE DANGER BIAS)
((GP-MAKN 'EXR-PROB (CAR (XPR-WHY-PROB CAVE DANGER)))
CAVE
DANGER
BIAS))
;;; EXR-PROBNIL returns the explanation for PROBNIL
(DEFUN EXR-PROBNIL (CAVE DANGER BIAS)
BIAS
(EXT-LIST-MORE-THAN (LIST CAVE) 0. DANGER T))
;;; EXR-PROB11 returns an explanation of PROB11.
(DEFUN EXR-PROB11 (CAVE DANGER BIAS)
(APPEND (EXT-CAVE-SET (XPR-WHY-P11 CAVE DANGER) DANGER T 0.)
;;; Cave-sets of one are self-explanatory.
(COND ((GP-EQ (XPR-GET-P11 CAVE DANGER) 1.0) NIL)
(T (WA-TOLD-RULE 11. DANGER)
(APPEND (EG-THEREFORE)
(EXR-CAVE-PROB CAVE DANGER BIAS))))))
;;; EXR-PROB12 returns an explanation for PROB12.
(DEFUN EXR-PROB12 (CAVE DANGER BIAS)
(COND
((XPR-WHY-P12 CAVE DANGER)
(WA-TOLD-RULE 12. DANGER)
(APPEND
'(|it is true that|)
(EXT-CAVE-SET (CADAR (XPR-WHY-P12 CAVE DANGER)) DANGER T 0.)
(EG-HOWEVER)
(EXT-CAVE-SET (CAAR (XPR-WHY-P12 CAVE DANGER)) DANGER T 0.)
'(|. This explains all the evidence for|)
(AEG-DANGER-SING DANGER)
(EG-INSERT-AND
'|in cave|
(XSR-GET-CAVE-SET (CADAR (XPR-WHY-P12 CAVE DANGER))
DANGER))
(COND
((CDR (XPR-WHY-P12 CAVE DANGER))
(APPEND
'(|. Likewise, we can explain away all the other evidence of|)
(AEG-DANGER-SING DANGER)
(LIST '|in cave| CAVE '|. |)))
(T '(|. |)))
(EXR-UNSAFE CAVE DANGER BIAS)))
(T (EXR-UNSAFE CAVE DANGER BIAS))))
;;; EXR-UNSAFE simply returns that a cave is unsafe.
(DEFUN EXR-UNSAFE (CAVE DANGER BIAS)
(APPEND '(|as we do not have any evidence of cave|)
(LIST CAVE '|containing|)
(AEG-DANGER-SING DANGER)
'(|, we can presume that|)
(EXR-CAVE-PROB CAVE DANGER BIAS)))
;;; EXR-PROB13 returns an expalnation for PROB13.
(DEFUN EXR-PROB13 (CAVE DANGER BIAS)
(WA-TOLD-RULE 13. DANGER)
(APPEND (EXT-LIST-CAVE-SET (XPR-GOOD-MEMBER-SETS CAVE DANGER)
DANGER
0.)
'(|. This is multiple evidence of|)
(AEG-DANGER-SING DANGER)
(LIST '|in cave| CAVE '|which makes it|)
(EG-PROBABLE (XPR-PROB CAVE DANGER) BIAS)
(LIST '|that cave| CAVE '|contains|)
(AEG-DANGER-SING DANGER)))
;;; EXR-PROB14 returns an explanation for PROB14.
(DEFUN EXR-PROB14 (CAVE DANGER BIAS)
(DECLARE (SPECIAL DANGER))
(PROG (MEMBER-SETS CHANGED-CAVES)
(WA-TOLD-RULE 14. DANGER)
(SETQ
MEMBER-SETS
(XPR-GOOD-MEMBER-SETS CAVE DANGER)
CHANGED-CAVES
(GP-UNION
(GM-MAPCAN (FUNCTION (LAMBDA (X)
(DECLARE (SPECIAL DANGER))
(XPR-P13-CHANGED X
DANGER)))
MEMBER-SETS)))
(RETURN (APPEND (EXT-LIST-CAVE-SET MEMBER-SETS DANGER 0.)
(EG-HOWEVER)
'(|we have multiple evidence for|)
(EG-INSERT-AND '|cave|
CHANGED-CAVES)
(EG-THEREFORE)
(EXR-CAVE-PROB CAVE DANGER BIAS)))))
;;; EXR-PROB15 returns an explanation for PROB15.
(DEFUN EXR-PROB15 (CAVE DANGER BIAS)
(COND
((EQ BIAS 'UNSAFE)
((GP-MAKN 'EXR-PROB (CADR (XPR-WHY-PROB CAVE DANGER)))
CAVE
DANGER
BIAS))
(T
(WA-TOLD-RULE 15. DANGER)
(APPEND
'(|we know that it is|)
(EG-PROBABLE (XPR-GET-P14 CAVE DANGER) NIL)
(LIST '|that cave| CAVE '|contains|)
(AEG-DANGER-SING DANGER)
(EG-THEREFORE)
'(|if we first shoot an arrow into cave|)
(LIST CAVE '|before visiting it, it is|)
(EG-PROBABLE (XPR-PROB CAVE DANGER) BIAS)
'(|that we will be killed by the arrow|
|(if it misses) or by|)
(AEG-DANGER-SING DANGER)))))
;;; EXR-CAVE-PROB returns a caves PROB in words.
(DEFUN EXR-CAVE-PROB (CAVE DANGER BIAS)
(APPEND '(|it is|)
(EG-PROBABLE (XPR-PROB CAVE DANGER) BIAS)
(LIST '|that cave| CAVE '|contains|)
(AEG-DANGER-SING DANGER)))
;;;******** General Purpose English Routines. *******
;;; EG-INSERT-AND takes a list, inserts commas, inserts "and",
;;;and adds the PRED (it omits additions as appropriate).
(DEFUN EG-INSERT-AND (PRED CAVE-LIST)
(COND ((NULL CAVE-LIST) (LIST '|no| (EG-PLURAL PRED)))
((= (LENGTH CAVE-LIST) 1.) (GP-CONS PRED CAVE-LIST))
((= (LENGTH CAVE-LIST) 2.)
(GP-CONS (EG-PLURAL PRED)
(LIST (CAR CAVE-LIST)
'|and|
(CADR CAVE-LIST))))
(T (APPEND (GP-CONS (EG-PLURAL PRED)
(EG-INSERT-COMMAS CAVE-LIST))
'(|and|)
(LAST CAVE-LIST)))))
;;; EG-INSERT-COMMAS inserts commas into any list it is sent.
(DEFUN EG-INSERT-COMMAS (LIST)
(COND ((CDR LIST)
(APPEND (LIST (CAR LIST) '|,|)
(EG-INSERT-COMMAS (CDR LIST))))))
;;; EG-NUMBER converts a decimal number to its word equivalent.
(DEFUN EG-NUMBER (NUMBER)
(COND ((< NUMBER 1.) '(|no|))
((< NUMBER 11.) (AEG-NUMBER (1- NUMBER)))
(T (LIST NUMBER))))
;;; EG-DANGERS converts a list of dangers into words.
(DEFUN EG-DANGERS (DANGERS)
(EG-INSERT-AND
NIL
(MAPCAR (FUNCTION (LAMBDA (X) (CAR (AEG-DANGER-PLUR X))))
DANGERS)))
;;; EG-PROBABLE is a function that receives a probability and returns a
;;;list of words that have about the same meaning.
(DEFUN EG-PROBABLE (NUMBER BIAS)
(COND ((GP-EQ NUMBER 0.0) '(|not possible|))
((EQ BIAS 'SAFE) '(|less likely|))
((EQ BIAS 'UNSAFE) '(|more likely|))
((< NUMBER 0.1) '(|very unlikely|))
((< NUMBER 0.25) '(|unlikely|))
((< NUMBER 0.4) '(|possible|))
((< NUMBER 0.55) '(|quite possible|))
((< NUMBER 0.7) '(|probable|))
((< NUMBER 0.85) '(|very likely|))
((< NUMBER 1.0) '(|almost certain|))
(T '(|certain|))))
;;; EG-THEREFORE has an unlimited supply of "therefore"s.
(DEFUN EG-THEREFORE NIL
(DECLARE (SPECIAL LEG-THEREFORE))
(GC-NEXT LEG-THEREFORE))
;;; EGT-ALSO has a never ending supply of "also"s.
(DEFUN EGT-ALSO (TEST)
(DECLARE (SPECIAL LEG-ALSO))
(COND ((GP-TEST TEST) (GC-NEXT LEG-ALSO))))
;;; EG-CONVERSELY has an unlimited supply of "conversely"s.
(DEFUN EG-CONVERSELY NIL
(DECLARE (SPECIAL LEG-CONVERSELY))
(GC-NEXT LEG-CONVERSELY))
;;; EG-HOWEVER has an unlimited supply of "however"s.
(DEFUN EG-HOWEVER NIL
(DECLARE (SPECIAL LEG-HOWEVER))
(GC-NEXT LEG-HOWEVER))
;;; EG-BECAUSE has an unlimited supply of "because"s.
(DEFUN EG-BECAUSE NIL
(DECLARE (SPECIAL EGV-BECAUSE))
EGV-BECAUSE)
;;; EG-PLURAL returns the plural of ITEM.
(DEFUN EG-PLURAL (ITEM)
(DECLARE (SPECIAL EGV-PLURAL))
;;; The plural of NIL is NIL?
(COND ((NOT ITEM) NIL)
((GET EGV-PLURAL ITEM))
(T (GP-MAKN ITEM '/s))))
;;; EGT-PLURAL returns the plural if TEST was a list or T.
(DEFUN EGT-PLURAL (LIST TEST)
(COND ((GP-TEST TEST) (CONS (EG-PLURAL (CAR LIST)) (CDR LIST)))
(T LIST)))
;;; EG-SPECULATIVE converts its argument into the speculative.
(DEFUN EG-SPECULATIVE (LIST)
(DECLARE (SPECIAL EG-SPEC))
(CONS (GET EG-SPEC (CAR LIST)) (CDR LIST)))
;;; EGT-TELL-AVOID returns an explanation why
;;;the player should avoid the DANGERS. (sometimes)
(DEFUN EGT-TELL-AVOID (DANGERS)
(EG-TELL-AVOID
(GM-ALL-TRUE (FUNCTION (LAMBDA (X) (< (ASK-WDRULES 18. 0. X) 3.)))
DANGERS)))
;;; EG-TELL-AVOID produces the actual English.
(DEFUN EG-TELL-AVOID (DANGERS)
(COND
((NULL DANGERS) NIL)
(T
(STORE (ASK-WDRULES 18. 0. (CAR DANGERS))
(1+ (ASK-WDRULES 18. 0. (CAR DANGERS))))
(APPEND (EVAL (AEG-TELL-AVOID (1- (ASK-WDRULES 18. 0. (CAR DANGERS)))
(CAR DANGERS)))
(EGT-ALSO DANGERS)
(EG-TELL-AVOID (CDR DANGERS))))))
;;; EG-TOLD-RULES returns rules for a danger.
(DEFUN EG-TOLD-RULES (RULES DANGER)
(APPEND (EG-INSERT-AND '|rule| RULES)
'(|for|)
(AEG-DANGER-PLUR DANGER)))
;;; EGT-MORE-THAN returns a list saying more than DIST.
(DEFUN EGT-MORE-THAN (DIST DANGER TEST)
(APPEND (COND ((< DIST 0.)
(WE-ERROR (LIST 'EGT-MORE-THAN
DIST
DANGER)))
((AND (= DIST 0.) (GP-TEST TEST))
'(|can contain|))
((= DIST 0.) '(|can not contain|))
((AND (= DIST 1.) (GP-TEST TEST))
'(|are next to|))
((= DIST 1.) '(|is not next to|))
(T (APPEND '(|is more than|)
(EG-NUMBER DIST)
'(|caves away from|))))
(AEG-DANGER-SING DANGER)))
;;; EGT-ALL-OF returns "all of" in conjunction with EGT-MORE-THAN.
(DEFUN EGT-ALL-OF (DIST LIST)
(COND ((NOT (CDR LIST)) NIL)
((AND (CDDR LIST) (< DIST 2.)) '(|none of|))
((< DIST 2.) '(|neither of|))
((CDDR LIST) '(|all of|))
(T '(|both of|))))
;;; EG-WITHIN returns an explanation of the propagation of warnings.
(DEFUN EG-WITHIN (T-ORIGIN EXPLAIN DANGER)
(APPEND '(|as cave|)
EXPLAIN
(COND ((= (ADB-WARNING-DIST DANGER) 1.)
'(|is next to cave|))
(T (APPEND '(|is within|)
(EG-NUMBER (ADB-WARNING-DIST DANGER))
'(|caves of cave|))))
T-ORIGIN))
;;; EG-N-AWAY retrurs a list saying DIST away.
(DEFUN EG-N-AWAY (DIST)
(COND ((< DIST 1.) '(|contains|))
((= DIST 1.) '(|next to|))
(T (APPEND '(|exactly|)
(EG-NUMBER DIST)
'(|caves away from|)))))
;;; EG-DIST-SET puts together English for a DIST-SET.
(DEFUN EG-DIST-SET (NEW-CAVES OTHER-CAVES PROB PRED DIST DANGER)
(APPEND
(COND
(OTHER-CAVES (APPEND (COND (PRED '(|. |)))
'(|we do not know the neighbors of|)
(EG-INSERT-AND '|cave|
OTHER-CAVES)
(EG-HOWEVER)
'(|it is|)
(EG-PROBABLE PROB NIL)
'(|that|)))
((GP-EQ PROB 1.0) PRED)
(T (APPEND PRED
'(|it is|)
(EG-PROBABLE PROB NIL)
'(|that|))))
(COND ((GP-TEST NEW-CAVES) '(|one of|)))
(EG-INSERT-AND '|cave| NEW-CAVES)
(COND ((GP-TEST (1+ DIST))
(APPEND '(|must be|) (EG-N-AWAY DIST)))
(T '(|contains|)))
(AEG-DANGER-SING DANGER)))
;;;;**************** The Wumpus Game Routines. ****************
;;;WG-MOVETO ACCEPTS THE NUMBER OF THE CAVE TO WHICH THE
;;;PLAYER IS MOVING, CHECKS OUT THE MOVE, AND PERFORMS IT
(DEFUN WG-MOVETO (CAVE)
(DECLARE (SPECIAL WE-NORESTART WG-HERE WE-DONE WE-MOVE DB-NUM-CAVES))
(COND ((WGR-DANGERP CAVE 2.)
(COND (WE-MOVE (SETQ WE-NORESTART T)))
(WE-NOTE-DANGER 2.)
(SETQ WE-DONE T))
((WGR-DANGERP CAVE 1.)
(WE-NOTE-DANGER 1.)
(SETQ WE-DONE T))
((WGR-DANGERP CAVE 0.)
(WE-NOTE-DANGER 0.)
;;;BATS CAN GO ANYWHERE-
(WG-MOVETO (RANDOM DB-NUM-CAVES)))
(T (SETQ WG-HERE CAVE))))
;;; WG-SHOOT is the Wumpus function to shoot an arrow.
(DEFUN WG-SHOOT (CAVE)
(DECLARE (SPECIAL WG-ARROWS WE-DONE))
(COND
((WGR-EXTRA-ARROWS)
(SETQ WG-ARROWS (1- WG-ARROWS))
(WG-SHOOT1 CAVE (1+ (RANDOM 4.))))
(T (COND ((WG-SHOOT1 CAVE (1+ (RANDOM 4.))) T)
(T (G-RSAY '(|You are out of arrows, you lose! |))
(SETQ WE-DONE T))))))
;;; WG-SHOOT1 does the actual work of shooting.
(DEFUN WG-SHOOT1 (CAVE DIST-LEFT)
(DECLARE (SPECIAL WE-SHOT WE-DONE WE-RETURN WG-HERE DB-NAME))
(COND ((< DIST-LEFT 1.) NIL)
((WGR-DANGERP CAVE 2.)
(G-RSAY (LIST '|Congratulations,|
DB-NAME
'|, you have shot the Wumpus. |))
(SETQ WE-RETURN T)
(SETQ WE-DONE T)
T)
((= CAVE WG-HERE)
(G-RSAY '(|You have just shot yourself. |))
(SETQ WE-DONE T)
NIL)
(T (G-RSAY '(|Poing|))
(COND (WE-SHOT (*SXD-MARK-SHOT WE-SHOT)
(XD-MARK-SHOT WE-SHOT)))
(WG-SHOOT1 (GP-RANDEL (WGR-NEIGHBORS CAVE))
(1- DIST-LEFT)))))
;;;*********** Routines to Change the Warren. **************
;;; WGM-TRANSPOSE does the actual transposition of two caves.
(DEFUN WGM-TRANSPOSE (CAVE-1 CAVE-2)
(PROG (TEMP TEMP-1 TEMP-2)
(SETQ TEMP (WGR-WARNINGS CAVE-1))
(WGI-MARK-WARNINGS CAVE-1 (WGR-WARNINGS CAVE-2))
(WGI-MARK-WARNINGS CAVE-2 TEMP)
(DO ((DANGER 0. (1+ DANGER)))
((> DANGER 2.))
(SETQ TEMP (WGR-DANGERP CAVE-1 DANGER))
(COND ((WGR-DANGERP CAVE-2 DANGER)
(WGI-STORE-DANGER CAVE-1 T DANGER))
(T (WGI-STORE-DANGER CAVE-1 NIL DANGER)))
(COND (TEMP (WGI-STORE-DANGER CAVE-2 T DANGER))
(T (WGI-STORE-DANGER CAVE-2 NIL DANGER))))
(SETQ TEMP-1 (WGR-NEIGHBORS CAVE-1)
TEMP-2 (WGR-NEIGHBORS CAVE-2))
(WGM-FIX-NEI CAVE-1 TEMP-1 (SUBST CAVE-2 CAVE-1 TEMP-2))
(WGM-FIX-NEI CAVE-2 TEMP-2 (SUBST CAVE-1 CAVE-2 TEMP-1))))
;;; WGM-FIX-NEI changes the neighbors of a cave.
(DEFUN WGM-FIX-NEI (CAVE O-NEI N-NEI)
(COND (O-NEI (WGM-UNMAKE-NEI CAVE (CAR O-NEI))
(WGM-FIX-NEI CAVE (CDR O-NEI) N-NEI))
(N-NEI (WGI-MAKNEI CAVE (CAR N-NEI))
(WGM-FIX-NEI CAVE NIL (CDR N-NEI)))))
;;; WGM-UNMAKE-NEI unmakes neighbors.
(DEFUN WGM-UNMAKE-NEI (CAVE-1 CAVE-2)
(WGI-PUT-NEI CAVE-1 (GP-DELETE CAVE-2 (WGR-NEIGHBORS CAVE-1)))
(WGI-PUT-NEI CAVE-2 (GP-DELETE CAVE-1 (WGR-NEIGHBORS CAVE-2))))
;;;*********** Wumpus Game Initiaialization Routines. ***********
;;;WGI-INIT SETS UP FOR A NEW GAME
(DEFUN WGI-INIT NIL
(DECLARE (SPECIAL WG-HERE DB-NUM-CAVES))
(WGI-MAZE)
(MAPC
(FUNCTION
(LAMBDA (X)
(DECLARE (SPECIAL DB-NUM-CAVES))
(WGI-PUT-DANGER (WGI-NOREPRAN (ADB-NUM-DANGERS X)
DB-NUM-CAVES)
X)))
'(2. 1. 0.))
(DO ((START (RANDOM DB-NUM-CAVES) (RANDOM DB-NUM-CAVES)))
((WGR-SAFEP START) (SETQ WG-HERE START))))
;;; WGI-MAZE CREATES A RANDOM NETWORK OF
;;;DB-NUM-CAVES CAVES. ....IT ALSO REMOVES THE OLD MAZE
(DEFUN WGI-MAZE NIL
(DECLARE (SPECIAL DB-NUM-CAVES))
(DO ((N 0. (1+ N)) (TP))
((= N 2.))
(SETQ TP (WGI-REORDER (GP-ORDLST DB-NUM-CAVES)))
(WGI-MAKNEI (CAR TP) (WGI-LISNEI TP))))
;;; WGI-PUT-DANGER marks the caves it is sent as containing
;;;said DANGER, and then marks the warnings as appropriate.
(DEFUN WGI-PUT-DANGER (CAVE-LIST DANGER)
(COND (CAVE-LIST (WGI-STORE-DANGER (CAR CAVE-LIST) T DANGER)
(WGI-PUT-WARNING (CAR CAVE-LIST)
(ADB-WARNING-DIST DANGER)
DANGER)
(WGI-PUT-DANGER (CDR CAVE-LIST) DANGER))))
;;; WGI-PUT-WARNING puts the warnings onto the necessary caves.
(DEFUN WGI-PUT-WARNING (CAVE DIST DANGER)
(DECLARE (SPECIAL DANGER))
(MAPC
(FUNCTION
(LAMBDA (X) (DECLARE (SPECIAL DANGER))
(WGI-MARK-WARNINGS X
(GP-CONS DANGER
(WGR-WARNINGS X)))))
(GP-DIST-AREA (LIST CAVE) DIST)))
;;; WGI-NEI PUTS N2 ON CAVE N1'S NEIGHBOR PROPERTY LIST
(DEFUN WGI-NEI (N1 N2)
(PROG (NLST)
(SETQ NLST (WGR-NEIGHBORS N2))
(OR (MEMBER N1 NLST) (WGI-PUT-NEI N2 (CONS N1 NLST)))))
;;; WGI-LISNEI MAKES NEIGHBORS OUT OF NEIGHBORING ELEMENTS
;;;OF ITS INPUT. IT RETURNS THE LAST ELEMENT OF THE LIST.
(DEFUN WGI-LISNEI (LIS)
(COND ((NULL (CADR LIS)) (CAR LIS))
(T (WGI-MAKNEI (CAR LIS) (CADR LIS))
(WGI-LISNEI (CDR LIS)))))
;;;WGI-MAKNEI MAKES N1 AND N2 NEIGHBORS OF EACH OTHER
(DEFUN WGI-MAKNEI (N1 N2) (PROG2 (WGI-NEI N1 N2) (WGI-NEI N2 N1)))
;;; WGI-NTHEL RETURNS A LIST WITH THE NTH ELEMENT AT THE FRONT
(DEFUN WGI-NTHEL (LST N)
(COND ((< N 2.) LST)
(T (WGI-INSERT2 (CAR LST)
(WGI-NTHEL (CDR LST) (1- N))))))
;;; WGI-INSERT2 PLACES EL SECOND IN THE LIST LST
(DEFUN WGI-INSERT2 (EL LST) (CONS (CAR LST) (CONS EL (CDR LST))))
;;; WGI-NOREPRAN OUTPUTS NUM UNIQUE RANDOM NUMBERS FROM THE
;;;RANGE 0 TO RANGE -1
(DEFUN WGI-NOREPRAN (NUM RANGE)
(COND ((= NUM 1.) (LIST (RANDOM RANGE)))
(T (SETQ NUM (WGI-NOREPRAN (1- NUM) RANGE))
(DO ((RNUM (RANDOM RANGE) (RANDOM RANGE)))
((NOT (MEMBER RNUM NUM)) (CONS RNUM NUM))))))
;;; WGI-REORDER RETURNS ITS ARGUMENT LIST IN RANDOM ORDER
(DEFUN WGI-REORDER (LST)
(PROG (N)
(COND ((NULL LST) NIL)
(T (SETQ N
(WGI-NTHEL LST
(1+ (RANDOM (LENGTH LST)))))
(RETURN (CONS (CAR N)
(WGI-REORDER (CDR N))))))))
;;;*********** Wumpus Game Routines to supply info. **********
;;; WGR-NEIGHBORS returns a list of the cave's neighbors.
(DEFUN WGR-NEIGHBORS (CAVE) (ADB-CAVE CAVE 0.))
;;; WGI-PUT-NEI stores the NEIGHBORS into the arrays.
(DEFUN WGI-PUT-NEI (CAVE VALUE) (STORE (ADB-CAVE CAVE 0.) VALUE))
;;; WGR-DANGERP is a predicate that return T if the given
;;;DANGER is located in the given CAVE.
(DEFUN WGR-DANGERP (CAVE DANGER) (ADB-DCAVE CAVE 0. DANGER))
;;; WGR-SAFEP returns T if the given cave is safe.
(DEFUN WGR-SAFEP (CAVE)
(NOT (OR (WGR-DANGERP CAVE 0.)
(WGR-DANGERP CAVE 1.)
(WGR-DANGERP CAVE 2.))))
;;; WGI-STORE-DANGER marks the danger in the arrays.
(DEFUN WGI-STORE-DANGER (CAVE VALUE DANGER)
(STORE (ADB-DCAVE CAVE 0. DANGER) VALUE))
;;; WGR-WARNINGS returns those dangers causing warnings at CAVE.
(DEFUN WGR-WARNINGS (CAVE) (ADB-CAVE CAVE 1.))
;;; WGI-MARK-WARNINGS puts the WARNINGS into the arrays.
(DEFUN WGI-MARK-WARNINGS (CAVE VALUE)
(STORE (ADB-CAVE CAVE 1.) VALUE))
;;; WGR-EXTRA-ARROWS returns T if the player has extra arrows.
(DEFUN WGR-EXTRA-ARROWS NIL
(DECLARE (SPECIAL WG-ARROWS))
(> WG-ARROWS 1.))
;;; ************************ Data Base Routines ****************
;;; This is the beginning of the routines that update the standard
;;;database for the program. They have a prefix of "D_".
;;; "DI" routines do the very first initializations. They initialize
;;;all the vital "inter-game" variables, finding about the player, etc.
;;; DI-DATABASE is called once for each new LISP. It fills the arrays, etc..
;;; It is executed as part of the initializations. (Not compiled).
(DEFUN DI-DATABASE NIL
(DECLARE (SPECIAL TYO CX-WHY-BETTER CX-WHY-WORSE G-READ-NUM G-SILENT
G-LAST G-BLAST G-BBLAST DB-NUMLOSSES GV-CURSORPOS
DB-NUM-PROP WE-GAME-HIST SC-UREPEAT SC-LREPEAT DB-DATE
SC-LFORGET SC-UFORGET EGV-PLURAL EGV-BECAUSE DB-LAST-DATE
EG-SPEC LWAW-TELL-WANDER LWA-TELL-C4 LEG-HOWEVER
LEG-CONVERSELY LEG-ALSO LEG-THEREFORE WAV-TOLD-RULE
SC-DECREASE-FORGET SC-DECREASE-REPEAT SC-INCREASE-FORGET
SC-INCREASE-REPEAT *SS-VERSION *SS-ACTIVE
WEV-RECREATE WE-VERSION XP-P12-CHANGED G-DOUBLESPACE
SF-VAR-LIST DB-NUM-CRULES DB-NUM-RULES DB-NUM-DPROP))
(ENDPAGEFN TYO NIL)
(SETSYNTAX 46. 128. NIL)
(SETQ IBASE 10.
BASE 10.
*NOPOINT T
*SS-ACTIVE NIL
*SS-VERSION NIL
WE-VERSION '|eight|
WEV-RECREATE NIL
WE-GAME-HIST NIL
DB-NUM-CRULES 6.
DB-NUM-RULES 19.
DB-NUM-PROP 7.
DB-NUM-DPROP 18.
DB-DATE (DI-DATE)
WAV-TOLD-RULE NIL
CX-WHY-BETTER NIL
CX-WHY-WORSE NIL
EGV-PLURAL 'EGV-PLURAL
EGV-BECAUSE '(|, because|)
EG-SPEC 'EG-SPEC
SC-LREPEAT 0.0
SC-UREPEAT 5.0
SC-LFORGET 2.0
SC-UFORGET 30.0
LEG-THEREFORE (GCI-CREATE 3.
'((|, and so|)
(|. Therefore|)
(|. Hence|)))
LEG-ALSO (GCI-CREATE 3.
'((|. Also,|)
(|, and|)
(|. Likewise,|)))
LEG-CONVERSELY (GCI-CREATE 2.
'((|. Conversely,|)
(|. In contrast,|)))
LEG-HOWEVER (GCI-CREATE 2.
'((|. However|) (|, but|)))
LWA-TELL-C4 (GCI-CREATE 3.
'((LIST '|I don't know,|
DB-NAME
'|, but|)
(LIST '|Well,|
DB-NAME
'|, I think that|)
(LIST '|You know,|
DB-NAME
'|,|)))
LWAW-TELL-WANDER (GCI-CREATE 3.
'((LIST DB-NAME
'|, we seem to be going in circles|)
(LIST '|I seem to remember just|
'|coming from that cave,|
DB-NAME)
(LIST '|We seem to be wandering aimlessly,|
DB-NAME)))
G-DOUBLESPACE NIL
G-LAST 32.
G-BLAST 32.
G-BBLAST 46.
G-SILENT NIL
G-READ-NUM 1.
GV-CURSORPOS 0.
XP-P12-CHANGED NIL
SC-INCREASE-FORGET NIL
SC-DECREASE-FORGET NIL
SC-INCREASE-REPEAT NIL
SC-DECREASE-REPEAT NIL
SF-VAR-LIST '(DB-UNAME DB-NAME DB-LAST-DATE DB-NUMWINS DB-NUMLOSSES
DB-MOVES DB-DEBUG DB-COMMENT SL-REPEAT SL-FORGET
SL-RECEPTIVITY SL-HEARD-OF WA-CAN-BACKTRACK
WA-TOLD-BACKTRACK WE-MOVE-NUM SL-LAST-LEARNED
SC-INITIALIZED SL-TUTOR DB-GAME-NUM DB-HISTORY))
(ARRAY ADB-CAVE T 1. DB-NUM-PROP)
(ARRAY ADB-DCAVE T 1. DB-NUM-DPROP 1.)
(ARRAY AEG-TELL-AVOID T 3. 3.)
(ARRAY ADB-TELL-WARNING T 3. 3.)
(ARRAY ADB-TELL-DANGER T 3. 3.)
(ARRAY ASK-WDRULES FIXNUM (1+ DB-NUM-RULES) 2. 3.)
(ARRAY ASK-DRULES FLONUM (1+ DB-NUM-RULES) 2. 3.)
(ARRAY AWE-EXPL-RULES T 16.)
(ARRAY ASL-PHASE-RULES T 5. 3.)
(ARRAY ASL-NEXT-RULES T 5. 3.)
(ARRAY ASL-PNUM-DANGERS T 5. 3.)
(ARRAY ASKC-RULES T 7. 3.)
(ARRAY AEG-NUMBER T 10.)
(MAPC (FUNCTION (LAMBDA (X) (*ARRAY X T 3.)))
'(AXS-CHANGED-SETS AEG-DANGER-SING AEG-DANGER-PLUR
ASL-WORK-ON-RULES AXR-FOUND-N AXS-EXACT-CAVES
AXS-PARTIAL-SETS AXS-COMPLETE-SETS
APS-RULE-ARRAY AEG-WARNING-PRES AEG-WARNING-PAST
ASC-INITIALIZED AEG-ENCOUNTER AWA-TOLD-RULES))
(MAPC (FUNCTION (LAMBDA (X) (*ARRAY X 'FIXNUM 3.)))
'(ADB-NUM-DANGERS ADB-WARNING-DIST AXR-NUM-IDENTIFIED
ASL-PHASE ADB-DIST-START))
(MAPC (FUNCTION (LAMBDA (X) (*ARRAY X 'FLONUM 3.)))
'(AXX-EST-NUM-DANGERS AXP-PROB12))
(MAPC (FUNCTION (LAMBDA (X Y)
(DECLARE (SPECIAL EGV-PLURAL))
(PUTPROP EGV-PLURAL Y X)))
'(|is cave| |is| |can| |could| |is rule|)
'(|are caves| |are| |can| |could| |are rules|))
(MAPC (FUNCTION (LAMBDA (X Y)
(DECLARE (SPECIAL EG-SPEC))
(PUTPROP EG-SPEC Y X)))
'(|were| |fell|)
'(|would have been| |would have fallen|))
(MAPC (FUNCTION (LAMBDA (X Y) (STORE (ASKC-RULES X 1.) Y)))
(GP-ORDLST 7.)
'(2. 1. 2. 0. 0. 0. 0.))
(MAPC (FUNCTION (LAMBDA (X A B C D E F G H I)
(STORE (ASL-PHASE-RULES X 0.) A)
(STORE (ASL-PHASE-RULES X 1.) B)
(STORE (ASL-PHASE-RULES X 2.) C)
(STORE (ASL-NEXT-RULES X 0.) D)
(STORE (ASL-NEXT-RULES X 1.) E)
(STORE (ASL-NEXT-RULES X 2.) F)
(STORE (ASL-PNUM-DANGERS X 0.) G)
(STORE (ASL-PNUM-DANGERS X 1.) H)
(STORE (ASL-PNUM-DANGERS X 2.) I)))
(GP-ORDLST 5.)
'((14.) (6. 10. 12. 13.) (4. 7. 11.) (0. 3. 5.) (1.))
'((14.) (6. 9. 10. 12. 13.) (4. 7. 11.) (0. 3. 5.)
(1.))
'((12. 13.) (6. 8. 9. 10. 11. 15.) (4. 7.)
(0. 2. 3. 5. 19.) (1.))
'((14.) (12. 13.) (4. 7. 11.) (3. 5.) (1.))
'((14.) (12. 13.) (4. 7. 11.) (3. 5.) (1.))
'((12. 13.) (11.) (4. 7.) (3. 5. 19.) (1.))
'(4. 3. 3. 2. 1.)
'(2. 3. 3. 2. 1.)
'(2. 1. 1. 1. 1.))
(MAPC (FUNCTION (LAMBDA (W A B C D E)
(STORE (ASL-PHASE W) 0.)
(STORE (ASL-WORK-ON-RULES W)
(ASL-PHASE-RULES 0. W))
(STORE (AEG-ENCOUNTER W) A)
(STORE (AEG-WARNING-PRES W) B)
(STORE (AEG-WARNING-PAST W) C)
(STORE (AEG-DANGER-SING W) D)
(STORE (AEG-DANGER-PLUR W) E)))
'(0. 1. 2.)
'((|were| |picked up by|) (|fell| |into|)
(|were| |eaten by|))
'((|hear squeaking|) (|feel a breeze|)
(|smell the Wumpus|))
'((|heard squeaking|) (|felt a breeze|)
(|smelled the Wumpus|))
'((|bats|) (|a pit|) (|the Wumpus|))
'((|bats|) (|pits|) (|the Wumpus|)))
(MAPC (FUNCTION (LAMBDA (X Y) (STORE (AEG-NUMBER X) Y)))
(GP-ORDLST 10.)
'((|ten|) (|nine|) (|eight|) (|seven|) (|six|)
(|five|) (|four|) (|three|) (|two|) (|one|)))
(MAPC (FUNCTION (LAMBDA (X Y) (STORE (AWE-EXPL-RULES X) Y)))
(GP-ORDLST 16.)
'((|P15, Shooting Principle, Whenever the probability of|
|the Wumpus being in a cave exceeds 0.25, it is safer to|
|shoot into the cave before visitng it. Hence, the more|
|likely it is that the Wumpus is in the cave, the less|
|likely it is that the player will be killed.|)
(|P14, Adjust For Multiple Evidence Principle, In cases|
|where P13 is applied, the other members of said|
|cave-set are less likely to contain the danger.|)
(|P13, Multiple Evidence Principle, if there is multiple|
|evidence that a given cave contains a danger (i.e. it|
|is a member of two cave-sets), then it is more likely|
|that the given cave contains the danger.|)
(|P12, Explain Away Evidence Principle, When it is noted|
|that there are two cave-sets, one of which is a subset|
|of the other, there is no evidence that those caves|
|in the superset and not in the subset whether or|
|not said caves contain a danger (as the caves in the|
|subset completely explain the warning) so the|
|probability is reduced to some consistent value.|)
(|P11, Equal Likelihood Principle, An estimation of|
|the probability for a given cave is 1N, where N|
|is the number of caves in the smallest cave-set|
|of which said cave is a member.|)
(|L10, Certain caves can be marked as "more than zero|
|away" based on consideration of the different|
|complete cave-sets and the number of dangers. |)
(|L9, If the player encountered a danger in a cave,|
|then the cave does not contain a danger of higher|
|priority, i.e. the Wumpus eats the player before|
|he can fall into a pit, and he will fall into a|
|pit before he is picked up by bats.|)
(|L8, When the algorithm is creating cave-sets and|
|it encounters a cave which would be N caves away|
|but which is also "more than N away", then that cave|
|can not have any contributions to the cave-set. |)
(|L7, If a cave is "more than (N-1) away" and|
|"less than (N+1) away", then it is "N away". |)
(|L6, If all of a caves neighbors are "more than|
|(N-1) away", then it can be marked "more than N away". |)
(|L5, If a cave is marked "more than N away" then all|
|of its neighbors can be marked as "more than (N-1) away". |)
(|L4, If a cave is visited and there is a warning,|
|then that cave is "less than (N+1) away". |)
(|L3, If a cave is visited and there is not a warning,|
|then that cave is "more than N away" where N|
|is the distance that the warning propagates. |)
(|L2, If the player shoots an arrow into a cave|
|and does not kill the Wumpus, then that cave can|
|be marked as "more than zero away" (Wumpus). |)
(|L1, A cave can be marked as "more than zero|
|away" if it was safely visited. |)
(|L0, A cave can be marked as "zero away" if it|
|was visited and found to contain a danger. |)))
;;; The other dangers are set when it is known how many there are.
(MAPC (FUNCTION (LAMBDA (W A X Y Z)
(STORE (AEG-TELL-AVOID W Z) A)
(STORE (ADB-TELL-WARNING W Z) X)
(STORE (ADB-TELL-DANGER W Z) Y)))
'(0. 1. 2. 0. 1. 2. 0. 1. 2.)
'((APPEND '(|it is not wise to visit caves with bats|
|because while THEY will not harm us|
|they will carry us to another cave which|
|could contain|) (AEG-DANGER-SING 1.) '(|or|) (AEG-DANGER-SING 2.))
(APPEND
'(|we should avoid bats because they|
|could drop us in a cave with|)
(AEG-DANGER-SING 1.)
'(|or|)
(AEG-DANGER-SING 2.))
'(|it is best to avoid bats as they could carry us to a fatal cave|)
(APPEND '(|we should try not to stumble into|)
(AEG-DANGER-SING 1.)
'(|as it would be fatal|))
'(|we should avoid pits as they are fatal|)
'(|pits are dangerous as falling into one is fatal|)
(APPEND '(|it is best to avoid|)
(AEG-DANGER-PLUR 2.)
'(|as|)
(AEG-DANGER-PLUR 2.)
'(|eats unwary players who stumble into his lair|))
'(|we should avoid Wumpii as they eat unwary players|)
'(|Wumpii are dangerous as they have insatiable|
|appetites for bumbling players|))
'((|Squeak. I hear bats, they must be in one of the neighboring caves. |)
(|Squeak. I hear bats. |) (|Squeak. |)
(|Brrrr. I feel a breeze! We must be next to a pit. |)
(|Brrrr. I feel a breeze. |) (|Brrrr. |)
(|Whew, what a stench! That is the smell of the Wumpus. |
|It means that we are within two caves of the Wumpus. |)
(|What a stench! The Wumpus is near. |)
(|What a stench! |))
'((|Bon Voyage! We have been picked up by bats! |)
(|Bon Voyage! Bats have picked us up. |)
(|Bon Voyage! |)
(|So Loonnngggggggg. We have fallen into a pit. |)
(|So Loonnngggggggg. We have fallen in a pit. |)
(|So Loonnngggggggg. |)
(|Oh no, the Wumpus is in here! Chomp Chomp Chomp. |)
(|Oh no, it's the Wumpus! Chomp Chomp Chomp. |)
(|Chomp Chomp Chomp. |))
'(0. 0. 0. 1. 1. 1. 2. 2. 2.)))
;;; DI-INITIALIZE is called for each new session. Loads the new user-file, etc..
(DEFUN DI-INITIALIZE NIL
(DECLARE (SPECIAL LINEL G-WRITE-NUM DB-NUMWINS DB-NUMLOSSES DB-LAST-DATE SL-REPEAT
SC-NOTEST SC-INITIALIZED DB-COMMENT DB-USER-ID DB-DEBUG SL-TUTOR
*SS-VERSION *SS-ACTIVE G-SILENT WE-LAST-SESSION LWA-CRULES
WE-THIS-SESSION WAM-NEXT-MOVE WAW-GIVEN-ROUTE DB-DATE SL-FORGET
WA-CAN-BACKTRACK WA-TOLD-BACKTRACK SL-LAST-LEARNED SL-HEARD-OF
LWA-MOVE-NUMS SL-MODE WE-MOVE-NUM DB-MOVES SL-RECEPTIVITY
DB-GAME-NUM DB-HISTORY))
(SETQ LINEL 60.
WE-MOVE-NUM 2.
WE-LAST-SESSION 0.
WE-THIS-SESSION 1.
WA-CAN-BACKTRACK 0.0
WA-TOLD-BACKTRACK NIL
WAW-GIVEN-ROUTE NIL
WAM-NEXT-MOVE NIL
;;; Set switch for interaction numbers to T iff
;;;this is a printing terminal.
G-WRITE-NUM (COND ((= TTY 0.)))
DB-DEBUG NIL
DB-COMMENT *SS-ACTIVE
DB-NUMWINS 0.
DB-NUMLOSSES 0.
DB-MOVES 0.
;;; Don't set DB-DATE if the Synthetic Student did.
DB-DATE (COND (*SS-ACTIVE DB-DATE) (T (DI-DATE)))
DB-LAST-DATE DB-DATE
SL-MODE NIL
SL-REPEAT 1.34
SL-FORGET 4.9
SL-RECEPTIVITY 6.0
SL-HEARD-OF (1-$ SL-REPEAT)
SL-LAST-LEARNED 0.
SC-NOTEST NIL
SC-INITIALIZED '(NIL NIL NIL)
SL-TUTOR T
DB-GAME-NUM NIL
DB-HISTORY NIL)
(MAPC (FUNCTION (LAMBDA (X) (STORE (ASC-INITIALIZED X) NIL)))
(GP-ORDLST 3.))
(DI-NEWS)
(G-RSAY '(|Please enter your login name so that my|
|programmer can reach you if he wishes. |))
(SETQ DB-USER-ID (G-READ *SS-VERSION))
(G-RISAY
'(|Would you like to run in demo mode? (Please|
|follow all reponses with a space.)|))
(COND
((AND (GQ-EVAL (G-READ 'WANT-DEMO)) (SF-LOAD-DEMO)))
(T
(COND ((NOT G-SILENT)
(CURSORPOS 'C)
(CURSORPOS 0. 0.)))
(G-RSAY
'(|Hello, my name is Wusor VIII. What is your name? |
|(Please type in your first and last name. |
|Follow all responses with a space.) |))
(COND
((DI-GET-NAME)
(G-RSAY
'(|I believe that we have hunted Wumpii|
|together before. Is that right? |))
(COND
((GQ-EVAL (G-READ 'PLAYED-BEFORE)))
(T
(G-RSAY
'(|This is very unusual. I have met another person|
|with the exact same name. Please enter a different|
|last name and remember to use it as your name in|
|all future games. |))
(DI-REREAD-LAST-NAME))))
(T (DIQ-INIT-FILE (DIQ-INTRO))))))
(SETQ
LWA-MOVE-NUMS
(GCI-CREATE
5.
(MAPCAR (FUNCTION (LAMBDA (X)
(DECLARE (SPECIAL WE-MOVE-NUM SL-RECEPTIVITY))
(- WE-MOVE-NUM
(FIX (*$ SL-RECEPTIVITY
(FLOAT (1+ X)))))))
(GP-ORDLST 5.)))
LWA-CRULES
(GCI-CREATE 5.)))
;;; DI-GET-NAME reads in the user's name and loads his file from
;;;disc if there is such a file. It returns T if there was a
;;;file on the user, and it returns NIL if there was no such file.
(DEFUN DI-GET-NAME NIL
(DECLARE (SPECIAL DB-UNAME DB-NAME))
(SETQ DB-UNAME (LIST (G-READ 'SYNDI)
(G-SREAD 'LAST-NAME)))
(SETQ DB-NAME (G-LOWER-CASE (CAR DB-UNAME) T))
(G-RSAY (LIST '|Do I have your name right,|
DB-NAME
(G-LOWER-CASE (CADR DB-UNAME) T)
'|? |))
(COND
((GQ-EVAL (G-READ 'YES)) (SF-GET-DISC-FILE DB-UNAME))
(T
(G-RSAY
'(|Then let's try to get it right. |
|Please retype your name. |))
(DI-GET-NAME))))
;;; DI-REREAD-LAST-NAME rereads the user's last name to assign
;;;a unique user-name to everyone.
(DEFUN DI-REREAD-LAST-NAME NIL
(DECLARE (SPECIAL DB-NAME DB-UNAME))
(SETQ DB-UNAME (LIST (CAR DB-UNAME) (G-READ 'LAST-NAME)))
(COND
((NULL (SF-GET-DISC-FILE DB-UNAME))
(G-RSAY (LIST '|Now we've got it straight. Before we start,|
DB-NAME
'|I would like to ask you some questions. |))
(DIQ-INIT-FILE NIL))
(T
(G-RSAY
'(|Humm! This is very unusual. |
|Please try another last name. |))
(DI-REREAD-LAST-NAME))))
;;; DI-DATE returns the date.
(DEFUN DI-DATE NIL
(PROG (DATE DAY MONTH)
(SETQ DATE (STATUS DATE)
DAY (CADDR DATE)
MONTH (CADR DATE)
DATE (+ DAY (* MONTH 30.)))
(RETURN DATE)))
;;; DI-NEWS is a place where the programmer can put things
;;;of relevance to the user. Later there will also be a
;;;function which gives the user a synopsis of the rules
;;;which the advisor thinks the player may have forgotten.
(DEFUN DI-NEWS NIL
(DECLARE (SPECIAL G-SILENT G-DOUBLESPACE))
(COND ((NOT G-SILENT) (CURSORPOS 'C) (CURSORPOS 0. 0.)))
(G-RSAY '(|Good Morning! My, but today is a beautiful day. |))
(G-RSAY '(|It should be a lovely day for hunting Wumpii. |))
(G-TERPRI)
(G-TERPRI)
(G-RSAY
'(|NOTES FROM THE PROGRAMMER: This is WUSOR VIII. |
|Please use Wusor only when system usage is low|
|as Wusor can eat up a lot of CPU time. |
|If you run into any problems please save the game|
|by typing "(SAVE)". If you would like to see the|
|pedagogical comments, try the *COMMENT and *NOCOMMENT|
|commands. For other such commands, do "*? ". |))
(G-TERPRI))
;;; DI-INSTRUCTIONS gives the player instructions.
(DEFUN DI-INSTRUCTIONS NIL
(DECLARE (SPECIAL G-SILENT G-DOUBLESPACE))
(COND ((NOT G-SILENT) (CURSORPOS 'C) (CURSORPOS 0. 0.)))
(setq doublespace nil)
(G-RISAY
'(|You are a world-renowned hunter descending down|
|into the caves of darkness, lair of the infamous|
|man-eating Wumpus. To win the game,|
|you must first kill the Wumpus by shooting one of|
|your five arrows into his lair from a neighboring|
|cave. If you go into the cave of the Wumpus he|
|will eat you. Within the warren there are two|
|other kinds of dangers, bats and pits. The pits|
|are bottomless and fatal if you fall into one of them. If|
|you visit the home cave of bats they will pick you|
|up and carry you to another cave which might|
|contain the Wumpus or a pit (either of which is fatal). |))
(G-RESET)
(G-RISAY
'(|You can gain information about the warren through|
|exploration. Anytime you visit a safe cave, you|
|will be told the number of the cave you are in and|
|the numbers of the caves connected to it. If bats|
|are in one of the neighboring caves you will hear|
|their high pitched squeaking. Likewise, if you are|
|next to a cave with a pit you will feel a chilling|
|breeze. If you are within two caves of the Wumpus,|
|you will smell his horrible stench. |))
(G-RESET)
(G-RISAY
'(|As you explore, you should try|
|to keep a map showing everything you learn about the|
|warren. Your life depends on this map. |))
(G-RESET)
(G-RISAY
'(|Before you shoot an arrow, you should consider the|
|fact that if the Wumpus is not in the cave, the|
|arrow will start ricocheting and may kill either|
|the Wumpus or yourself (and it is an agonizing|
|death). If it does start ricocheting, there is roughly|
|a one third chance that it will kill you. |))
(G-RESET)
(G-RISAY
'(|Your only companion on the endeavor is the wise|
|old sage, Wusor. He will ask you "What now?" to|
|which you can reply with a neighboring cave that you|
|would like to visit, or "SHOOT",|
|indicating that you would like to shoot one of|
|your arrows into a neighboring cave. If you make a|
|hasty move, Wusor may stop you and give you|
|advice, but the final decision rests with you. |))
(SETQ G-DOUBLESPACE NIL))
;;; ****** Initialization Questionaire Routines. **********
;;; DIQ-INIT-FILE is the executive routine of the questionaire.
;;;It insures that the disc file and studentmodel are initialized
;;;appropriately.
(DEFUN DIQ-INIT-FILE (BEFORE)
(DECLARE (SPECIAL SL-FORGET SL-HEARD-OF SL-REPEAT))
(PROG (EDUCATION MATH-BIAS AGE TOTAL EXPERIENCE
FILE-NAME READ-FILE)
(SETQ EDUCATION (DIQ-EDUCATION)
MATH-BIAS (DIQ-MATH-BIAS)
AGE (DIQ-GET-AGE)
TOTAL (+$ (FLOAT AGE) (*$ MATH-BIAS
(FLOAT EDUCATION)))
SL-REPEAT (//$ (LOG 85.) (LOG TOTAL))
SL-HEARD-OF (1-$ SL-REPEAT)
SL-FORGET (*$ 2.0 (LOG TOTAL))
EXPERIENCE (DIQ-EXPERIENCE BEFORE)
FILE-NAME (DIQ-EVALUATE (//$ (FLOAT EXPERIENCE) SL-REPEAT))
READ-FILE (SF-READ-DISC-FILE FILE-NAME))
(SKI-PUT-MODEL (CAR READ-FILE))
(SF-SAVE-USER-FILE)))
;;; DIQ-EDUCATION reads in the player's education.
(DEFUN DIQ-EDUCATION NIL
(PROG (RESPONSE)
(G-TERPRI)
(G-RSAY '(|I need to know how many years of education|
|have you completed? For example:|))
(G-RISAY '(|If you are in the 8th grade, enter 7.|))
(G-RISAY '(|If you are a Junior in college, enter 14.|))
(G-RISAY '(|If you are a 2nd year grad student, enter 17.|))
(G-RISAY '(|If you are a college grad, enter 16.|))
(SETQ RESPONSE (G-READ 0.))
(COND ((FLOATP RESPONSE)
(SETQ RESPONSE (FIX RESPONSE))))
(COND ((AND (FIXP RESPONSE)
(> RESPONSE -1.))
(RETURN (MIN RESPONSE 20.)))
(T (RETURN (DIQ-EDUCATION))))))
;;; DIQ-MATH-BIAS reads in the player's math bias and returns
;;;an appropriate value.
(DEFUN DIQ-MATH-BIAS NIL
(PROG (RESPONSE RET-VAL)
(G-TERPRI)
(G-RSAY '(|What do think of the Math//Sciences? |
|(Please enter 1, 2, or 3). |))
(G-RISAY '(|1) I hate it! |))
(G-RISAY '(|2) I guess it is OK. |))
(G-RISAY '(|3) I love it! |))
(SETQ RESPONSE (G-READ 1.))
(COND ((FLOATP RESPONSE)
(SETQ RESPONSE (1+ (FIX RESPONSE)))))
(COND ((AND (FIXP RESPONSE)
(> RESPONSE 0.)
(< RESPONSE 4.))
(COND ((= RESPONSE 3.)
(SETQ RET-VAL 3.5))
((= RESPONSE 2.)
(SETQ RET-VAL 2.2))
(T (SETQ RET-VAL 1.0)))
(RETURN RET-VAL))
(T (RETURN (DIQ-MATH-BIAS))))))
;;; DIQ-GET-AGE gets and returns the player's age.
(DEFUN DIQ-GET-AGE NIL
(PROG (RESPONSE)
(G-TERPRI)
(G-RISAY '(|Please enter your age (in years). |))
(SETQ RESPONSE (G-READ 7.))
(COND ((FLOATP RESPONSE)
(SETQ RESPONSE (FIX RESPONSE))))
(COND ((AND (FIXP RESPONSE)
(> RESPONSE -1.))
(RETURN (MAX 7. (MIN RESPONSE 25.))))
(T (RETURN (DIQ-GET-AGE))))))
;;; DIQ-EXPERIENCE returns the player's game experience considering
;;;whether or not he read the rules. BEFORE is set to T only if
;;;the player has claimed to have played with the WA before.
(DEFUN DIQ-EXPERIENCE (BEFORE)
(PROG (RET-VAL NEW-BEFORE)
(G-TERPRI)
(COND ((NOT BEFORE)
(G-RSAY
'(|Have you ever played the game of Wumpus before? |))
(SETQ NEW-BEFORE (GQ-EVAL (G-READ 'NO)))))
(COND (BEFORE (SETQ RET-VAL (DIQ-NUM-GAMES)))
((NOT NEW-BEFORE)
(G-RSAY '(|Would you like to read the instructions? |))
(SETQ RET-VAL 0.))
(T (SETQ RET-VAL (DIQ-NUM-GAMES))
(G-RISAY
'(|The rules of the hunt are a little different|
|here than in many Wumpus games. Would you|
|like to scan through the rules? |))))
(COND (BEFORE)
((GQ-EVAL (G-READ 'NO))
(SETQ RET-VAL (+ 2. RET-VAL))
(DI-INSTRUCTIONS)))
(RETURN RET-VAL)))
;;; DIQ-NUM-GAMES returns how many games the player has played.
(DEFUN DIQ-NUM-GAMES NIL
(PROG (RESPONSE)
(G-TERPRI)
(G-RISAY '(|Please enter the number of Wumpus hunts|
|you have been on (approximately). |))
(SETQ RESPONSE (G-READ 0.))
(COND ((FLOATP RESPONSE)
(SETQ RESPONSE (FIX RESPONSE))))
(COND ((AND (FIXP RESPONSE)
(> RESPONSE -1.))
(RETURN (MIN RESPONSE 20.)))
(T (RETURN (DIQ-NUM-GAMES))))))
;;; DIQ-EVALUATE converts factor into an initialization value.
(DEFUN DIQ-EVALUATE (FACTOR)
(DECLARE (SPECIAL WA-CAN-BACKTRACK SL-REPEAT))
(COND ((< FACTOR 1.0) NIL)
((< FACTOR 3.0) (SETQ WA-CAN-BACKTRACK (-$ SL-REPEAT 0.5)) NIL)
((< FACTOR 6.0) (SETQ WA-CAN-BACKTRACK (+$ SL-REPEAT 0.5)) 'NOVICE)
((< FACTOR 10.0) (SETQ WA-CAN-BACKTRACK (+$ SL-REPEAT 0.5)) 'AMATEUR)
((< FACTOR 15.0) (SETQ WA-CAN-BACKTRACK (+$ SL-REPEAT 0.5)) 'MODERATE)
(T (SETQ WA-CAN-BACKTRACK (+$ SL-REPEAT 0.5)) 'ADVANCED)))
;;; DIQ-INTRO gives a preface for all this question and
;;;determines if the player has ever played with the WA before.
(DEFUN DIQ-INTRO NIL
(DECLARE (SPECIAL DB-NAME))
(G-TERPRI)
(G-RISAY '(|I don't believe that we have met before.|
|Have we ever hunted Wumpii together? |))
(COND ((NOT (GQ-EVAL (G-READ 'NO)))
(G-RSAY
(LIST '|Well,|
DB-NAME
'|, before we start I would like to|
'|ask you some questions. |))
NIL)
(T (G-RSAY
(LIST '|I am really sorry,|
DB-NAME
'|, but I seem to have misplaced my|
'|records of our previous games. I|
'|need to ask you some questions before|
'|we can start.|))
T)))
;;; ****** Standard Data Base Routines. ***********
;;;DB-END-SESSION saves whatever is needed.
(DEFUN DB-END-SESSION NIL
(DECLARE (SPECIAL DB-NAME))
(G-RISAY
(APPEND
(LIST '|Well,| DB-NAME)
'(|, have a nice day. Please look me up next|
|time you want to go on a Wumpii hunt. |))))
;;; DB-END-GAME saves whatever is necessary.
(DEFUN DB-END-GAME NIL
(DECLARE (SPECIAL SL-MODE))
(COND ((NOT SL-MODE) (SF-SAVE-USER-FILE))))
;;; DB-INIT-NEWGAME initializes the global variables for the
;;;WUMPUS-ADVISOR and its sub-modules.
(DEFUN DB-INIT-NEWGAME NIL
(DECLARE (SPECIAL CX-COMPARE G-READ-NUM DB-TIME G-SILENT SL-MODE
DB-NUM-PROP SC-NOTEST WE-NORESTART DB-DEBUG WE-MOVE
DB-COMMENT WA-TOLD-C6 WEV-RECREATE LWA-GOOD-MOVES
XD-VISITED-CAVES WEV-ERROR XX-CHANGED DB-NUM-DPROP
DB-OLD-USER-FILE WG-ARROWS WE-LAST-MOVE WG-HERE
DB-TOTAL-DIST SL-LAST-LEARNED LWA-BAD-MOVES
WE-MOVE-NUM WAD-FRINGE DB-NUM-CAVES DB-GAME-NUM))
(G-RSAY '(|Just a second while I erase my blackboard.|))
;;; These calls insure that the cave arrays are the
;;;correct size and have the correct starting values.
(*REARRAY 'ADB-CAVE T DB-NUM-CAVES DB-NUM-PROP)
;;; This to insure that the array is initialized to NIL.
(*REARRAY 'ADB-DCAVE T 1. 1. 1.)
(*REARRAY 'ADB-DCAVE
T
DB-NUM-CAVES
(+ DB-NUM-DPROP (* 3. DB-TOTAL-DIST))
3.)
(DO ((I 0. (1+ I)))
((= I DB-NUM-CAVES))
(DO ((J 0. (1+ J))
(VALUES '(NIL NIL NIL -1.0 -1.0 -1.0 NIL)
(CDR VALUES)))
((> J (1- DB-NUM-PROP)))
(STORE (ADB-CAVE I J) (CAR VALUES)))
(DO ((J 0. (1+ J))
(VALUES '(NIL -1. (-1.) 100. (-1.) -1. (-1.) NIL
NIL NIL NIL -1.0 NIL -1.0 -1.0 NIL 0.
(-1. NIL))
(CDR VALUES)))
((> J (1- DB-NUM-DPROP)))
(DO ((K 0. (1+ K)))
((= K 3.))
(STORE (ADB-DCAVE I J K) (CAR VALUES)))))
(COND (WEV-RECREATE NIL)
((DB-RAND-READ) NIL)
(DB-GAME-NUM
(SETQ DB-TIME DB-GAME-NUM DB-GAME-NUM (1+ DB-GAME-NUM)))
(T (SETQ DB-TIME (REMAINDER (FIX (TIME)) 300.))))
(SETQ DB-OLD-USER-FILE (SF-GET-USER-FILE))
(G-TERPRI)
(COND ((NOT DB-COMMENT) (SETQ G-SILENT T)))
(SF-TELL-MODEL)
(SF-TELL-VARS)
(COND ((NOT DB-COMMENT) (SETQ G-SILENT NIL)))
(G-TSAY (LIST '|*** Time is| DB-TIME '|. ***|))
(G-RSAY '(|O.K., now I will draw up a new warren. |))
(DB-RAND-LOOP DB-TIME)
(COND ((OR SL-MODE DB-DEBUG SC-NOTEST) NIL)
((> WE-MOVE-NUM (+ SL-LAST-LEARNED 100.))
(SC-HELP '|not advancing|)))
(WGI-INIT)
(WAM-MODIFY-GAME)
(SETQ WE-MOVE NIL
WE-LAST-MOVE NIL
WE-NORESTART NIL
WAD-FRINGE (LIST WG-HERE)
WA-TOLD-C6 NIL
LWA-GOOD-MOVES (GCI-CREATE 5.
'(-1. -1. -1. -1. -1.))
LWA-BAD-MOVES (GCI-CREATE 5.
'(-1. -1. -1. -1. -1.))
WEV-ERROR NIL
XX-CHANGED T
XD-VISITED-CAVES NIL
CX-COMPARE NIL
WG-ARROWS 5.
G-READ-NUM 1.)
(DO ((I 0. (1+ I)))
((> I 2.))
(STORE (AXR-NUM-IDENTIFIED I) 0.)
(STORE (AXR-FOUND-N I) NIL)
(STORE (AXS-EXACT-CAVES I) NIL)
(STORE (AXS-CHANGED-SETS I) NIL)
(STORE (AXS-PARTIAL-SETS I) NIL)
(STORE (AXS-COMPLETE-SETS I) NIL)
(XP-P12-CALC I))
(COND ((> (ADB-NUM-DANGERS 1.) 1.)
(STORE (AEG-DANGER-SING 0.) '(|bats|))
(STORE (AEG-DANGER-PLUR 0.) '(|bats|)))
(T (STORE (AEG-DANGER-SING 0.) '(|the bats|))
(STORE (AEG-DANGER-PLUR 0.) '(|the bats|))))
(COND ((> (ADB-NUM-DANGERS 1.) 1.)
(STORE (AEG-DANGER-SING 1.) '(|a pit|))
(STORE (AEG-DANGER-PLUR 1.) '(|pits|)))
(T (STORE (AEG-DANGER-SING 1.) '(|the pit|))
(STORE (AEG-DANGER-PLUR 1.) '(|the pit|))))
(COND ((> (ADB-NUM-DANGERS 2.) 1.)
(STORE (AEG-DANGER-SING 2.) '(|a Wumpus|))
(STORE (AEG-DANGER-PLUR 2.) '(|Wumpii|)))
(T (STORE (AEG-DANGER-SING 2.) '(|the Wumpus|))
(STORE (AEG-DANGER-PLUR 2.) '(|the Wumpus|))))
(XX-INIT-DANGER-EST)
(*SDB-INIT-NEW-GAME))
;;; DB-DEFINE-GAME asks the user sufficient questions to
;;;define the game. It returns true after a successful
;;;read, false if it was unsuccessful.
(DEFUN DB-DEFINE-GAME NIL
(DECLARE (SPECIAL WE-GAME-HIST SL-MODE DB-DEBUG DB-NUM-CAVES DB-GAME-NUM
DB-NUMLOSSES DB-PHASE DB-TOTAL-DIST DB-NAME))
;;; This is where recreations start, so the HIST is
;;;cleared here.
(SETQ WE-GAME-HIST NIL
DB-PHASE
(COND ((NOT DB-GAME-NUM) (SLI-LEAST-PHASE))
((> DB-GAME-NUM 16.) 4.)
((> DB-GAME-NUM 7.) 3.)
((> DB-GAME-NUM 3.) 2.)
((> DB-GAME-NUM 1.) 1.)
(T 0.)))
(COND
(DB-DEBUG (G-RSAY '(|Would you like to define the game? |))))
(COND
((OR (AND DB-DEBUG (GQ-EVAL (G-READ 'NO)))
(EQ SL-MODE 'SUPER))
(STORE (ADB-WARNING-DIST 0.) (DB-READ-DIST '|bats'|))
(STORE (ADB-WARNING-DIST 1.) (DB-READ-DIST '|pits'|))
(STORE (ADB-WARNING-DIST 2.)
(DB-READ-DIST '|Wumpii's|))
(SETQ DB-NUM-CAVES (DB-NUM-READ '|caves|))
(STORE (ADB-NUM-DANGERS 2.) (DB-NUM-READ '|Wumpii|))
(STORE (ADB-NUM-DANGERS 0.) (DB-NUM-READ '|bats|))
(STORE (ADB-NUM-DANGERS 1.) (DB-NUM-READ '|pits|)))
(T
(STORE (ADB-NUM-DANGERS 2.) 1.)
(STORE (ADB-NUM-DANGERS 0.) (ASL-PNUM-DANGERS DB-PHASE 0.))
(STORE (ADB-NUM-DANGERS 1.) (ASL-PNUM-DANGERS DB-PHASE 1.))
(STORE (ADB-NUM-DANGERS 2.) (ASL-PNUM-DANGERS DB-PHASE 2.))
(SETQ DB-NUM-CAVES
(COND ((> (ADB-NUM-DANGERS 2.) 1.) 25.) (T 20.)))
(STORE (ADB-WARNING-DIST 0.) 1.)
(STORE (ADB-WARNING-DIST 1.) 1.)
(STORE (ADB-WARNING-DIST 2.) 2.)
(G-RISAY (APPEND (LIST '|In this game,| DB-NAME)
'(|, there will be|)
(EG-NUMBER DB-NUM-CAVES)
(EGT-PLURAL '(|cave|) DB-NUM-CAVES)
'(|all total,|)
(EG-NUMBER (ADB-NUM-DANGERS 1.))
(EGT-PLURAL '(|pit|)
(ADB-NUM-DANGERS 1.))
'(|, and|)
(EG-NUMBER (ADB-NUM-DANGERS 0.))
(EGT-PLURAL '(|cave|)
(ADB-NUM-DANGERS 0.))
'(|with bats. |)))
(G-TERPRI)
(COND
((> (ADB-NUM-DANGERS 2.) 1.)
(G-RISAY (APPEND '(|NOTE THAT in this game there will be|)
(EG-NUMBER (ADB-NUM-DANGERS 2.))
'(|Wumpii. You only need to kill|)
'(|one of them to win the game. |)))))
T))
(DO ((I 0. (1+ I)) (VAL 0. (+ VAL (1+ (ADB-WARNING-DIST I)))))
((> I 2.) (SETQ DB-TOTAL-DIST VAL))
(STORE (ADB-DIST-START I) VAL))
(COND
((< DB-NUM-CAVES
(+ (ADB-NUM-DANGERS 0.)
(ADB-NUM-DANGERS 1.)
(ADB-NUM-DANGERS 2.)
1.))
(G-RSAY
'(|You lose this game as there were no|
|safe caves for you to start at. |))
(SETQ DB-NUMLOSSES (1+ DB-NUMLOSSES))
NIL)
(T T)))
;;; DB-NUM-READ this functions reads how many "TYPES" that
;;;the player wants.
(DEFUN DB-NUM-READ (TYPES)
(PROG (RESPONSE)
(G-RSAY (LIST '|How many|
TYPES
'|would you like in this game. |))
(SETQ RESPONSE (G-READ 1.))
(COND ((OR (NOT (FIXP RESPONSE)) (< RESPONSE 0.))
(RETURN (DB-NUM-READ TYPES)))
(T (RETURN RESPONSE)))))
;;; DB-READ-DIST reads in the warning dist.
(DEFUN DB-READ-DIST (T-DANGER)
(PROG (RESPONSE)
(G-RSAY (LIST '|How far would you like for|
T-DANGER
'|warnings to propagate? |))
(COND ((AND (FIXP (SETQ RESPONSE (G-READ 1.)))
(> RESPONSE -1.))
(RETURN RESPONSE))
(T (RETURN (DB-READ-DIST T-DANGER))))))
;;; DB-RAND-READ reads the initailization for the
;;;random number generator if appropriate.
(DEFUN DB-RAND-READ NIL
(DECLARE (SPECIAL SL-MODE DB-DEBUG DB-TIME))
(PROG (RESPONSE)
(COND ((NOT (OR SL-MODE DB-DEBUG)) (RETURN NIL)))
(G-RSAY
'(|Would you like to initialize|
|the random number generator? |))
(COND ((GP-NUM-TEST (SETQ RESPONSE (G-READ 'NO))
300.)
(GO GOT-IT))
((NOT (GQ-EVAL RESPONSE)) (RETURN NIL)))
TRY (G-RSAY
'(|Please enter a non-negative integer|
|(not too large). |))
(COND ((NOT (GP-NUM-TEST (SETQ RESPONSE (G-READ 1.))
300.))
(GO TRY)))
GOT-IT
(SETQ DB-TIME RESPONSE)
(RETURN T)))
;;; DB-RAND-LOOP is a function to initialize the random
;;;number generator.
(DEFUN DB-RAND-LOOP (NUMBER)
(RANDOM NIL)
(DO ((COUNTER NUMBER (1- COUNTER)))
((< COUNTER 0.) T)
(RANDOM 10.)))
;;;*****************UTILITY FUNCTIONS**********************
;;; GP-MAKN concatenates its two arguments and returns
;;;the resulting string.
(DEFUN GP-MAKN (FIRST SECOND)
(IMPLODE (APPEND (EXPLODEN FIRST) (EXPLODEN SECOND))))
;;; GP-EG expects two floating point args and
;;;returns T if they are approximately equal.
(DEFUN GP-EQ (X Y) (AND (> (+$ X 1.0E-4) Y) (> (+$ Y 1.0E-4) X)))
;;; GP-LT expects two floating point args and returns
;;;T if the first is sufficiently less than the second.
(DEFUN GP-LT (LESS MORE) (< (+$ LESS 1.0E-4) MORE))
;;; GP-UNION returns the set-theoretic union of N arguments.
(DEFUN GP-UNION NARGS
(DO ((I 1. (1+ I)) (VAL))
((> I (ARG NIL)) (REVERSE VAL))
(DO ((LIST (ARG I) (CDR LIST)))
((NULL LIST))
(COND ((NOT (MEMBER (CAR LIST) VAL))
(SETQ VAL (CONS (CAR LIST) VAL)))))))
;;; GP-INTERSECTION returns the set intersection of the two lists.
(DEFUN GP-INTERSECTION (LIST1 LIST2)
(COND ((NOT LIST1) NIL)
((MEMBER (CAR LIST1) LIST2)
(CONS (CAR LIST1) (GP-INTERSECTION (CDR LIST1) LIST2)))
(T (GP-INTERSECTION (CDR LIST1) LIST2))))
;;; GP-DELETE does the same thing as a regular delete except
;;;that it doesn't have any bad side effects.
(DEFUN GP-DELETE (ITEM LIST)
(COND ((NULL LIST) NIL)
((EQUAL ITEM (CAR LIST)) (GP-DELETE ITEM (CDR LIST)))
(T (CONS (CAR LIST) (GP-DELETE ITEM (CDR LIST))))))
;;; GP-REMOVE-LIST returns the set of B minus those members
;;;who are also members of A.
(DEFUN GP-REMOVE-LIST (B A)
(COND ((NULL B) NIL)
((NULL A) B)
(T (GP-REMOVE-LIST (GP-DELETE (CAR A) B) (CDR A)))))
;;; GP-CONS does a CONS after first insuring that ATOM
;;;is not already a member of LIST.
(DEFUN GP-CONS (ATOM LIST)
(COND ((MEMBER ATOM LIST) LIST)
(ATOM (CONS ATOM LIST))
(T LIST)))
;;; GP-EQUIV determines if two lists are eqivalent.
(DEFUN GP-EQUIV (LIST1 LIST2)
(NOT (OR (GP-REMOVE-LIST LIST1 LIST2)
(GP-REMOVE-LIST LIST1 LIST2))))
;;; GP-NUM-TEST tests if NUM is a non-negative integer less than LIMIT.
(DEFUN GP-NUM-TEST (NUM LIMIT)
(AND (FIXP NUM) (> NUM -1.) (< NUM LIMIT)))
;;; GP-RANDEL chooses a random element from its input list.
(DEFUN GP-RANDEL (LIS)
(CAR (WGI-NTHEL LIS (RANDOM (1+ (LENGTH LIS))))))
;;; GP-CAVE-CHECK insures that there is a cave to match its arg.
;;;It returns T if there is no such cave.
(DEFUN GP-CAVE-CHECK (T-CAVE)
(DECLARE (SPECIAL DB-NUM-CAVES))
(COND ((AND (FIXP T-CAVE) (GP-NUM-TEST T-CAVE DB-NUM-CAVES)) NIL)
(T (G-RSAY (LIST '|There is no cave|
T-CAVE
'|. |))
T)))
;;; GP-TEST returns T if its argument is a list, T, or > 1.
(DEFUN GP-TEST (TEST)
(OR (EQ TEST T)
(AND (NOT (ATOM TEST)) (CDR TEST))
(AND (FIXP TEST) (> TEST 1.))))
;;; GP-DIST-AREA returns all the caves which are within
;;;DIST caves of any cave in CAVE-LIST.
(DEFUN GP-DIST-AREA (CAVE-LIST DIST)
(COND ((< DIST 1.) CAVE-LIST)
(T (DO ((LIST CAVE-LIST (CDR LIST))
(T-CAVE (CAR CAVE-LIST) (CAR LIST))
(RESULT CAVE-LIST
(GP-UNION RESULT (WGR-NEIGHBORS T-CAVE))))
((NOT T-CAVE) (GP-DIST-AREA RESULT (1- DIST)))))))
;;; GP-ORDLST JUST PRODUCES A LIST OF THE FIRST N NUMBERS
;;;IN REVERSE ORDER
(DEFUN GP-ORDLST (N)
(COND ((< N 1.) NIL) (T (CONS (1- N) (GP-ORDLST (1- N))))))
;;; GP-INSERT inserts ITEM into the list (globally).
(DEFUN GP-INSERT (AFTER ITEM) (RPLACD AFTER (CONS ITEM (CDR AFTER))))
;;; ****** General Purpose Routines For Circular Lists. *****
;;; GCI-CREATE creates a circular list (with header) of
;;;the given length (first argument). If a second argument
;;;is supplied, it is the intial values.
;;; These functions are part of each LISPs initialization.
(DEFUN GCI-CREATE NARGS
(CONS (ARG 1.)
(GCI-WCREATE (ARG 1.)
NIL
(COND ((> (ARG NIL) 1.) (ARG 2.))))))
;;; GCI-WCREATE does the actual work of WGI-CREAT.
(DEFUN GCI-WCREATE (NUM LIST VALS)
(COND ((< NUM 1.) (RPLACD (LAST LIST) LIST))
(T (GCI-WCREATE (1- NUM)
(CONS (GCI-VAL VALS) LIST)
(CDR VALS)))))
;;; GCI-VAL returns the appropriate value.
(DEFUN GCI-VAL (VALS) (COND ((ATOM VALS) NIL) (T (CAR VALS))))
;;; GC-PUT inserts a new value into the circular list,
;;;deleting the oldest previous value.
(DEFUN GC-PUT (CLIST VAL) (RPLACD CLIST (RPLACA (CDDR CLIST) VAL)))
;;; GC-NEXT returns the next value while advancing the pointer.
(DEFUN GC-NEXT (CLIST) (RPLACD CLIST (CDDR CLIST)) (CADR CLIST))
;;; GC-WNEXT is an internal routine to do GC-NEXT.
(DEFUN GC-WNEXT (NAME) (SET NAME (CDR (EVAL NAME))) (CAR (EVAL NAME)))
;;; GC-MEMBER determines if the second argument is a member
;;;of the first argument. The third argument is optional;
;;;it must be an integer (N) and tells the routine to skip
;;;the last N elements.
(DEFUN GC-MEMBER NARGS
(COND ((AND (> (ARG NIL) 2.)
(= (ARG 3.) 0.))
NIL)
(T (GC-WMEMBER (CDR (ARG 1.))
(CDR (ARG 1.))
(ARG 2.)
(COND ((> (ARG NIL) 2.)
(- (CAR (ARG 1.)) (ARG 3.)))
(T 0.))))))
;;; GC-WMEMBER does the actual work of GC-MEMEBR.
(DEFUN GC-WMEMBER (C-CLIST O-CLIST VALUE SKIP)
(DECLARE (SPECIAL C-CLIST))
(COND ((NOT (< SKIP 1.))
(GC-WMEMBER (CDR C-CLIST) O-CLIST VALUE (1- SKIP)))
((EQUAL (GC-WNEXT 'C-CLIST) VALUE) C-CLIST)
((EQ C-CLIST O-CLIST) NIL)
(T (GC-WMEMBER C-CLIST O-CLIST VALUE SKIP))))
;;; GC-AVERAGE computes the average of the elements of the
;;;first argument. It will skip the last N elements if the
;;;second argument is specified (N).
(DEFUN GC-AVERAGE NARGS
(GC-WAVERAGE (CDR (ARG 1.))
(CDR (ARG 1.))
0.0
0.
(COND ((> (ARG NIL) 1.)
(- (CAR (ARG 1.)) (ARG 2.)))
(T 0.))))
;;; GC-WAVERAGE does the actual work of GC-AVERAGE.
(DEFUN GC-WAVERAGE (C-CLIST O-CLIST TOTAL NUM SKIP)
(DECLARE (SPECIAL C-CLIST))
(SETQ TOTAL (PLUS TOTAL (GC-WNEXT 'C-CLIST)))
(SETQ NUM (1+ NUM))
(COND ((NOT (< SKIP 1.))
(GC-WAVERAGE C-CLIST O-CLIST 0.0 0. (1- SKIP)))
((EQ C-CLIST O-CLIST) (//$ TOTAL (FLOAT NUM)))
(T (GC-WAVERAGE C-CLIST O-CLIST TOTAL NUM SKIP))))
;;;******* General Purpose Mapping Functions. ********
;;; GM-MAPCAN does a non-destructive MAPCAN.
(DEFUN GM-MAPCAN (PRED LIST)
(COND ((NULL LIST) NIL)
(T (APPEND (PRED (CAR LIST))
(GM-MAPCAN PRED (CDR LIST))))))
;;;DOES A MAPCAR OF A PREDICATE, RETURNS THE FIRST LIST VALUE
;;;FOR WHICH THE PREDICATE IS TRUE
(DEFUN GM-FIRST-TRUE (PRED LST)
(COND ((NOT LST) NIL)
((PRED (CAR LST)) (CAR LST))
(T (GM-FIRST-TRUE PRED (CDR LST)))))
;;;GIVES A LIST OF ALL ELEMENTS OF A LIST FOR WHICH
;;;A GIVEN PREDICATE IS TRUE
(DEFUN GM-ALL-TRUE (PRED LST)
(COND ((NOT LST) NIL)
((NOT (PRED (CAR LST))) (GM-ALL-TRUE PRED (CDR LST)))
(T (CONS (CAR LST) (GM-ALL-TRUE PRED (CDR LST))))))
;;;********* I/O Related General Purpose Functions. ********
;;; G-AFFIRMATIVE evaluates the response and if it is yes
;;;or an equivalent it returns T.
(DEFUN G-AFFIRMATIVE (REPLY)
(MEMBER REPLY
'(Y T YES UH-HUH OK YEA OKAY SURE YEAH DEFINITELY
POSITIVELY INDEED PLEASE RIGHT YUP)))
;;; G-NEGATIVE is a function to check for the various ways of saying no.
(DEFUN G-NEGATIVE (REPLY)
(MEMBER REPLY '(N NIL NO NOPE UHN-HUH NAH NAW)))
;;; G-LOWER-CASE converts the character string it is sent into lower case.
;;;If the flag is true, it also capitalizes the first character.
(DEFUN G-LOWER-CASE (STRING FLAG)
(DO ((CHARS (REVERSE (EXPLODEN STRING)) (CDR CHARS))
(RESULT NIL))
((NULL (CDR CHARS))
(IMPLODE (COND (FLAG (CONS (BOOLE 1. 95. (CAR CHARS))
RESULT))
(T (CONS (BOOLE 7. 32. (CAR CHARS))
RESULT)))))
(SETQ RESULT (CONS (BOOLE 7. 32. (CAR CHARS)) RESULT))))
;;; G-WRITE is a function originally written by Dave MacDonald
;;;that recieves a string of numbers(ASCII) and prints them out.
(DEFUN G-WRITE (LIST)
(DECLARE (SPECIAL LINEL GV-CURSORPOS G-SILENT G-DOUBLESPACE))
(PROG (LIST-LENGTH ROOM-ON-LINE STARTING-POINT)
(COND ((NULL LIST) (RETURN T)))
(SSTATUS TERPRI T)
(SETQ LIST-LENGTH (LENGTH LIST))
(SETQ STARTING-POINT GV-CURSORPOS
;;; I think that this is one less that actual room.
ROOM-ON-LINE (- LINEL STARTING-POINT))
(COND
((OR (= LIST-LENGTH ROOM-ON-LINE)
(< LIST-LENGTH ROOM-ON-LINE))
;;; i.e. is the list going to fit
;;; on this line?
(COND (G-SILENT (SETQ ^W T)))
(G-WRITE-WORK LIST LIST-LENGTH)
(COND (G-SILENT (SETQ ^W NIL))))
(T
;;; first find the word break
(PROG (L SAID-SO-FAR LAST-SP THIS-SP)
(SETQ L LIST
SAID-SO-FAR 0.
LAST-SP 0.
THIS-SP 0.)
FIND-WORD
(SETQ LAST-SP THIS-SP)
(SETQ THIS-SP
(DO ((I 1. (1+ I)) (C (CAR L) (CAR L)))
((OR (NULL L) (= C 32.) (= C 13.))
(SETQ L (CDR L))
(COND ((NULL C))
((= C 13.)
(SETQ SAID-SO-FAR -1.)))
(+ LAST-SP I))
(SETQ L (CDR L))
(SETQ SAID-SO-FAR (1+ SAID-SO-FAR))))
(COND ((AND (= LAST-SP 0.)
(= STARTING-POINT 0.)
(> SAID-SO-FAR ROOM-ON-LINE))
(SETQ LAST-SP THIS-SP)
(GO DO-IT))
((> SAID-SO-FAR ROOM-ON-LINE) (GO DO-IT))
(T (SETQ SAID-SO-FAR (1+ SAID-SO-FAR))
;;; include the passed space
(GO FIND-WORD)))
DO-IT(COND (G-SILENT (SETQ ^W T)))
(SETQ LIST (G-WRITE-WORK LIST LAST-SP))
(G-TERPRI)
(COND (G-DOUBLESPACE (G-TERPRI)))
(COND (G-SILENT (SETQ ^W NIL)))
(G-WRITE LIST))))))
;;; G-WRITE-WORK does the actual writing for G-WRITE.
(DEFUN G-WRITE-WORK (LIST LAST-SP)
(DECLARE (SPECIAL GV-CURSORPOS G-LAST G-BLAST G-BBLAST))
(DO ((I LAST-SP (1- I))
;;; C is the character that is being worked on.
(C (CAR LIST) (CAR LIST))
;;; N is the next character to be worked on.
(N (CADR LIST) (CADR LIST)))
((< I 1.))
(SETQ LIST (CDR LIST))
(COND ((NOT LIST) (SETQ I 0.))
;;;check for spaces preceding commas, periods,
;;;and question marks. If so, then omit the space.
((AND (= C 32.) (OR (= N 46.) (= N 44.) (= N 63.)))
(COND ((= I 1.) (SETQ I 2.))))
;;; If this is a new sentence, as indicated by
;;;the punctuation, then insure that the first
;;;letter is capitalized.
((AND (= G-LAST 32.)
(= G-BLAST 32.)
(OR (= G-BBLAST 46.)
(= G-BBLAST 63.)
(= G-BBLAST 33.))
(> C 96.)
(< C 123.))
(TYO (- C 32.)))
(T (TYO C)))
;;; G-BBLAST is the character before the character before last.
(SETQ G-BBLAST G-BLAST)
;;; G-BLAST is the character before last.
(SETQ G-BLAST G-LAST)
;;; G-LAST is the last character that was worked on.
(SETQ G-LAST C)
(SETQ GV-CURSORPOS (1+ GV-CURSORPOS)))
;;; Do not output spaces at the start of a new line.
(COND ((AND (FIXP (CAR LIST)) (= (CAR LIST) 32.))
(G-WRITE-WORK LIST 1.))
(T LIST)))
;;; G-TERPRI does a terpri if it appropriate according to G-SILENT.
(DEFUN G-TERPRI NIL
(DECLARE (SPECIAL GV-CURSORPOS G-SILENT *SS-ACTIVE))
(SETQ GV-CURSORPOS 0.)
(COND ((AND G-SILENT
(OR *SS-ACTIVE
(NOT (CURSORPOS))
(= (CDR (CURSORPOS)) 0.)))
(SETQ ^W T)
(TYO 13.)
(SETQ ^W NIL))
(T (TYO 13.))))
;;; G-SAY is a modification of the standard SAY function as it fills
;;;lines before causing a carriage return.
(DEFUN G-SAY (LIST)
(DECLARE (SPECIAL GV-CURSORPOS))
(PROG (NEW-LIST)
(SETQ NEW-LIST (EXPLODEN LIST))
;;;This statement removes the preceding open
;;;paren. G-WRITE does not print the last character
;;;which is a close paren.
(SETQ NEW-LIST (CDR NEW-LIST))
;;; Insert a space between sentences.
(COND ((> GV-CURSORPOS 0.)
(SETQ NEW-LIST (CONS 32. NEW-LIST))))
(G-WRITE NEW-LIST)))
;;; G-RSAY is a function to do a SAY after doing a carriage RETURN.
(DEFUN G-RSAY (LIST)
(DECLARE (SPECIAL G-LAST G-BLAST G-BBLAST G-DOUBLESPACE))
(G-TERPRI)
(COND (G-DOUBLESPACE (G-TERPRI)))
;;; These two SETQs insure new sentence is capitalized.
(SETQ G-LAST 32.)
(SETQ G-BLAST 32.)
(SETQ G-BBLAST 46.)
(G-SAY LIST))
;;; G-TSAY does a say of pedagogical comments. G-SILENT is the
;;;switch to restrict output to the terminal.
(DEFUN G-TSAY (LIST)
(DECLARE (SPECIAL DB-COMMENT G-SILENT GV-CURSORPOS))
(COND ((NOT DB-COMMENT)
(SETQ G-SILENT (CURSORPOS))
(G-TERPRI)))
(G-RSAY LIST)
(COND ((NOT DB-COMMENT)
(CURSORPOS (CAR G-SILENT) (CDR G-SILENT))
(SETQ GV-CURSORPOS (CDR G-SILENT) G-SILENT NIL))))
;;; G-PSAY positions the cursor before doing a SAY.
(DEFUN G-PSAY (LIST POSITION)
(DECLARE (SPECIAL GV-CURSORPOS))
(DO ((SPACES (- POSITION GV-CURSORPOS) (1- SPACES)))
((< SPACES 1.) (SETQ GV-CURSORPOS POSITION))
(G-WRITE '(32. 32.)))
(G-SAY LIST))
;;; G-RESET clears the screen when the player is ready.
(DEFUN G-RESET NIL
(DECLARE (SPECIAL G-SILENT))
(G-RSAY '(|Enter any character for more. |))
(G-READ 'A)
(COND ((NOT G-SILENT)
(CURSORPOS 'C)
(CURSORPOS 0. 0.))))
;;; G-RISAY is a function to do a SAY after doing a carriage
;;;return and then indenting six spaces.
(DEFUN G-RISAY (LIST)
(DECLARE (SPECIAL G-LAST G-BLAST G-DOUBLESPACE))
(G-TERPRI)
(COND (G-DOUBLESPACE (G-TERPRI)))
(G-WRITE '(32. 32. 32. 32. 32. 32.))
;;; This SETQ insures that new sentence is capitalized.
(SETQ G-LAST 32.)
(SETQ G-BLAST 46.)
(G-SAY LIST))
;;; G-READ is a function that reads after sending a TERPRI.
(DEFUN G-READ (REQUEST)
(DECLARE (SPECIAL G-READ-NUM G-WRITE-NUM))
(PROG (CURSOR)
(COND (G-WRITE-NUM (G-SAY (LIST (GP-MAKN G-READ-NUM
'>)))))
(G-WRITE '(32. 32.))
;;; Only do cursorpos if this is not a printing terminal.
(COND ((> TTY 0.)
(SETQ CURSOR (CURSORPOS))
(G-TERPRI)
(G-TERPRI)
(CURSORPOS (CAR CURSOR) (CDR CURSOR))))
(SETQ G-READ-NUM (1+ G-READ-NUM))
(RETURN (G-SREAD REQUEST))))
;;; G-SREAD does a read without the linefeeds and such.
(DEFUN G-SREAD (REQUEST)
(DECLARE (SPECIAL WEV-RECREATE *SS-ACTIVE WE-GAME-HIST
G-WRITE-NUM DB-DEBUG DB-COMMENT GV-CURSORPOS
XX-BEST-MOVES SL-TUTOR DB-GAME-NUM))
(PROG (RESPONSE)
;;; Unless this is a syntheitic student, this is a regular read.
(SETQ RESPONSE (*SS-READ REQUEST))
;;; If this is a recreation, then don't necessarily read.
(COND ((AND WEV-RECREATE (EQ RESPONSE T))
(SETQ RESPONSE (CAR WEV-RECREATE))
(SETQ WEV-RECREATE (CDR WEV-RECREATE))
(G-RSAY (LIST '|Her input was|
RESPONSE
'|. |)))
(*SS-ACTIVE (G-SAY (LIST RESPONSE)))
(T (SETQ GV-CURSORPOS
(+ 1.
(LENGTH (EXPLODEN RESPONSE))
GV-CURSORPOS))))
(SETQ WE-GAME-HIST (CONS RESPONSE WE-GAME-HIST))
(COND ((EQ RESPONSE '*?) (WE-*COMMANDS))
((EQ RESPONSE '*INDEX)
(WE-WRITE-INDEX XX-BEST-MOVES))
((EQ RESPONSE '*EXEC) (WE-EXECUTE))
((EQ RESPONSE '*MODEL) (SF-TELL-MODEL))
((EQ RESPONSE '*VARIABLE) (SF-TELL-VARS))
((EQ RESPONSE '*TUTOR) (SETQ SL-TUTOR T))
((EQ RESPONSE '*NOTUTOR) (SETQ SL-TUTOR NIL))
((EQ RESPONSE '*SEQUENCE)
(COND ((NOT DB-GAME-NUM) (SETQ DB-GAME-NUM 0.))))
((EQ RESPONSE '*PROB) (WE-PROB))
((EQ RESPONSE '*RULES) (WE-RULES))
((EQ RESPONSE '*EXPL-RULES) (WE-EXPL-RULES))
((EQ RESPONSE '*EXPLAIN) (WE-EXPLAIN))
((EQUAL RESPONSE '(SAVE)) (SAVE))
((EQ RESPONSE '*DEBUG) (SETQ DB-DEBUG T))
((EQ RESPONSE '*NODEBUG)
(SETQ DB-DEBUG NIL))
((EQ RESPONSE '*COMMENT)
(SETQ DB-COMMENT T))
((EQ RESPONSE '*NOCOMMENT)
(SETQ DB-COMMENT NIL))
((EQ RESPONSE '*NUMB) (SETQ G-WRITE-NUM T))
((EQ RESPONSE '*NONUMB)
(SETQ G-WRITE-NUM NIL))
((EQ RESPONSE '*CHEAT) (WE-CHEAT))
(T (RETURN RESPONSE)))
(G-RSAY
'(|Please answer my original question now. |
|(Enter "**" for a cue to your response.)|))
(RETURN (G-SREAD REQUEST))))
;;; G-READ-RESPONSE reads in a response by the student
;;;terminated with two semicolons.
(DEFUN G-READ-RESPONSE NIL
(DO ((VAL NIL) (THIS (TYI) (TYI)) (LAST NIL THIS))
((AND (= THIS 59.) (= LAST 59.))
(SETQ VAL (IMPLODE (REVERSE VAL)))
(RETURN VAL))
(COND ((EQUAL THIS '127.)
(CURSORPOS 'X)
(SETQ VAL (CDR VAL)))
(T (SETQ VAL (CONS THIS VAL))))))
;;; G-APPEND-FILE sets up for writing to a file.
(defun g-append-file (filename)
(cond ((apply 'uprobe filename)
(setq filename (g-*ugreat filename))
(g-*uwrite filename 'append filename))
(t (apply 'uwrite (cddr filename)))))
;;; G-*UGREAT is a variant of a routine of JONL, as is above.
(defun g-*ugreat (name)
(mergef (mergef name
(cond ((status feature dec10)
'(* . lsp))
((status feature its)
'(* . >))))
nil))
;;; G-*UWRITE is also such a variaint.
(defun g-*uwrite (name mode newdefault)
(DECLARE (SPECIAL UWRITE OUTFILES))
(cond (uwrite
(setq outfiles (delq uwrite outfiles))
(close uwrite)
(setq uwrite nil)))
((lambda (file)
(setq outfiles
(cons (setq uwrite file)
outfiles))
(car (defaultf newdefault)))
(open name mode)))
;;; GQ-GO-AHEAD asks the player if he would like to go
;;;ahead with MOVE.
(DEFUN GQ-GO-AHEAD (MOVE)
(G-RSAY (LIST '|Would you like to go to cave|
MOVE
'|anyway? |))
(COND ((GQ-EVAL (G-READ 'DECIDE-YES)) NIL) (T)))
;;; GQ-SHOOT-ANYWAY asks the player if he would like to
;;;shoot into CAVE anyway.
(DEFUN GQ-SHOOT-ANYWAY (CAVE)
(G-RSAY (LIST '|Would you like to shoot into cave|
CAVE
'|anyway? |))
(COND ((GQ-EVAL (G-READ 'DECIDE-YES)) NIL) (T)))
;;; GQ-EVAL expects a response that is either yes or no and
;;;converts it to T or NIL. If the response is not correct it
;;;asks for a yes or no response.
(DEFUN GQ-EVAL (RESPONSE)
(COND ((G-AFFIRMATIVE RESPONSE) T)
((G-NEGATIVE RESPONSE) NIL)
(T (GQ-YES-OR-NO))))
;;; GQ-YES-OR-NO is a function that asks the player to answer
;;;yes or no, reads his response, and returns his response.
(DEFUN GQ-YES-OR-NO NIL
(G-RSAY '(|Please answer yes or no. |))
(GQ-EVAL (G-READ 'NO)))
;;; ********* Synthetic Student Student Non-Functions. **********
(DEFUN *SXD-MARK-DANGER (CAVE DANGER) CAVE DANGER)
(DEFUN *SXD-MARK-NOWARNING (CAVE DANGER) CAVE DANGER)
(DEFUN *SXD-MARK-VISITED (CAVE DANGERS) CAVE DANGERS)
(DEFUN *SXD-MARK-WARNING (CAVE DANGER) CAVE DANGER)
(DEFUN *SXD-MARK-SHOT (CAVE) CAVE)
(DEFUN *SS-READ (REQUEST) REQUEST (READ))
(DEFUN *SSK-TOLD-RULE (RULE DANGER) RULE DANGER)
(DEFUN *SS-TOLD-MOVE (G-MOVE B-MOVE C-RULE) G-MOVE B-MOVE C-RULE)
(DEFUN *SS-INITIALIZE NIL NIL)
(DEFUN *SDB-INIT-NEW-GAME NIL NIL)
(DEFUN *SS-IMPLIED-RULES (REASONS DANGER) REASONS DANGER)
Reference in New Issue View Git Blame Copy Permalink