;;; -*- Mode: LISP; Package: PENMAN -*-
(in-package "PENMAN")

;;;========================================================================
;;; 
;;; General structures for instantial linguistic objects...  
;;; ----------------------------------------------------
;;;
;;;     The following structures and operations on structures provides
;;; a generalized treatment of syntagmatic structures that can be
;;; triggered via realization constraints in the traversal of system
;;; networks. The structures are meant to be linguistically
;;; transparent, thereby aiding further extensions on syntagmatic
;;; representations in the future. These definitions should eventually
;;; replace the structure building operations used within
;;; (ISI-)Penman.
;;;
;;;                                     John Bateman: IPSI: 7 Oct 1993
;;;========================================================================


;;;========================================================================
;;; The structures...

(defstruct paradigmatic-unit
  (selection-expression nil :type list)
  (stratum nil :type symbol)
  )

(defstruct syntagmatic-unit
  (parent nil :type symbol)
  (children nil :type list)
  (intra-stratal-constraints nil)
  (inter-stratal-constraints-above nil)
  (inter-stratal-constraints-below nil)
  (inter-stratal-constraints-general nil)
  (labels nil :type list)
  (exponent nil :type (or string symbol list inter-axis-relation))
  (stratum nil :type symbol)
  )

(defstruct syntagmatic-configuration
  (units nil :type list)
  (ordering-constraints nil :type list)
  (stratum nil :type symbol)
  )

(defstruct inter-axis-relation
  (para nil :type (or paradigmatic-unit null))
  (synt nil :type (or syntagmatic-configuration null))
  (stratum nil :type symbol)
  )

(defstruct inter-stratal-relation
  (upper nil :type (or null inter-axis-relation))
  (lower nil :type list)
  (stratum nil :type symbol)
  )

(defstruct canned-text-realization
  (text "" :type string))

;;;--------------------------------------------------------------------------------
;;; Places to keep the structures...

(defvar *labelled-units-table* (make-hash-table))
(defvar *syntagmatic-units-table* (make-hash-table))

;;;  ... and ways of binding them all together...

(defvar *inter-stratal-relations* nil)


;;;--------------------------------------------------------------------------------
;;; Ways of doing stuff with structures...

