AAL sources (8 of 8)
Jonathan Amsterdam
jba at wheaties.ai.mit.edu
Sun Jun 11 07:33:53 AEST 1989
;;; -*- 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 , at 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 , at 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.
More information about the Alt.sources
mailing list