(in-package :adage :use (list :lisp :util))



;========================================================================
;a layout of a circuit consists of the following:

;x and y coordinates to each component,
;a y coordinate to each wire,
;an x coordinate to each input and output of each component.
;an x coordinate to each input and output of the circuit.

;This information is sufficient to specify a drawing of the circuit.
;each input is extended horixontally from a standard place on its component to
;the x coordinate of that input.  a line is then extended vertically from
;the endpoint of the input wire to the y-coordinate of the wire involved in the input.
;wires are then drawn at the given y coordinate to the extreme x coordinates of
;inputs and outputs connected to that wire.

;This package takes a circuit and automatically computes a layout
;guarnteeing that no components overlap and that no wires cross components.
;Heuristics are used to minimize the amount of wire used and the number
;of wire crossings.

;A layout is constructed in four phases.

;Phase1: the components are sorted in "levels" where each level is a
;list of componets and wires that must cross the level.  All components
;and wires in a given level will be drawn vertically (one above the other)
;at the same x-position in the layout.
;In constructing the levels heuristics are used to minimize the number of "backedges" --- connections
;from an output to an input that appears earlier than (to the left of)
;the output.

;Phase2: y coordinates are assigned to the wires and to each component.
;Heuristics are used to mimize the amount of vertical wire needed to connect
;inputs and outputs to the y-coordinate of the corresponding wire.

;Phase3: x coordinates are assigned to all inputs and outputs.  The layout guarantees
;that between any two levels all connections to the same wire share the same vertical line.
;In future implementations heuristics will be used to minize the number of crossings
;in the between level circuitry.
;========================================================================



;========================================================================
;Phase1 --- construct the circuit levels
;========================================================================

;the following function assigns a level to each component (including registers)

(defun compute-layout (circ)
  (create-register-components circ)
  (assign-levels circ)
  (assign-y-coordinates circ)
  (assign-x-coordinates circ))

(defun create-register-components (circ)
  (setf (all-components circ) (components circ))
  (dolist (reg-init (register-inits circ))
    (let ((name (register-part reg-init)))
      (let ((comp (make-component :register? t
				  :name name
				  :inputs (this-register-inputs name circ)
				  :outputs (list name))))
	(push comp (all-components circ))))))

(defun this-register-inputs (reg circ)
   (let ((inputs nil))
     (dolist (reg-input (register-inputs circ))
       (when (eq reg (register-part reg-input))
	 (push (data-part reg-input) inputs)
	 (push (clock-part reg-input) inputs)))
     inputs))


(defun assign-levels (circ)
  (let* ((edges (circuit-edges circ))
	 (levels (heuristic-levels (all-components circ) edges)))
    (setf (levels circ) levels)
    (let ((level-index 1))
      (dolist (level levels)
	(dolist (comp level)
	  (setf (component-level comp) level-index))
	(incf level-index)))))

(defun circuit-edges (circ)
  (let ((components (all-components circ)))
    (mapcan (lambda (comp1)
	      (mapcan (lambda (comp2)
			(edges-between comp1 comp2))
		      components))
	    components)))

(defun edges-between (node1 node2)
  (unless (component-register? node2)
    (let ((result nil))
      (dolist (output (component-outputs node1))
	(dolist (input (component-inputs node2))
	  (when (eq output input)
	    (push (cons node1 node2) result))))
      result)))


;========================================================================
;Now the components (both regular components and registers) have been
;placed in levels.  The next step is to assign coordinates.
;We must assign the following:

;x and y coordinates to each component,
;a y coordinate to each wire,
;an x coordinate to each input and output of each component.
;an x coordinate to each input and output of the circuit.

;this phase assigns y coordinates to each wire and each component.
;There are three subphases.  First
;we compute temporary y-values that are the fixed point of a
;reestimation technique.  Then insert wires into the levels they cross
;and sort the levels.  Finally we assign actual y-values for the wires
;which have sufficient room for components
;between wires at each level.  Finally we assign the final y values to the
;wires and components.
;========================================================================

(defun assign-y-coordinates (circ)
  (y-coordinates-phase1 circ)
  (y-coordinates-phase2 circ)
  (y-coordinates-phase3 circ)
  (clean-up-wires circ)
  (insulate-wire-values circ))