(defun MICRO-FN-LABEL (label cycle)
  "returns, creating if new, a cycle-unique internal label for a unit"
  (let* ((cycle-info (gethash cycle *labelled-units-table*))
	 (label? (gethash label cycle-info)))
    (cond ((not label?)
	   (setf label? (gentemp "INST-" 'penman))
	   (setf (gethash label cycle-info) label?)))
    label?))

(defun MAKE-CYCLE-INSTANCES-RECORD (&optional (cycle-label "CYCLE-"))
  (let ((cycle-id (gentemp cycle-label 'penman)))
    (setf (gethash cycle-id *labelled-units-table*)
	  (make-hash-table))
    cycle-id))

(defun MAKE-LABELLED-SYNTAGMATIC-UNIT-INSTANCE 
  (&key (parent nil)
	(children nil)
	(intra-stratal-constraints nil)
	(inter-stratal-constraints-above nil)
	(inter-stratal-constraints-below nil)
	(labels nil)
	(exponent nil)
	(stratum nil))
  (let ((label (gentemp "INST-" 'penman)))
    (setf (gethash label *syntagmatic-units-table*)
	  (make-syntagmatic-unit
	   :parent parent
	   :children children
	   :intra-stratal-constraints intra-stratal-constraints
	   :inter-stratal-constraints-above inter-stratal-constraints-above
	   :inter-stratal-constraints-below inter-stratal-constraints-below
	   :labels labels
	   :exponent exponent
	   :stratum stratum))
    label))

;;; Some shorthand...

(defun MICRO-FN (unit)
  (gethash (micro-fn-label unit *current-cycle*) *syntagmatic-units-table*))

(defun MICRO-FN-UPDATER (unit value)
  (setf (gethash (micro-fn-label unit *current-cycle*) *syntagmatic-units-table*)
	value))

(defsetf MICRO-FN micro-fn-updater)

(defun LABEL-DEREF (internal-label)
  "Returns the syntagmatic-unit(configuration) with the given internal label; the
   label *TOP* always points to the topmost syntagmatic unit configuration."
  (if (eq internal-label '*TOP*)
      (inter-axis-relation-synt *top*)
      (gethash internal-label *syntagmatic-units-table*)))

(defun COLLECT-PARENT-INSTANCES (instance-label)
  (cond ((eq (syntagmatic-unit-parent (label-deref instance-label)) '*TOP*)
	 nil)
	(t
	 (cons
	  (syntagmatic-unit-parent (label-deref instance-label))
	  (collect-parent-instances
	   (syntagmatic-unit-parent (label-deref instance-label)))))))


(defun PARENT-OF (mf1 mf2)
  "Returns true if mf1 is a parent of mf2"
  (member (micro-fn-label mf1 *current-cycle*)
	  (collect-parent-instances (micro-fn-label mf2 *current-cycle*))))

;;;========================================================================


;;;---------------------------------------------------------------------------
;;; A variety of display functions for debugging and looking at actualization 
;;; progress...

(defun show-active-labels (&optional (this-cycle? nil))
  (format t "~% Currently active internal labels are:")
  (cond (this-cycle?
	 (format t " (for this cycle)")
	 (maphash #'(lambda (key val)
			    (format t "~%  Label: ~A with value: ~A" key val))
			(gethash *current-cycle* *labelled-units-table*)))
	(t
	 (maphash #'(lambda (key val)
	       (format t "~%  >> For cycle: ~A" key)
	       (maphash #'(lambda (key val)
			    (format t "~%  Label: ~A with value: ~A" key val))
			(gethash key *labelled-units-table*)))
	   *labelled-units-table*))))

(defun show-systemic-instances ()
  (format t "~% Current systemic instances are :")
  (maphash #'(lambda (key val)
	       (format t "~%  Unit: ~A with value: ~A" key val))
	   *syntagmatic-units-table*))

(defun show-active-labels-and-instances ()
  (format t "~% Currently active instances with their labels are:")
  (maphash #'(lambda (key val)
	       (format t "~%  >> For cycle: ~A" key)
	       (maphash #'(lambda (key val)
			    (format t "~%  Label: ~A with internal label: ~A ~%      ~
       and value: ~A" 
				    key val (gethash val *syntagmatic-units-table*)))
			(gethash key *labelled-units-table*)))
	   *labelled-units-table*))

(defun syntagmatic-structure-to-list (units)
  (mapcar #'(lambda (su)
	      (if (syntagmatic-unit-children (label-deref su))
		  (cons
		    (syntagmatic-structure-to-list
		      (syntagmatic-unit-children (label-deref su)))
		    (feature-pack (syntagmatic-unit-labels (label-deref su))))
		  (feature-pack (syntagmatic-unit-labels (label-deref su)))))
	  units))

(defun syntagmatic-configuration-to-list (config)
  (syntagmatic-structure-to-list (syntagmatic-configuration-units config)))

(defun synt ()
  "Show current syntagmatic organization structure"
  (syntagmatic-configuration-to-list (inter-axis-relation-synt *top*)))


;;;========================================================================
;;;
;;; Generalized structure building operations... (to form basis of all
;;; realization statements)
;;;----------------------------------------------------------------------
;;; assumed global variables:
;;;   *top* contains the topmost interaxis relation for the current cycle
;;;         (defined in network traversal).
;;;   *current-cycle* contains an identifier for the current cycle
;;;         (defined in network traversal).
;;;   *current-stratum* contains the current stratum being realized
;;;         (defined in network traversal).
;;;----------------------------------------------------------------------
;;; internal functions, not intended for direct use in structure building...

(defun FORCE-FUNCTION-TO-EXIST (microfunction)
  "If the microfunction does not exist for the current cycle, it is created"
  (cond ((micro-fn microfunction)
	 nil)
	(t (setf (micro-fn microfunction)
		 (make-syntagmatic-unit :parent '*TOP*
					:labels (list microfunction)
					:stratum *current-stratum*))
	   (push (micro-fn-label microfunction *current-cycle*)
		 (syntagmatic-configuration-units 
		  (inter-axis-relation-synt *top*)))
	   T)))


(defun PROCESS-LEAVES-OF-SYNTAGMATIC-UNIT (units function)
  "Apply function to the leaves of the unit structure."
  (mapcar #'(lambda (unit)
	      (cond ((syntagmatic-unit-children (label-deref unit))
		     (PROCESS-LEAVES-OF-SYNTAGMATIC-UNIT
		      (syntagmatic-unit-children (label-deref unit)) function))
		    (t
		     (apply function (list unit))
		     )))
	  units))

(defun PROCESS-NONLEAVES-OF-SYNTAGMATIC-UNIT (units function)
  "Apply function to the nonterminals of the unit structure."
  (mapcar #'(lambda (unit)
	      (cond ((syntagmatic-unit-children (label-deref unit))
		     (apply function (list unit))
		     (PROCESS-NONLEAVES-OF-SYNTAGMATIC-UNIT
		      (syntagmatic-unit-children (label-deref unit)) function))
		    (t
		     nil)))
	  units))


;;;----------------------------------------------------------------------
;;; the generalized structure builders themselves...

(defun GENERALIZED-INSERT (microfunction)
 (let ((not-exists? (force-function-to-exist microfunction)))
  (if (member (micro-fn-label microfunction *current-cycle*)
	      *expanded-not-yet-inserted-list*)
      (setf *expanded-not-yet-inserted-list* 
	    (delete (micro-fn-label microfunction *current-cycle*) 
	      *expanded-not-yet-inserted-list*))
      (unless not-exists?
	(warning "Microfunction: " microfunction " already inserted in this cycle.")))))


;;; Generalized expansion takes two microfunctions and creates
;;; subconstituency that is rank internal. Microfunction mf2 is
;;; constrained to be a subconstituent of microfunction mf1. In terms
;;; of internal structure, mf2 is
;;; i) removed from the units of its current configuration or,
;;; if it is already subject to expansion, from the list of children
;;; units of its parent.
;;; ii) added to the children list of the unit mf1. 


