;; The following macros are self explanitory.
;; All but "def-net" have to do with manipulating an *agenda* entry.

(defmacro def-net (name . body)
  `(setq ,name ',body))

(defmacro push-stack (symbol)
  `(push ,symbol *pstack*))

(defmacro get-sentence (list)
  `(car ,list))

(defmacro get-stack (list)
  `(cadr ,list))

(defmacro get-regs (list)
  `(caddr ,list))

(defmacro get-actions (list)
  `(cdddr ,list))

;; ----------------------------------------------------------------------------------

;; "set-register" sticks a '$' in fron of "register-type" and sets its
;; value to "value."  "rem-register" is called with the register.  It
;; adds it to the list of active registers.  "value" is returned.

(defun set-register (register-type value)
  (let ((reg (implode (cons '$ (explode register-type)))))
    (set reg value)
    (rem-register reg)
    value))

;; "rem-register" sticks "register" on *registers* if it is not already there.

(defun rem-register (register)
  (cond ((not (memq register *registers*)) (setq *registers* (cons register *registers*)))))

;; "push-agenda," through some yucky list hacking, saves the current
;; environment onto *agenda*.  See comment below for "make-bindings."

(defun push-agenda (actions)
  (push (cons *s* (append (list (make-bindings *pstack*)
				(make-bindings *registers*))
			  actions))
	*agenda*))
 
;; "make-bindings" takes a list of atoms as input (although it could be a
;; list of other things).  For each atom it creates a list who's car is
;; the atom and whose cdr is the value of the atom.  It returns the list
;; of these lists.  I don't know if there is a predefined lisp funtion
;; having to do with assoc that does this.

(defun make-bindings (symbols)
  (mapcar (function (lambda (symbol)
		      (cons symbol (eval symbol))))
	  symbols))

;; "node-bindings" basically does the reverse of "make-bindings."  it
;; goes through the bindings list setting the car of each element to
;; the cdr.

(defun node-bind (bindings-list)
  (mapcar (function (lambda (bindings)
		      (set (car bindings) (cdr bindings))
		      (car bindings)))
	  bindings-list))

;; "add-node" is esential for setting up the parse tree.  It takes "symbol"
;; and adds it to the value of the first thing on the *pstack* which
;; conceptually makes "symbol" a node of the current parse-node being
;; worked on.  It then sets the property "type" of "symbol" to be
;; whatever kind of node "symbol" is ("kind").  It also sets the property
;; "higher-node" to be the parent node, or first thing on the *pstack*.

(defun add-node (symbol kind)
  (set symbol nil)
  (let ((higher-node (car *pstack*)))
    (cond ((not (null higher-node))
	   (set higher-node (cons symbol (eval higher-node)))))
    (putprop symbol kind 'type)
    (putprop symbol higher-node 'node-of)))

;; "print-tree" is given the top node of a section of the parse tree, when
;; called from "atn" it is given the top of the whole parse tree.
;; "branches" is bound to the value of "top-node."  If branches is an
;; atom it means that it is a word at the end of a branch.  The list
;; of the type of word and the word is returned.  If branches isn't an
;; atom it is a list of nodes, or branches.  A list who's car is
;; the type of node "top-node" is and who's cdr is "print-tree" of
;; each of the branch nodes (in reverse order) is returned.
;; If "print-tree" is given null then there was a bad parse.

(defun print-tree (top-node)
  (let ((branches (eval top-node)))
    (cond ((null top-node) (format t "Bad sentence") nil)
	  ((null branches) (format t "Something wrong found no brancehs for ~a ~%" top-node) nil)
	  ((atom branches) (list (get top-node 'type) branches))
	  (t
	   (cons (get top-node 'type)
		 (mapcar (function print-tree) (reverse branches)))))))

;; "part-of-speech" goes through the dictionary looking for "word."
;; If it finds it it checks to see if it is of type "pos."  If so it
;; returns the rest of the dictionary entry which is used by other
;; functions.

(defun part-of-speech (word pos)
  (mapcan (function (lambda (entry)
		      (cond ((eq word (car entry))
			     (memq pos (cdr entry)))
			    (t nil))))
	  *dictionary*))


;; "get-node" is given a list of nodes.  It cdr's down the list checking
;; each node to see if its "type" property  is of type "type."
;; If so it returns that node.

(defun get-node (type nodes)
  (let ((n (car nodes)))
    (cond ((null n) nil)
	  ((eq type (get n 'type)) n)
	  (t (get-node type (cdr nodes))))))

;; "info" is a list of stuff returned by "part-of-speech."  "set-feature"
;; goes down this lists looking for elements that are lists "(tense past)."
;; For each one it finds it sets the property of the car of that list
;; of "node" to be the cdr of that list.

(defun set-features (node info)
  (cond ((atom info) nil)
	(t (mapc (function (lambda (data)
			     (cond ((listp data) (putprop node (cdr data) (car data))))))
		 info))))

;; "get-feature" gets "feature" off of "node"s property list.  If the
;; enrty is null it returns the "default-value" for that feature.

(defun get-feature (feature node)
  (cond ((or (not (atom feature)) (not (atom node)) (null node))
	 (format t "Cannot get feature: ~a from node ~a~%" feature node) nil)
	((get node feature))
	(t (default-value feature))))

;; "default-value" returns the default value for the given "feature."

(defun default-value (feature)
  (selectq feature
    (tense (list 'tenseless 'present))
    (mood (list 'statement))
    (n-number (list '|3s|))
    (v-number (list '|1s| '|2s| '|1p| '|2p| '|3p|))
    (dative (list 'no))
    (othereise nil)))

;; "thing1" and "thing2" can be atoms or lists.  If they are both atoms
;; "intersectp" succeeds if they are eq.  If one is an atom and
;; is a memq of the other it succeeds.  If they are both lists and
;; an element of one is a memq then it succeeds.

(defun intersectp (thing1 thing2)
  (cond ((and (atom thing2) (atom thing1)) (eq thing1 thing2))
	((atom thing2) (memq thing2 thing1))
	((atom thing1) (memq thing1 thing2))
	(t (mapcan (function (lambda (symbol)
			       (memq symbol thing2)))
		   thing1))))

;; "last" cdr's down the list until it hits the last element which it
;; returns.

(defun last (list)
  (cond ((null (cdr list)) (car list))
	(t (last (cdr list)))))

;; "butlast" cdr's down the list creating a new list of its elements as
;; it goes.  It stops when it is on the last element and returns nil
;; to end the running list.

(defun butlast (list)
  (cond ((null (cdr list)) nil)
	(t (cons (car list) (butlast (cdr list))))))