AAL sources (8 of 8)

[Jonathan Amsterdam]

;;; -*- 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.