jba@wheaties.ai.mit.edu (Jonathan Amsterdam) (06/11/89)
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*- ;;; filename: aal ;;; AAL: The Adventure Authoring Language. Version 1.0. ;;; Copyright 1988 by Jonathan Amsterdam. All Rights Reserved. ;;; This is the main file for loading. Loading this file loads all of AAL, in ;;; the right order. ;;; Notes: ;;; There are several files; in addition to the six files of source code ;;; mentioned below, there is also sample.lisp, which contains a sample ;;; adventure. ;;; The copyright to this code is held by me, which means that if ;;; use it any purpose other than personal use, you must obtain my ;;; permission. ;;; This implementation of AAL is preliminary and has not been well-tested. ;;; There are probably many bugs. You are on your own in debugging. Good ;;; luck! (load "streams") (load "initial") (load "parser") (load "deducer") (load "interp") (load "comp") ;;; End aal.lisp.
jba@wheaties.ai.mit.edu (Jonathan Amsterdam) (06/11/89)
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
;;; A sample adventure in AAL.
;;; First, basic stuff you'd find in every adventure.
;;; Some conventions: objects are AT locations, player is CARRYING things,
;;; things can be IN other things.
;;; The transitive closure of the IN relation.
(rules ((within *x *y) <- (in *x *y))
((within *x *y) <- (in *x *z) (within *z *y)))
;;; Something is HERE if it's at this location, or being carried by the player,
;;; or in something that's at this location or being carried.
(rule (here *x) <- (or (at *x *loc)
(carrying player *x)
(and (or (at *y *loc) (carrying player *y)) (within *x *y))))
;;; Moving something from one loc to another.
(rule (move *object *location) <- (at *object *cur-loc)
(do (not (at *object *cur-loc))
(at *object *location)))
;;; Prints out all the things that are at the current location.
(rule (loc-contents) <- (do
(every *x (and (at *x *loc) (not (eql *x player)))
(query (desc *x *d))
("There is a ~a here." *d))))
(rules ((describe *object) <- (description *object *desc)
(display *desc))
((describe *object) <- (do "I can't tell you anything more.")))
(rule (drop *object) <- (do (not (carrying player *object))
(at *object *loc)))
(rule (inventory) <- (or (and (carrying player *x)
(every *y (carrying player *y) (display *y)))
(display "You're not carrying anything.")))
;;; Print out info about new loc whenever the player moves.
(when-asserted (at player *location) -> (set *loc *location)
(lisp (terpri))
(((been-to player *loc) -> ("You're in ~a." *loc))
(-> (describe *loc) (been-to player *loc)))
(loc-contents))
(feature movement
(actions-order *loc *command)
(requires ((exit *loc self *) "You can't go that way.")))
(command (n north) movement)
(command (s south) movement)
(command (e east) movement)
(command (w west) movement)
(command ne movement)
(command se movement)
(command nw movement)
(command sw movement)
(command (u up) movement)
(command (d down) movement)
(command take (take *obj)
(requires ((here *obj) "I see no ~a." *obj)
((not (carrying player *obj)) "You already have the ~a!" *obj)
((at *obj *loc) "The ~a is inside something else." *obj)
((not (fixed *obj)) "That object can't be taken."))
(carrying player *obj)
(not (at *obj *loc))
"Taken.")
(feature fixed) ;; Fixed things can't be taken.
(command drop (drop *obj)
(requires ((carrying player *obj) "You don't have the ~a." *obj))
(drop *obj)
"Dropped.")
;;; This command is different from the above rule. The command makes sure that
;;; the object to be described is present.
(command describe (describe *obj)
(((here *obj) -> (describe *obj))
(-> ("I see no ~a" *obj))))
(command look
(describe *loc)
(loc-contents))
;;; We have to say "query" here because of the way a command form is parsed--it
;;; thinks the list (inventory) is the syntax specification. The problem is
;;; too much syntactic sugar.
(command inventory
(query (inventory)))
(command invent
(inventory))
(command time
(display *tick))
(command score
(display-score))
(command quit
(end-game))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The test game.
(loc the-first-room
"You are in a small, gloomy room lit by an unseen source above you.
The walls and floor are smooth, hard and dark, like obsidian. Exits
lead west and south."
(contains whistle)
(exits
(w the-second-room)
(s "You have wandered around and wound up back where you started.")))
(loc the-second-room
"You are in a vast chamber of ice and rock. Fiery torches in the walls
provide an eerie light. There is a passageway south and another exit to
the north."
(contains monster)
(exits
(s the-first-room)
(n ((alive monster) -> "The monster won't let you pass.")
v-room)))
(loc v-room "the victory room"
"You are in an incredibly beautiful room. Hordes of attractive attendants
are catering to your every whim, and why shouldn't they? You WON THE GAME!!"
)
;;; This timer ends the game as soon as the player enters the v-room.
(timer (before each turn
((at player v-room) -> (end-game))))
(command blow
(blow *obj)
(requires ((carrying player *obj) "You don't have the ~a" *obj))
"You can't blow that!")
(command (throw hurl chuck)
(throw *instr at *obj)
(requires ((carrying player *instr) "You're not carrying the ~a." *instr)
((here *obj) "I see no ~a here." *obj))
(drop *instr)
"Thrown.")
(obj monster fixed
(description "It is one hairy mother of a monster!")
(initially (alive monster))
(score 10 ((not (alive monster)) -> 10))
(command throw *obj
((alive monster) -> ("The monster destroys the ~a." *instr)
(destroy *instr))))
(when-retracted (alive monster) -> (description monster "It is one dead monster.")
(desc monster "dead monster"))
(obj whistle
(command blow *obj
"The whistle emits a piercing screech."
((at monster *loc) (alive monster) ->
"The monster's eyes bug out--wider--wider--and then, ~
finally, close forever."
(not (alive monster)))))
(obj gold "precious gold nugget"
(initially (at gold the-first-room))
(score 2 ((carrying player gold) -> 2)))
(when-asserted (in water bottle) -> (description bottle "There's some water in it."))
(when-retracted (in water bottle) -> (description bottle "The bottle is empty."))
(obj bottle
(command throw *instr
"The bottle makes a funny noise when you throw it..."
(continue))
(initially (at bottle the-first-room)
(in water bottle)))
(command drink (drink *obj)
(requires ((here *obj) "I see no ~a." *obj))
"You can't drink that.")
;;; The following stuff is just for illustration; it doesn't play any role in
;;; the game.
;;; Objects can have local variables.
(feature (resource n name)
(var (*quantity n)
(*name name)))
(obj water (resource 2 "gallon")
(command drink *obj
(requires ((in water bottle) "The water's not in the bottle.")
((carrying player bottle) "You're not carrying the bottle."))
"Yummm!"
(dec *quantity)
((zerop *quantity) -> (destroy water) "That was the last of the water.")))
(command how (how much *obj)
(requires ((here *obj) "I see no ~a" *obj)
((resource *obj * *) "It doesn't make sense to ask how much of that"))
(let *q (value *obj *quantity))
(let *n (value *obj *name))
(((= *q 1) -> ("There is now ~d ~a of ~a." *q *n *obj))
(-> ("There are now ~d ~as of ~a." *q *n *obj))))
(command increase (increase *obj *amount)
(inc (*obj *quantity)))
(command decrease (decrease *obj *amount)
(dec (*obj *quantity)))
(command suggest
;; This illustrates the choose action.
(choose *x (at *x *loc))
("How about ~a?" *x))
(command choose (choose exit)
;; Another example of the choose action.
(choose *exit (exit *loc *exit *))
;; The choose just binds *exit, so we have to query to find out the
;; destination.
(query (exit *loc *exit *dest))
("How about ~a, which goes to ~a?" *exit *dest))
(timer (after turn 5
"That's five turns you've blown!"))
(initially (at player the-first-room))jba@wheaties.ai.mit.edu (Jonathan Amsterdam) (06/11/89)
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
;;; Streams.
;;; Copyright 1988 by Jonathan Amsterdam. All Rights Reserved.
(provide 'streams)
(defconstant *empty-stream* nil)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Macros.
(defmacro delay (thing)
`#'(lambda () ,thing))
(defmacro dostream ((var stream) &body body)
;; Iterate through the elements of a stream. Syntax is like dolist.
(let ((tempvar (gensym)))
`(do* ((,tempvar ,stream (stream-cdr ,tempvar))
(,var (stream-car ,tempvar) (stream-car ,tempvar)))
((stream-empty? ,tempvar) *empty-stream*)
,@body)))
(defmacro stream-cons (thing stream)
`(cons ,thing (delay ,stream)))
(defmacro stream-append (stream1 stream2)
`(stream-append-func ,stream1 (delay ,stream2)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Functions.
(defun force (thing)
(funcall thing))
(defun stream-append-func (stream delayed-stream)
(if (stream-empty? stream)
(force delayed-stream)
(stream-cons (stream-car stream)
(stream-append-func (stream-cdr stream) delayed-stream))))
(defun stream-mapcar (function stream)
(if (stream-empty? stream)
*empty-stream*
(stream-cons (funcall function (stream-car stream))
(stream-mapcar function (stream-cdr stream)))))
(defun stream-mapcan (function stream)
(if (stream-empty? stream)
*empty-stream*
(stream-append (funcall function (stream-car stream))
(stream-mapcan function (stream-cdr stream)))))
(defun stream-empty? (stream)
(eq stream *empty-stream*))
(defun stream-car (stream)
(car stream))
(defun stream-cdr (stream)
;; This is the only function besides stream-cons and stream-append that
;; differs from normal list functions.
(force (cdr stream)))
(defun stream->list (stream)
(if (stream-empty? stream)
nil
(cons (stream-car stream)
(stream->list (stream-cdr stream)))))
(defun list->stream (list)
(if (null list)
*empty-stream*
(stream-cons (car list)
(list->stream (cdr list)))))
(defun stream (&rest things)
;; This is like the list function; it returns a stream of its arguments.
(list->stream (copy-list things))) ;Must copy in Symbolics Common Lisp,
;because the rest arg is popped from
;the stack after stream returns.
;;; End streams.lisp.jba@wheaties.ai.mit.edu (Jonathan Amsterdam) (06/11/89)
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
;;; Copyright 1988 by Jonathan Amsterdam. All Rights Reserved.
(provide 'initial)
;;; Initial stuff for AAL. This file should be loaded before the others
;;; (except streams, which doesn't depend on anything).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Macros.
#-3600
(defmacro defprop (sym value indicator)
;; Like putprop, but doesn't evaluate its arguments. The Symbolics 3600
;; already has this defined.
`(setf (get ',sym ',indicator) ',value))
(defmacro defunp (prop-symbol arglist &body body)
;; Allows defining a function to be the value of a property on a symbol. See
;; the deducer, execute-action and keywords in the compiler for usage.
(let* ((prop (first prop-symbol))
(symbol (second prop-symbol))
(name (symbol-append prop '- symbol '- 'func)))
`(progn
(defun ,name ,arglist ,@body)
(defprop ,symbol ,name ,prop))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Structures.
;;; Changed slightly from the article--instead of a failure string, you can
;;; have any action.
(defstruct requirement
pattern
(failure-action ;action to take on failure
'(lisp (format t "You can't do that.")))
succeeded? ;used internally by check-reqs
)
(defstruct timer ; used for timers and demons
before-after ;:before, :after
turn-tick ;:turn, :tick
time-to-run ;number indicating when to run
action ;code to run
(renew-time 0) ;if 0, not renewable; else this is
;added to time-to-run when expired
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Constants.
(defconstant *initial-lisp-names*
'(eql member cons car cdr + - * / setf incf decf push print eval
get null = zerop)
"The action and pattern parsers translate these automatically")
(defconstant *initial-global-specs*
'(*agent *command *obj *instr *verb *loc (*turn 0) (*tick 0)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Global variables.
(defvar *report* nil "Controls debugging messages")
;;; The following are modified by the compiler.
(defvar *objects* nil "A list of all the objects in the game (including locs)")
(defvar *assertion-rules* nil "Forward rules to run on assertions")
(defvar *retraction-rules* nil "Forward rules to run on retractions")
(defvar *initial-actions* nil "Actions executed when the game starts")
(defvar *initial-rules* nil "Rules asserted when the game starts")
(defvar *initial-timers* nil)
(defvar *lisp-names* nil "Used in parsing actions and patterns")
(defvar *global-specs* nil "Used in declaring globals")
(defvar *backward-predicates* nil "Used in parsing actions and patterns")
;;; The following are modified during the game.
(defvar *tick* nil "The current tick")
(defvar *turn* nil "The current turn")
(defvar *abort-action* nil "Indicates when an action has been aborted in the middle")
(defvar *globals* nil "An alist of the AAL globals")
(defvar *protected-vars* nil "An alist of variables protected from renaming")
(defvar *db* nil "The database, which holds a list of all the facts")
(defvar *indices* nil "The symbols used as indices by the database indexer")
(defvar *timers* nil "Lists of the currently active timers")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Initialization.
(defun play (filename)
(cold-init)
(load filename)
(reverse-lists)
(replay))
(defun reverse-lists ()
;; Reverse the objects, so the ones earlier in the file are first.
;; Reverse the initial actions, so that the ones earlier in the file are done
;; before those later.
(setq *objects* (nreverse *objects*))
(setq *initial-actions* (nreverse *initial-actions*))
(dolist (obj *objects*)
(setf (get obj 'initial-actions) (nreverse (get obj 'initial-actions)))))
(defun replay ()
(warm-init)
(run))
(defun cold-init ()
;; Set up stuff necessary to load a new file.
(setq *objects* nil)
(setq *assertion-rules* nil)
(setq *retraction-rules* nil)
(setq *initial-actions* nil)
(setq *initial-rules* nil)
(setq *initial-timers* nil)
(setq *lisp-names* *initial-lisp-names*)
(setq *global-specs* *initial-global-specs*)
(setq *backward-predicates* nil)
)
(defun warm-init ()
;; Do things necessary for replaying an already loaded game.
(setq *tick* 0)
(setq *turn* 0)
(setq *abort-action* nil)
(setq *protected-vars* nil)
(clear-database)
(clear-timers)
(init-vars)
(init-timers)
;; Add the b-rules before the facts, because adding facts might trigger
;; rules. Also, this will put the rules at the end of the database, where
;; they should be (so facts can override them).
(init-rules)
(init-actions)
)
(defun clear-database ()
(setq *db* nil)
(dolist (index *indices*)
(setf (get index 'database) nil))
(setq *indices* '(*)))
(defun clear-timers ()
;; We need to do a copy-tree because this list is destructively modified.
(setq *timers* (copy-tree '((:after . ((:tick . nil) (:turn . nil)))
(:before . ((:tick . nil) (:turn . nil)))))))
(defun init-vars ()
(setq *globals* (specs->alist *global-specs*))
(dolist (obj *objects*)
(setf (get obj 'vars) (specs->alist (get obj 'var-specs)))))
(defun specs->alist (specs)
;; A variable spec is either a variable name, in which case it's bound to
;; NIL, or a list (<name> <value>).
(mapcar #'(lambda (spec) (if (symbolp spec)
(cons spec nil)
(cons (first spec) (second spec))))
specs))
(defun init-rules ()
(dolist (rule *initial-rules*)
(assert rule)))
(defun init-timers ()
(mapc #'add-timer (mapcar #'eval *initial-timers*)))
(defun init-actions ()
;; First do all the actions local to objects. Then do the global actions.
(dolist (obj *objects*)
(dolist (action (get obj 'initial-actions))
(execute-action-in-object obj action)))
(dolist (action *initial-actions*)
(execute-action action *globals*)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Utilities.
(defun symbol-append (&rest symbols)
(intern (apply #'string-append symbols)))
(defun report (&rest args)
(if *report*
(apply #'format t args)))
;;; End initial.lisp.jba@wheaties.ai.mit.edu (Jonathan Amsterdam) (06/11/89)
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
(provide 'parser)
(require 'initial "initial.lisp")
;;; 'Parsing' rules and patterns. This is not the natural-language parser for
;;; AAL; rather, it contains functions that translate from lists to internal
;;; forms of patterns, actions and rules.
;;; A pattern is a list. The following cars are special:
;;; (not <pattern>) succeeds only if pattern fails
;;; (or <pattern>*) succeeds if any of the patterns succeeds
;;; (and <pattern>*) succeeds if all of the patterns succeed
;;; (do <action>*) the actions are executed; always succeeds
;;; any action The action is executed; succeeds if its
;;; result is non-NIL. All free variables
;;; in the action must be instantiated.
;;; Syntactic sugar for patterns:
;;; <lisp expression> => (lisp <lisp expression>) if the car of the expression
;;; is in *lisp-names*.
(defun list->pattern (list)
(cond
((stringp list)
(list->action list))
((not (listp list))
(error "Illegal pattern: ~a" list))
((eq (car list) 'not)
(if (not (singleton? (cdr list)))
(error "Too many patterns in a not: ~a" list)
`(not ,(list->pattern (second list)))))
((member (car list) '(and or))
(cons (car list) (mapcar #'list->pattern (cdr list))))
((eq (car list) 'do)
`(do ,(list->actions (cdr list))))
((aal-action? (car list))
(list->action list))
((member (car list) *lisp-names*)
`(lisp ,list))
(t list)))
(defun simple-pattern? (pat)
(not (or (member (car pat) '(and or not do))
(aal-action? (car pat)))))
;;; An AAL action is one of the following:
;;; (rule-list <rule>*) like a cond
;;; (block <action>*) like a progn
;;; (rule <pattern> <action>) does action if pattern is satisfied;
;;; returns NIL if it isn't
;;; (lisp <lisp expression>) evaluates lisp expression
;;; (every <var> <pattern> <action>) does action for every binding of var
;;; satisfying pattern; returns last
;;; (choose <var> <pattern>) chooses at random a binding of var
;;; satisfying pattern; returns binding
;;; (let <var> <action>) binds var to result of action; returns
;;; result of action
;;; (assert <pattern>) add to the database; always succeeds
;;; (retract <pattern>) remove from database; always succeeds
;;; (query <pattern>) invoke the deducer with the pattern
;;; Other actions are defined in interp.lisp. They are not "parsed".
(defun list->actions (list)
(singleton-optimize (mapcar #'list->action list) 'block))
(defun list->action (list)
(list->action-desugared (desugar-action list)))
(defun var-of (action)
(if (member (car action) '(every choose let))
(second action)
(error "action ~a does not have a var" action)))
(defun pattern-of (action)
(case (car action)
((rule assert retract query)
(second action))
((every choose)
(third action))
(otherwise
(error "action ~a does not have a pattern" action))))
(defun action-of (action)
(case (car action)
((rule let)
(third action))
(every
(fourth action))
(otherwise
(error "action ~a does not have an action" action))))
(defun expression-of (action)
(if (eq (car action) 'lisp)
(second action)
(error "action ~a does not have an expression" action)))
(defun list->action-desugared (list)
;; Handles lists whose car is already known to be an action word
(case (car list)
(rule-list `(rule-list ,@(mapcar #'list->rule (cdr list))))
(block `(block ,@(mapcar #'list->action (cdr list))))
(rule `(rule ,(list->pattern (pattern-of list)) ,(list->action (action-of list))))
(lisp list)
(every `(every ,(check-var list) ,(list->pattern (pattern-of list))
,(list->action (action-of list))))
(choose `(choose ,(check-var list) ,(list->pattern (pattern-of list))))
(let `(let ,(check-var list) ,(list->action (action-of list))))
(assert `(assert ,(list->pattern (pattern-of list))))
(retract `(retract ,(list->pattern (pattern-of list))))
(query `(query ,(list->pattern (pattern-of list))))
(otherwise list)))
(defun check-var (list)
(let ((var (var-of list)))
(if (not (var? var))
(error "variable expected instead of ~a in ~a" var list)
var)))
;;; Syntactic sugar:
;;; blocks are sometimes implicit; also:
;;; (<rule>*) => (rule-list <rule>*)
;;; (<pattern>* -> <action>*) => (rule (and <pattern>*) (block <action>*))
;;; <lisp expression> => (lisp <lisp expression>) if the car of the expression
;;; is in the list *lisp-names*
;;; (<- <pattern>) => (query <pattern>)
;;; <string> => (lisp (format t <string>))
;;; (<string> ...) => (lisp (format t <string> ...))
;;; <pattern> => (query <pattern>) if its car is the same as the consequent of a
;;; previously defined b-rule
;;; <pattern> => (assert <pattern>) if its car doesn't fit anything else
;;; (not <pattern>) => (retract <pattern>)
;;; (choose <var> <pattern>*) => (choose <var> (and <pattern>*))
;;; (let <var> <action>*) => (let <var> (block <action>*))
;;; (every <var> <pattern> <action>*) => (every <var> <pattern> (block <action>*))
;;; <lisp atom> (other than string) => (lisp <lisp atom>)
(defun desugar-action (list)
(if (stringp list)
(setq list (list list)))
(if (atom list)
`(lisp ,list)
(let ((car (car list)))
(cond
((stringp car)
`(lisp (eval (format t ,(string-append "~&" car "~%")
,@(mapcar #'var->sd (cdr list))))))
((eq car 'every)
`(every ,(var-of list) ,(pattern-of list)
,(singleton-optimize (cdddr list) 'block)))
((eq car 'let)
`(let ,(var-of list) ,(singleton-optimize (cddr list) 'block)))
((eq car 'choose)
`(choose ,(var-of list) ,(singleton-optimize (cddr list) 'and)))
((aal-action? car)
list)
((eq car '<-)
`(query ,(second list)))
((eq car 'not)
`(retract ,(second list)))
((member '-> list)
(desugar-rule list))
((member car *lisp-names*)
`(lisp ,list))
((member car *backward-predicates*)
`(query ,list))
((listp (car list))
(cons 'rule-list list))
(t
`(assert ,list))))))
(defun var->sd (thing)
;; If thing is a var, translate it to (printed-rep var).
(if (var? thing)
`(printed-rep ',thing)
thing))
(defun aal-action? (thing)
;; We can tell a symbol is the name of an action by seeing if its ACTION
;; property is non-NIL.
(and (symbolp thing)
(get thing 'action)))
(defun list->rule (list)
(list->action-desugared (desugar-rule list)))
(defun desugar-rule (list)
(let ((->pos (member '-> list)))
(if (not ->pos)
(error "illegal rule: ~a" list)
(let* ((ant-lists (ldiff list ->pos))
(conseq-lists (cdr ->pos))
(pattern (singleton-optimize ant-lists 'and))
(action (singleton-optimize conseq-lists 'block)))
`(rule ,pattern ,action)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Backward rules.
;;; (b-rule <consequent> <antecedent>)
(defun consequent-of (b-rule)
(second b-rule))
(defun antecedent-of (b-rule)
(third b-rule))
(defun list->b-rule (list)
(list->b-rule-desugared (desugar-b-rule list)))
(defun list->b-rule-desugared (list)
(let ((conseq (list->pattern (consequent-of list))))
(if (not (simple-pattern? conseq))
(error "The consequent of a backwards rule must be simple: ~a" list)
`(b-rule ,conseq
,(list->pattern (antecedent-of list))))))
;;; Syntactic sugar:
;;; (<consequent> <- <antecedent>*) => (b-rule <consequent> (and <antecedent>*))
(defun desugar-b-rule (list)
(let ((<-pos (member '<- list)))
(if (not <-pos)
(error "illegal backward rule: ~a" list)
(let* ((conseq-list (ldiff list <-pos))
(ant-lists (cdr <-pos)))
(if (not (singleton? conseq-list))
(error "backward rules have exactly one consequent: ~a" list)
`(b-rule ,(car conseq-list)
,(singleton-optimize ant-lists 'and)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Forward rules.
(defun list->f-rule (list)
;; The only thing we do here is error-checking.
(let ((rule (list->rule list)))
(if (not (simple-pattern? (pattern-of rule)))
(error "Forward rules must have only a single, simple pattern: ~a" list)
rule)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Requirements.
;;; Syntax of a requirement:
;;; <pattern> or (<pattern> . <action>)
;;; This allows ((on a b) "foo") or ((on a b) "foo ~a" *obj), which are the
;;; usual cases.
(defun list->requirements (list)
(cons 'list (mapcar #'list->requirement list)))
(defun list->requirement (list)
(if (listp (car list))
(let ((pattern (car list))
(action (cdr list)))
`(make-requirement :pattern ',(list->pattern pattern)
:failure-action ',(list->action action)))
`(make-requirement :pattern ',(list->pattern list))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun singleton-optimize (list first-el)
;; If list has one element, return it; else return a list of the elements
;; with first-el as its first element.
(if (singleton? list)
(car list)
(cons first-el list)))
(defun singleton? (list)
;; Returns T if list has only one element
(null (cdr list)))
;;; End parser.lisp.jba@wheaties.ai.mit.edu (Jonathan Amsterdam) (06/11/89)
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
;;; The deducer for AAL.
;;; Copyright 1988 by Jonathan Amsterdam. All Rights Reserved.
(provide 'deducer)
(require 'initial "initial.lisp")
(require 'streams "streams.lisp")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Deductive retriever.
(defun assert (stmt)
;; Clobbers the Common-Lisp assert macro.
;; When a fact is asserted, it's translated into a b-rule to simplify the
;; rest of the deducer.
(if (not (eq (car stmt) 'b-rule))
(setq stmt `(b-rule ,stmt)))
(when (add-to-database stmt)
(report "~&Asserting ~a~%" stmt)
(if (null (antecedent-of stmt))
;; run rules only for facts
(run-forward-rules *assertion-rules* (consequent-of stmt))))
stmt)
(defun retract (stmt)
(if (not (eq (car stmt) 'b-rule))
(setq stmt `(b-rule ,stmt)))
(when (remove-from-database stmt)
(report "~&Retracting ~a~%" stmt)
(if (null (antecedent-of stmt))
;; run rules only for facts
(run-forward-rules *retraction-rules* (consequent-of stmt))))
stmt)
(defun run-forward-rules (rules fact)
;; Run a rule if its pattern matches the fact.
(dolist (frule rules)
(let ((bindings (unify fact (pattern-of frule) *globals*)))
(when (not (eq bindings :fail))
(report "~&Firing rule ~a~%" frule)
(execute-action (action-of frule) bindings)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Deduce.
;;; A pattern is a list. The following cars are special:
;;; (not <pattern>)
;;; (or <pattern>*)
;;; (and <pattern>*)
;;; (do <action>*) the actions areis executed; always
;;; succeeds
;;; any action The action is executed; succeeds if its
;;; result is non-NIL. All free variables
;;; in the action must be instantiated.
(defun deduce (pattern bindings)
;; Returns a stream of bindings (variable lists) for things that match the
;; pattern, or the empty stream if there are none.
(let ((func (get (car pattern) 'deduce)))
(cond
(func
(funcall func pattern bindings))
((aal-action? (car pattern))
(deduce-action pattern bindings))
(t
(deduce-pattern pattern bindings (find-possible-unifiers pattern))))))
(defunp (deduce nil) (pattern bindings)
;; The null pattern always succeeds.
(declare (ignore pattern))
(stream bindings))
(defunp (deduce not) (pattern bindings)
;; Pattern should be fully instantiated. Returns a stream consisting of
;; bindings if the pattern is not satisfied, the empty stream if it is.
(if (stream-empty? (deduce (second pattern) bindings))
(stream bindings)
*empty-stream*))
(defunp (deduce or) (pattern bindings)
;; Returns a stream of all bindings satisfying any pattern in the list.
(stream-mapcan #'(lambda (p) (deduce p bindings))
(list->stream (cdr pattern))))
(defunp (deduce and) (pattern bindings)
;; Returns a stream of bindings (variable lists) for things that match all
;; the patterns, or the empty stream if there are none.
(deduce-list (cdr pattern) bindings))
(defun deduce-list (pattern-list bindings)
(if (null pattern-list)
(stream bindings)
(let ((bindings-stream (deduce (car pattern-list) bindings)))
(stream-mapcan #'(lambda (b) (deduce-list (cdr pattern-list) b))
bindings-stream))))
(defunp (deduce do) (pattern bindings)
;; The action is executed and the result ignored. Always succeeds.
(execute-action (second pattern) bindings)
(stream bindings))
(defun deduce-action (action bindings)
;; The action is executed and succeeds if the result is non-NIL. It also
;; augments the bindings.
(multiple-value-bind (result new-bindings)
(execute-action action bindings)
(if result
(stream new-bindings)
*empty-stream*)))
(defun deduce-pattern (pattern bindings possibilities)
;; This is the only place "real work" gets done.
(if (null possibilities)
*empty-stream*
(let* ((rule (rename-rule (car possibilities)))
(bindings1 (unify pattern (consequent-of rule) bindings)))
(if (eq bindings1 :fail)
(deduce-pattern pattern bindings (cdr possibilities))
(stream-append
(deduce (antecedent-of rule) bindings1)
(deduce-pattern pattern bindings (cdr possibilities)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Unifier.
;;; This is a simplified unifier. It doesn't do nested patterns, and it also
;;; doesn't do the "occur check". See Abelson & Sussman for a full-blooded
;;; unifier.
(defun unify (pat1 pat2 bindings)
;;Returns :FAIL if it can't unify, a list of bindings if it can.
(cond
((and (null pat1) (null pat2))
bindings)
((or (null pat1) (null pat2))
:fail)
((let* ((el1 (car pat1))
(el2 (car pat2))
(new-bindings (if (var? el1)
(unify-var el1 el2 bindings)
(unify-const el1 el2 bindings))))
(if (eq new-bindings :fail)
:fail
(unify (cdr pat1) (cdr pat2) new-bindings))))))
(defun unify-var (v el bindings)
(let ((val (var-value v bindings)))
(if (eq val :unbound)
(if (eq v '*)
;; The * variable, like the underscore in Prolog, indicates a
;; "don't care". It matches, but we create no binding for it.
bindings
(add-binding v el bindings))
(unify-const val el bindings))))
(defun unify-const (const el bindings)
(if (var? el)
(unify-var el const bindings)
(if (eql const el) bindings :fail)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun find-possible-unifiers (pattern)
(if (var? (car pattern))
*db*
(append (get '* 'database)
(get (car pattern) 'database))))
(defun add-to-database (rule)
;; Returns NIL iff not added (because already present)
(let ((index (index-of rule)))
(cond
((member rule (get index 'database) :test #'equal)
nil)
(t
(push rule (get index 'database))
(push rule *db*)
(pushnew index *indices*)
t))))
(defun remove-from-database (rule)
;; Returns NIL iff not removed (because not present)
(let* ((index (index-of rule))
(the-rule (car (member rule (get index 'database) :test #'equal))))
(cond
(the-rule
(setf (get index 'database) (delete the-rule (get index 'database) :test #'eq))
(setq *db* (delete the-rule *db* :test #'eq))
t)
(t nil))))
(defun index-of (rule)
(car (consequent-of rule)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun var? (thing)
;; A variable is a lisp symbol that begins with a *, but does not end with
;; one (except for the single-character variable "*"). We institute this
;; last requirement so that lisp globals, traditionally written as *symbol*,
;; can be accessed from AAL.
(if (symbolp thing)
(let* ((name (symbol-name thing))
(length (length name)))
(and
(char= (char name 0) #\*)
(or (= length 1)
(not (char= (char name (1- length)) #\*)))))
nil))
(defun add-binding (var value bindings)
(cons (cons var value) bindings))
(defun var-value (var bindings)
;; Follow the chain of bindings to the end.
(let ((val-pair (assoc var bindings)))
(if (not val-pair)
:unbound
(let ((val (cdr val-pair)))
(if (var? val)
(var-value val bindings)
val)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Renaming variables in a rule.
;;; This needs to be done so that variables with the same name from two
;;; different rules (or two instantiations of the same, recursive, rule) don't
;;; interact.
(defun rename-rule (rule)
;; Renames all the variables in rule.
(copy-pattern rule nil))
(defun copy-pattern (pattern correspondences)
;; Copy pattern, renaming variables. So that textually distinct occurrences
;; of the same variable are renamed the same way, we need to keep a list of
;; the old-var/new-var correspondences. We first build up an a-list of
;; the correspondences, then let sublis do the work.
(let ((new-correspondences (create-correspondences pattern correspondences)))
(if new-correspondences
(sublis new-correspondences pattern)
;; nothing to substitute (i.e. pat has no variables) so no need to copy
pattern)))
(defun create-correspondences (pattern correspondences)
;; Avoid renaming global and local variables.
(cond
((null pattern)
correspondences)
((atom pattern)
(if (and (var? pattern)
(not (assoc pattern correspondences))
(not (assoc pattern (or *protected-vars* *globals*))))
(add-binding pattern (rename-var pattern) correspondences)
correspondences))
(t
(create-correspondences (cdr pattern)
(create-correspondences (car pattern)
correspondences)))))
(defun rename-var (var)
;; Generate a new symbol.
(gentemp (symbol-name var)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; For testing.
(defun dedp (p)
;; for testing only
(let ((uvars (reverse (unbound-vars-in-pattern p *globals* nil))))
(mapcar #'(lambda (b) (extract-bindings b uvars))
(stream->list (deduce p *globals*)))))
(defun extract-bindings (bindings var-names)
(mapcar #'(lambda (name) (cons name (var-value name bindings)))
var-names))
(defun unbound-vars-in-pattern (pattern bindings unbound-vars)
(cond
((null pattern)
unbound-vars)
((atom pattern)
(if (and (var? pattern) (unbound? pattern bindings))
(adjoin pattern unbound-vars)
unbound-vars))
(t
(unbound-vars-in-pattern
(cdr pattern) bindings
(unbound-vars-in-pattern (car pattern)
bindings unbound-vars)))))
(defun unbound? (var bindings)
(eq (var-value var bindings) :unbound))
(defun asserts (list)
(dolist (pat list)
(assert pat)))
(defun show-db (&optional predicate)
(fresh-line)
(dolist (stmt (if predicate (get predicate 'database) *db*))
(format t "~s~%" (if (null (antecedent-of stmt))
(consequent-of stmt)
stmt))))
;;; End deducer.lisp.jba@wheaties.ai.mit.edu (Jonathan Amsterdam) (06/11/89)
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
;;; Interpreter for AAL.
;;; Copyright 1988 by Jonathan Amsterdam. All Rights Reserved.
(provide 'interp)
(require 'initial "initial.lisp")
(require 'streams "streams.lisp")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The main loop of the adventure system:
;;; 1. Run all expired BEFORE-TICK timers.
;;; 2. If between turns, run all expired BEFORE-TURN timers.
;;; 3. If between turns, prompt for command and parse input.
;;; 4. Do the requested command.
;;; 5. Increment TICK.
;;; 6. Run all expired AFTER-TICK timers.
;;; 7. If the command's duration has not expired, goto step 1.
;;; 8. Increment TURN.
;;; 9. Run all expired AFTER-TURN timers.
;;; Ticks measure time passage in the game. Turns just measure the player's
;;; inputs; a turn may take 0, 1 or several ticks. For zero-tick turns, the
;;; tick timers are not run, but the turn timers are.
;;; NOTE: This whole turn/tick distinction and its implementation needs to be
;;; rethought. It theory it's a nice idea to be able to have turns take longer
;;; than one time unit. You might want to have a walk down a long hall to take
;;; longer than just going through a doorway, or have filling a gallon jug from
;;; a spigot take longer than filling a cup. The problem is that it's hard to
;;; actually spread out the execution of a command over an extended amount of
;;; time. Instead, it's modelled here by doing the action all at once, then
;;; counting off the time. This can differ from the "right" way when timers go
;;; off during the time of the action. Take the spigot case: say a timer goes
;;; off at some point, shutting off the supply to the spigot. If the shutoff
;;; occurs in the middle of an action, the player should get an amount of
;;; liquid proportional to the portion of the action completed; but in this
;;; implementation, the player would get the full amount of liquid.
;;; Another problem, easier to solve, is that in this implementation
;;; durations are numbers associated with commands; so the "n" command can only
;;; have one duration. As the above examples make clear, the duration should
;;; be a function of all the things involved in the command.
(defun run ()
(let ((action-duration 1)
(tick-to-resume 0))
(catch 'end-game
(loop
(unless (= action-duration 0)
(run-expired-timers :before :tick))
(when (or *abort-action* (>= *tick* tick-to-resume))
(setq *abort-action* nil)
(run-expired-timers :before :turn)
(setq action-duration (input-and-act))
(setq tick-to-resume (+ action-duration *tick*)))
(unless (= action-duration 0)
(inc-tick)
(run-expired-timers :after :tick)
(when (>= *tick* tick-to-resume)
(inc-turn)
(run-expired-timers :after :turn)))))))
(defun inc-tick ()
;; We keep the actual tick count (in lisp variable *tick*) separate from the
;; AAL global *tick so that the AAL program can't alter the real value. (And
;; similarly for turn.)
(incf *tick*)
(set-global '*tick *tick*))
(defun inc-turn ()
(incf *turn*)
(set-global '*turn *turn*))
(defun input-and-act ()
(if (not (prompt-and-parse))
0
(initiate-command (global-value '*command))))
(defun end-game ()
(format t "~2%The game is over.~%")
(display-score)
(throw 'end-game nil))
;;; Scoring is simple: just ask every object for its maximum score and the
;;; current score. The problem is that scores must be associated with objects
;;; (including locations); you can't easily arrange to get points for, say,
;;; surviving past the 30th turn.
(defun display-score ()
(let ((score (compute-score))
(max-score (compute-max-score)))
(format t "Your score is ~d out of a possible ~d " score max-score)
(format t "(that's ~d%).~%"
(round (* (/ score (if (zerop max-score) 1 (float max-score)))
100)))
(format t "You've taken ~d turns in ~d ticks.~%" *turn* *tick*)
score))
(defun compute-score ()
(sum-action-results 'score))
(defun compute-max-score ()
(sum-action-results 'max-score))
(defun sum-action-results (prop)
;; For every object that has property prop, run the action, and accumulate
;; the results.
(let ((sum 0))
(dolist (obj *objects*)
(let ((action (get obj prop)))
(if action
(incf sum (or (execute-action-in-object obj action) 0)))))
sum))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Timers.
(defun run-expired-timers (before-after turn-tick)
(let ((timer-list (get-headed-timer-list before-after turn-tick))
(time (if (eq turn-tick :turn) *turn* *tick*)))
(dolist (ti (cdr timer-list))
(if (> time (timer-time-to-run ti))
(error "time ~a > timer ~a time" time ti)
(when (= time (timer-time-to-run ti))
(report "~&Running timer ~a~%" ti)
(execute-action (timer-action ti) *globals*)
(if (> (timer-renew-time ti) 0)
(setf (timer-time-to-run ti) (+ time (timer-renew-time ti)))))))
;; purge expired timers
(setf (cdr timer-list)
(delete-if #'(lambda (ti) (= time (timer-time-to-run ti))) (cdr timer-list)))))
(defun get-headed-timer-list (before-after turn-tick)
(assoc turn-tick (cdr (assoc before-after *timers*))))
(defun add-timer (timer)
(push timer (cdr (get-headed-timer-list (timer-before-after timer)
(timer-turn-tick timer)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Global and local variables.
(defun global-value (var)
(alist-var-value var *globals*))
(defun alist-var-value (var alist)
;; This is simpler than var-value: it doesn't have to deal with variables
;; bound to other variables.
(let ((pair (assoc var alist)))
(if pair
(cdr pair)
(error "The variable ~a is unbound" var))))
(defun set-global (var value)
(set-var var value *globals*))
(defun set-var (var value alist)
;; You can't set variables that don't exist. That's why globals have to be
;; declared.
(let ((pair (assoc var alist)))
(if pair
(setf (cdr pair) value)
(error "Attempt to set unbound AAL variable ~a" var))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Parsing the player's input.
;;; The syntax of a command is: [agent,] verb ... where "..." is specified by
;;; the SYNTAX property of the verb. There are several weaknesses in the
;;; parsing method: commands are tied too closely to their syntax (the first
;;; word of the command line must be the name of the command); commands can
;;; have only one syntax (so you can't have both "give the bone to the dog" and
;;; "give the dog the bone") and each thing (command or object) mentioned must
;;; be one word long.
(defun prompt-and-parse ()
;; Returns T if successful.
(fresh-line)
(format t "~d> " (1+ *turn*))
(let* ((string-input (read-line))
(input (string->list string-input))
(comma-list (member :comma input))
(agent-list (ldiff input comma-list))
(verb-list (or (cdr comma-list) input)))
(cond
((null comma-list)
(set-global '*agent 'player))
((not (singleton? agent-list))
(format t "~&Syntax is: <agent>, ...~%")
(return-from prompt-and-parse nil))
(t
(set-global '*agent (car agent-list))))
(let* ((verb (car verb-list))
(command (get-command-name verb))
(syntax (get command 'syntax)))
(when (null command)
(format t "~&I don't know the word ~a.~%" verb)
(return-from prompt-and-parse nil))
(set-global '*verb verb)
(set-global '*command command)
(parse-by-syntax (cdr verb-list) syntax))))
(defun parse-by-syntax (input-list syntax-list)
;; Returns T iff successful.
;; This is basically like unification: the input list contains symbols, and
;; the syntax list contains symbols and possibly variables. We set the
;; global values of the variables to what they match, and confirm that the
;; symbols match.
;; If the input list is shorter, error. Ideally, the program would figure
;; out reasonable values for the missing variables. But not now.
;; If the syntax list is shorter, that's OK.
(cond
((null input-list)
(cond
((null syntax-list)
t)
(t
(format t "~&I need more info~%")
nil)))
((null syntax-list)
t)
((var? (car syntax-list))
(set-global (car syntax-list) (car input-list))
(parse-by-syntax (cdr input-list) (cdr syntax-list)))
((eql (car input-list) (car syntax-list))
(parse-by-syntax (cdr input-list) (cdr syntax-list)))
(t
(format t "~&The word ~a should be ~a~%" (car input-list)
(car syntax-list))
nil)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Reading a string into a list without character-by-character parsing: it's
;;; easy using read-from-string, except that we have to watch out for commas,
;;; which are the only legal punctuation. Other punctuation might cause
;;; problems too, but this implementation doesn't worry about that. (We have
;;; to watch out for commas because in Common Lisp, they're illegal outside a
;;; backquote.)
(defvar *hacked-readtable* (copy-readtable))
(defun comma-reader-func (stream char)
(declare (ignore stream char))
:comma)
(set-macro-character #\, #'comma-reader-func nil *hacked-readtable*)
(defun string->list (string)
;; Temporarily rebind the readtable to my own version, put parens around the
;; string, and read it.
(let ((*readtable* *hacked-readtable*))
(read-from-string (string-append "(" string ")"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Doing a command:
;;; 1. Check the REQUIRES conditions in the order specified by the
;;; REQUIREMENTS-ORDER property of the command. If one is not satisfied,
;;; print a message and return 0 duration.
;;; 2. Begin executing the first of the actions found in the order specified by
;;; the ACTIONS-ORDER property of the command. If that action returns
;;; :CONTINUE (by the use of the (continue) action) then keep going.
;;; This is a generalization of what was presented in the article; there, the
;;; requirements order was fixed as (*command *agent *obj *instr) and the
;;; actions order as (*agent *obj *instr *command). Those are still basically
;;; the default, except that the location (*loc) has been added to allow rooms
;;; to have a say in what goes on. It is also possible for a command to
;;; override the default order. See the "command" macro in comp.lisp.
(defun initiate-command (command)
;;Returns the duration of the action in ticks.
(cond
((not (satisfies-requirements command (get command 'requirements-order)))
0)
(t
(execute-command command (get command 'actions-order))
(or (get command 'duration) 1))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Requirements.
(defun satisfies-requirements (command req-order)
(every #'(lambda (var) (check-requirements command var))
req-order))
(defun check-requirements (command case)
(let* ((obj (global-value case))
(reqs (get-requirements obj command case)))
(dolist (req reqs)
(setf (requirement-succeeded? req) nil))
(let ((result (call-function-in-object #'(lambda (bindings)
(check-reqs reqs bindings))
obj)))
(if (not (eq result t))
(execute-action-in-object obj result))
(eq result t))))
;;; Checking requirements: the failure message is printed only if the pattern
;;; never succeeds. Once a pattern succeeds, its message will not be printed.
(defun check-reqs (reqs bindings)
;; Returns either T if all requirements can be satisfied, or the action to
;; be done if they can't.
(if (null reqs)
t
(let* ((req (car reqs))
(binding-stream (deduce (requirement-pattern req) bindings))
(f-action nil))
(cond
((stream-empty? binding-stream)
(return-from check-reqs (if (requirement-succeeded? req)
nil
(requirement-failure-action req))))
(t
(setf (requirement-succeeded? req) t)
(dostream (binds binding-stream)
(let ((result (check-reqs (cdr reqs) binds)))
(if (eq result t)
(return-from check-reqs t)
(if result
(setq f-action result)))))
f-action)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Executing user commands.
(defun execute-command (command actions-order)
;; The variables in actions-order are checked in order for actions pertaining
;; to this command. When an action is found, it is executed. If the rules
;; of the action actually fired, then execute-command returns, unless the
;; result of the rules was :continue. If no rules fired, execute-command
;; continues looking. The result of the action is returned, or NIL if no
;; action fired.
(dolist (case actions-order)
(let* ((obj (global-value case))
(action (get-action obj command case)))
(if action
(let ((result (execute-action*-in-object obj action)))
(if (not (member result '(:did-not-fire :continue)))
(return result)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Executing actions.
(defun execute-action (action bindings)
;; Returns two values. The first is the result of the action, or NIL if no
;; rule in the action fired. The second is the new bindings (this would only
;; be used internally.) You can't distinguish between an action consisting
;; of rules returning NIL as a result of one of its rules firing, vs. having
;; none of its rules fire.
(multiple-value-bind (result new-bindings)
(execute-action* action bindings)
(values (if (eq result :did-not-fire) nil result) new-bindings)))
(defun execute-action* (action bindings)
;; Differs from execute-action only in that it returns :DID-NOT-FIRE instead
;; of NIL when appropriate.
(funcall (get (car action) 'action) action bindings))
(defun execute-action-in-object (obj action)
;; This makes sure that the object's local variables are accessible.
(call-function-in-object #'(lambda (bindings)
(execute-action action bindings))
obj))
(defun execute-action*-in-object (obj action)
(call-function-in-object #'(lambda (bindings)
(execute-action* action bindings))
obj))
(defunp (action block) (block bindings)
;; (block <action>*). Does all the actions one after the other.
;; Returns the value of the last action, like PROGN. Accumulates bindings.
(let (result)
(dolist (action (cdr block))
(multiple-value-setq (result bindings) (execute-action action bindings)))
(values result bindings)))
;;; A rule-list is a list of forward rules. The first rule whose pattern is
;;; satisfied is executed, and the value of the action of that rule is
;;; returned. :DID-NOT-FIRE is returned if no rules in the list match. The
;;; bindings are consulted to obtain values for free variables in the rules.
;;; Bindings are not accumulated from rule to rule; the top-level bindings are
;;; used throughout.
(defunp (action rule-list) (rule-list bindings)
(dolist (rule (cdr rule-list))
(let ((result (action-rule-func rule bindings)))
(if (not (eq result :did-not-fire))
(return-from action-rule-list-func (values result bindings)))))
(values :did-not-fire bindings))
(defunp (action rule) (rule bindings)
;; (rule <pattern> <action>)
(let ((bindings-stream (deduce (pattern-of rule) bindings)))
(if (stream-empty? bindings-stream)
(values :did-not-fire bindings)
;; It's crucial here that execute-action does *not* return
;; :did-not-fire; if it did, then the rule-list function might think
;; this rule didn't fire, when at this point we know it did.
(execute-action (action-of rule) (stream-car bindings-stream)))))
(defunp (action every) (every bindings)
;; (every <var> <pattern> <action>)
;; Get a list of bindings for the variable, using the pattern; then execute
;; the action for each binding. Return the value of the last action; but do
;; not alter the bindings. NOTE: we should really add the bindings of all
;; the variables in the pattern.
(let* ((var (var-of every))
(action (action-of every))
(var-values (unique-values var (pattern-of every) bindings))
(new-bindings-list (mapcar #'(lambda (val) (add-binding var val bindings))
var-values))
(result))
(dolist (new-bindings new-bindings-list)
(setq result (execute-action action new-bindings)))
(values result bindings)))
(defun unique-values (var pattern bindings)
;; Returns a list of values of var satisfying pattern, with no duplicate
;; values.
(let* (;;get the stream of bindings satisfying pattern...
(bindings-stream (deduce pattern bindings))
;;turn it into a list...
(bindings-list (stream->list bindings-stream))
;;remove the values for var...
(values-list (mapcar #'(lambda (b) (var-value var b))
bindings-list)))
;; return the values with duplicates deleted.
(delete-duplicates values-list)))
(defunp (action let) (let bindings)
;; (let <var> <action>)
;; Execute the action and bind the result to the variable; return the result
;; of the action, and the new bindings.
(let ((result (execute-action (action-of let) bindings)))
(values result (add-binding (var-of let) result bindings))))
(defunp (action choose) (choose bindings)
;; (choose <var> <pattern>)
;; This is like a let, except the value for the variable is chosen randomly
;; from those that match the pattern. The result of choose is the value, and
;; it also augments the bindings.
(let ((result (randomly-choose-from-list
(unique-values (var-of choose)
(pattern-of choose) bindings))))
(values result (add-binding (var-of choose) result bindings))))
(defun randomly-choose-from-list (list)
(let ((n (random (length list))))
(nth n list)))
(defunp (action lisp) (lisp-action bindings)
;; Returns the result of applying the car of lisp expression to its cdr, and
;; the same bindings. (If the expression is an atom, it's just returned.) We
;; have to go through the expression replacing AAL variables with their
;; values. Note that we are not evaluating the expression; the difference is
;; that our way, the arguments are not evaluated.
(let ((expr (instantiate (expression-of lisp-action) bindings)))
(if (atom (expression-of lisp-action))
(values expr bindings)
(values (apply (car expr) (cdr expr)) bindings))))
(defunp (action assert) (assert bindings)
;; Get the pattern and instantiate it. It must be simple and contain no
;; unbound variables.
(let ((pattern (second assert)))
(if (not (simple-pattern? pattern))
(error "Cannot assert the pattern ~a because it is not simple"
pattern)
(values (assert (instantiate pattern bindings))
bindings))))
(defunp (action retract) (retract bindings)
;; This is similar to assert
(let ((pattern (pattern-of retract)))
(if (not (simple-pattern? pattern))
(error "Cannot retract the pattern ~a because it is not simple"
pattern)
(values (retract (instantiate pattern bindings))
bindings))))
;;; (query <pattern>)
(defunp (action query) (query bindings)
;; Calls the deducer on the pattern. Returns what the deducer returns, and
;; augments the bindings by returning the first binding-list in the stream
;; returned by the deducer, if any.
(let ((result (deduce (pattern-of query) bindings)))
(values result (if (stream-empty? result)
bindings
(stream-car result)))))
;;; (continue)
(defunp (action continue) (continue bindings)
(declare (ignore continue))
(values :continue bindings))
;;; (end-game)
(defunp (action end-game) (form bindings)
(declare (ignore form bindings))
(end-game))
;;; (display-score)
(defunp (action display-score) (form bindings)
(declare (ignore form))
(values (display-score) bindings))
(defmacro with-instantiated-arg (&body body)
;; This simplifies the expression of simple actions that take only one
;; argument and instantiate it.
`(let ((arg (instantiate (second form) bindings)))
(values (progn ,@body) bindings)))
;;; (destroy <obj>)
(defunp (action destroy) (form bindings)
;; (destroy obj) removes all facts in the database that mention obj.
;; We can't use the deducer directly to do this because we have to handle
;; assertions of all arities.
(with-instantiated-arg (destroy arg)))
(defun destroy (obj)
(dolist (stmt *db*)
(when (and (null (antecedent-of stmt)) ;it's a fact
(member obj (consequent-of stmt)))
(retract (consequent-of stmt))))
t)
;;; (value <obj> <var>) For local variables of an object that the code is not
;;; executing within.
(defunp (action value) (form bindings)
(with-instantiated-arg
(alist-var-value (third form) (get arg 'vars))))
;;; (set <var> <value>) sets globals.
;;; (set (<obj> <var>) <value>) sets locals.
(defunp (action set) (form bindings)
(if (not (= (length form) 3))
(error "In ~a: wrong number of args" form)
(multiple-value-bind (obj var value)
(parse-modify-form form)
(let ((alist (if obj (get (instantiate obj bindings) 'vars) bindings)))
(if (not (var? var))
(error "In ~a: ~a is not a variable" form var)
(values (set-var var (instantiate value bindings) alist)
bindings))))))
(defun parse-modify-form (form)
;; form is either (<name> (<obj> <var>) [<value>]) or (<name> <var>
;; [<value>]). Return three values: obj, var, value.
(let ((varspec (second form)))
(if (listp varspec)
(if (not (= (length varspec) 2))
(error "In ~a: illegal var: ~a" form (second form))
(values (first varspec) (second varspec) (third form)))
(values nil varspec (third form)))))
;;; (inc <var> [<amount>]) for globals
;;; (inc (<obj> <var>) [<amount>]) for locals
(defunp (action inc) (form bindings)
(values (modify-var form bindings #'+) bindings))
;;; Same as inc
(defunp (action dec) (form bindings)
(values (modify-var form bindings #'-) bindings))
(defun modify-var (form bindings func)
;; Form should be (name (obj var) [amount]) or (name var [amount])
(multiple-value-bind (obj var amount-form)
(parse-modify-form form)
(if (not (var? var))
(error "In ~a: ~a is not a variable" form var)
(let* ((alist (if obj (get (instantiate obj bindings) 'vars) bindings))
(amount (if amount-form (instantiate amount-form bindings) 1))
(value (var-value var alist)))
(cond
((eq value :unbound)
(error "In ~a: variable ~a is unbound" form var))
((not (numberp value))
(error "In ~a: variable ~a's value, ~a, is not a number"
form var value))
((not (numberp amount))
(error "In ~a: the argument, ~a, is not a number"
form amount-form))
(t
(set-var var (funcall func value amount) alist)))))))
;;; (display <action>)
(defunp (action display) (form bindings)
(with-instantiated-arg
(let ((pr (printed-rep arg)))
(format t "~&~a~%" pr)
pr)))
(defun printed-rep (thing)
(if (symbolp thing)
(or (get thing 'desc) (string-downcase thing))
thing))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Miscellaneous.
(defun call-function-in-object (func obj)
;; The main thing here is handling the object's local variables correctly.
;; They must be added to the bindings so that their values will be found, and
;; we also have to handle setting them. This is what we do: we nconc the
;; list of locals onto the bindings, first keeping the last cons of the
;; locals. Accessing will work as usual. Set will destructively modify the
;; binding--new ones can't be created. When execution is done, we restore
;; the locals to their former state.
;; This can only be called at top-level. It doesn't return bindings,
;; just a result. The function to be called must take one argument, the
;; bindings.
(let ((locals (get obj 'vars)))
(if (null locals)
;; This is the easy case.
;; We use values to assure that we're only returning one value.
(values (funcall func *globals*))
(let* ((last-cons (last locals))
(*protected-vars* (nconc locals *globals*))
(result (funcall func *protected-vars*)))
(setf (cdr last-cons) nil)
result))))
(defun instantiate (pattern bindings)
;; Create a copy of the pattern with variables replaced by their values. It
;; is an error if there is an unbound variable in the pattern.
(labels ((instantiate-1 (pat bindings)
(cond
((null pat)
nil)
((atom pat)
(if (not (var? pat))
pat
(let ((value (var-value pat bindings)))
(if (eq value :unbound)
(error "Pattern ~a contains unbound variable ~a"
pattern pat)
value))))
(t
(cons (instantiate-1 (car pat) bindings)
(instantiate-1 (cdr pat) bindings))))))
(instantiate-1 pattern bindings)))
;;; End interp.lisp.
jba@wheaties.ai.mit.edu (Jonathan Amsterdam) (06/11/89)
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
;;; The compiler for AAL.
;;; Copyright 1988 by Jonathan Amsterdam. All Rights Reserved.
(provide 'comp)
(requires 'initial "initial.lisp")
;;; The "compiler" is mostly a bunch of macros that handle the top-level forms
;;; in an AAL source file. Usually these macros just expand to lisp
;;; equivalents of the AAL forms (most of that is putting properties on
;;; property lists). Another important job is 'parsing' rules and patterns to
;;; make sure they're in the form that the interpreter expects. Some macros
;;; have a compile-time effect, usually to add or remove something from a list,
;;; because the parser examines these lists to determine how to translate
;;; rules.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Declaring globals. You have to do this to set them.
;;; A spec is a symbol, or a list (<symbol> <value>). The value is not
;;; evaluated in any way; it probably should be, though.
(defmacro global (&rest specs)
`(dolist (spec ',specs)
(if (valid-var-spec? spec)
(pushnew spec *global-specs*)
(error "Illegal global spec: ~a" spec))))
(defun valid-var-spec? (spec)
(or (symbolp spec)
(and (listp spec) (= (length spec) 2) (symbolp (car spec)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Declaring and undeclaring lisp functions. Declaring a lisp function means
;;; that it can be used in patterns and actions without surrounding it by
;;; (lisp ...). You can also undeclare the predeclared functions (see
;;; initial.lisp for a list).
(defmacro lisp (&rest names)
(dolist (name names)
(pushnew name *lisp-names*))
`(dolist (name ',names)
(pushnew name *lisp-names*)))
(defmacro unlisp (&rest names)
(dolist (name names)
(setq *lisp-names* (delete name *lisp-names*)))
`(dolist (name ',names)
(setq *lisp-names* (delete name *lisp-names*))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Actions to take when starting up the game. Usually these will be
;;; assertions, but they can be any action. Actions are done in the order
;;; they're encountered in the file.
;(initially (in keys house)
; (in food house)
; (set *gl 3))
(defmacro initially (&body actions)
`(progn
,@(mapcar #'(lambda (action) `(push ',(list->action action)
*initial-actions*))
actions)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Backward rules.
;(rule (in2 *x *y) <- (in *x *z) (in *z *y))
;(rules ((in2 *x *y) <- (in *x *z) (in *z *y))
; ((under *x *y) <- (on *y *x)))
;
;(rules ((within *x *y) <- (in *x *y))
; ((within *x *y) <- (in *x *z) (within *z *y)))
(defmacro rule (&body body)
(rule-func (list body)))
(defmacro rules (&body body)
(rule-func body))
(defun rule-func (rules)
;; The rules must be added in the order they appear, so that the last will be
;; asserted first; that's because assertions always happen at the beginning
;; of the database, and we want to preserve the order of the rules.
(let ((preds (delete-if #'var? (mapcar #'caar rules))))
(dolist (pred preds)
(pushnew pred *backward-predicates*))
`(progn
,@(mapcar #'(lambda (r) `(push ',(list->b-rule r) *initial-rules*))
rules)
(dolist (pred ',preds)
(pushnew pred *backward-predicates*)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Forward rules.
;;; Forward rules run when something is asserted or retracted. The rules
;;; should be put at the end of their respective lists so they will be checked
;;; in the same order in which they were defined. (The order they're examined
;;; could make a difference.) Each rule can have only a single, simple pattern
;;; that corresponds directly to a fact (no and's, or's, not's, do's, etc.).
;(when-asserted (at *x *place) -> (move *y *place))
(defmacro when-asserted (&body body)
`(setq *assertion-rules* (nconc *assertion-rules* ',(list (list->f-rule body)))))
(defmacro when-retracted (&body body)
`(setq *retraction-rules* (nconc *retraction-rules* ',(list (list->f-rule body)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Timers.
;;; The syntax of these is quite complex and is best explained by example:
;;; (after every turn [starting 0] [from now] <action>*)
;;; (before every 2 ticks ...) [can say "each" instead of every]
;;; (after turn 30 <action>*)
;;; (after 30 turns [from now] ...)
;(timer (after every 3 ticks starting 7 from now
; (at foo bar) (eql t nil)))
;(before turn 30 (at foo bar))
;(after 30 turns from now (at foo bar))
(defmacro timer (timer)
`(push ',(parse-timer timer) *initial-timers*))
(defun parse-timer (timer-list)
(let (a-or-b renew-time-expr turn-or-tick start-time-expr actions
(body (cdr timer-list)))
(setq a-or-b (case (car timer-list)
(after :after)
(before :before)
(otherwise (error "~a must be AFTER or BEFORE" (car timer-list)))))
(cond
((member (first body) '(every each))
(cond
((member (second body) '(turn tick))
(setq renew-time-expr 1)
(setq body (cdr body)))
(t
(setq renew-time-expr (second body))
(setq body (cddr body))))
(setq turn-or-tick (get-turn-or-tick (first body)))
(setq body (cdr body))
(cond
((eq (first body) 'starting)
(setq start-time-expr (second body))
(setq body (cddr body))
(when (and (eq (first body) 'from)
(eq (second body) 'now))
(setq start-time-expr `(+ ,(if (eq turn-or-tick :tick) '*tick* '*turn*)
,start-time-expr))
(setq body (cddr body))))
(t
(setq start-time-expr 0)))
(setq actions body))
((member (first body) '(turn tick))
(setq turn-or-tick (get-turn-or-tick (first body)))
(setq renew-time-expr 0)
(setq start-time-expr (second body))
(setq actions (cddr body)))
(t
(setq renew-time-expr 0)
(setq turn-or-tick (get-turn-or-tick (second body)))
(setq start-time-expr `(+ ,(if (eq turn-or-tick :tick) '*tick* '*turn*)
,(first body)))
(if (and (eq (third body) 'from)
(eq (fourth body) 'now))
(setq actions (cddddr body))
(setq actions (cddr body)))))
`(make-timer :before-after ,a-or-b
:turn-tick ,turn-or-tick
:time-to-run ,start-time-expr
:renew-time ,renew-time-expr
:action ',(list->action (singleton-optimize actions 'block)))))
(defun get-turn-or-tick (thing)
(case thing
((tick ticks) :tick)
((turn turns) :turn)
(otherwise (error "~a should be TURN or TICK" thing))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Commands.
;;; (command <name-or-list> <syntax> <feature-or-keyword-list>* <action>*)
;;; Important: for this syntax to be parsable, it's necessary that no possible
;;; car of an action is a keyword or feature. Otherwise, we can't distinguish
;;; the actions from the keywords and features.
(defmacro command (name-list &body body)
(let ((syntax nil))
(if (not (listp name-list))
(setq name-list (list name-list)))
(when (and (listp (car body)) (eq (caar body) (car name-list)))
(setq syntax (cdar body))
(setq body (cdr body)))
(let* ((name (car name-list))
(actions (member-if
#'(lambda (item) (not (or (feature-spec? item)
(keyword-list? item))))
body)))
(if actions
(setq body (nconc (ldiff body actions) `((actions ,@actions)))))
`(progn
,@(mapcar #'(lambda (sym) `(defprop ,sym ,name command-name)) name-list)
(defprop ,name ,syntax syntax)
(defprop ,name ,(default-requirements-order syntax) requirements-order)
(defprop ,name ,(default-actions-order syntax) actions-order)
(defprop ,name nil command-info)
,@(process-obj-internal name body)))))
(defun default-requirements-order (syntax)
(let ((vars (remove-if-not #'var? syntax)))
(append '(*command *agent) vars '(*loc))))
(defun default-actions-order (syntax)
(let ((vars (remove-if-not #'var? syntax)))
(append '(*agent) vars '(*loc *command))))
(defunp (keyword requirements-order) (name list)
;; Only for commands; it will be ignored if you put it anywhere else.
`((defprop ,name ,(cdr list) requirements-order)))
(defunp (keyword actions-order) (name list)
;; Only for commands; it will be ignored if you put it anywhere else.
`((defprop ,name ,(cdr list) actions-order)))
(defunp (keyword requires) (name list)
;; This is only for commands; it's a bad idea to use it anywhere else. A
;; better implementation would check for this error.
`((add-command-info :requires ',name ',name '*command
,(list->requirements (cdr list)))))
(defunp (keyword actions) (name list)
;; This is only for commands; see above comment.
`((add-command-info :action ',name ',name '*command
',(list->actions (cdr list)))))
(defun get-command-name (word)
(get word 'command-name))
(defun add-command-info (type obj command case thing)
;; Command info is stored on the command-info property of the object, as an
;; alist of alists. The first alist is by command name, the second by case.
(let ((command-alist (command-alist obj command))
(new-info (if (eq type :requires)
(cons case (list thing nil))
(cons case (list nil thing)))))
(if command-alist
(let ((info (cdr (assoc case (cdr command-alist)))))
(if info
(if (eq type :requires)
(setf (first info) thing)
(setf (second info) thing))
(push new-info (cdr command-alist))))
(push (cons command (list new-info))
(get obj 'command-info)))))
(defun command-alist (obj command)
(assoc command (get obj 'command-info)))
(defun get-command-info (obj command case)
(cdr (assoc case (cdr (command-alist obj command)))))
(defun get-requirements (obj command case)
(first (get-command-info obj command case)))
(defun get-action (obj command case)
(second (get-command-info obj command case)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Locations.
;;; (loc <name> [<short-desc>] <long-desc> <feature-or-keyword-list>*)
;;; Locations are just objects; this form is syntactic sugar.
;;; If short-desc is omitted the name, modified to remove hyphens, is used.
(defmacro loc (name &body body)
(let ((initial `(initially (location ,name)))
desc)
(cond
((and (stringp (first body)) (stringp (second body)))
(setq desc `(desc ,(first body)))
(setq body (cdr body)))
(t
(setq desc `(desc ,(symbol->string name)))))
(if (not (stringp (car body)))
(error "For loc ~a: must have a description" name)
(process-obj name
(append (list initial desc
`(description ,(car body)))
(cdr body))))))
;;; (contains <obj>*) for locations only; use (initially (in ...)) for other
;;; things.
(defunp (keyword contains) (name list)
(mapcar #'(lambda (obj) `(push '(assert (at ,obj ,name))
(get ',name 'initial-actions)))
(cdr list)))
;;; (exits (<cmd-list> <action>* [loc])*)
;;; where <cmd-list> is either a single command (symbol) or a list of them, and
;;; loc is a symbol (the name of a location). If loc is omitted, it is assumed
;;; to be name. The actions are converted to rules, and the rules and loc are
;;; combined into a rule-list with the effect that, if no rule fires, the
;;; effect is to move the player to loc. Use this only for locations.
(defunp (keyword exits) (name list)
(mapcan #'(lambda (l) (process-exit-list name l)) (cdr list)))
(defun process-exit-list (name list)
(let* ((cmd-list (if (listp (car list)) (car list) (list (car list))))
(last-item (car (last list)))
(loc (if (symbolp last-item) last-item name))
(actions (if (symbolp last-item) (butlast (cdr list)) (cdr list)))
(rules (mapcar #'(lambda (a) (action->rule (list->action a)))
actions))
(final-rule (list->rule `(-> (move player ,loc))))
(cmd-action `(rule-list ,@rules ,final-rule)))
(mapcan #'(lambda (cmd)
`((defprop ,cmd ,cmd command-name)
(push '(assert (exit ,name ,cmd ,loc)) *initial-actions*)
(add-command-info :action ',name ',cmd '*loc ',cmd-action)))
cmd-list)))
(defun action->rule (action)
(if (eq (car action) 'rule)
action
`(rule nil ,action)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Objects.
;;; (obj name [desc] <feature-or-keyword-list>*)
(defmacro obj (name &body body)
(if (stringp (car body))
(process-obj name (cons `(desc ,(car body)) (cdr body)))
(process-obj name (cons `(desc ,(symbol->string name))
body))))
(defun symbol->string (symbol)
;; Translate hyphens to spaces, and convert to lower case.
(let ((string (string-downcase (symbol-name symbol))))
(dotimes (i (length string))
(if (char= (char string i) #\-)
(setf (char string i) #\space)))
string))
(defun process-obj (name body)
`(progn
(pushnew ',name *objects*)
(defprop ,name nil command-info)
(defprop ,name nil var-specs)
(defprop ,name nil initial-actions)
,@(process-obj-internal name body)))
(defun process-obj-internal (name body)
(let ((result-list (list nil)))
(dolist (item body)
(cond
((feature-spec? item)
(nconc result-list (process-feature-spec name item)))
((not (listp item))
(error "In ~a: unknown feature: ~a" name item))
((keyword-list? item)
(nconc result-list (process-keyword-list name item)))
(t
(error "In ~a: unknown feature or keyword ~a" name (car item)))))
(cdr result-list)))
(defun keyword-list? (thing)
(and (listp thing)
(symbolp (car thing))
(get (car thing) 'keyword)))
(defun feature-spec? (thing)
(or (and (symbolp thing) (get thing 'aal-feature))
(and (listp thing) (symbolp (car thing)) (get (car thing) 'aal-feature))))
(defun process-keyword-list (obj-name klist)
(funcall (get (car klist) 'keyword) obj-name klist))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Features.
;;; Features are treated like macros: their code is just inserted into the
;;; object's definition as if it had been written there directly; first,
;;; though, the arguments are substituted in, including the implicit argument
;;; "self", bound to the name of the object.
;;; You can use "dot notation" to bind many args: e.g. consider
;;; (feature (lockable . things) ...). If an object has: (lockable a b c),
;;; then things gets bound to the list (a b c).
(defmacro feature (name-args &body body)
(let ((name (if (listp name-args) (car name-args) name-args))
(arglist (if (listp name-args) (cdr name-args) nil)))
`(progn
(defprop ,name t aal-feature)
(defprop ,name ,arglist feature-arglist)
(defprop ,name ,body feature-body))))
(defun process-feature-spec (obj-name fspec)
(let* ((feature-name (if (listp fspec) (car fspec) fspec))
(actuals (if (listp fspec) (cdr fspec) nil))
(formals (get feature-name 'feature-arglist))
(body (get feature-name 'feature-body))
(bindings (add-binding 'self obj-name
(bind-args formals actuals obj-name feature-name)))
(new-body (sublis bindings body)))
(cons (make-feature-assertion feature-name bindings)
(process-obj-internal obj-name new-body))))
(defun make-feature-assertion (feature-name bindings)
;; If the obj was described with (feature-name arg1 arg2 ...), then this
;; arranges for the fact (feature-name obj-name arg1 arg2 ...) to be asserted
;; initially.
`(push '(assert (,feature-name ,@(mapcar #'cdr bindings)))
*initial-actions*))
(defun bind-args (formals actuals obj-name feature-name)
;; The binding list is in the same order as the formals. (This is important
;; for make-feature-assertion.)
(cond
((null formals)
(if (null actuals)
nil
(error "In ~a: too many arguments to feature ~a" obj-name feature-name)))
((symbolp formals)
(list (cons formals actuals)))
((null actuals)
(error "In ~a: too few arguments to feature ~a" obj-name feature-name))
(t
(add-binding (car formals) (car actuals)
(bind-args (cdr formals) (cdr actuals)
obj-name feature-name)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Keywords.
;;; (desc <string>) [the short description of an object]
(defunp (keyword desc) (name list)
`((defprop ,name ,(second list) desc)
(push '(assert (desc ,name ,(second list))) *initial-actions*)))
;;; (description <string>) [the long description]
(defunp (keyword description) (name list)
`((defprop ,name ,(second list) description)
(push '(assert (description ,name ,(second list))) *initial-actions*)))
;;; (duration <n>)
(defunp (keyword duration) (name list)
`((defprop ,name ,(second list) duration)))
;;; (score <max-action> [<action>])
(defunp (keyword score) (name list)
(let* ((max-action (second list))
(action (or (third list) max-action)))
`((defprop ,name ,(list->action action) score)
(defprop ,name ,(list->action max-action) max-score))))
;;; (command <command-name> <case> [(requires ...)] <actions>)
(defunp (keyword command) (name list)
(process-reqs-and-actions name (second list) (third list) (cdddr list)))
(defun process-reqs-and-actions (name command-name case list)
;; Expects a list of the form ([(requires <reqs>)] <action>*)
(let (requires action)
(cond
((requires-form? (car list))
(setq requires (list->requirements (cdar list)))
(setq action (list->actions (cdr list))))
(t
(setq requires nil)
(setq action (list->actions list))))
`((add-command-info :requires ',name ',command-name ',case ,requires)
(add-command-info :action ',name ',command-name ',case ',action))))
(defun requires-form? (thing)
(and (listp thing) (eq (car thing) 'requires)))
;;; (initially <fact>*). The difference between this and top-level "initially"
;;; is that here, the object's local variables can be accessed. Also, all
;;; local initializations are done before the top-level ones, in the order in
;;; which they appear in the file.
(defunp (keyword initially) (name list)
(mapcar #'(lambda (action)
`(push ',(list->action action) (get ',name 'initial-actions)))
(cdr list)))
;;; (var <var-spec>*)
(defunp (keyword var) (name list)
(process-vars name (cdr list)))
;;; This is just a synonym for var.
(defunp (keyword vars) (name list)
(process-vars name (cdr list)))
(defun process-vars (name specs)
(dolist (spec specs)
(if (not (valid-var-spec? spec))
(error "In ~a: invalid variable spec: ~a" name spec)))
(mapcar #'(lambda (spec) `(push ',spec (get ',name 'var-specs)))
specs))
;;; End comp.lisp.