;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - NFS Share File - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package 'util :use '(lisp))

;the following allows this file to be loaded without having loaded emacs-eval.lisp
;This allows the utility package to be used when there is no ilisp present.

(eval-when (compile load eval)
  (unless (fboundp 'emacs-eval)
    (export 'emacs-eval)
    (defun emacs-eval (&rest args)
      (declare (ignore args))
      nil))

  (unless (fboundp 'emacs-indent)
    (defmacro emacs-indent (&rest args)
      (declare (ignore args))
      nil))

  (unless (fboundp 'rprint)
    (defun rprint (x)
      (let ((*print-level* 150)
	    (*print-length* 150))
	(pprint x)))))

(export '(emacs-eval emacs-indent rprint))

#-Symbolics
(defmacro lambda (vars &body body)
  `#'(lambda ,vars ,@body))

(export 'defexport)

(eval-when (compile load eval)
  (defmacro defexport (name args &body body)
    `(progn (export ',name)
	    (defun ,name ,args ,@body))))

(export 'defexportmacro)
;(emacs-indent defexportmacro 2)

(defmacro defexportmacro (name args &body body)
  `(progn (export ',name)
	  (defmacro ,name ,args ,@body)))

(defexportmacro definline (name vars &body body)
  `(progn (proclaim '(inline ,name))
	  (defun ,name ,vars ,@body)
	  ,@(when (null (rest body))
	      `((define-setf-method ,name ,vars
		  (multiple-value-bind
		      (temps vals stores store-form access-form)
		      (get-setf-method
		       (sublis (mapcar (lambda (var val)
					 (cons var val))
				       ',vars (list ,@vars))
			       ',@body))
		    (values temps vals
			    stores store-form access-form)))))))

;     (definline foo (x)  (car x))

;(define-setf-method foo (x)
;    (mul-val-bind (t v s st ac)
;	 (get-setf-method (sublis (mapcar (lambda (var)
;					    (cons var (symbol-value var)))
;					  '(x y z))
;				  'body)
;				  (list (cons 'x x))
;				  (values t v s st ac)))
;
;
;(setf (foo node) 5)

(defexportmacro defnotinline (name vars &body body)
  `(progn (proclaim '(notinline ,name))
	  (defun ,name ,vars ,@body)))

;;(defexportmacro property-macro (symbol)
;;  `(definline ,symbol (x) (get x ',symbol)))
;;	  (defsetf ,symbol (sym) (value)
;;	    `(setf (get ,sym ',',symbol) ,value))))

(defexportmacro property-macro (symbol)
  `(defmacro ,symbol (x)
     (list 'get x '',symbol)))

(defexportmacro hash-table-macro (symbol)
  (let ((hash-table-var (create-name symbol 'hash 'table)))
    `(eval-when (load eval compile)
      (defvar ,hash-table-var (make-hash-table))
      (defmacro ,symbol (x)
	`(gethash ,x ,',hash-table-var))
      (defun ,(create-name 'clear 'all symbol) ()
	(clrhash ,hash-table-var)))))

(defexportmacro equal-hash-table-macro (symbol)
  (let ((hash-table-var (create-name symbol 'hash 'table)))
    `(eval-when (load eval compile)
      (defvar ,hash-table-var (make-hash-table :test #'equal))
      (defmacro ,symbol (x)
	`(gethash ,x ,',hash-table-var))
      (defun ,(create-name 'clear 'all symbol) ()
	(clrhash ,hash-table-var)))))

(defexport the-one (list)
  (unless list
    (error "an empty set of possibilities given to the function THE"))
  (when (cdr list)
    (error "more than one value given to the function THE"))
  (first list))

(defexportmacro while (form &body body)
  `(loop
     (when (not ,form) (return nil))
     ,@body))

(defexportmacro do-from-to ((var min max) &body body)
  (let ((limit (gensym "LIMIT-")))
    `(let ((,var ,min)
	   (,limit ,max))
       (loop
         ,@body
	 (when (= ,var ,limit) (return))
	 (incf ,var)))))

(defexportmacro mvlet (bindings &body body)
  (cond ((null (cdr bindings))
	 `(multiple-value-bind ,(first (first bindings)) ,(second (first bindings))
	    ,@body))
	(t
	 `(multiple-value-bind ,(first (first bindings)) ,(second (first bindings))
	    (mvlet ,(rest bindings)
	      ,@body)))))

(emacs-indent mvlet 1)

(defexport fill-array (array value)
  (let ((d (array-dimensions array)))
    (cond ((= (length d) 1)
	   (dotimes (x (car d))
	     (setf (aref array x) value)))
	  ((= (length d) 2)
	   (dotimes (x (car d))
	     (dotimes (y (second d))
	       (setf (aref array x y) value))))
	  (t
	   (error "fill-array does not handle more than 2 diemensions")))))

(defexport assoc-value (item alist)
  (cdr (assoc item alist)))

(define-setf-method assoc-value (item alist)
  (mvlet (((temps vals stores store-form access-form)
	   (get-setf-method alist)))
    (let ((itemvar (gensym))
	  (listvar (gensym))
	  (store (gensym))
	  (celvar (gensym)))
      (values
	(append temps (list itemvar listvar celvar))
	(append vals (list item access-form `(assoc ,itemvar ,listvar)))
	(list store)
	`(progn (if (cdr ,celvar)
		    (if ,store
			(setf (cdr ,celvar) ,store)
			(let ((,(car stores) (remove ,itemvar ,listvar :key #'car)))
			  ,store-form
			  (setf (cdr ,celvar) nil)))
		    (when ,store
		      (if ,celvar
			  (setf (cdr ,celvar) ,store)
			  (progn
			    (setf ,celvar (cons ,itemvar ,store))
			    (push ,celvar ,listvar)))  ;;  I didn't write this -- rlg
		      (let ((,(car stores) ,listvar))
			,store-form)))
		,store)
	`(assoc-value ,itemvar ,access-form)))))


(defexportmacro dolists (specs &body body)
  (let ((new-vars (mapcar (lambda (spec) (gensym "VAR-")) specs)))
    `(do* ,(mapcan (lambda (spec new-var) `((,new-var ,(cadr spec) (cdr ,new-var))
					    (,(car spec) (car ,new-var) (car ,new-var))))
		   specs
		   new-vars)
	 ((null ,(caar specs)) t)
       ,@body)))

(defexportmacro do-tails ((var list) &body body)
  `(do ((,var ,list (cdr ,var)))
       ((null ,var))
     ,@body))

(defexportmacro dolist-with-prev ((var list prev-var) &body body)
  (let ((var-list (gensym "VAR-LIST-")))
    `(do ((,var-list ,list (cdr ,var-list))
	  (,prev-var nil ,var-list))
	 ((null ,var-list))
       (let ((,var (car ,var-list)))
	 ,@body))))

;iterate and ilabels are like labels except that only tail recursion is allowed
;and it compiles into an iteration.

(defexportmacro iterate (tag specs &body body)
  (let ((vars (mapcar #'car specs))
	(id (gensym)))
    `(block ,id
       (let ,specs
	 (tagbody
	   ,id (macrolet ((,tag ,vars
			   `(progn (psetq ,@(list ,@(mapcan #'(lambda (var)
								`(',var ,var))
							    vars)))
				   (go ,',id))))
		 (return-from ,id (progn ,@body))))))))

(emacs-indent iterate 2)

(defexport find-best (pred list)
  (when list
    (iterate loop ((best (car list))
		   (rest (cdr list)))
      (cond ((null rest)
	     best)
	    ((funcall pred best (car rest))
	     (loop best (cdr rest)))
	    (t
	     (loop (car rest) (cdr rest)))))))


(defexportmacro find-and-delete-best (pred list)
  (let ((list-var (gensym "LIST-VAR-"))
	(best-prev (gensym "BEST-PREV-"))
	(best (gensym "BEST-"))
	(item (gensym "ITEM-"))
	(prev (gensym "PREV-")))
    `(let* ((,list-var ,list)
	    (,best-prev nil)
	    (,best (car ,list-var)))
       (dolist-with-prev (,item ,list-var ,prev)
	 (when (funcall ,pred ,item ,best)
	   (setf ,best-prev ,prev)
	   (setf ,best ,item)))
       (if ,best-prev
	   (setf (rest ,best-prev) (rest (rest ,best-prev)))
	   (pop ,list))
       ,best)))

(export 'long-union)

(eval-when (compile eval load)

  (defun long-union (&rest lists)
    (iterate rec-union ((to-do lists)
			(result '()))
	     (if to-do
		 (rec-union (rest to-do) (union (first to-do) result))
		 result))))

(defexportmacro ilabels (bindings &body body)
  `(macrolet ,(mapcar (lambda (definition)
			`(,(first definition) ,(second definition)
			  `(progn (psetq ,@(list ,@(mapcan #'(lambda (var)
							       `(',var ,var))
							   (second definition))))
				  (go ,',(first definition)))))
		      bindings)
     (prog ,(apply #'long-union (cons nil (mapcar 'cadr bindings)))
	   (tagbody
	     (return (progn ,@body))
	     ,@(mapcan #'(lambda (definition)
			   `(,(car definition)
			     (return (progn ,@(cddr definition)))))
		       bindings)))))



;system initialization is generally useful

(defexport combine-symbols (s1 s2 &optional (package *package*) &key (inserting "-"))
  (intern (concatenate 'string (string s1) inserting (string s2))
	  package))

(defexport combine-symbol-list (s-list &optional (package *package*) &key (inserting "-"))
  (cond ((null s-list) nil)
	((null (rest s-list)) (car s-list))
	(t (combine-symbols (car s-list)
			    (combine-symbol-list (cdr s-list) package :inserting inserting)
			    package
			    :inserting inserting))))

(defexport create-name (&rest symbols)
  (combine-symbol-list symbols))

(defexport map-to-package (symbol &optional (package *package*))
  (intern (string symbol) package))

(defexportmacro initable (&optional (package *package*))
  (let ((system-init (map-to-package 'system-init package))
	(system-init-phase1 (map-to-package 'system-init-phase1 package))
	(system-init-phase2 (map-to-package 'system-init-phase2 package))
	(system-init-phase3 (map-to-package 'system-init-phase3 package))
	(system-init-phase4 (map-to-package 'system-init-phase4 package)))
    `(progn (defun ,system-init ()
	      (initialize-marking)
	      (initialize-contexts)
	      (,system-init-phase1)
	      (,system-init-phase2)
	      (,system-init-phase3)
	      (,system-init-phase4))
	    (defpiecefun ,system-init-phase1 ())
	    (defpiecefun ,system-init-phase2 ())
	    (defpiecefun ,system-init-phase2 ())
	    (defpiecefun ,system-init-phase3 ())
	    (defpiecefun ,system-init-phase4 ()))))

(defexportmacro def-inited-var (variable &optional value)
  `(progn (defvar ,variable ,value)
	  (defpiece (,(map-to-package 'system-init-phase1)
		     ,(combine-symbols 'init variable))
		    ()
	    (setq ,variable ,value))))


(defvar *free-increment* 1000)

(defvar *free-list* (list (list nil)))

(defun make-free-list (size)
  (cond ((= size 0) nil)
	(t  (cons (cons nil nil) (make-free-list (1- size))))))

(defun init-free-list (size)
  (setq *free-list* (make-free-list size)))

(defmacro free-list-cdr (free-list)
  `(or (cdr ,free-list)
       (setf (cdr ,free-list) (make-free-list *free-increment*))))


;(defmacro with-stack-maplist ((var fun list) &body body)
;  (let ((result (gensym)))
;    `(if ,list
;       (let ((,result (car *free-list*)))
;	 (setf (car ,result) (opt-funcall ,fun ,list))
;	 (let ((,var ,result))
;	   (let ((*free-list*
;		   (iterate mapper ((todo-list (cdr ,list))
;				    (last-cell ,result)
;				    (internal-free-list (free-list-cdr *free-list*)))
;		     (if todo-list
;			 (let ((new-cell (car internal-free-list)))
;		           (setf (car new-cell)
;				 (opt-funcall ,fun todo-list))
;			   (setf (cdr last-cell) new-cell)
;			   (mapper (cdr todo-list)
;				   new-cell
;				   (free-list-cdr internal-free-list)))
;			 (setf (cdr last-cell) nil)
;			 internal-free-list))))
;		,@body)))
;       (let ((,var nil))
;	    ,@body))))
;
;(defmacro without-stack-maplist ((var fun list) &body body)
;  `(let ((,var (iterate mapper ((to-do-list ,list)
;				(result nil))
;		 (if to-do-list
;		     (mapper (cdr to-do-list)
;			     (cons (opt-funcall ,fun to-do-list) result))
;		     result))))
;     ,@body))
;
;(defmacro opt-funcall (fun &rest args)
;  (if (and (listp fun)
;           (eq (car fun) 'function)
;	    (eq (car (second fun)) 'lambda)
;	    args
;	    (null (cdr args)))
;      (subst (car args) (car (second (second fun))) (third (second fun)))
;      `(funcall ,fun ,@args)))
;
;
;;; test cases for time consumed by free-list business
;;;
;(defun test-wsml nil (time (with-stack-maplist (x #'(lambda(x)(car x)) test-list) x)) t)
;(defun test-wosml nil(time (without-stack-maplist (x #'(lambda(x)(car x)) test-list) x)) t)
;(defun test-clml nil (time (maplist #'(lambda(x)(car x)) test-list)) t)
;
;(defmacro opt-funcall1 (fun &rest args)
;  `(funcall ,fun ,@args))
;

; The following stuff is apparently not used anywhere.  -JAR

(defmacro freeblock (&body body)
  `(let ((*free-list* *free-list*)) ,@body))

(defmacro fcons (arg1 arg2)
  `(let ((new-cell (car *free-list*)))
     (setf (car new-cell) ,arg1)
     (setf (cdr new-cell) ,arg2)
     (setf *free-list* (free-list-cdr *free-list*))))

(defun test-fcons (size)
  (time (freeblock (fconser size))))

(defun test-cons (size)
  (time (conser size)))

(defun conser (size)
  (if (= size 0)
      nil
      (cons nil (conser (1- size))))
  t)

(defun fconser (size)
  (if (= size 0)
      nil
      (fcons nil (fconser (1- size))))
  t)

(defvar *prompt* "-->")

(export 'continue)
(export 'abort)

#+Symbolics
(defexport read-eval-print (io-stream &optional (prompt-modifier 'identity))
  (loop (format io-stream "~&~%~a " (funcall prompt-modifier *prompt*))
	(let ((char (si:tyipeek)))
	  (when (char= #\resume char)
	    (read-char)
	    (return-from read-eval-print *)))
	(let ((form (cp:read-command-or-form *standard-input* :prompt nil)))
	  (scl:catch-error-restart
	    (sys:abort "Back to most recent read-eval-print loop")
	    (let ((*prompt* (concatenate 'string *prompt* "-->")))
	      (when (equal form '(continue)) (return *))
	      (setq + form)
	      (setq / (multiple-value-list (eval form)))
	      (setq *** **)
	      (setq ** *)
	      (setq * (car /))
	      (dolist (result /)
		(print result io-stream)))))
	))

(in-package 'util)

#-Symbolics
(defvar *abort* nil)
#-Symbolics
(defexport abort () (setq *abort* t) (throw 'abort nil))
#-Symbolics
(defexport read-eval-print (io-stream &optional (prompt-modifier 'identity))
  (let ((*abort* nil))
    (catch 'abort
      (unwind-protect
	   (rep-internal io-stream prompt-modifier)
	(unless *abort*
	  (rep-internal io-stream prompt-modifier))))))
#-Symbolics
(defun rep-internal (io-stream prompt-modifier)
  (loop (format io-stream "~&~%~a " (funcall prompt-modifier *prompt*))
	(let ((form (read io-stream)))
	  (let ((*prompt* (concatenate 'string *prompt* "-->")))
	    (when (equal form '(continue)) (return t))
	    (setq + form)
	    (setq / (multiple-value-list (eval form)))
	    (setq *** **)
	    (setq ** *)
	    (setq * (car /))
	    (dolist (result /)
	      (print result io-stream))))))




(defexportmacro selectmatch (arg &body cases)
  (let ((arg-var '#:arg-var))
    `(block success
       (let ((,arg-var ,arg))
	  ,@(mapcar (lambda (case)
		      `(block fail
			 ,(unitest (car case)
				   arg-var
				   nil
				   (lambda (ignore) `(return-from success
						       (progn ,@(cdr case)))))))
		    cases)))))

(defmacro guarded-selectmatch (arg &body cases)
  (let ((arg-var '#:arg-var))
    `(block success
      (let ((,arg-var ,arg))
	,@(mapcar (lambda (case)
		    `(block fail
		      ,(unitest (first case)
			arg-var
			nil
			(lambda (ignore) `(if ,(second case)
					   (return-from success
					     (progn ,@(cddr case)))
					   (return-from fail nil))))))
		  cases)))))

(eval-when (compile load eval)
  (defexport variable? (x)
    (and (symbolp x) (string= "?" (subseq (string x) 0 1)))))

(defexport constant? (x)
  (and (symbolp x)
       (not (variable? x))))

(defexport first-word (string)
  (subseq string 0 (position #\- string)))

(defexport copy-var (var)
  (let ((string (string var)))
    (let ((pos (position #\- string)))
      (if pos
	  (gensym (subseq string 0 (1+ pos)))
	  (gensym (concatenate 'string string "-"))))))

(defexport variables (exp)
  (cond ((and (consp exp)
	      (not (eq (car exp) 'quote)))
	 (union (variables (car exp))
		(variables (cdr exp))))
	((variable? exp)
	 (list exp))))

(eval-when (compile load eval)
  (defun unitest (pattern object bound-vars body-continuation)
    (cond ((null pattern)
	   `(if ,object
		(return-from fail nil)
		,(funcall body-continuation bound-vars)))
	  ((listp pattern)
	   (let ((car-var (gensym))
		 (cdr-var (gensym)))
	     `(if (not (and ,object (listp ,object)))
		  (return-from fail nil)
		  ,(cond ((and (eq (car pattern) :anything)
			       (eq (cdr pattern) :anything))
			  (funcall body-continuation bound-vars))
			 ((eq (car pattern) :anything)
			  `(let ((,cdr-var (cdr ,object)))
			     ,(unitest (cdr pattern) cdr-var bound-vars body-continuation)))
			 ((eq (cdr pattern) :anything)
			  `(let ((,car-var (car ,object)))
			     ,(unitest (car pattern) car-var bound-vars body-continuation)))
			 (t
			  `(let ((,car-var (car ,object))
				 (,cdr-var (cdr ,object)))
			     ,(unitest (car pattern) car-var bound-vars
				       (lambda (bound-vars)
					 (unitest (cdr pattern)
						  cdr-var
						  bound-vars
						  body-continuation)))))))))
	  ((eq pattern :anything) (funcall body-continuation bound-vars))
	  ((not (variable? pattern))
	   `(if (not (eq ,object ',pattern))
		(return-from fail nil)
		,(funcall body-continuation bound-vars)))

	  ((member pattern bound-vars)
	   `(if (not (equal ,object ,pattern))
		(return-from fail nil)
		,(funcall body-continuation bound-vars)))
	  (t
	   `(let ((,pattern ,object))
	      ,(funcall body-continuation (cons pattern bound-vars)))))))




(defexport internal-member (item s-exp)
  (or (eq item s-exp)
      (and s-exp
	   (consp s-exp)
	   (or (internal-member item (car s-exp))
	       (internal-member item (cdr s-exp))))))

(defexport opt-funcall (fun args)
  (if (and (listp fun)
	   (eq (car fun) 'lambda))
      (iterate loop ((expression (third fun))
		     (params (second fun))
		     (args args))
	(if (null params)
	    expression
	    (loop (subst (car args) (car params) expression)
		  (cdr params)
		  (cdr args))))
      `(funcall ,fun ,@args)))



;; Recursion unrolling optimization

;; (unroll n (defun ...) (defun ...))  unrolls each function call down to n levels.
;;  Warning -- the size of the code generated can be exponential in n.
;
;the following is a fast sum procedure.  The tenfold unrolling of the
;following list-sum procedure is 3 times faster than the simple (un-unrolled)
;recursive version.  This indicates the procedure is 2/3 recursion overhead.
;
;(unroll 10
;  (defun list-sum (list)
;    (if (null list) 0 (+ (car list) (list-sum (cdr list))))))

(defexportmacro unroll (n &body defuns)
  (when (< n 1)
    (error "unroll used with no expansions (expansion count less than 1)"))
  (let ((function-alist (mapcar #'cdr defuns)))
    (labels ((unroll-expression (exp n)
	       (if (atom exp)
		   exp
		   (let ((def (assoc (car exp) function-alist)))
		     (if def
			 (unroll-application def (cdr exp) n)
			 (mapcar (lambda (exp2) (unroll-expression exp2 n))
				 exp)))))
	     (unroll-application (def arglist n)
	       (if (= n 0)
		   (cons (car def) arglist)
		   (let* ((newarg-alist (mapcar (lambda (arg) (cons arg (copy-symbol arg)))
						(second def)))
			  (bindings (mapcar (lambda (newarg-pair arg)
					      (list (cdr newarg-pair)
						    (unroll-expression arg (1- n))))
					    newarg-alist
					    arglist)))
		     `(let ,bindings
			,@(mapcar (lambda (exp)
				    (unroll-expression (sublis newarg-alist exp) (1- n)))
				  (cddr def)))))))
    `(progn ,@(mapcar (lambda (def)
			`(defun ,(first def) ,(second def)
			   ,@(mapcar (lambda (exp) (unroll-expression exp n))
				     (cddr def))))
		      function-alist)))))



;Marks

;; The following structure is to be included in other structures.

(export 'markable-thing)
(export 'mark)

(defstruct (markable-thing (:conc-name nil))
  (mark 0))

(export 'simply-markable)
(export 'contents)

(defstruct (simply-markable (:include markable-thing))
  contents)

(export 'markabilize)

(definline markabilize (thing)
  (make-simply-markable :contents thing))

(export 'unmarkabilize)

(definline unmarkabilize (thing)
  (simply-markable-contents thing))

;The stack of marked objects is used for restoring previous marking states.

(defvar *mark-stack-pointer* 0)
(defvar *mark-stack-size* 5000)
(defvar *marked-objects* (make-array *mark-stack-size*))
(defvar *old-mark-array* (make-array *mark-stack-size*))

;Marks are numbers.

(defvar *smallest-mark* 0 "the smallest active mark")
(defvar *largest-mark* 0 "the largest active mark")

(defexport initialize-marking ()
  (setq *mark-stack-pointer* 0)
  (setq *smallest-mark* 0)
  (setq *largest-mark* 0))

(export 'active-mark?)

(definline active-mark? (mark)
  (not (< mark *smallest-mark*)))

(export 'earliest-active-mark?)

(definline earliest-active-mark? (mark)
  (= mark *smallest-mark*))

(export 'latest-active-mark?)

(definline latest-active-mark? (mark)
  (= mark *largest-mark*))

(export 'unmarked?)

(definline unmarked? (obj)
  (< (mark obj) *smallest-mark*))

(export 'marked?)

(definline marked? (obj)
  (not (unmarked? obj)))

(export 'most-recently-marked?)

(definline most-recently-marked? (obj)
  (= (mark obj) *largest-mark*))

(export 'push-mark)
(definline push-mark ()
  (incf *largest-mark*))

(export 'mark!)

(definline mark! (obj)
  (incf *mark-stack-pointer*)
  (setf (aref *marked-objects* *mark-stack-pointer*) obj)
  (setf (aref *old-mark-array* *mark-stack-pointer*) (mark obj))
  (setf (mark obj) *largest-mark*))

(export 'unmark!)

(definline unmark! (obj)
  (incf *mark-stack-pointer*)
  (setf (aref *marked-objects* *mark-stack-pointer*) obj)
  (setf (aref *old-mark-array* *mark-stack-pointer*) (mark obj))
  (setf (mark obj) 0))

(export 'mark-with-earliest-active-mark!)
(definline mark-with-earliest-active-mark! (obj)
  (incf *mark-stack-pointer*)
  (setf (aref *marked-objects* *mark-stack-pointer*) obj)
  (setf (aref *old-mark-array* *mark-stack-pointer*) (mark obj))
  (setf (mark obj) *smallest-mark*))

(defmacro marking-and-clearing (obj &body body)
  (let ((obj-var (gensym "OBJ-"))
	(old-mark (gensym "OLD-MARK-")))
    `(let* ((,obj-var ,obj)
	    (,old-mark (mark ,obj-var)))
       (setf (mark ,obj-var) *largest-mark*)
       (unwind-protect (progn ,@body)
	 (setf (mark ,obj-var) ,old-mark)))))

(defexportmacro with-mark-level (&body body)
  (let ((old-stack-pointer (gensym "OLD-POINTER-")))
    `(let* ((*smallest-mark* (1+ *largest-mark*))
	    (*largest-mark* *smallest-mark*)
	    (,old-stack-pointer *mark-stack-pointer*))
       (unwind-protect
	   (progn ,@body)
	 (while (not (= *mark-stack-pointer* ,old-stack-pointer))
	   (setf (mark (aref *marked-objects* *mark-stack-pointer*))
		 (aref *old-mark-array* *mark-stack-pointer*))
	   (decf *mark-stack-pointer*))))))



;Utilities built on marking

(defexport mark-all-members (s)
  (dolist (x s)
    (mark! x)))

(defexport append-unmarked (s2 s1)
  (iterate append-u-internal ((rest s2) (result s1))
    (cond ((null rest)
	   result)
	  ((marked? (car rest))
	   (append-u-internal (cdr rest) result))
	  (t
	   (append-u-internal (cdr rest) (cons (car rest) result))))))

(defexport marking-append-unmarked (s2 s1)
  (iterate append-u-internal ((rest s2) (result s1))
    (cond ((null rest)
	   result)
	  ((marked? (car rest))
	   (append-u-internal (cdr rest) result))
	  (t
	   (mark! (car rest))
	   (append-u-internal (cdr rest) (cons (car rest) result))))))

;
;;there must be no active marks in set1 when this is called
;
;(defun mark-union (set1 set2)
;  (push-mark)
;  (mark-all-members set1)
;  (let ((result (append-unmarked set2 set1)))
;    (clear-most-recent-mark)
;    result))


(defexport mark-union (&rest sets)
  (with-mark-level
    (mark-all-members (car sets))
    (iterate repeat-append-unmarked ((rest-sets (rest sets)) (result (car sets)))
      (if (null rest-sets)
	  result
	  (repeat-append-unmarked (rest rest-sets)
				  (marking-append-unmarked (car rest-sets) result))))))


(defexport collect-marked (set)
  (iterate continue-collect-marked ((rest set) (result nil))
    (cond ((null rest) result)
	  ((marked? (car rest))
	   (continue-collect-marked (cdr rest) (cons (car rest) result)))
	  (t
	   (continue-collect-marked (cdr rest) result)))))

(defexport delete-unmarked (set)
  (ilabels ((delete-prefix ()
	      (cond ((null set) nil)
		    ((marked? (car set))
		     (continue-delete-unmarked set (cdr set)))
		    (t (setq set (cdr set))
		       (delete-prefix))))
	    (continue-delete-unmarked (prev current)
	      (cond ((null current) set)
		    ((marked? (car current))
		     (continue-delete-unmarked current (cdr current)))
		    (t
		     (let ((rest (cdr current)))
		       (setf (cdr prev) rest)
		       (continue-delete-unmarked current rest))))))
    (delete-prefix)))

(defexport mark-intersection (set1 set2)
  (with-mark-level
    (mark-all-members set1)
    (collect-marked set2)))




;; Priority queueus.

(export '*max-pqueue-size*)

(defvar *max-pqueue-size* 100)

(export 'priority-queue)

(defstruct (priority-queue (:conc-name nil))
  (queue-array (make-array *max-pqueue-size*))
  (priority-array (make-array *max-pqueue-size*))
  (last-elt 0)
  (pq-size *max-pqueue-size*))

(defexport make-pqueue (size)
  (let ((*max-pqueue-size* size))
    (make-priority-queue)))

(definline car-index (i) (+ i i))
(definline cdr-index (i) (+ i i 1))

(definline parent-index (i) (floor (/ i 2)))

(defun insert-pqueue (value pri q)
  (let ((array (queue-array q))
	(p-array (priority-array q)))
    (macrolet ((move-to (val pri index)
		 `(progn (setf (aref array ,index) ,val)
			 (setf (aref p-array ,index) ,pri))))
      (let ((cur-index (incf (last-elt q))))
	(when (= cur-index (pq-size q))
	  (error "Priority queue grew beyond maximum alloted size"))
	(iterate continue-move-up ((cur-index (last-elt q)))
	  (if (eq cur-index 1)
	      (move-to value pri cur-index)
	      (let* ((p-index (parent-index cur-index))
		     (p-pri (aref p-array p-index)))
		(cond ((>= pri p-pri)
		       (move-to value pri cur-index))
		      (t
		       (move-to (aref array p-index) p-pri cur-index)
		       (continue-move-up p-index))))))))))

(export 'empty-queue)

(definline empty-queue (q) (= (last-elt q) 0))

;;; user must check empty-queue before calling---error not handled

(defexport pop-pqueue (q)
  (let* ((array (queue-array q))
	 (p-array (priority-array q))
	 (last (last-elt q))
	 (last-value (aref array last))
	 (last-pri (aref p-array last))
	 (first-value (aref array 1))
	 (first-pri (aref p-array 1)))
	(decf last)
	(setf (last-elt q) last)
	(move-down last-value last-pri array p-array last)
	(values first-value first-pri)))

(defun move-down (value pri array p-array last)
  (macrolet ((move-to (val pri index)
	       `(progn (setf (aref array ,index) ,val)
		       (setf (aref p-array ,index) ,pri))))
    (iterate continue-move-down ((cur-index 1))
      (if (= cur-index last)
	  (move-to value pri cur-index)
	  (let ((left-index (car-index cur-index)))
	    (if (> left-index last)
		(move-to value pri cur-index)
		(let ((left-pri (aref p-array left-index)))
		  (if (= left-index last)
		      (cond ((<= pri left-pri)
			     (move-to value pri cur-index))
			    (t
			     (move-to (aref array left-index) left-pri cur-index)
			     (move-to value pri left-index)))
		      (let* ((right-index (1+ left-index))
			     (right-pri (aref p-array right-index)))
			(cond ((<= pri left-pri)
			       (cond ((<= pri right-pri)
				      (move-to value pri cur-index))
				     (t
				      (move-to (aref array right-index) right-pri cur-index)
				      (continue-move-down right-index))))
			      ((< right-pri left-pri)
			       (move-to (aref array right-index) right-pri cur-index)
			       (continue-move-down right-index))
			      (t
			       (move-to (aref array left-index) left-pri cur-index)
			       (continue-move-down left-index))))))))))))

(export 'clear-pqueue)

(definline clear-pqueue (q)
  (setf (last-elt q) 0))

;the following is really just a test function

;(defun empty (q)
;  (when (not (= 0 (last-elt q)))
;    (cons (pop-pqueue q)
;	  (empty q))))
;
;(defun print-heap (q)
;  (let ((array (queue-array q))
;	(last (last-elt q)))
;    (ilabels ((print-from-index (index)
;		(when (<= index last)
;		  (list (aref array index)
;			(print-from-index (car-index index))
;			(print-from-index (cdr-index index))))))
;      (print-from-index 1))))


(defvar *context-stack* '())
(defvar *base-context*)
(proclaim '(special *base-context*))
(defvar *current-context*)
(defvar *context-counter* 0)
(defvar *assumption-stack* nil)
(defvar *contradictory-context* nil)

(defun initialize-contexts ()
  ;We must insure that control has
  ;returned to the top level, i.e., there are no clreanup
  ;forms currently on the Lisp stack.
  (when (and (boundp '*current-context*) (not (eq *current-context* *base-context*)))
    (error "Attempt to initialize Ontic when the context stack is not empty"))
  (setq *context-counter* 0)
  (setf *contradictory-context* nil)
  (init-context-stack)
  (setq *base-context* (first *context-stack*)))

(defstruct (context (:copier nil)
		    (:print-function print-context)
		    (:constructor make-context (level)))
  (id (incf *context-counter*))
  level
  (active? t))

;(definline context-active? (context)
;  (cdr context))
;
;(definline context-level (context)
;  (car context))

(defun print-context (context stream depth)
  (declare (ignore depth))
  (if (context-active? context)
      (format stream "C-~s" (context-level context))
      (format stream "inactive-C")))

;(definline make-context (level)
;  (cons level t))

(defun init-context-stack ()
  (setq *context-counter* 0)
  (setq *context-stack* '())
  (let ((new-context (make-context 0)))
    (push new-context *context-stack*)
    (setq *current-context* new-context)))

(defun push-context ()
  (let ((new-context (make-context (1+ (context-level *current-context*)))))
    (push new-context *context-stack*)
    (setq *current-context* new-context)))


;in-new-context returns as a value the set of assertions added to the sub-context

(defmacro in-new-context (&body body)
  `(unwind-protect (progn (push-context) ,@body)
     (pop-context)))

; The following occurs in a cleanup form in the above.  Thus, the following
; function can not call error (very
; horrible things happen if you call error from a cleanup form)

(defun pop-context ()
  (if (null (cdr *context-stack*))
      (format t "Warning: you are popping the base context")
      (let ((old-context (pop *context-stack*)))
	(setf (context-active? old-context) nil)
	(setq *current-context* (car *context-stack*)))))

(defun context-contradictory? (context)
  (and *contradictory-context*
       (context-active? *contradictory-context*)
       (context-less-or-equalp *contradictory-context* context)))

(defun assert-contradiction (context)
  (when (not (context-contradictory? context))
    (setf *contradictory-context* context))
    (format t "~%Contradiction in ~s" context))

(definline context-lessp (c1 c2)
  (< (context-level c1) (context-level c2)))

(definline context-less-or-equalp (c1 c2)
  (<= (context-level c1) (context-level c2)))


(definline context-maxer (c1 c2)
  (if (context-lessp c1 c2) c2 c1))

(defmacro context-max (c1 &rest c-list)
  (cond ((null c-list)
	 c1)
	((null (rest c-list))
	 `(context-maxer ,c1 ,(first c-list)))
	(t
	 `(context-maxer ,c1 (context-max ,@c-list)))))

(definline context-min-er (c1 c2)
  (if (context-lessp c1 c2) c1 c2))

(defmacro context-min (c1 &rest c-list)
  (cond ((null c-list)
	 c1)
	((null (rest c-list))
	 `(context-min-er ,c1 ,(first c-list)))
	(t
	 `(context-min-er ,c1 (context-min ,@c-list)))))

(definline parent-context ()
  (if (eq *current-context* *base-context*)
      *base-context*
      (second *context-stack*)))

;a bound is either nil or a context.  Nil represents the infinite bound.

(definline bound-min (b1 b2)
  (cond ((null b1) b2)
	((null b2) b1)
	((context-min b1 b2))))

(definline bound-max (b1 b2)
  (and b1 b2 (context-max b1 b2)))

(definline bound-lessp (b1 b2)
  (and b1
       (or (null b2)
	   (context-lessp b1 b2))))

(definline bound-less-or-equalp (b1 b2)
  (not (bound-lessp b2 b1)))

(definline bound-active? (bound)
  (or (null bound)
      (context-active? bound)))




(definline make-cpair (term context)
  (cons term context))

(definline cpair-item (cpair)
  (car cpair))

(definline cpair-context (cpair)
  (cdr cpair))

(definline cpair-active? (cpair)
  (context-active? (cpair-context cpair)))

; CP-SETF returns nil if the setf operation did not change the state of
; the generalized variable.  This can be used for testing if a cp-setf
; operation should propagate inferences.

(defmacro cp-setf (genvar item context)
  (let ((formval (gensym)))
    `(let ((,formval ,genvar))
       (when (or (null ,formval) (not (cpair-active? ,formval))
		 (context-lessp ,context (cpair-context ,formval)))
	 (setf ,genvar (make-cpair ,item ,context))))))

(defmacro cp-getf (genvar)
  (let ((formval (gensym)))
    `(let ((,formval ,genvar))
       (cond ((null ,formval)
	      (values :unknown *base-context*))
	     ((cpair-active? ,formval)
	      (values (cpair-item ,formval) (cpair-context ,formval)))
	     (t
	      (setf ,genvar nil)
	      (values :unknown *base-context*))))))


; The second kind of generalized variable holds a list of values.

(defmacro cp-push (item context cp-list)
  `(push (make-cpair ,item ,context) ,cp-list))

(defmacro do-cp-list ((itemvar contextvar cp-list-form) &body body)
  (let ((cp-list (gensym)))
    `(ilabels ((remove-obsolete-initials (,cp-list)
		(when ,cp-list
		  (cond
		    ((cpair-active? (car ,cp-list))	;active
		      (let ((,itemvar (cpair-item (car ,cp-list)))
			    (,contextvar (cpair-context (car ,cp-list))))
			,@body)
		      (process-cdr ,cp-list))
		    (t  ;;obsolete
		      (setf ,cp-list-form (cdr ,cp-list))
		      (remove-obsolete-initials (cdr ,cp-list))))))
	      (process-cdr (,cp-list)
		(when (cdr ,cp-list)
		  (cond
		    ((cpair-active? (second ,cp-list))	;active
		      (let ((,itemvar (cpair-item (second ,cp-list)))
			    (,contextvar (cpair-context (second ,cp-list))))
			,@body)
		      (process-cdr (cdr ,cp-list)))
		    (t ;;;obsolete
		      (setf (cdr ,cp-list) (cddr ,cp-list))
		      (process-cdr ,cp-list))))))
       (remove-obsolete-initials ,cp-list-form))))

(export 'call-debugger)

#+Symbolics
(defun call-debugger ()
  (dbg:dbg))

#-Symbolics
(defun call-debugger ()
  (break))

(defexportmacro guarantee (form)
  `(when (not ,form)
     (format t "~%Failed to guarantee the invariant ~s" ',form)
     (call-debugger)))

(defexport circular-p (sexp &optional (seen nil))
  (cond ((atom sexp) nil)
	((member sexp seen) t)
	(t (or (circular-p (car sexp) (cons sexp seen))
	       (circular-p (cdr sexp) (cons sexp seen))))))

(defexport negation (form)
  (selectmatch form
    ((not ?form2) ?form2)
    (:anything `(not ,form))))


(defexportmacro nmapcar (fun list)
  (let ((list-var (gensym "LIST-"))
	(remaining (gensym "REMAINING-")))
    `(let ((,list-var ,list) )
       (do ((,remaining ,list-var (rest ,remaining)))
	   ((null ,remaining) ,list-var)
	 (setf (car ,remaining)
	       (funcall ,fun (car ,remaining)))))))

(defexport apply-to-cross-product (fun lists)
  (labels ((build-tuple-and-apply-fun (remaining-lists tuple)
	     (if (null remaining-lists)
		 (list (apply fun tuple))
		 (mapcan (lambda (item)
			   (build-tuple-and-apply-fun (rest remaining-lists)
						      (cons item tuple)))
			 (first remaining-lists)))))
    (build-tuple-and-apply-fun (reverse lists) nil)))



(defexport some-intersection (list1 list2)
  (dolist (elt list1)
    (when (member elt list2)
      (return-from some-intersection t)))
  nil)


(defexport npartition (list fun)
  (let ((in nil)
	(out nil))
    (do* ((list list rest-list)
	  (rest-list (rest list) (rest rest-list)))
	 ((null list) (values in out))
      (if (funcall fun (first list))
	  (progn (setf (rest list) in)
		 (setf in list))
	  (progn (setf (rest list) out)
		 (setf out list))))))

(defexport set-equal (set1 set2)
  (and (subsetp set1 set2)
       (subsetp set2 set1)))

(defexportmacro apply-if (flag munger exp &rest other-args)
  `(if ,flag
       (apply ,munger ,exp (list ,@other-args))
       ,exp))

(defexportmacro apply-if-not (flag munger exp &rest other-args)
  `(if ,flag
       ,exp
       (apply ,munger ,exp (list ,@other-args))))

(defexport flatten (exp)
  (if (consp exp)
      (nconc (flatten (car exp)) (flatten (cdr exp)))
      (list exp)))

(defexport expose (val str &rest forms)
  (format t "~%~A~s " str val)
  (dolist (form forms) (format t "--- ~s" form))
  val)

(defexport expose-if (do-it? val str &rest forms)
  (when do-it?
    (format t "~%~A~s " str val)
    (dolist (form forms) (format t "--- ~s" form)))
  val)

(export 'equal-member)
(definline equal-member (x y)
  (member x y :test #'equal))

(defexportmacro re-bind ((&rest vars) &body body)
  `(let ,(mapcar (lambda (var) (list var var)) (remove-duplicates vars))
     ,@body))

;(emacs-indent re-bind 1)

(defexport ms-time-diff (t1 t2)
  (round (* (- t1 t2) 1000)
	 internal-time-units-per-second))


(defvar *bridge-min-wait* 100)
(export '*bridge-min-wait*)
(defvar *compile-noticer* #'(lambda (&rest args) args))
(export '*compile-noticer*)
(defexportmacro notify-and-compile (&rest args)
  `(let ((notifying? (>= (ms-time-diff (get-internal-real-time) *last-message-time*)
			 *bridge-min-wait*)))
    (when notifying? (funcall *compile-noticer* :before))
    (let ((compile-value (compile ,@args)))
      (when notifying? (funcall *compile-noticer* :after))
      compile-value)))

;; kcz -- filtered non-defuns
;;
(defexport compile-defuns (defuns)
  (mapc (lambda (form)
	  (if (eq (car form) 'defun)
	      (notify-and-compile (cadr form)
				  `(lambda ,(caddr form) ,@(cdddr form)))
	      (eval form)))
	defuns))


(defexportmacro ctime (form)
  `(funcall (compile nil '(lambda () (time ,form)))))

(defexport file-forms (filename)
  (let ((forms nil)
	(eof-marker (list 'eof)))
    (with-open-file (istream filename :direction :input)
      (iterate loop ()
	       (let ((form (read istream nil eof-marker)))
		 (unless (eq form eof-marker)
		   (push form forms)
		   (loop)))))
    (nreverse forms)))

(defexport write-forms (forms filename)
    (let ((*print-level* 1000)
	  (*print-length* 1000)
	  (*print-circle* t))
      (with-open-file (istream filename :direction :output :if-exists :overwrite
			       :if-does-not-exist :create)
	(dolist (form forms)
	  (format istream "~%~% ~s" form))))
  t)



;the following sort function heuristically minimizes the number of
;edges that go backward.  If there exists a topological sort
;then the procedure guarantees that there are no backward edges.

(defexport heuristic-topsort-pred (nodes pred)
  (let ((edges (mapcan (lambda (node1)
			 (mapcan (lambda (node2)
				   (when (funcall pred node1 node2)
				     (list (cons node1 node2))))
				 nodes))
		       nodes)))
    (heuristic-topsort nodes edges)))

(defexport heuristic-topsort (nodes edges)
  (let ((graph (create-sort-graph nodes edges)))
    (values (node-list graph) (backedges graph))))

(defexport heuristic-levels (nodes edges)
  (let ((graph (create-sort-graph nodes edges)))
    (values (node-levels graph) (backedges graph))))

(defstruct sort-graph
  nodes
  first-node
  edges
  backedges)

(defstruct (sort-node (:print-function (lambda (self stream ignore)
					 (declare (ignore ignore))
					 (format stream "[node ~s]" (sort-node-datum self)))))
  datum ;the original element of the edge
  level
  pred-edges
  succ-edges
  pred-node
  succ-node)

(defun node-list (graph)
  (labels ((list-from (node)
	     (when node
	       (cons (sort-node-datum node)
		     (list-from (sort-node-succ-node node))))))
    (list-from (sort-graph-first-node graph))))

(defstruct (sort-edge (:print-function (lambda (self stream ignore)
					 (declare (ignore ignore))
					 (format stream "[edge ~s ~s]"
						 (sort-edge-source self)
						 (sort-edge-destination self)))))
  source
  destination
  backedge?)

(defun create-sort-graph (nodes edges)
  (let ((g (simple-create-sort-graph nodes edges)))
    (h-topsort-graph g)
    (install-backedges g)
    g))

(defun simple-create-sort-graph (nodes edges)
  (let ((datum-alist nil))
    (labels ((datum-node (datum)
	       (or (cdr (assoc datum datum-alist))
		   (let ((new-node (make-sort-node :datum datum)))
		     (push (cons datum new-node) datum-alist)
		     new-node))))
      (let ((datum-nodes (mapcar #'datum-node nodes))
	    (sort-edges (mapcar (lambda (edge)
				  (let* ((source (datum-node (car edge)))
					 (destination (datum-node (cdr edge)))
					 (sort-edge (make-sort-edge :source source
								    :destination destination)))
				    (push sort-edge (sort-node-succ-edges source))
				    (push sort-edge (sort-node-pred-edges destination))
				    sort-edge))
				edges)))
	(make-sort-graph :nodes datum-nodes :edges sort-edges)))))

(defun h-topsort-graph (graph)
  (clear-levels graph)
  (setf (sort-graph-first-node graph) nil)
  (let ((next-level 1)
	(last-node nil))
    (labels ((finish-order ()
	       (let ((next-node (minimum-unassigned-node graph)))
		 (if (null next-node)
		     (when last-node
		       (setf (sort-node-succ-node last-node) nil))
		     (progn
		       (when (null last-node)
			 (setf (sort-graph-first-node graph) next-node)
			 (setf (sort-node-pred-node next-node) nil))
		       (add-next-node next-node)
		       (finish-order)))))
	     (add-next-node (next-node)
;	       (format t "~%adding node ~s" (sort-node-datum next-node))
	       (setf (sort-node-pred-node next-node) last-node)
	       (when last-node
		 (setf (sort-node-succ-node last-node) next-node))
	       (setf (sort-node-level next-node) next-level)
	       (incf next-level)
	       (setf last-node next-node)
	       (dolist (out-edge (sort-node-succ-edges next-node))
		 (check-for-addition (sort-edge-destination out-edge))))
	     (check-for-addition (node)
	       (unless (sort-node-level node)
		 (when (every #'(lambda (pred-edge)
				  (sort-node-level (sort-edge-source pred-edge)))
			      (sort-node-pred-edges node))
		   (add-next-node node)))))
      (finish-order))))

(defun minimum-unassigned-node (graph)
  (let ((best nil)
	(best-count nil))
    (dolist (node (sort-graph-nodes graph))
      (unless (sort-node-level node)
	(let ((count (unassigned-count node)))
	  (when (= count 0)
	    (return-from minimum-unassigned-node node))
	  (when (and (> count 0)
		     (or (null best-count)
			 (< count best-count)))
	    (setf best-count count)
	    (setf best node)))))
    best))

(defun unassigned-count (node)
  (let ((count 0))
    (dolist (edge (sort-node-pred-edges node))
      (unless (sort-node-level (sort-edge-source edge))
	(incf count)))
    count))

(defun clear-levels (graph)
  (dolist (node (sort-graph-nodes graph))
    (setf (sort-node-level node) nil)))

;the following assumes the graph is sorted

(defun node-levels (graph)
  (clear-levels graph)
  (let ((max-level 0)
	(node-array (make-array (1+ (length (sort-graph-nodes graph))))))
    (labels ((check-level (node)
	       (unless (sort-node-level node)
;		 (format t "~%checking node ~s" node)
		 (let ((level 0))
		   (dolist (edge (sort-node-succ-edges node))
		     (unless (sort-edge-backedge? edge)
		       (let* ((pred-node (sort-edge-destination edge))
			      (pred-level (sort-node-level pred-node)))
			 (if (null pred-level)
			     (return-from check-level nil)
			     (setf level (max level pred-level))))))
		   (let ((this-level (1+ level)))
;		     (format t "~%assigning ~s level ~s" node this-level)
		     (setf (sort-node-level node) this-level)
		     (push (sort-node-datum node)
			   (aref node-array this-level))
		     (setf max-level (max max-level this-level)))
		   (dolist (pred-edge (sort-node-pred-edges node))
		     (check-level (sort-edge-source pred-edge)))))))
      (mapc #'check-level (sort-graph-nodes graph))
      (when (> max-level 0)
	(let ((result nil))
	  (do-from-to (index 1 max-level)
	    (push (aref node-array index) result))
	  result)))))

(defun install-backedges (graph)
  (setf (sort-graph-backedges graph) nil)
  (dolist (edge (sort-graph-edges graph))
    (unless (> (sort-node-level (sort-edge-destination edge))
	       (sort-node-level (sort-edge-source edge)))
;      (format t "~%noticing backedge ~s" edge)
      (push edge (sort-graph-backedges graph))
      (setf (sort-edge-backedge? edge) t))))

(defun backedges (graph)
  (install-backedges graph)
  (sort-graph-backedges graph))


;;
(defexport heuristic-topsort-with-hard-constraints (nodes edges hard-edges)
  (let* ((hard-nodes (remove-if-not (lambda (node) (or (member node hard-edges :key 'cdr)
						      (member node hard-edges :key 'car)))
				   nodes))
	 (sorted-hards (heuristic-topsort hard-nodes hard-edges))
	 (soft-nodes (set-difference nodes hard-nodes))
	 (block-node (gensym "BLOCK-NODE"))
	 (fixed-edges (sublis (mapcar (lambda (node) (cons node block-node)) hard-nodes)
			      edges))
	 (soft-sort (heuristic-topsort (cons block-node soft-nodes) fixed-edges)))
    (mapcan (lambda (node) (if (eq node block-node)
			       sorted-hards
			       (list node)))
	    soft-sort)))



;========================================================================
;anneal-order orders the nodes in a cyclic graph so as to minimize the number
;of backward edges.  It takes a sort-graph that has been heuristically sorted
;using heuristic-tsort but which still has a backedge (and is therefore cyclic).
;It uses a local optimization algorithm where the mutation
;operations are allowed to move the source and destination of a single existing
;backward edge.  If no such operation can reduce the number of backward edges
;then a mutation that does not increase the number of backward edges is done
;at random.  This is analogous to GSAT.

;These functions have never been debugged and have not been maintained over changes
;in the data structures.  However, they may be usefule if someone wants as a starting
;point for writing this algorithm.
;========================================================================
;
;(defvar *annealing-bound* 100)
;
;(defun anneal-order (graph bound)
;  (let ((count 0))
;    (loop
;     (when (> count *annealing-limit*)
;       (return graph))
;     (let ((edges (sort-graph-backedges graph)))
;       (if (null edges)
;	   graph
;	   (if (some #'(lambda (backedge)
;			 (reduction-reversal backedge graph))
;		     edges)
;	       (setf count 0)
;	       (let* ((backedge (nth (random (length edges)) edges))
;		      (source (sort-node-source backedge))
;		      (destination (sort-edge-destination edge)))
;		 (mvlet (((free-source-level or-source-level) (one-reversal-forward-level source))
;			 ((free-destination-level or-destination-level (one-reversal-backward-level destination))))
;		   (if (and or-source-level
;			    (> free-destination-level or-source-level))
;			   (progn (move-node-backward source or-source-level graph)
;				  (move-node-forward destination free-destination-level graph)
;				  (incf count))
;			   (if (and or-destination-level
;				    (> or-destination-level free-source-level))
;			       (progn (move-node-backward source free-source-level graph)
;				      (move-node-forward destination free-destination-level graph)
;				      (incf count))))))))))))
;
;;reduction-reversal will reverse the backedge if this reversal
;;can be achieved by moving the two nodes without introducing any other
;;backedge.
;
;(defun reduction-reversal (backedge graph)
;  (let ((source (sort-edge-source backedge))
;	(destination (sort-edge-destination edge)))
;    (when (not (exists-edge? destination source))
;      (let ((free-source-level (free-forward-level source))
;	    (free-destination-level (free-backward-level destination)))
;	(when (> free-destination-level free-source-level)
;	  (move-node-backward source free-source-level graph)
;	  (move-node-forward destination free-destination-level graph)
;	  t)))))
;
;(defun exists-edge? (node1 node2)
;  (some #'(lambda (edge)
;	    (eq (sort-edge-destination edge)
;		node2)))
;	(sort-node-succ-edge node1))
;
;(defun free-forward-level (node graph)
;  (let (edges (successor-edges node))
;    (if (null edges)
;	(length (sort-graph-nodes graph))
;	(let ((level (forward-edge-limit (car edges))))
;	  (dolist (edge (cdr edges))
;	    (let ((limit2 (forward-edge-limit edge)))
;	      (when (< forward-edge-limit limit)
;		(setf limit forward-edge-limit))))
;	  level))))
;
;(defun forward-edge-limit (edge)
;  (1- (sort-node-level (sort-edge-destination edge))))
;
;(defun free-backward-level (node graph)
;  (let (edges (predicessor-edges node))
;    (if (null edges)
;	1
;	(let ((level (backward-edge-limit (car edges))))
;	  (dolist (edge (cdr edges))
;	    (let ((limit2 (backward-edge-limit edge)))
;	      (when (> backward-edge-limit limit)
;		(setf limit backward-edge-limit))))
;	  level))))
;
;(defun backward-edge-limit (edge)
;  (1+ (sort-node-level (sort-edge-source edge))))
;
;(defun one-reversal-forward-level (node graph)
;  (let (edges (sort-node-succ-edges node))
;    (if (null (cdr edges))
;	(values (free-forward-level node graph)
;		(length (sort-graph-nodes graph)))
;	(let ((level1 (forward-edge-limit (first edges)))
;	      (level2 (forward-edge-limit (second edges))))
;	  (when (> level2 level1)
;	    (let ((temp level1))
;	      (setq level1 level2)
;	      (setq level2 temp)))
;	  (dolist (edge (cddr edges))
;	    (let ((limit2 (forward-edge-limit edge)))
;	      (cond ((< forward-edge-limit limit1)
;		     (setf limit2 (min limit1 limit2))
;		     (setf limit1 forward-edge-limit))
;		    ((< forward-edge-limit limit2)
;		     (setf limit2 forward-edge-limit)))))
;	  (values level1 level2)))))
;
;(defun one-reversal-backward-level (node graph)
;  (let (edges (sort-node-pred-edges node))
;    (if (null (cdr edges))
;	(values (free-backward-level node graph) 1)
;	(let ((level1 (forward-edge-limit (first edges)))
;	      (level2 (forward-edge-limit (second edges))))
;	  (when (< level2 level1)
;	    (let ((temp level1))
;	      (setq level1 level2)
;	      (setq level2 temp)))
;	  (dolist (edge (cddr edges))
;	    (let ((limit2 (backward-edge-limit edge)))
;	      (cond ((> backward-edge-limit limit1)
;		     (setf limit2 (max limit1 limit2))
;		     (setf limit1 forward-edge-limit))
;		    ((> backward-edge-limit limit2)
;		     (setf limit2 backward-edge-limit)))))
;	  (values level1 level2)))))
;
;(defun forward-edge? (edge)
;  (< (sort-node-level (sort-edge-source edge))
;     (sort-node-level (sort-edge-destination edge))))
;
;(defun backward-edge? (edge)
;  (< (sort-node-level (sort-edge-source edge))
;     (sort-node-level (sort-edge-destination edge))))
;
;;move-node-forward and move-node-backward need to be implemented.
;
;(defun move-node-forward (node level graph)
;  (let ((end-of-interval (decrement-interval node level)))
;    (splice-out node)
;    (splice-in-after node end-of-interval)
;    (dolist (edge (sort-node-pred-edges node))
;      (unless (backedge? edge)
;	(remove edge (sort-graph-backedges graph))))
;    (dolist (edge (sort-node-succ-edges node))
;      (when (backedge? edge)
;	(pushnew edge (sort-graph-backedges graph))))))
;
;(defun decrement-interval (node level)
;  (if (= (sort-node-level node) level)
;      node
;      (let ((next (sort-node-succ-node node)))
;	(if next
;	    (progn (decf (sort-node-level next))
;		   (decrement-internval next level))
;	    (error "failure to find next node in decrement-interval")))))
;
;(defun splice-out-node (node)
;  (make-link (sort-node-pred-node node) (sort-node-succ-node node)))
;
;(defun make-link (previous next)
;  (when previous
;    (setf (sort-node-succ-node previous) next))
;  (when next
;    (setf (sort-node-pred-node next) previous)))
;
;(defun splice-in-after (node place-node)
;  (let ((old-succ-node (sort-node-succ-node place-node)))
;    (make-link place-node node)
;    (make-link node old-succ-node)))
;
;(defun move-node-backward (node level graph)
;  (let ((beginning-of-interval (increment-interval node level)))
;    (splice-out node)
;    (splice-in-before node beginning-of-interval)
;    (dolist (edge (sort-node-succ-edges node))
;      (unless (backedge? edge)
;	(remove edge (sort-graph-backedges graph))))
;    (dolist ((edge (sort-node-pred-edges node)))
;      (when (backedge? edge)
;	(pushnew edge (sort-graph-backedges graph))))))
;  
;(defun increment-interval (node level)
;  (if (= (sort-node-level node) level)
;      node
;      (let ((next (sort-node-pred-node node)))
;	(if next
;	    (progn (incf (sort-node-level next))
;		   (increment-internval next level))
;	    (error "failure to find next node in increment-interval")))))
;
;(defun splice-in-before (node place-node)
;  (let ((old-pred-node (sort-node-pred-node place-node)))
;    (setf (sort-node-level node) (1- (sort-node-level place-node)))
;    (make-link place-node node)
;    (make-link node old-succ-node)))

;;;========================================================================
;;A "long edge" is an edge that must cross some layer of components.
;;Any backedge is a long edge.
;;A forwad edge whose destination is more than one layer away from its
;;source is also a long edge.
;;long edges are handled by adding "wire nodes" to the component levels
;;crossed by the edge.
;;========================================================================
;
;(defun insert-wire-nodes (graph)
;  (dolist (edge (edges graph))
;    (let* ((wire (sort-edge-wire edge))
;	   (source (sort-edge-source edge))
;	   (destination (sort-edge-destination edge))
;	   (backedge? (backedge? edge))
;	   (start-level (if backedge?
;			    (sort-node-level source)
;			    (1+ (sort-node-level source))))
;	   (end-level (if backedge?
;			  (sort-node-level destination)
;			  (1- (sort-node-level destination))))
;	   (levels (sort-graph-levels graph)))
;      (do-from-to (level start-level end-level)
;	(let ((node (find-wire-node wire level levels)))
;	  (unless node
;	    (setf node (new-wire-node wire level levels)))
;	  (when (and (= level start-level)
;		     (not backedge?))
;	    (add-edge source node wire graph)))))))
;
;
;(defun find-wire-node (wire level levels)
;  (car (member wire (nth (1- level) levels) :key 'laytout-node-datum)))
;
;(defun new-wire-node (wire level levels)
;  (let ((new-node (make-sort-node :datum-type 'wire :datum wire)))
;    (push new-node (nth (1- level) levels))
;    (when (> level 1)
;      (let ((previous-wire-node (find-wire-node wire (1- level))))
;	(when previous-wire-node
;	  (add-edge previous-wire-node new-node))))))