(definline wire-y-coordinate (wire)
  (get wire 'wire-y-coordinate))

(defun insulate-wire-values (circ)
  (setf (wire-y-coordinates circ)
	(mapcar (lambda (wire) (cons wire (wire-y-coordinate wire)))
		(list* 'top 'bottom (wires circ)))))

(defun wire-y-value (wire circ)
  (cdr (assoc wire (wire-y-coordinates circ))))

(defun y-coordinates-phase1 (circ)
  (init-y-coordinates circ)
  (compute-reestimation-fixedpoint circ))

(defun init-y-coordinates (circ)
  (dolist (wire (wires circ))
    (setf (wire-y-coordinate wire) .5))
  (dolist (comp (all-components circ))
    (setf (component-y-coordinate comp) .5)))

(definline wire-target-y-sum (wire)
  (get wire 'wire-target-y-sum))

(definline wire-target-count (wire)
  (get wire 'wire-target-count))

(defun compute-reestimation-fixedpoint (circ)
  (dotimes (i 10)
    (declare (ignore i))
    (reestimate-y-coordinates circ)))

(defun reestimate-y-coordinates (circ)
  (clear-target-stats circ)
  (notice-io-targets (inputs circ))
  (notice-io-targets (outputs circ))
  (dolist (comp (all-components circ))
    (notice-comp-targets comp))
  (reset-y-coordinates circ))

(defun clear-target-stats (circ)
  (dolist (wire (wires circ))
    (setf (wire-target-y-sum wire) (wire-y-coordinate wire))
    (setf (wire-target-count wire) 1))
  (dolist (comp (all-components circ))
    (setf (component-target-y-sum comp) (component-y-coordinate comp))
    (setf (component-target-y-count comp) 1)))

(defun notice-io-targets (io-wires)
  (let* ((delta (/ 1.0 (+ 1 (length io-wires))))
	 (y-delta delta))
    (dolist (wire io-wires)
      (add-wire-target wire (- 1.0 y-delta))
      (incf y-delta delta))))

(defun add-wire-target (wire target)
  (incf (wire-target-y-sum wire) target)
  (incf (wire-target-count wire)))

(defun notice-comp-targets (comp)
  (notice-comp-io-targets comp (component-inputs comp))
  (notice-comp-io-targets comp (component-outputs comp)))


(defvar *minimum-height* .1)

(defvar *io-delta* .05)

(defvar *component-seperation* .05)

(defun notice-comp-io-targets (comp io-wires)
  (let ((comp-y-value (component-y-coordinate comp))
	(y-delta *io-delta*))
    (dolist (wire io-wires)
      (add-wire-target wire (- comp-y-value y-delta))
      (add-component-target comp (+ y-delta (wire-y-coordinate wire)))
      (incf y-delta *io-delta*))))

(defun component-height (comp)
  (max *minimum-height*
       (* *io-delta* (1+ (length (component-inputs comp))))
       (* *io-delta* (1+ (length (component-outputs comp))))))

(defun component-space (comp)
  (+ *component-seperation* (component-height comp)))

(defun add-component-target (comp target)
  (incf (component-target-y-sum comp) target)
  (incf (component-target-y-count comp)))

(defun reset-y-coordinates (circ)
  (mapc #'reset-wire (wires circ))
  (mapc #'reset-comp (components circ)))

(defun reset-wire (wire)
  (setf (wire-y-coordinate wire)
	(/ (wire-target-y-sum wire)
	   (wire-target-count wire))))

(defun reset-comp (comp)
  (setf (component-y-coordinate comp)
	(/ (component-target-y-sum comp)
	   (component-target-y-count comp))))



;========================================================================
;phase2 of y-coordinate assignment
;========================================================================

(defun y-coordinates-phase2 (circ)
  (compute-wire-extents circ)
  (setf (wires circ) (sort (wires circ) '< :key 'wire-y-coordinate))
  (insert-wires-&-sort-levels circ))

;some numerical functions

(defvar *slop* .000001)

(defun definitely-< (x y)
  (< (+ x *slop*) y))

(defun definitely-> (x y)
  (> x (+ y *slop*)))

(defun possibly-= (x y)
  (not (or (definitely-> x y)
	   (definitely-< x y))))

(defun compute-wire-extents (circ)
  (clear-wire-extents circ)
  (dolist (comp (all-components circ))
    (dolist (input (component-inputs comp))
      (connection-before! input (component-level comp)))
    (dolist (output (component-outputs comp))
      (connection-before! output (1+ (component-level comp)))))
  (dolist (input (inputs circ))
    (connection-before! input 1))
  (let ((nlevels (length (levels circ))))
    (dolist (output (outputs circ))
      (connection-before! output (1+ nlevels)))))

(definline wire-min-connection (wire)
  (get wire 'wire-min-level))

(definline wire-max-connection (wire)
  (get wire 'wire-max-level))

(defun clear-wire-extents (circ)
  (dolist (wire (wires circ))
    (setf (wire-min-connection wire) nil)
    (setf (wire-max-connection wire) nil)))
	   

(defun connection-before! (wire level)
  (let ((old-min (wire-min-connection wire)))
    (setf (wire-min-connection wire)
	  (if old-min
	      (min old-min level)
	      level)))
  (let ((old-max (wire-max-connection wire)))
    (setf (wire-max-connection wire)
	  (if old-max
	      (max old-max level)
	      level))))

(defun insert-wires-&-sort-levels (circ)
  (when (levels circ)
    (do-from-to (n 1 (length (levels circ)))
      (let ((new-level (append (remove-if-not (lambda (wire)
						(let ((min (wire-min-connection wire)))
						  (and min
						       (<= min n)
						       (< n (wire-max-connection wire)))))
					      (wires circ))
			       (nth (1- n) (levels circ)))))
					;      (format t "~%new level ~s" new-level)
	(setf (nth (1- n) (levels circ))
	      (stable-sort new-level '< :key (lambda (elem)
					       (if (symbolp elem)
						   (wire-y-coordinate elem)
						   (component-y-coordinate elem)))))))))


;========================================================================
;phase3 of y coordinate assignment
;========================================================================

(defvar *floating-wires* nil)

(defun y-coordinates-phase3 (circ)
  (clear-phase3-info circ)
  (assign-wire-ys circ)
  (dolist (level (levels circ))
    (assign-component-heights 'bottom nil level level)))

(definline wire-lower-deltas (wire)
  (get wire 'wire-lower-deltas))

(definline wire-upper-deltas (wire)
  (get wire 'wire-upper-deltas))

(definline wire-upper-bound (wire)
  (get wire 'wire-upper-bound))

(definline wire-lower-bound (wire)
  (get wire 'wire-lower-bound))

(defun floating? (wire)
  (member wire *floating-wires*))

(defun clear-phase3-info (circ)
  (setq *floating-wires* nil)
  (dolist (wire (wires circ))
    (unless (some (lambda (level)
		    (member wire level))
		  (levels circ))
      (push wire *floating-wires*)))
  (mapc 'clear-wire (wires circ))
  (clear-wire 'top)
  (clear-wire 'bottom))

(defun clear-wire (wire)
  (setf (wire-upper-bound wire) nil)
  (setf (wire-lower-bound wire) nil)
  (setf (wire-lower-deltas wire) nil)
  (setf (wire-upper-deltas wire) nil))

(defun assign-wire-ys (circ)
  (compute-wire-deltas circ)
  (let ((extended-wires (list* 'top 'bottom (wires circ))))
    (setf (wire-y-coordinate 'top) 1.0)
    (setf (wire-y-coordinate 'bottom) 0.0)
    (dolist (wire extended-wires)
      (assign-upper-bound! wire 1.0))
    (mapc 'assign-value extended-wires)))


(defun compute-wire-deltas (circ)
  (mapc 'compute-level-deltas (levels circ)))

(defun compute-level-deltas (level)
  (compute-delta2 'bottom *component-seperation* level))

(defun compute-delta2 (last-wire delta-so-far level)
  (cond ((null level)
	 (assert-delta! last-wire delta-so-far 'top))
	((symbolp (car level))
	 (let ((next-wire (car level)))
	   (assert-delta! last-wire delta-so-far next-wire)
	   (compute-delta2 next-wire *component-seperation* (cdr level))))
	(t
	 (compute-delta2 last-wire
			 (+ delta-so-far (component-space (car level)))
			 (cdr level)))))

(defun assert-delta! (low-wire delta high-wire)
  (push (cons low-wire delta) (wire-lower-deltas high-wire))
  (push (cons high-wire delta) (wire-upper-deltas low-wire)))

(defun assign-upper-bound! (wire bound)
  (let ((old-bound (wire-upper-bound wire)))
    (when (or (null old-bound)
	      (< bound old-bound))
;      (format t "~%improving upper bound on ~s from ~s to ~s" wire old-bound bound)
      (setf (wire-upper-bound wire) bound)
      (dolist (bcell (wire-lower-deltas wire))
	(assign-upper-bound! (car bcell) (- bound (cdr bcell)))))))

(defun assign-lower-bound! (wire bound)
  (let ((old-bound (wire-lower-bound wire)))
    (when (or (null old-bound)
	      (> bound old-bound))
;      (format t "~%improving lower bound on ~s from ~s to ~s" wire old-bound bound)
      (setf (wire-lower-bound wire) bound)
      (dolist (bcell (wire-upper-deltas wire))
	(assign-lower-bound! (car bcell) (+ bound (cdr bcell)))))))

(defun assign-value (wire)
  (let ((lb (wire-lower-bound wire))
	(ub (wire-upper-bound wire))
	(yc (wire-y-coordinate wire)))
    (when (and lb ub (definitely-> lb ub))
      (error "overconstrained wire y coordinate"))
    (cond ((and lb (> lb yc))
	   (assign-value2 wire lb))
	  ((and ub (< ub yc))
	   (assign-value2 wire ub))
	  (t
	   (assign-value2 wire yc)))))

(defun assign-value2 (wire value)
  (assign-upper-bound! wire value)
  (assign-lower-bound! wire value)
  (setf (wire-y-coordinate wire) value))

(defun assign-component-heights (wire components-so-far level complete-level)
  (cond ((null level)
	 (assign-component-heights2 wire components-so-far 'top complete-level))
	((symbolp (car level))
	 (assign-component-heights2 wire components-so-far (car level) complete-level)
	 (assign-component-heights (car level) nil (cdr level) complete-level))
	(t
	 (when components-so-far
	   (install-adjacent-constraint (car components-so-far) (car level)))
	 (assign-component-heights wire (cons (car level) components-so-far) (cdr level) complete-level))))

(defun install-adjacent-constraint (comp1 comp2)
  (let ((seperation-delta (component-space comp2)))
    (setf (component-upper-delta comp1) seperation-delta)
    (setf (component-vertical-successor comp1) comp2)
    (setf (component-lower-delta comp2) seperation-delta)
    (setf (component-vertical-predicessor comp2) comp1)))

(defun clear-successor (comp)
  (setf (component-upper-delta comp) nil)
  (setf (component-vertical-successor comp) nil))

(defun clear-predecessor (comp)
  (setf (component-lower-delta comp) nil)
  (setf (component-vertical-predicessor comp) nil))

(defun assign-component-heights2 (wire1 reversed-level wire2 level)
  (when reversed-level
    (clear-successor (car reversed-level))
    (clear-predecessor (car (last reversed-level))))
  (dolist (comp reversed-level)
    (setf (component-lower-bound comp) nil)
    (setf (component-upper-bound comp) nil))
  (when reversed-level
    (let ((lowest-component (car (last reversed-level))))
      (assign-component-lower-bound lowest-component
				    (+ (wire-y-coordinate wire1) (component-space lowest-component)))
      (assign-component-upper-bound (car reversed-level)
				    (- (wire-y-coordinate wire2) *component-seperation*)))
    (dolist (comp (middle-out-sort reversed-level))
      (assign-comp-y-coordinate comp level))))

(defun assign-component-lower-bound (comp bound)
  (let ((old-bound (component-lower-bound comp)))
    (when (or (null old-bound)
	      (> bound old-bound))
      (setf (component-lower-bound comp) bound)
      (let ((succ-comp (component-vertical-successor comp)))
	(when succ-comp
	  (assign-component-lower-bound succ-comp (+ bound (component-upper-delta comp))))))))

(defun assign-component-upper-bound (comp bound)
  (let ((old-bound (component-upper-bound comp)))
    (when (or (null old-bound)
	      (< bound old-bound))
      (setf (component-upper-bound comp) bound)
      (let ((pred-comp (component-vertical-predicessor comp)))
	(when pred-comp
	  (assign-component-upper-bound pred-comp (- bound (component-lower-delta comp))))))))

(defun assign-comp-y-coordinate (comp level)
  (let ((upper-bound (component-upper-bound comp))
	(lower-bound (component-lower-bound comp)))
    (when (definitely-> lower-bound upper-bound)
      (error "unsatisfiable bounds on component y value"))
    (assign-component-2 comp (compute-y-value lower-bound upper-bound comp level))))

(defun compute-y-value (lower-bound upper-bound comp level)
  (dolist (target (target-y-values comp level))
    (when (and (<= target upper-bound)
	       (>= target lower-bound))
      (return-from compute-y-value target)))
  (/ (+ lower-bound upper-bound) 2.0))

(defun target-y-values (comp level)
  (let ((targets nil)
	(y-delta *io-delta*))
    (dolist (in (component-inputs comp))
      (let ((target (+ (wire-y-coordinate in) y-delta)))
	(let ((pos (position comp level)))
	  (unless (and (find-if (lambda (comp2)
				  (and (not (symbolp comp2))
				       (member in (component-inputs comp2))))
				level
				:end pos)
		       (find-if (lambda (comp2)
				  (and (not (symbolp comp2))
				       (member in (component-inputs comp2))))
				level
				:start (1+ pos)))
	    (push target targets))))
      (incf y-delta *io-delta*))
    targets))
			
(defun assign-component-2 (comp value)
  (setf (component-y-coordinate comp) value)
  (assign-component-upper-bound comp value)
  (assign-component-lower-bound comp value)
  (map-on-outputs comp
    (lambda (out y-val)
      (when (floating? out)
	(setf (wire-y-coordinate out) y-val)))))
      
(defun middle-out-sort (items)
  (when items
    (let ((mid (floor (/ (length items) 2))))
      (nconc (list (nth mid items))
	     (middle-out-sort (subseq items 0 mid))
	     (middle-out-sort (subseq items (1+ mid)))))))


(defun clean-up-wires (circ)
  (dolist (wire (wires circ))
    (unless (some (lambda (level)
		    (member wire level))
		  (levels circ))
      (dolist (comp (all-components circ))
	(map-on-io-wires comp
			 (lambda (io-wire y-val)
			   (when (eq io-wire wire)
			     (setf (wire-y-coordinate wire) y-val))))))))

(defun map-on-io-wires (comp fun)
  (map-on-inputs comp fun)
  (map-on-outputs comp fun))

(emacs-indent map-on-inputs 1)

(defun map-on-inputs (comp fun)
  (let* ((comp-y-value (component-y-coordinate comp))
	 (y-delta *io-delta*))
    (dolist (wire (component-inputs comp))
      (funcall fun wire (- comp-y-value y-delta))
      (incf y-delta *io-delta*))))

(emacs-indent map-on-outputs 1)

(defun map-on-outputs (comp fun)
  (let* ((comp-y-value (component-y-coordinate comp))
	 (y-delta *io-delta*))
    (dolist (wire (component-outputs comp))
      (funcall fun wire (- comp-y-value y-delta))
      (incf y-delta *io-delta*))))



;========================================================================
;We now assign x-coordinates to each component and to each input
;and output of the circuit and each input and output of each component.
;========================================================================

(defvar *between-level-spacing* .14)

(defvar *max-levels* 3)

(defvar *inter-level-spacing* (/ (- 1.0 *between-level-spacing*) *max-levels*))

(defvar *component-width* (- *inter-level-spacing* *between-level-spacing*))

(defun right-border (circ)
  (max 1
       (+ *between-level-spacing*
	  (* *inter-level-spacing* (length (levels circ))))))

(defun assign-x-coordinates (circ)
  (assign-component-x-coordinates circ)
  (assign-component-io-x-coordinates circ))


(defun assign-component-x-coordinates (circ)
  (let ((x-coor *between-level-spacing*))
    (dolist (level (levels circ))
      (dolist (comp level)
	(unless (symbolp comp)
	  (setf (component-x-coordinate comp) x-coor)))
      (incf x-coor *inter-level-spacing*))))	  

(defun assign-component-io-x-coordinates (circ)
  (assign-x-internal circ 0 'inputs (levels circ)))

(defun assign-x-internal (circ x-coor previous-level remaining-levels)
  (let ((next-level (if remaining-levels (car remaining-levels) 'outputs)))
    (let ((sorted-wires (sort-wires circ previous-level next-level)))
      (let ((wire-x-coordinates (interlevel-x-coordinates sorted-wires x-coor)))
	(assign-level-x-forward circ previous-level wire-x-coordinates)
	(assign-level-x-backward circ next-level wire-x-coordinates)
	(when remaining-levels
	  (assign-x-internal circ (+ x-coor *inter-level-spacing*) next-level (cdr remaining-levels)))))))


(defun semi-max (x y)
  (if x
      (if y
	  (max x y)
	  x)
      y))

(defun semi-min (x y)
  (if x
      (if y
	  (min x y)
	  x)
      y))

(defmacro maxf (loc newval)
  `(setf ,loc (semi-max ,loc ,newval)))

(defmacro minf (loc newval)
  `(setf ,loc (semi-min ,loc ,newval)))

(emacs-indent map-on-connections 3)

(emacs-indent map-on-circuit-inputs 2)

(emacs-indent map-on-circuit-outputs 2)

(emacs-indent map-on-forward-connections 2)

(emacs-indent map-on-backward-connections 2)

(defun sort-wires (circ level1 level2)
  (let ((connected-wires nil)
	(y-min-alist nil)
	(y-max-alist nil)
	(preference-arcs nil)
	(hard-preference-arcs nil))
    (map-on-connections circ level1 level2
      (lambda (wire y-val)
	(pushnew wire connected-wires)
	(minf (assoc-value wire y-min-alist) y-val)
	(maxf (assoc-value wire y-max-alist) y-val)))
    (map-on-forward-connections circ level1
      (lambda (wire y-val)
	(dolist (wire2 connected-wires)
	  (when (and (not (eq wire2 wire))
		     (<= y-val (assoc-value wire2 y-max-alist))
		     (>= y-val (assoc-value wire2 y-min-alist)))
	    (push (cons wire wire2) preference-arcs)))))
    (map-on-backward-connections circ level2
      (lambda (wire y-val)
	(dolist (wire2 connected-wires)
	  (when (and (not (eq wire2 wire))
		     (<= y-val (assoc-value wire2 y-max-alist))
		     (>= y-val (assoc-value wire2 y-min-alist)))
	    (push (cons wire2 wire) preference-arcs)))))
    (map-on-backward-connections circ level2
      (lambda (back-wire back-y-val)
	(map-on-forward-connections circ level1
	  (lambda (forward-wire forward-y-val)
	    (when (<= (abs (- forward-y-val back-y-val)) .01)
	      (push (cons forward-wire back-wire) hard-preference-arcs))))))
    (heuristic-topsort-with-hard-constraints connected-wires preference-arcs hard-preference-arcs)))

(defun map-on-connections (circ level1 level2 fun)
  (map-on-forward-connections circ level1 fun)
  (map-on-backward-connections circ level2 fun))
    
(defun map-on-forward-connections (circ level fun)
  (if (eq level 'inputs)
      (map-on-circuit-inputs circ fun)
      (dolist (comp level)
	(if (wire? comp)
	    (funcall fun comp (wire-y-coordinate comp))
	    (map-on-outputs comp fun)))))

(defun map-on-circuit-inputs (circ fun)
  (let* ((delta (/ 1.0 (+ 1 (length (inputs circ)))))
	 (y-delta delta))
    (dolist (wire (inputs circ))
      (funcall fun  wire (- 1.0 y-delta))
      (incf y-delta delta))))

(defun map-on-backward-connections (circ level fun)
  (if (eq level 'outputs)
      (map-on-circuit-outputs circ fun)
      (dolist (comp level)
	(if (wire? comp)
	    (funcall fun comp (wire-y-coordinate comp))
	    (map-on-inputs comp fun)))))

(defun map-on-circuit-outputs (circ fun)
  (let* ((delta (/ 1.0 (+ 1 (length (outputs circ)))))
	 (y-delta delta))
    (dolist (wire (outputs circ))
      (funcall fun  wire (- 1.0 y-delta))
      (incf y-delta delta))))

(defvar *routing-width* .04)

(defvar *label-space* (/ (- *between-level-spacing* *routing-width*) 2))

(defun interlevel-x-coordinates (sorted-wires x-coor)
  (let ((result nil)
	(wire-delta (if (< (length sorted-wires) 2)
			0
			(/ *routing-width* (1- (length sorted-wires)))))
	(wire-x (+ x-coor *label-space*)))
    (dolist (wire sorted-wires)
      (setf result (acons wire wire-x result))
      (incf wire-x wire-delta))
    result))

(defun assign-level-x-forward (circ level wire-x-alist)
  (cond ((eq level 'inputs)
	 (setf (input-x-coordinates circ)
	       (mapcar (lambda (in) (cdr (assoc in wire-x-alist)))
		       (inputs circ))))
	(t
	 (dolist (comp level)
	   (unless (symbolp comp)
;	     (format t "~% assigning output x coordinates to ~s with outs ~s and wires ~s" comp (component-outputs comp) (mapcar 'car wire-x-alist))
	     (setf (component-output-x-coordinates comp)
		   (mapcar (lambda (out) (cdr (assoc out wire-x-alist)))
			   (component-outputs comp))))))))

(defun assign-level-x-backward (circ level wire-x-alist)
  (cond ((eq level 'outputs)
	 (setf (output-x-coordinates circ)
	       (mapcar (lambda (in) (cdr (assoc in wire-x-alist)))
		       (outputs circ))))
	(t
	 (dolist (comp level)
	   (unless (symbolp comp)
	     (setf (component-input-x-coordinates comp)
		   (mapcar (lambda (out) (cdr (assoc out wire-x-alist)))
			   (component-inputs comp))))))))



;========================================================================
;test cases
;========================================================================

(defun define-circuits ()
  (declare-type 3d-position (3-vector position (Q 1 0 0) (Q 1 0 0) (Q 1 0 0)))

  (declare-type 3d-vector (3-vector vector (Q 1 0 0) (Q 1 0 0) (Q 1 0 0)))

  (declare-type 3d-velocity (3-vector velocity (Q 1 -1 0) (Q 1 -1 0) (Q 1 -1 0)))

  (declare-primitive 3d-position-difference
		     (:inputs (x 3d-position) (y 3d-position))
		     (:outputs (diff 3d-vector))
		     (:output-procedure 3-vector-difference))

  (declare-primitive 3d-position-plus-vector
		     (:inputs (x 3d-position) (y 3d-vector))
		     (:outputs (sub 3d-position))
		     (:output-procedure 3-vector-sum))

  (declare-primitive 3-vector-difference
		     (:inputs (x (3-vector ?type1 (Q ?n1 ?n2 ?n3) (Q ?n4 ?n5 ?n6) (Q ?n7 ?n8 ?n9)))
			      (y (3-vector ?type2 (Q ?n1 ?n2 ?n3) (Q ?n4 ?n5 ?n6) (Q ?n7 ?n8 ?n9))))
		     (:outputs (diff (3-vector ?type3 (Q ?n1 ?n2 ?n3) (Q ?n4 ?n5 ?n6) (Q ?n7 ?n8 ?n9))))
		     (:output-procedure 3-vector-difference))

  (declare-primitive 3-vector-sum
		     (:inputs (x (3-vector ?type1 (Q ?n1 ?n2 ?n3) (Q ?n4 ?n5 ?n6) (Q ?n7 ?n8 ?n9)))
			      (y (3-vector ?type2 (Q ?n1 ?n2 ?n3) (Q ?n4 ?n5 ?n6) (Q ?n7 ?n8 ?n9))))
		     (:outputs (diff (3-vector ?type3 (Q ?n1 ?n2 ?n3) (Q ?n4 ?n5 ?n6) (Q ?n7 ?n8 ?n9))))
		     (:output-procedure 3-vector-sum))

  (declare-primitive 3-vector-weighted-combination
		     (:inputs (x (3-vector ?type1 (Q ?n1 ?n2 ?n3) (Q ?n4 ?n5 ?n6) (Q ?n7 ?n8 ?n9)))
			      (y (3-vector ?type2 (Q ?n1 ?n2 ?n3) (Q ?n4 ?n5 ?n6) (Q ?n7 ?n8 ?n9))))
		     (:outputs (diff (3-vector ?type3 (Q ?n1 ?n2 ?n3) (Q ?n4 ?n5 ?n6) (Q ?n7 ?n8 ?n9))))
		     (:output-procedure 3-vector-weighted-combination))

  (define-circuit 3-vector-difference-from-previous
      (:inputs clock val)
    (:register-init previous-val 3-vector-0)
    (:component diff (3-vector-difference val previous-val))
    (:register-input previous-val val clock)
    (:outputs diff))

  (declare-primitive +
		     (:inputs (x (Q ?n1 ?n2 ?n3)) (y (Q ?n1 ?n2 ?n3)))
		     (:outputs (sum (Q ?n1 ?n2 ?n3)))
		     (:output-procedure +))

  (declare-primitive -
		     (:inputs (x (Q ?n1 ?n2 ?n3)) (y (Q ?n1 ?n2 ?n3)))
		     (:outputs (sum (Q ?n1 ?n2 ?n3)))
		     (:output-procedure -))

  (define-circuit 3-vector-complementary-filter
      (:inputs clock-input s1 s2)
    (:outputs combination)
    (:register-init reg-for-previous 0)
    (:component delta-s1 (3-vector-difference-from-previous clock-input s1))
    (:component new-s1-estimate (3-vector-sum reg-for-previous delta-s1))
    (:component combination (3-vector-weighted-combination s2 new-s1-estimate))
    (:register-input reg-for-previous combination clock-input))

  (declare-primitive inu-device
		     (:inputs (measure-clock :clock))
		     (:outputs (inu-pos 3d-position)
			       (inu-velocity 3d-velocity))
		     (:clock-procedure measure-clock internaly-update-inu)
		     (:instance-maker make-inu-device)
		     (:output-procedure updated-inu-output))

  (declare-primitive gps-device
		     (:inputs (measure-clock :clock))
		     (:outputs (gps-pos 3d-position))
		     (:clock-procedure measure-clock internally-update-gps)
		     (:instance-maker make-gps-device)
		     (:output-procedure updated-gps-output))

  (define-circuit simple-guidance
      (:inputs basic-clock)
    (:outputs position inu-vel)
    (:component inu-pos inu-vel (inu-device basic-clock))
    (:component gps-pos (gps-device basic-clock))
    (:component position (3-vector-complementary-filter basic-clock inu-pos gps-pos))))

(defvar test-circ)

(defun test ()
;  (define-circuits)
  (setq test-circ (circuit-named '3-vector-complementary-filter))
  (compute-layout test-circ)
;  (create-register-components test-circ)
;  (assign-levels test-circ)
;  (y-coordinates-phase1 test-circ)
;  (y-coordinates-phase2 test-circ)
;  (clear-phase3-info test-circ)
;  (assign-wire-ys test-circ)
;  (dolist (level (levels test-circ))
;    (assign-component-heights 'bottom nil level))
;  (clean-up-wires test-circ)
;  (insulate-wire-values test-circ)
;  (assign-x-coordinates test-circ)
  )

(defun show-levels (test-circ)
  (compute-layout test-circ)
  (let ((level-view (mapcar (lambda (level)
			      (mapcar (lambda (comp)
					(cons comp
					      (if (symbolp comp)
						  (assoc-value comp (wire-y-coordinates test-circ))
						  (component-y-coordinate comp))))
				      level))
			    (levels test-circ))))
    (rprint level-view)))