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

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

;the following avoids name conflicts between the common-lisp package and the clim package

(shadow '(close input-stream-p stream-element-type output-stream-p streamp make-instance))

;the following avoids name conflicts between the clos package and the clim package

(shadow '(make-instance))

(use-package '(:clim :clos))
;the following avoids name conflicts between the common-lisp package and the clim package

(shadow '(close input-stream-p stream-element-type output-stream-p streamp make-instance))

;the following avoids name conflicts between the clos package and the clim package

(shadow '(make-instance))

(use-package '(:clim :clos))


(defstruct (circuit (:conc-name nil)
		    (:print-function (lambda (self stream &rest ignore)
				       (declare (ignore ignore))
				       (format stream "[circuit ~s]" (circuit-print-name self)))))
  circuit-print-name
  inputs
  input-x-coordinates
  register-inits
  components
  all-components
  register-inputs
  outputs
  output-x-coordinates
  wires
  wire-types
  clock-procedures
  output-procedure
  circuit-type
  instance-maker
  clock-inputs
  levels
  wire-y-coordinates
  source-file
  sample-times
  sample-values
  ids
  checked?
  assignments)

(defvar *dam-ignoring-errors* nil)

(defmacro dam-ignore-errors (&rest body)
  `(catch 'dam-ignoring-errors
    (let ((*dam-ignoring-errors* t))
      ,@body)))

(defmacro dam-error (string &rest args)
  `(if *dam-ignoring-errors*
    (progn (print-on-explainer (format nil ,string ,@args))
	   (throw 'dam-ignoring-errors nil))
    (error ,string ,@args)))

(defmacro dam-warning (string &rest args)
  `(if *dam-ignoring-errors*
    (progn (print-on-explainer (format nil ,string ,@args))
	   (throw 'dam-ignoring-errors nil))
    (format t ,string ,@args)))

(definline wire? (x)
  (symbolp x))

(definline wire-name (wire)
  wire)

(definline register-part (register-input)
  (first register-input))

(definline data-part (register-input)
  (second register-input))

(definline clock-part (register-input)
  (third register-input))

(definline initial-value (register-init)
  (second register-init))

(property-macro global-register?)

(defmacro declare-global-register (name initial-value)
  `(global-reg-fun ',name ',initial-value))

(defvar *global-initializations* nil)

(defun global-reg-fun (name init-value)
  (setf (global-register? name) t)
  (push (make-assignment name init-value) *global-initializations*))

(defun wire-type (wire circuit)
  (or (assoc-value wire (wire-types circuit))
      (let ((type (new-type-variable 'undeclared-type)))
	(setf (assoc-value wire (wire-types circuit)) type)
	type)))

(property-macro circuit-named)

(defun get-circuit-named (name)
  (let ((circuit (circuit-named name)))
    (unless circuit (dam-error "there is no circuit-named ~s" name))
    circuit))

(property-macro primitive-name?)

(defmacro declare-primitive (name &rest declarations)
  `(declare-primitive-fun ',name ',declarations))

(emacs-indent declare-primitive 1)

(defun declare-primitive-fun (name declarations)
  (let ((circuit (make-circuit)))
    (setf (circuit-named name) circuit)
    (setf (circuit-print-name circuit) name)
    (setf (primitive-name? name) t)
    (dolist (decl declarations)
      (case (car decl)
	(:inputs (when (inputs circuit)
		   (dam-error "only one data inputs declaration is allowed"))
		 (setf (inputs circuit)
		       (cdr decl)))
	(:outputs (when (outputs circuit)
		    (dam-error "only one outputs declaration is allowed"))
		  (setf (outputs circuit)
			(cdr decl)))
	(:output-procedure
	 (setf (output-procedure circuit) (second decl)))
	(:clock-procedure
	 (push (cons (second decl) (third decl)) (clock-procedures circuit))
	 (unless (matches? (wire-type (second decl) circuit) :clock)
	   (dam-error "attempt to place clock procedure on non-clock input")))
	(:instance-maker
	  (setf (instance-maker circuit)
		(second decl)))
	(:component (dam-error "primitive circuits may not contain components"))
	(:register-init (dam-error "primitive circuits may not contain registers"))
	(:register-input (dam-error "primitive circuits may not contain registers"))
	(t (dam-error "unrecognized declaration ~s" (car decl)))))
    (setf (clock-inputs circuit)
	  (mapcar 'car (remove-if-not #'(lambda (x) (and (consp x) (eq (second x) :clock)))
				      (inputs circuit))))
    (straighten-out-io-spec circuit)
    (type-check-circuit circuit)
    (dolist (cproc (clock-procedures circuit))
      (unless (member (car cproc) (clock-inputs circuit))
	(dam-error "the clock ~s is not a clock input of the circuit" (car cproc))))
    (dolist (cinput (clock-inputs circuit))
      (unless (assoc-value cinput (clock-procedures circuit))
	(dam-error "the clock input ~s has no clock-update-procedure" cinput)))
    (when (and (clock-inputs circuit)
	       (null (instance-maker circuit)))
      (dam-error "the circuit has clock procedures but no instance maker"))
    (when (null (output-procedure circuit))
      (dam-error "the primitive ~s has a data input but no data update procedure" name))
    name))

(defmacro define-circuit (name &rest declarations)
  `(define-circuit-fun ',name ',declarations))

(emacs-indent define-circuit 1)

(defun define-circuit-fun (name declarations)
  (define-concrete-circuit-fun name declarations))

;the wires slot in a circuit is initialized to those wires that
;are assigned values.  In a well formed circuit this is exactly
;the set of all wires.

(defstruct (component (:print-function (lambda (self stream ignore)
					 (declare (ignore ignore))
					 (format stream "[component ~s]" (append (component-outputs self)
										 (list (component-name self)))))))
  name
  inputs
  outputs
  register?
  id
  ;the following are used in graphical layout
  level
  x-coordinate
  y-coordinate
  input-x-coordinates
  output-x-coordinates
  target-y-sum
  target-y-count
  upper-delta
  vertical-successor
  lower-delta
  vertical-predicessor
  upper-bound
  lower-bound)
  
(defun define-concrete-circuit-fun (name declarations)
  (let ((circuit (circuit-for-specs name declarations)))
    (check-circuit circuit)
    name))

(defun subcircuits (circ)
  (mapcar (lambda (comp) (circuit-named (component-name comp)))
	  (components circ)))

(defun check-circuit (circuit)
  (check-wires circuit)
  (type-check-circuit circuit))

(defun check-circuit-top-level (circ)
  (clear-checks circ)
  (recursively-check circ)
  (initialize-assignments (instantiate-circuit (circuit-print-name circ))))

(defun clear-checks (circ)
  (let ((so-far nil))
    (labels ((real-check (circ)
	       (when circ
		 (unless (member circ so-far)
		   (setf (checked? circ) nil)
		   (setf (wire-types circ) nil)
		   (push circ so-far)
		   (dolist (comp (components circ))
		     (real-check (circuit-named (component-name comp))))))))
      (real-check circ))))

(defun recursively-check (circ)
  (when circ
    (unless (or (checked? circ) (primitive-name? (circuit-print-name circ)))
      (setf (checked? circ) t)
      (dolist (comp (components circ))
	(recursively-check (circuit-named (component-name comp))))
      (straighten-out-io-spec circ)
      (check-circuit circ))))

(defun circuit-for-specs (name declarations)
  (let ((circuit (make-circuit)))
    (setf (circuit-named name) circuit)
    (setf (circuit-print-name circuit) name)
    (setf (primitive-name? name) nil)
    (dolist (decl declarations)
      (case (car decl)
	(:inputs (when (inputs circuit)
		   (dam-error "only one data inputs declaration is allowed"))
		 (setf (inputs circuit)
		       (cdr decl))
		 (dolist (input (cdr decl))
		   (push (strip-off-type input) (wires circuit))))
	(:outputs (when (outputs circuit)
		    (dam-error "only one outputs declaration is allowed"))
		  (setf (outputs circuit)
			(cdr decl)))
	(:component
	 (let* ((call (first (last decl)))
		(name (first call))
		(outputs (cddr (butlast decl)))
		(id (second decl)))
	   (when (find #\. (string id))
	     (dam-error "Error in component ~s component ID's may not contain the '.' character" id))
	   (when (member id (ids circuit))
	     (dam-error "Two components has the same name: ~s" id))
	   (push id (ids circuit))
	   (let ((comp (make-component :name name :inputs (cdr call) :id id
				       :outputs outputs)))
	     (push comp (components circuit))
	     (dolist (wire (component-outputs comp))
	       (pushnew wire (wires circuit)))
	     (dolist (wire (component-inputs comp))
	       (pushnew wire (wires circuit))))))
	(:register-init
	 (push (cdr decl) (register-inits circuit))
	 (push (second decl) (wires circuit)))
	(:register-input
	 (push (cdr decl) (register-inputs circuit)))
	(t (dam-error "unrecognized declaration ~s" (car decl)))))
    (straighten-out-io-spec circuit)
    circuit))

(defun straighten-out-io-spec (circuit)
  (setf (circuit-type circuit)
	(copy-type-expression (list (mapcar #'(lambda (input) (if (consp input)
								  (second input)
								  (new-type-variable 'undeclared-type)))
					    (inputs circuit))
				    (mapcar #'(lambda (output) (if (consp output)
								   (second output)
								   (new-type-variable 'undeclared-type)))
					    (outputs circuit)))))  
  (setf (inputs circuit)
	(mapcar #'strip-off-type (inputs circuit)))
  (setf (outputs circuit)
	(mapcar #'strip-off-type (outputs circuit))))

(defun type-check-circuit (circuit)
  (dolist (comp (components circuit))
    (check-component comp circuit))
  (dolist (reg-inp (register-inputs circuit))
    (unless (matches? (wire-type (third reg-inp) circuit) :clock)
      (dam-error "illegal clock signal in ~s" (cons 'register-input reg-inp)))
    (unless (matches? (wire-type (first reg-inp) circuit)
		      (wire-type (second reg-inp) circuit))
      (dam-error "type violation in register input ~s" (cons 'register-input reg-inp))))
  (mapc #'(lambda (input input-type)
	    (unless (matches? (wire-type input circuit) input-type)
	      (dam-error "illegal input type derived for input ~s" input)))
	(inputs circuit) (first (circuit-type circuit)))
  (mapc #'(lambda (output output-type)
	    (unless (matches? (wire-type output circuit) output-type)
	      (dam-error "illegal output type for output ~s" output)))
	(outputs circuit) (second (circuit-type circuit)))
  (setf (circuit-type circuit) (make-instance (circuit-type circuit))))

(defun check-component (comp circuit)
  (let ((circ (circuit-named (component-name comp))))
    (unless circ
      (dam-error "undefined component ~s" (component-name comp)))
    (unless (matches? (io-type (component-inputs comp) (component-outputs comp) circuit)
		      (copy-type-expression (circuit-type circ)))
      (dam-error "type violation in ~s " (cons :component
					   (append (component-outputs comp)
						   (list (cons (component-name comp)
							       (component-inputs comp)))))))))

(defun io-type (inputs outputs circuit)
  (list (mapcar #'(lambda (input) (make-instance (wire-type input circuit)))
		inputs)
	(mapcar #'(lambda (input) (make-instance (wire-type input circuit)))
		outputs)))

(defun strip-off-type (input)
  (if (consp input) (car input) input))


;========================================================================
;we need to check that no wire has two sources, every wire is used,
;and no register is set twice by the same clock.
;========================================================================

(defun check-wires (circuit)
  (let ((redundant-wire (find-duplicate (wires circuit))))
    (when redundant-wire
      (dam-error "the wire ~s has two sources" redundant-wire)))
  (when (some (lambda (wire) (global-register? wire)) (wires circuit))
    (dam-error "attempt to assign a value to the global wire ~s"))
  (let ((used-wires (append (outputs circuit)
			    (mapcan #'(lambda (comp) (copy-list (component-inputs comp)))
				    (components circuit))
			    (mapcan #'(lambda (ri) (copy-list (cdr ri)))
				    (register-inputs circuit)))))
;    (let ((unused-wire (find-if (lambda (wire) (not (member wire used-wires)))
;				(wires circuit))))
;      (when unused-wire
;	(dam-error "the wire ~s is not used" unused-wire)))
    (let ((undefined-wire (find-if #'(lambda (wire)
				       (and (not (member wire (wires circuit)))
					    (not (global-register? wire))))
				   used-wires)))
      (when undefined-wire
	(dam-error "the wire ~s is not defined" undefined-wire))))
  (dolist (r-input (register-inputs circuit))
    (unless (or (member (car r-input) (register-inits circuit) :key #'car)
		(global-register? (car r-input)))
      (dam-error "uninitialized register ~s" (car r-input)))		  
    (dolist (r-input2 (register-inputs circuit))
      (when (and (not (eq r-input r-input2))
		 (eq (first r-input2) (first r-input))
		 (eq (third r-input2) (third r-input)))
	(dam-error "the register ~s is set twice by the same clock" (first r-input2))))))

(defun find-duplicate (items)
  (when items
    (if (member (car items) (cdr items))
	(car items)
	(find-duplicate (cdr items)))))

(defun report-bug ()
  (dam-error "this is bug that should be reported to the system builders"))




;========================================================================
;An ML type system.
;========================================================================

(defstruct (type-variable (:print-function (lambda (self stream ignore)
					       (declare (ignore ignore))
					       (format stream "[~s ~s]"
						       (type-variable-name self)
						       (type-variable-index self))))
			  (:predicate type-variable?))
  name
  index
  binding)

(property-macro cached-variable-count)

(property-macro type-value)

(defmacro declare-type (name type)
  `(setf (type-value ',name) (copy-type-expression ',type)))

(defun copy-type-expression (template &optional bindings)
  (cond ((or (variable? template) (type-variable? template))
	 (let ((binding (cdr (assoc template bindings))))
	   (if binding
	       (values binding bindings)
	       (let ((new-var (new-type-variable (if (symbolp template) template (type-variable-name template)))))
		 (values new-var (acons template new-var bindings))))))
	((and (symbolp template)
	      (type-value template))
	 (values (copy-type-expression (type-value template)) bindings))
	((consp template)
	 (mvlet (((car-exp bindings2) (copy-type-expression (car template) bindings)))
	   (mvlet (((cdr-exp bindings3) (copy-type-expression (cdr template) bindings2)))
	     (values (cons car-exp cdr-exp) bindings3))))
	(t (values template bindings))))
		   
(defun new-type-variable (name)
  (let ((var (make-type-variable :name name)))
    (let ((index (cached-variable-count name)))
      (if index
	  (progn (setf (cached-variable-count name) (1+ index))
		 (setf (type-variable-index var) index))
	  (progn (setf (cached-variable-count name) 1)
		 (setf (type-variable-index var) 0))))
    var))


(defun matches? (types1 types2)
  (catch 'failure
    (unify! types1 types2)
    t))

(defun declare-same! (e1 e2)
  (unless (matches? e1 e2)
    (dam-error "type failure")))

(defun fail ()
  (throw 'failure nil))

(defun unify! (e1 e2)
  (setq e1 (compress-variable e1))
  (setq e2 (compress-variable e2))
  ;;neither e1 nor e2 are bound variables.
  (cond ((type-variable? e1)
	 (bind! e1 e2))
	((type-variable? e2)
	 (bind! e2 e1))
	((not (consp e1))
	 (when (not (eq e1 e2))
	   (fail)))
	((not (consp e2))
	 (fail))
	(t (unify! (car e1) (car e2))
	   (unify! (cdr e1) (cdr e2)))))

(defun compress-variable (var)
  (cond ((not (type-variable? var))
	 var)
	((type-variable-binding var)
	 (compress-variable (type-variable-binding var)))
	(t var)))

(defun bind! (var exp)
  (when (not (eq var exp))
    (if (occurs-in? var exp)
	(fail)
	(setf (type-variable-binding var) exp))))

(defun occurs-in? (var exp)
  (or (eq var exp)
      (and (consp exp)
	   (or (occurs-in? var (car exp))
	       (occurs-in? var (cdr exp))))
      (and (type-variable? exp)
	   (type-variable-binding exp)
	   (occurs-in? var (type-variable-binding exp)))))

(defun make-instance (exp)
  (cond ((type-variable? exp)
	 (if (type-variable-binding exp)
	     (make-instance (type-variable-binding exp))
	     exp))
	((consp exp)
	 (cons (make-instance (car exp))
	       (make-instance (cdr exp))))
	(t exp)))




(defmacro declare-structure-type (name &rest slots)
  (let ((slot-names (mapcar (lambda (slot) (if (consp slot) (car slot) slot))
			    slots)))
  `(progn
      (defstruct (,name (:constructor ,(combine-symbols 'make name) ,slot-names))
	,@slot-names)
      (declare-primitive ,(combine-symbols 'make name)
	(:inputs ,@slots)
	(:outputs (output ,name))
	(:output-procedure ,(combine-symbols 'make name)))
      ,@(mapcar (lambda (slot)
		  (let ((slot-name (if (consp slot) (car slot) slot)))
		    `(declare-primitive ,(combine-symbols name slot-name)
		      (:inputs (input ,name))
		      (:outputs ,slot)
		      (:output-procedure ,(combine-symbols name slot-name)))))
	        slots))))



;========================================================================
;we now have code to make instances of circuit types
;========================================================================

(defun circuit-code (name)
  (let* ((circuit (circuit-named name)))
    (unless circuit
      (dam-error "there is no circuit named ~s" name))
    (let* ((inputs (inputs circuit))
	   (outputs (outputs circuit))
	   (name2 (make-circuit-instance name inputs outputs)))
      (initialize-assignments name2)
      (values (append (variable-declarations name2)
		      (list (init-procedure name2))
		      (mapcan #'(lambda (input)
				  (when (eq :clock (make-instance (wire-type input circuit)))
				    (list (clock-procedure name2 input))))
			      inputs))
	      name2))))

(defun instantiate-circuit (name)
  (let ((name (make-circuit-instance name (inputs (circuit-named name)) (outputs (circuit-named name)))))
    (initialize-assignments name)
    name))

(defun clock-wire? (wire circuit)
  (eq :clock (make-instance (wire-type wire circuit))))
	  
(defun make-circuit-instance (circuit-name inputs outputs &optional (path-so-far nil))
;;  (expose (list 'circuit-name circuit-name 'inputs inputs 'outputs outputs 'path-so-far path-so-far) "Args to make-instance")
  (let ((circuit (circuit-named circuit-name)))
    (unless circuit
      (dam-error "undefined circuit type ~s" circuit-name))
    ;;we assume that the circuit type-checks.
    (let* ((internal-renaming (mapcar (lambda (wire)
					(cons wire (if path-so-far
						       (combine-symbols (combine-symbol-list path-so-far
											     *package* :inserting ".")
									wire
									*package*
									:inserting ".")
						       wire)))
				      (wires circuit)))
	   (renaming (nconc (mapcar 'cons (inputs circuit) inputs)
			    (mapcar 'cons (outputs circuit) outputs)
			    internal-renaming))
	   (name (gentemp (string circuit-name)))
	   (circuit (make-circuit
		     :circuit-print-name name
		     :inputs inputs
		     :outputs outputs
		     :components (nconc (identity-components (inputs circuit) (outputs circuit) inputs outputs)
					(mapcar #'(lambda (comp) (make-component-instance comp renaming path-so-far))
						(components circuit)))
		     :register-inits (mapcar #'(lambda (register-init)
						 (cons (sublis renaming (car register-init))
						       (cdr register-init)))
					     (register-inits circuit))
		     :register-inputs (mapcar #'(lambda (register-input)
						  (sublis renaming register-input))
					      (register-inputs circuit))
		     :wires (sublis renaming (wires circuit))
		     :output-procedure (output-procedure circuit)
		     :clock-procedures (mapcar #'(lambda (cproc)
						   (cons (assoc-value (car cproc) renaming)
							 (cdr cproc)))
					       (clock-procedures circuit))
		    :circuit-type (copy-type-expression (circuit-type circuit))
		    :instance-maker (instance-maker circuit)
		    :clock-inputs (sublis renaming (clock-inputs circuit)))))
      (type-check-circuit circuit)
      (setf (circuit-named name) circuit)
      (setf (primitive-name? name) (primitive-name? circuit-name))
      name)))

(defun identity-components (cinputs coutputs inputs outputs)
  (mapcan (lambda (out)
	    (when (member out cinputs)
	      (format t "~% common output ~s" out)
	      (let ((external-in (assoc-value out (mapcar 'cons cinputs inputs)))
		    (external-out (assoc-value out (mapcar 'cons coutputs outputs))))
		(format t "~% in ~s out ~s" external-in external-out)
		(let ((id-circuit (make-circuit-instance 'identity (list external-in) (list external-out))))
		  (list (make-component :name id-circuit :inputs (list external-in) :outputs (list external-out)))))))
	  coutputs))

(defun make-component-instance (component renaming path-so-far)
  (let ((outputs (sublis renaming (component-outputs component)))
	(inputs (sublis renaming (component-inputs component))))
    (let ((new-circuit (make-circuit-instance (component-name component) inputs outputs
					      (append path-so-far (list (component-id component))))))
      (make-component :name new-circuit
		      :outputs outputs
		      :inputs inputs))))

(defun type-check-instance (circuit)
  (dolist (comp (components circuit))
    (check-component-instance comp circuit))
  (dolist (reg-inp (register-inputs circuit))
    (unless (matches? (wire-type (third reg-inp) circuit) :clock)
      (dam-error "illegal clock signal in ~s" (cons 'register-input reg-inp)))
    (unless (matches? (wire-type (first reg-inp) circuit)
		      (wire-type (second reg-inp) circuit))
      (dam-error "type violation in register input ~s" (cons 'register-input reg-inp))))
  (mapc #'(lambda (input input-type)
	    (unless (matches? (wire-type input circuit) input-type)
	      (dam-error "illegal instance input type derived for input ~s" input)))
	(inputs circuit) (first (circuit-type circuit)))
  (mapc #'(lambda (output output-type)
	    (unless (matches? (wire-type output circuit) output-type)
	      (dam-error "illegal instance output type for output ~s" output)))
	(outputs circuit) (second (circuit-type circuit)))
  (setf (circuit-type circuit) (make-instance (circuit-type circuit))))

(defun check-component-instance (comp circuit)
  (let ((circ (circuit-named (component-name comp))))
    (unless circ
      (dam-error "undefined component ~s" (component-name comp)))
    (unless (matches? (io-type (component-inputs comp) (component-outputs comp) circuit)
		      (circuit-type circ))
      (dam-error "type violation in ~s " (cons :component
					   (append (component-outputs comp)
						   (list (cons (component-name comp)
							       (component-inputs comp)))))))))



(defun initialize-assignments (name)
  (let ((circ (circuit-named name))
	(assignments (circuit-assignments name)))
    (setf (assignments circ) (sort-assignments assignments))))

(defun circuit-assignments (name)
  (let* ((circuit (get-circuit-named name)))
    (component-assignments (components circuit))))

(defun component-assignments (components)
  (when components
    (let* ((next-comp (car components))
	   (name (component-name next-comp)))
      (append (if (primitive-name? name)
		  (primitive-data-code name)
		  (circuit-assignments name))
	      (component-assignments (cdr components))))))

(defun primitive-data-code (name)
  (let* ((circ (circuit-named name))
	 (inputs (remove-if #'(lambda (input) (member input (clock-inputs circ)))
			    (inputs circ)))
	 (outputs (outputs circ))
	 (arguments (if (clock-inputs circ)
			(cons name inputs)
			inputs)))			
    (when (output-procedure circ)
      (if (> (length outputs) 1)
	  (let ((temps (mapcar (lambda (ignore)
				 (declare (ignore ignore))
				 (gentemp "TEMP-"))
			       outputs)))
	    `((mvlet ((,temps (,(output-procedure circ) ,@arguments)))
		,@(mapcar (lambda (temp var)
			    `(setq ,var ,temp))
			  temps
			  outputs))))
	  (list (make-assignment (car outputs) `(,(output-procedure circ) ,@arguments)))))))

(defun sort-assignments (assignments)
  (mvlet (((sorted-ass backs) (heuristic-topsort-pred assignments
						      #'(lambda (a1 a2)
							  (some (lambda (o1)
								  (member o1 (ass-input-wires a2)))
								(ass-output-wires a1))))))
    (when backs
      (dam-error "there appears to be an instantaneous data loop"))
    sorted-ass))

(defun ass-input-wires (ass)
  (selectmatch ass
    ((setq :anything ?val)
     (if (consp ?val)
	 (cdr ?val)
	 (list ?val)))
    ((mvlet ((:anything (:anything . ?args))) . :anything)
     ?args)))

(defun ass-output-wires (ass)
  (selectmatch ass
    ((setq ?var :anything)
     (list ?var))
    ((mvlet :anything . ?body)
     (mapcar #'second ?body))))





;========================================================================
;Now we construct the procedure for circuit initialization and a procedure for each clock
;========================================================================

(defvar *constant-values* nil)

(defun variable-declarations (name)
  (let ((circuit (get-circuit-named name)))
    (append (mapcan #'(lambda (input)
			(when (not (clock-wire? input circuit))
			  (list (variable-declaration input circuit))))
		    (inputs circuit))
	    (mapcar #'(lambda (output) (variable-declaration output circuit))
		    (outputs circuit))
	    (mapcar #'(lambda (constant-pair) `(defvar ,(car constant-pair) nil))
		    *constant-values*)
	    (internal-variable-declarations circuit))))

(defun state-primitive? (circuit)
  (some #'(lambda (input) (clock-wire? input circuit))
	(inputs circuit)))

(defun internal-variable-declarations (circuit)
  (let ((result nil))
    (dolist (wire (wires circuit))
      (unless (or (member wire (inputs circuit))
		  (member wire (outputs circuit)))
	(push (variable-declaration wire circuit) result)))
    (dolist (comp (components circuit))
      (let* ((comp-name (component-name comp))
	     (comp-circ (circuit-named comp-name)))
	(cond ((primitive-name? comp-name)
	       (when (state-primitive? comp-circ)
		 (push `(defvar ,comp-name ,(format nil "a variable of type ~s state vector" comp-name))
		       result)))
	      (t
	       (setq result (append (internal-variable-declarations comp-circ)
				    result))))))
    result))

(defun variable-declaration (wire circuit)
  `(defvar ,wire ,(format nil "A variable of type ~s" (make-instance (wire-type wire circuit)))))

(defun init-procedure (name)
  (let ((circuit (get-circuit-named name)))
    (dolist (input-type (car (circuit-type circuit)))
      (unless (eq input-type :clock)
	(dam-error "the circuit ~s has a non-clock input and can not be initialized" name)))
    `(defun ,(combine-symbols name 'initialization) ()
      ,@(constant-initializations name)
      ,@(register-initializations name)
      ,@(assignments circuit))))

(defun constant-initializations (name)
  (let ((circuit (circuit-named name)))
    (unless circuit (dam-error "there is no circuit named ~s" name))
    (let ((constants (mapcar #'car *constant-values*))
	  (edges nil))
      (dolist (node1 constants)
	(dolist (node2 constants)
	  (when (internal-member node1 (assoc-value node2 *constant-values*))
	    (push (cons node1 node2) edges))))
      (let ((new-constants (heuristic-topsort constants edges)))
	(mapcar (lambda (c) `(setq ,c ,(assoc-value c *constant-values*))) new-constants)))))
      

(defun register-initializations (name)
  (let ((circuit (circuit-named name)))
    (unless circuit (dam-error "there is no circuit named ~s" name))
    (if (primitive-name? name)
	(when (instance-maker circuit)
	  (list (make-assignment name `(,(instance-maker circuit)))))
	(nconc (mapcan (lambda (r-init)
			 `((setq ,(first r-init) ,(second r-init))))
		       (register-inits circuit))
	       (mapcan #'(lambda (component)
			   (register-initializations (component-name component)))
		       (components circuit))))))
;
;(defun wire-initializations (name)
;  (labels ((initial-wire-inits (name)
;	     (let ((circuit (circuit-named name)))
;	       (if (primitive-name? name)
;		   (primitive-data-code name)
;		   (mapcan #'(lambda (comp) (initial-wire-inits (component-name comp)))
;			   (components circuit))))))
;    (let* ((nodes (initial-wire-inits name))
;	   (edges nil))
;      (dolist (node1 nodes)
;	(dolist (node2 nodes)
;	  (when (internal-member (second node1) (third node2))
;	    (push (cons node1 node2) edges))))
;      (heuristic-topsort nodes edges))))

(defun clock-procedure (name clock-input)
  `(defun ,(combine-symbols name clock-input) ()
    ,@(mvlet (((updates updated-wires) (register-updates-for name clock-input)))
	(nconc updates (circuit-ramifications name updated-wires)))))

(defun register-updates-for (name clock-input)
  (mvlet (((code updated-variables) (register-updates2 name clock-input)))
    (let* ((assignments (remove-if-not #'(lambda (update) (eq (car update) 'setq))
				       code))
	   (primitive-clock-updates (set-difference code assignments)))
      (values (nconc primitive-clock-updates (parallelize assignments))
	      updated-variables))))

(defun parallelize (assignments)
  (when assignments
    (add-parallel-assignment (car assignments)
			     (parallelize (cdr assignments)))))

(defun assigned-var (ass)
  (second ass))

(defun assigned-val (ass)
  (third ass))

(defun make-assignment (var val)
  (list 'setq var val))

(defun add-parallel-assignment (assignment others)
  (if (null others)
      (list assignment)
      (let ((var (assigned-var assignment))
	    (val (assigned-val assignment)))
	(cond ((not (internal-member (assigned-var (first others)) val))
	       (cons (first others)
		     (add-parallel-assignment assignment (cdr others))))
	      ((not (internal-member var others))
	       (cons assignment others))
	      (t
	       (let ((temp (gentemp "TEMP-")))
		 (cons (make-assignment temp val)
		       (append others
			       (list (make-assignment var temp))))))))))

(defun register-updates2 (name clock-input)
  (let ((assignments nil)
	(variables nil))
    (labels ((reg-update-3 (name)
	       (let ((circuit (get-circuit-named name)))
		 (if (primitive-name? name)
		     (when (member clock-input (inputs circuit))
		       (let ((proc (assoc-value clock-input (clock-procedures circuit))))
			 (unless proc
			   (dam-error "no clock procedure for clock input in primitive ~s" name))
			 (push `(,proc ,name) assignments)
			 (setq variables (append (outputs circuit) variables))))
		     (progn
		       (dolist (r-input (register-inputs circuit))
			 (when (eq (third r-input) clock-input)
			   (push (make-assignment (first r-input) (second r-input))
				 assignments)
			   (push (first r-input) variables)))
		       (dolist (component (components circuit))
			 (reg-update-3 (component-name component))))))))
      (reg-update-3 name)
      (values assignments variables))))

;ramification code

(defun circuit-ramifications (name updated-wires)
  (let* ((circuit (get-circuit-named name))
	 (assignments (assignments circuit)))
    ;since the assignments are sorted we can simply go through them
    (let  ((output nil))
      (dolist (ass assignments)
	(when (or (some (lambda (i) (member i updated-wires))
			(ass-input-wires ass))
		  (some (lambda (i) (member i updated-wires))
			(ass-output-wires ass)))
	  (push ass output)
	  (setf updated-wires (append (ass-output-wires ass) updated-wires))))
      (nreverse output))))
;
;(defun ramifications (components updated-wires)
;  (if (null components)
;      (values updated-wires nil)
;      (let* ((next-comp (car components))
;	     (name (component-name next-comp)))
;	(mvlet (((new-updated-wires code)
;		 (if (primitive-name? name)
;		     (primitive-ramifications name
;					      (component-inputs next-comp)
;					      (component-outputs next-comp)
;					      updated-wires)
;		     (circuit-ramifications name updated-wires))))
;	  (mvlet (((final-update-wires rest-code)
;		   (ramifications (cdr components) new-updated-wires)))
;	    (values final-update-wires (nconc code rest-code)))))))
;
;
;(defun primitive-ramifications (name inputs outputs updated-wires)
;  (if (some (lambda (x) (member x updated-wires))
;	    inputs)
;      (values (append outputs updated-wires)
;	      (primitive-data-code name))
;      (values updated-wires nil)))	      



	

(defun primitive-circuit? (circuit)
  (primitive-name? (circuit-print-name circuit)))


;;; simulator

(defmacro simulate (circuit-name clock-rates)
  `(simulate-fun ',circuit-name ',clock-rates))

;; clock-rates is an a-list mapping clock-inputs to pulses per unit time
;;
(defvar *sim-count* 0)

(defun simulate-fun (circuit-name clock-rates timeout notice-fun)
  (incf *sim-count*)
  (let ((circuit (circuit-named circuit-name)))
    (unless (and (circuit-p circuit)
		 (every #'consp clock-rates)
		 (equal clock-rates (remove-duplicates clock-rates :key #'car))
		 (subsetp (mapcar #'car clock-rates) (inputs (circuit-named circuit-name)))
		 (every #'numberp (mapcar #'cdr clock-rates))) 
      (dam-error "Simulate expects a circuit-name and an a-list of clock-input symbols and clock rates"))
    (mvlet (((code instance-name) (circuit-code circuit-name)))
      (mapc 'eval code)
      (dolist (form code)
	(selectmatch form
	  ((defun ?fun . :anything)
	   (compile ?fun))))
      (let ((instance (circuit-named instance-name))
;	    (wire-variables (mapcar #'second (remove-if-not (lambda (code) (eq (first code) 'defvar)) code)))
	    (schedule (sort (mapcar (lambda (clock-rate-pair) (cons (car clock-rate-pair)
								    (/ 1.0 (cdr clock-rate-pair))))
				    clock-rates)
			    #'< :key #'cdr))
	    (time 0))
	(setf (sample-times instance) nil)
	(setf (sample-values instance) nil)
	(funcall (combine-symbols instance-name 'initialization))
	(loop (when (> time timeout)
		(return-from simulate-fun (values (sample-times instance) (sample-values instance))) )
	      (funcall notice-fun time)
	      (let* ((pair (pop schedule))
		     (clock (car pair))
		     (stime (cdr pair)))
		(setf time stime)
		(funcall (combine-symbols instance-name clock))
		(setf schedule (sort (cons (cons clock (+ stime (/ 1.0 (assoc-value clock clock-rates))))
					   schedule)
				     #'< :key #'cdr))))))))

(defun sample (circuit time wire-variables)
  (push time (sample-times circuit))
  (dolist (var wire-variables)
    (push (symbol-value var) (assoc-value var (sample-values circuit)))))
		
(declare-structure-type 3-vector x y z)

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

;;;(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))
;;;
;;;(defun make-inu-device () (let ((instance (gensym "INU-DEVICE")))
;;;			    (setf (symbol-value instance) 0)
;;;			    instance))
;;;(defun internally-update-inu (device)
;;;  (setf (symbol-value device) (symbol-value device)))
;;;(defun updated-inu-output (device) (symbol-value device))
;;;
;;;(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))
;;;
;;;(defun make-gps-device () (let ((instance (gensym "GPS-DEVICE")))
;;;			    (setf (symbol-value instance) 0)
;;;			    instance))
;;;(defun internally-update-gps (device)
;;;  (setf (symbol-value device) (symbol-value device)))
;;;(defun updated-gps-output (device) (symbol-value device))
;;;
;;;(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)))

;
;(circuit-code 'simple-guidance)
;evaluates to
;
;((DEFVAR POSITION
;         "A variable of type (3-VECTOR [?TYPE3 17] (Q 1 0 0) (Q 1 0 0) (Q 1 0 0))")
;  (DEFVAR INU-VEL
;          "A variable of type (3-VECTOR VELOCITY (Q 1 -1 0) (Q 1 -1 0) (Q 1 -1 0))")
;  (DEFVAR PREVIOUS-VAL1842
;          "A variable of type (3-VECTOR POSITION (Q 1 0 0) (Q 1 0 0) (Q 1 0 0))")
;  (DEFVAR REG-FOR-PREVIOUS1236
;          "A variable of type (3-VECTOR [?TYPE3 17] (Q 1 0 0) (Q 1 0 0) (Q 1 0 0))")
;  (DEFVAR DELTA-S11135
;          "A variable of type (3-VECTOR [?TYPE2 10] (Q 1 0 0) (Q 1 0 0) (Q 1 0 0))")
;  (DEFVAR NEW-S1-ESTIMATE1034
;          "A variable of type (3-VECTOR [?TYPE2 11] (Q 1 0 0) (Q 1 0 0) (Q 1 0 0))")
;  (DEFVAR INU-DEVICE832
;          "a variable of type INU-DEVICE832 state vector")
;  (DEFVAR GPS-DEVICE731
;          "a variable of type GPS-DEVICE731 state vector")
;  (DEFVAR INU-POS428
;          "A variable of type (3-VECTOR POSITION (Q 1 0 0) (Q 1 0 0) (Q 1 0 0))")
;  (DEFVAR GPS-POS226
;          "A variable of type (3-VECTOR POSITION (Q 1 0 0) (Q 1 0 0) (Q 1 0 0))")
;  (DEFUN SIMPLE-GUIDANCE630-INITIALIZATION49
;         NIL
;         (SETQ GPS-DEVICE731 (MAKE-GPS-DEVICE))
;         (SETQ INU-DEVICE832 (MAKE-INU-DEVICE))
;         (SETQ REG-FOR-PREVIOUS1236 0)
;         (SETQ PREVIOUS-VAL1842 3-VECTOR-0)
;         (SETQ GPS-POS226 (UPDATED-GPS-OUTPUT GPS-DEVICE731))
;         (MVLET (((TEMP-50 TEMP-51) (UPDATED-INU-OUTPUT INU-DEVICE832)))
;                (SETQ INU-POS428 TEMP-50)
;                (SETQ INU-VEL TEMP-51))
;         (SETQ DELTA-S11135 (3-VECTOR-DIFFERENCE INU-POS428 PREVIOUS-VAL1842))
;               
;         (SETQ NEW-S1-ESTIMATE1034 (3-VECTOR-SUM REG-FOR-PREVIOUS1236
;                                                 DELTA-S11135))
;         (SETQ POSITION (3-VECTOR-WEIGHTED-COMBINATION GPS-POS226
;                                                       NEW-S1-ESTIMATE1034)))
;  (DEFUN SIMPLE-GUIDANCE630-BASIC-CLOCK52
;         NIL
;         (INTERNALLY-UPDATE-GPS GPS-DEVICE731)
;         (INTERNALY-UPDATE-INU INU-DEVICE832)
;         (SETQ PREVIOUS-VAL1842 INU-POS428)
;         (SETQ REG-FOR-PREVIOUS1236 POSITION)
;         (SETQ GPS-POS226 (UPDATED-GPS-OUTPUT GPS-DEVICE731))
;         (MVLET (((TEMP-53 TEMP-54) (UPDATED-INU-OUTPUT INU-DEVICE832)))
;                (SETQ INU-POS428 TEMP-53)
;                (SETQ INU-VEL TEMP-54))
;         (SETQ DELTA-S11135 (3-VECTOR-DIFFERENCE INU-POS428 PREVIOUS-VAL1842))
;               
;         (SETQ NEW-S1-ESTIMATE1034 (3-VECTOR-SUM REG-FOR-PREVIOUS1236
;                                                 DELTA-S11135))
;         (SETQ POSITION (3-VECTOR-WEIGHTED-COMBINATION GPS-POS226
;                                                       NEW-S1-ESTIMATE1034))))

(defun bad-pair (assignments)
  (iterate loop ((first (car assignments))
		 (rest (cdr assignments)))
    (when rest
      (dolist (next rest)
	(when (some (lambda (out) (member out (ass-input-wires first)))
		    (ass-output-wires next))
	  (return-from bad-pair (list first next))))
      (loop (car rest) (cdr rest)))))