AAL sources (5 of 8)

[Jonathan Amsterdam]

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