(defun GENERALIZED-EXPAND (mf1 mf2)
  "Microfunction mf1 is expanded to include microfunction mf2 as sub-unit"
  (let* ((mf1-not-exist? (force-function-to-exist mf1))
	 (mf2-not-exist? (force-function-to-exist mf2))
	 (mf1-top-level? (eq (syntagmatic-unit-parent (micro-fn mf1)) '*TOP*))
	 (mf2-top-level? (eq (syntagmatic-unit-parent (micro-fn mf2)) '*TOP*))
	 (mf2-label (micro-fn-label mf2 *current-cycle*)))

    (cond ((not mf2-top-level?)
	   (warning "Cannot expand using the already subordinated unit: " mf2))
	  (t 
	   (push mf2-label (syntagmatic-unit-children (micro-fn mf1)))
	   (setf (syntagmatic-unit-parent (micro-fn mf2)) 
		 (micro-fn-label mf1 *current-cycle*))
	   
	   (setf (syntagmatic-configuration-units
		  (inter-axis-relation-synt *top*))
		 (delete mf2-label 
			 (syntagmatic-configuration-units
			  (inter-axis-relation-synt *top*)))))
	  
	   (if mf1-not-exist? (push (micro-fn-label mf1 *current-cycle*)
				    *expanded-not-yet-inserted-list*))
	   
	   (setf (syntagmatic-unit-parent (micro-fn mf2)) 
		 (micro-fn-label mf1 *current-cycle*)))))


;;; ordering: note that all ordering information is entered at the configuration
;;; level, since precise relationships can alter due to expansions. The detailed
;;; ordering then must be calculated following traversal, first by percolating 
;;; constraints down to appropriate (subrank) units, and then working out the
;;; ordering within those units.

(defun GENERALIZED-ORDER (mf1 mf2)
  "Microfunction mf1 is ordered immediately before mf2"

 (push `(,(micro-fn-label mf1 *current-cycle*) 
	 before 
	 ,(micro-fn-label mf2 *current-cycle*))
       (syntagmatic-configuration-ordering-constraints
	(inter-axis-relation-synt *top*))))
       
(defun GENERALIZED-PRECEDE (mf1 mf2)
  "Microfunction mf1 is ordered somewhere before mf2"

 (push `(,(micro-fn-label mf1 *current-cycle*) 
	 precedes 
	 ,(micro-fn-label mf2 *current-cycle*))
       (syntagmatic-configuration-ordering-constraints
	(inter-axis-relation-synt *top*))))

(defun GENERALIZED-FINAL (mf1)
  "Microfunction mf1 is position finally among its siblings"

  (push `(,(micro-fn-label mf1 *current-cycle*) 
	 final)
       (syntagmatic-configuration-ordering-constraints
	(inter-axis-relation-synt *top*))))
       
(defun GENERALIZED-INITIAL (mf1)
  "Microfunction mf1 is position initially among its siblings"

  (push `(,(micro-fn-label mf1 *current-cycle*) 
	 initial)
       (syntagmatic-configuration-ordering-constraints
	(inter-axis-relation-synt *top*))))
       
;;; Conflation/Unification...  The conditions on conflation are that
;;; one (or both) of the microfunctions are at the top level in their
;;; configuration (and does not include the outher microfunction as a
;;; subconstituent), or they are both at the same level of subrank
;;; constituency, i.e., they are siblings. That is, differing parents
;;; only works iff one of the parents is *TOP* and that parent doesn't
;;; have the other as a child.

(defun GENERALIZED-CONFLATE (mf1 mf2)
  "Combines mf1 and mf2 to become the same structural instance"

  (let* ((mf1-not-exist? (force-function-to-exist mf1))
	 (mf2-not-exist? (force-function-to-exist mf2))
	 (parent1 (syntagmatic-unit-parent (micro-fn mf1)))
	 (parent2 (syntagmatic-unit-parent (micro-fn mf2)))
	 (mf1-top-level? (eq parent1 '*TOP*))
	 (mf2-top-level? (eq parent2 '*TOP*))
	 subsumer subsumee)

    (cond ((and (not (eq parent1 parent2))
		(or
		 (not mf1-top-level?)
		 (parent-of mf1 mf2))
		(or 
		 (not mf2-top-level?)
		 (parent-of mf2 mf1)))
	   (warning "Cannot conflate conflictingly structured microfunctions: " 
		    mf1 " and " mf2))
	  ((eq (micro-fn-label mf1 *current-cycle*)
	       (micro-fn-label mf2 *current-cycle*))
	   "already conflated, nothing to do!")
	  (t
	   (cond ((eq parent1 parent2) (setf subsumee mf2 subsumer mf1))
		 (mf1-top-level? (setf subsumee mf1 subsumer mf2))
		 (mf2-top-level? (setf subsumee mf2 subsumer mf1)))

	   (instance-subsume subsumer subsumee)))))

;;;   Function subsumee is made redundent by adding its information
;;; into subsumer, references to subsumee in its parent are removed,
;;; and subsequently the label for subsumee that is used is that of
;;; subsumer.

(defun INSTANCE-SUBSUME (subsumer subsumee)
  "Function subsumee is made redundent by adding its information into subsumer"
  (let* ((subinstance (micro-fn subsumee))
	 (parent (label-deref (syntagmatic-unit-parent subinstance))))

    (cond ((eq (syntagmatic-unit-parent subinstance) '*TOP*)
	   (setf (syntagmatic-configuration-units
		  (inter-axis-relation-synt *top*))
		 (delete (micro-fn-label subsumee *current-cycle*)
			 (syntagmatic-configuration-units
			  (inter-axis-relation-synt *top*)))))
	  (t
	   (setf (syntagmatic-unit-children parent)
		 (delete (micro-fn-label subsumee *current-cycle*)
			 (syntagmatic-unit-children parent)))))

    (setf (syntagmatic-unit-children (micro-fn subsumer))
	  (append
	   (syntagmatic-unit-children (micro-fn subsumer))
	   (syntagmatic-unit-children subinstance))
	  
	  (syntagmatic-unit-intra-stratal-constraints (micro-fn subsumer))
	  (append
	   (syntagmatic-unit-intra-stratal-constraints (micro-fn subsumer))
	   (syntagmatic-unit-intra-stratal-constraints subinstance))

	  (syntagmatic-unit-inter-stratal-constraints-above (micro-fn subsumer))
	  (append
	   (syntagmatic-unit-inter-stratal-constraints-above (micro-fn subsumer))
	   (syntagmatic-unit-inter-stratal-constraints-above subinstance))

	  (syntagmatic-unit-inter-stratal-constraints-below (micro-fn subsumer))
	  (append
	   (syntagmatic-unit-inter-stratal-constraints-below (micro-fn subsumer))
	   (syntagmatic-unit-inter-stratal-constraints-below subinstance))

	  (syntagmatic-unit-inter-stratal-constraints-general (micro-fn subsumer))
	  (append
	   (syntagmatic-unit-inter-stratal-constraints-general (micro-fn subsumer))
	   (syntagmatic-unit-inter-stratal-constraints-general subinstance))

	  (syntagmatic-unit-labels (micro-fn subsumer))
	  (append
	   (syntagmatic-unit-labels (micro-fn subsumer))
	   (syntagmatic-unit-labels subinstance)))

    (setf (gethash subsumee (gethash *current-cycle* *labelled-units-table*))
	(micro-fn-label subsumer *current-cycle*))
    ))
       

;;; Preselect adds features simply to the intra stratal constraints slot
;;; of the selected unit...

(defun GENERALIZED-PRESELECT (mf1 feature)
  "Microfunction mf1 is preselected to include feature at same stratum"
  (let ((mf1-not-exist? (force-function-to-exist mf1)))
    (pushnew feature
	     (syntagmatic-unit-intra-stratal-constraints (micro-fn mf1)))))



;;;========================================================================
;;; ORDERING...
;;;
;;; Following creation of a fully specified syntagmatic unit, the
;;; constraints on ordering of the involved constituent must be
;;; resolved. This is best done when all the information is available
;;; and so should be triggered at earliest when a network-traversal is
;;; complete. More sophisticated ordering behaviour may require even
;;; further delay before ordering resolution.
;;;
;;; A function is defined: resolve-order, which takes a syntagmatic 
;;; configuration as argument. On returning from the function, the
;;; ordering constraints of the configuration contain an extra
;;; entry identified as RESOLVED. This is a straightforward list
;;; of lists with left-to-right ordering reflecting the resolved
;;; ordering of the relevant constituents. 
;;;
;;; This version is still very basic, and does not yet handle defaults...

(defun RESOLVE-ORDER (configuration)
  (let ((top-most-resolved-order (resolve-order-internal configuration)))
  (setf (syntagmatic-configuration-ordering-constraints configuration)
	(cons 'RESOLVED 
	      (syntagmatic-configuration-ordering-constraints configuration)))))


(defun RESOLVE-ORDER-INTERNAL (configuration)
  (let ((units-to-resolve (syntagmatic-configuration-units configuration))
	(constraints (syntagmatic-configuration-ordering-constraints configuration)))
    (percolate-ordering-constraints units-to-resolve constraints)
    (process-nonleaves-of-syntagmatic-unit units-to-resolve #'resolve-children-order)
    (resolve-units-order configuration)))


(defun PERCOLATE-ORDERING-CONSTRAINTS (unit-label-list constraints)
 "percolate relevant ordering constraints down to expanded units"
 (dolist (unit-label unit-label-list)
	  (let* ((unit (label-deref unit-label))
		 (subunit-label-list (syntagmatic-unit-children unit)))
	    (dolist (subunit-label subunit-label-list)
		    (dolist (c constraints)
			   (if (member subunit-label c)
			       (setf 
				(syntagmatic-unit-intra-stratal-constraints unit)
				(cons
				 c
				 (syntagmatic-unit-intra-stratal-constraints unit)))))
		    (setf 
		     (syntagmatic-unit-intra-stratal-constraints unit)
		     (remove-duplicates
		      (syntagmatic-unit-intra-stratal-constraints unit)
		      :test #'equal)))
	    (percolate-ordering-constraints subunit-label-list constraints))))




(defun COLLECT-ORDERING-CONSTRAINTS (constraints)
  "temporalily: all lists are ordering constraints..."
  (remove nil
	  (remove-duplicates
	   (mapcar #'(lambda (e) (if (consp e) e
				   nil)) constraints))))
  

(defun RESOLVE-CHILDREN-ORDER (unit-label)
  (let* ((unit (label-deref unit-label))
	 (units-to-order (syntagmatic-unit-children unit))
	 (constraints (syntagmatic-unit-intra-stratal-constraints unit))
	 (ordering-constraints (collect-ordering-constraints constraints)))
    (cond ((eq (length units-to-order) 1)
	   t)
	  (t
	   (setf 
	    (syntagmatic-unit-children unit)
	    (resolve-unit-order units-to-order ordering-constraints))))))

(defun RESOLVE-UNITS-ORDER (configuration)
  (let* ((units-to-order (syntagmatic-configuration-units configuration))
	 (constraints (syntagmatic-configuration-ordering-constraints configuration))
	 (ordering-constraints (collect-ordering-constraints constraints))
	 (filtered-constraints (remove-duplicates-and-nil 
				       (mapcar #'(lambda (e) 
						   (cond ((intersection e units-to-order)
							  e)
							 (t nil))) 
					       ordering-constraints))))
    (cond ((eq (length units-to-order) 1)
	   t)
	  (t
	   (setf 
	    (syntagmatic-configuration-units configuration)
	    (resolve-unit-order units-to-order filtered-constraints))))))


;;;--------------------------------------------------------------------------------
;;; following takes a first bash... (should work for complete orderings...)


(defstruct orderer
  (left nil)
  (right nil))

(defun RESOLVE-UNIT-ORDER (units-to-order constraints)
  (let ((ordering-table (make-hash-table))
	(from-left nil)
	(from-right nil)
	(units-still-to-order nil))
    (dolist (unit units-to-order)
	    (setf (gethash unit ordering-table)
		  (make-orderer :left (get-left-of unit constraints)
				:right (get-right-of unit constraints))))
    (dolist (c constraints)
	    (cond ((eq (second c) 'final)
		   (setf (gethash '*END* ordering-table)
			 (make-orderer :left (first c)
				      :right '*END*)))
		  ((eq (second c) 'initial)
		   (setf (gethash '*BEGIN* ordering-table)
			 (make-orderer :left '*BEGIN*
				     :right (first c))))))
    (when show-ordering-events
	  (format t  "Ordering table computed:")
	  (maphash #'(lambda (key value) 
		       (print key)(pprint value)) ordering-table))
    (when (gethash '*BEGIN* ordering-table)
	  (setf from-left (remove '*BEGIN*
				  (collect-rights-of '*BEGIN* ordering-table))))
    (when (gethash '*END* ordering-table)
	  (setf from-right (remove '*END* 
				   (collect-lefts-of '*END* ordering-table))))
    (setf units-still-to-order (set-difference units-to-order 
					       (append from-left from-right)))
    (dolist (u units-still-to-order)
	    (let ((rights (collect-rights-of u ordering-table))
		  (lefts  (collect-lefts-of u ordering-table)))
	      (when (eq (length rights) (length units-still-to-order))
		    (return-from RESOLVE-UNIT-ORDER
				 (append from-left rights from-right)))
	      (when (eq (length lefts) (length units-still-to-order))
		    (return-from RESOLVE-UNIT-ORDER
				 (append from-left lefts from-right)))))
    (append from-left units-still-to-order from-right)  ;; should recurse here on the remainder...
    ))                                                  ;; with the longest lists removed or somesuch...


(defun GET-LEFT-OF (unit constraints)
  (let ((lefts 
	 (remove-duplicates-and-nil
	  (mapcar #'(lambda (e) (cond ((and
					(equal (third e) unit)
					(equal (second e) 'before))
				       (first e))
				      (t
				       nil)))
		  constraints))))
    (when (> (length lefts) 1)
	  (warning "Ordering error (left) of " unit " wrt " lefts))
    (first lefts)))



(defun GET-RIGHT-OF (unit constraints)
  (let ((rights 
	 (remove-duplicates-and-nil
	  (mapcar #'(lambda (e) (cond ((and
					(equal (first e) unit)
					(equal (second e) 'before))
				       (third e))
				      (t
				       nil)))
		  constraints))))
    (when (> (length rights) 1)
	  (warning "Ordering error (right) of " unit " wrt " rights))
    (first rights)))


(defun COLLECT-LEFTS-OF (unit ordering-table)
  (cond ((null unit) nil)
	(t
	 (append (COLLECT-LEFTS-OF 
		  (orderer-left
		   (gethash unit ordering-table))
		  ordering-table)
		 (list unit)))))

(defun COLLECT-RIGHTS-OF (unit ordering-table)
  (cond ((null unit) nil)
	(t
	 (cons unit
	       (COLLECT-RIGHTS-OF
		(orderer-right
		 (gethash unit ordering-table))
		ordering-table)))))



;;;--------------------------------------------------------------------------------
;;; working on order.... maybe take Penman code?

;;; the ordering is not yet resolved!................

(defun leftmostunit (unit-label-list constraints)
  (dolist (unit-label unit-label-list)
	  	 (dolist (c constraints)
		  (if (and (eq (first  c) unit-label)
			   (eq (second c) 'initial))
		      (return-from leftmostunit (first c))))))

(defun get-following-unit (unit-label constraints)
  (dolist (c constraints)
	  (if (and (eq (first c) unit-label)
		   (eq (second c) 'precedes))
	      (return-from get-following-unit (third c)))))

	       
;;;----------------------------------------------------------------------
;;; odds and ends...

(defun LIST-OR-ATOM (x)
  (cond ((listp x)
	 (if (eq (length x) 1)
	     (first x)
	   x))
	(t x)))

(defun WHERE-INSERTED (microfunction)
  (remove-duplicates-and-nil
   (mapcar #'(lambda (pair)
	       (when (eq (car pair) microfunction)
		     (cdr pair)))
	   *register-microfunction-inserts*)))





