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

(defvar *simulation-vector-w* nil)
(defvar *simulation-signal-w* nil)

(property-macro clock-alist)
(property-macro timeout)
(defvar *time-out* 10)
(defvar *current-path* nil)
(defvar *current-path-circuits* nil)
;(defvar *constant-file-name* "/home/on/dam/code/adage/constants.prim")

(define-application-frame circ-editor ()
  ((circuit :initform nil :accessor editor-circuit))
  (:panes ((display :application
		    :default-text-style '(:variable :roman :very-small)
		    :text-style '(:variable :roman :very-small)
		    :display-function 'draw-the-display
		    :scroll-bars :both)
	   (listener :interactor
		     :scroll-bars :vertical)
	   (explainer :application :scroll-bars :vertical
		      :default-text-style '(:variable :roman :normal))
	   (menu :command-menu)))
  (:layout ((default (:column 1
			      (display .72)
			      (menu .18)
			      (:row :rest (listener .7) (explainer :rest)))))))

(definline current-circuit ()
  (editor-circuit *application-frame*))

(defun print-on-command (string)
  (let ((stream (if (eq (type-of *application-frame*) 'circ-editor)
		    (get-frame-pane *application-frame* 'listener)
		    *standard-output*)))
    (format stream "~%~A" string)))

(defun print-on-explainer (string)
  (let ((stream (if (eq (type-of *application-frame*) 'circ-editor)
		    (get-frame-pane *application-frame* 'explainer)
		    *standard-output*)))
    (format stream "~%~A" string)))

(defun rprint-on-explainer (obj)
  (let ((*standard-output* (if (eq (type-of *application-frame*) 'circ-editor)
			       (get-frame-pane *application-frame* 'explainer)
			       *standard-output*)))
    (rprint obj)))

(defvar *root-w* (open-root-window :clx))

(defvar *frame* nil)

(defun edit-circuit (&optional circuit &key new-frame)
  (when (or (null *frame*) new-frame)
    (setq *frame*
	  (make-application-frame 'circ-editor
				  :parent *root-w*
				  :left 100 :right 1100 :top 10 :bottom 800)))
;    (unless *constant-values* (load-constants))
    (when circuit (setf (editor-circuit *frame*) circuit))
    (run-frame-top-level *frame*))

(define-circ-editor-command (exit :menu T) ()
  (frame-exit *application-frame*))

(define-circ-editor-command (add-component :menu T) ()
  (print-on-command (format nil "Enter the inputs : "))
  (setq inputs (accept 'expression :prompt nil))
  (print-on-command (format nil "Enter the name : "))
  (setq name (accept 'symbol :prompt nil))
  (print-on-command (format nil "Enter the outputs : "))
  (setq outputs (accept 'expression :prompt nil))
  (if (and (consp inputs)
	   (every 'symbolp inputs)
	   (symbolp name)
	   (listp outputs)
	   (every 'symbolp outputs))
      (let ((circ (editor-circuit *application-frame*)))
	(add-new-component circ inputs name outputs)
	(notice-modification! circ))
      (print-on-explainer "Illegal Syntax for Circuit Addition")))


(define-circ-editor-command (refresh :menu T) ()
  (compute-layout (editor-circuit *application-frame*)))

(define-circ-editor-command (add-expression :menu T) ()
  (print-on-command (format nil "Enter the value-wire : "))
  (setq value-wire (accept 'symbol :prompt nil))
  (print-on-command (format nil "Enter the expression : "))
  (setq expression (accept 'expression :prompt nil))
  (let ((circ (editor-circuit *application-frame*)))
    (install-expression expression circ value-wire)
    (notice-modification! circ)))

(defun install-expression (expression circ &optional value-wire)
  (if (symbolp expression)
      expression
      (let ((inputs (mapcar (lambda (subexp)
			      (install-expression subexp circ))
			    (cdr expression)))
	    (name (car expression))
	    (outputs (list (or value-wire (gentemp "W-")))))
	(add-new-component circ inputs name outputs)
	(car outputs))))

(defun add-new-component (circ inputs name outputs)
  (let ((new-comp (make-component :name name :inputs inputs :outputs outputs)))
    (dolist (wire inputs)
      (pushnew wire (wires circ)))
    (dolist (wire outputs)
      (pushnew wire (wires circ)))
    (push new-comp (components circ))
    (let ((id (dotimes (n 1000)
		(let ((id (intern (format nil "~A-~s" name n))))
		  (unless (member id (ids circ))
		    (return id))))))
      (setf (component-id new-comp) id)
      (push id (ids circ)))))

(define-circ-editor-command (delete-component :menu T) ()
  (print-on-command (format nil "Enter the name of the component you want to delete : "))
  (setq component-id (accept 'symbol :prompt nil))
  (let ((circ (editor-circuit *application-frame*)))
    (setf (components circ)
	  (remove component-id (components circ) :key 'component-id))
    (notice-modification! circ)))

(emacs-indent with-slots 2)

(define-circ-editor-command (add-new-register :menu T) ()
  (print-on-command (format nil "Enter the register name : "))
  (setq register-name (accept 'symbol :prompt nil))
  (print-on-command (format nil "Enter the initial value : "))
  (setq initial-value (accept 'expression :prompt nil))
  (let ((circ (editor-circuit *application-frame*)))
    (when circ
      (if (some (lambda (init) (eq (register-part init) register-name))
		(register-inits circ))
	  (print-on-explainer "There is already a register of that name")
	  (push (list register-name initial-value) (register-inits circ)))
      (notice-modification! circ))))

(define-circ-editor-command (add-register-input :menu T) ()
  (print-on-command (format nil "Enter the register name : "))
  (setq register-name (accept 'symbol :prompt nil))
  (print-on-command (format nil "Enter the clock : "))
  (setq clock (accept 'symbol :prompt nil))
  (print-on-command (format nil "Enter the value : "))
  (setq value (accept 'symbol :prompt nil))
  (let ((circ (editor-circuit *application-frame*)))
    (when circ
      (if (not (some (lambda (init) (eq (register-part init) register-name))
		     (register-inits circ)))
	  (print-on-explainer "There is no register of that name")
	  (push (list register-name value clock) (register-inputs circ)))
      (notice-modification! circ))))

(define-circ-editor-command (com-delete-register :menu T) ()
  (print-on-command (format nil "Enter the register name : "))
  (setq register-name (accept 'symbol :prompt nil))
  (let ((circ (editor-circuit *application-frame*)))
    (when circ
      (setf (register-inits circ)
	    (remove register-name (register-inits circ) :key 'register-part))
      (setf (register-inputs circ)
	    (remove register-name (register-inputs circ) :key 'register-part))
      (notice-modification! circ))))

(define-circ-editor-command (com-set-inputs :menu T) ()
  (print-on-command (format nil "Enter the inputs : "))
  (setq inputs (accept 'expression :prompt nil))
  (if (and (consp inputs)
	   (every 'symbolp inputs))
      (let ((circ (editor-circuit *application-frame*)))
	(setf (inputs circ) inputs)
	(notice-modification! circ))
      (print-on-explainer "Illegal format for input specification")))

(define-circ-editor-command (com-set-output :menu T) ()
  (print-on-command (format nil "Enter the outputs : "))
  (setq outputs (accept 'expression :prompt nil))
  (if (and (consp outputs)
	   (every 'symbolp outputs))
      (let ((circ (editor-circuit *application-frame*)))
	(setf (outputs circ) outputs)
	(notice-modification! circ))
      (print-on-explainer "Illegal format for output specification")))



;========================================================================
;Drawing the main display pane
;========================================================================

;the following transformation allows us to use units that are percentages of
;the nominal circuit box with (0 0) as the lower left corner and (1 1)
;as the upper right corner of the nominal circuit boarder.

(defvar *circuit-transformation*
  (compose-transformations
   (make-translation-transformation 50 680)
   (make-scaling-transformation 900 -650)))

(defun transformed-set-cursor (stream x y)
  (mvlet (((x2 y2) (transform-point* *circuit-transformation* x y)))
    (stream-set-cursor-position* stream (floor x2) (floor y2))))

(defun transform-width (width)
  (mvlet (((new-width y) (transform-point* *circuit-transformation* width 0)))
    (declare (ignore y))
    new-width))

(defmethod draw-the-display ((application circ-editor) stream)
  (with-drawing-options (stream :transformation *circuit-transformation*)
    (if (editor-circuit application)
	(draw-circuit (editor-circuit application) stream)
	(draw-string* stream "No Circuit Selected" .4 .5))))

(defvar *wire-max-x* nil)

(definline wire-max-x (wire)
  (assoc-value wire *wire-max-x*))

(defvar *wire-min-x* nil)

(definline wire-min-x (wire)
  (assoc-value wire *wire-min-x*))

(defun draw-circuit (circ stream)
  (compute-layout circ)
  (draw-rectangle* stream 0 1
		   (right-border circ)
		   (wire-y-value 'bottom circ)
		   :filled nil
		   :line-thickness 2)
  (draw-string* stream (format nil "Circuit: ~S     in File: ~A"
			       (circuit-print-name circ)
			       (or (source-file circ)
				   "Unassigned"))
		.1 1.01)
  (let ((*wire-min-x* nil)
	(*wire-max-x* nil))
    (dolist (comp (all-components circ))
      (draw-component circ comp stream))
    (draw-inputs circ stream)
    (draw-outputs circ stream)
    (dolist (wire (wires circ))
      (let ((x1 (wire-min-x wire))
	    (x2 (wire-max-x wire))
	    (y (assoc-value wire (wire-y-coordinates circ))))
	(when (not (= x1 x2))
	  (draw-line* stream x1 y x2 y))))
    (label-wires circ stream)))
	    

(defun draw-inputs (circ stream)
  (let* ((io-wires (inputs circ))
	 (delta (/ 1.0 (+ 1 (length io-wires))))
	 (y-delta delta))
    (mapc (lambda (wire x-val)
	    (let ((io-y (- 1.0 y-delta)))
	      (draw-line* stream 0 io-y x-val io-y)
	      (draw-line* stream x-val io-y x-val (assoc-value wire (wire-y-coordinates circ)))
	      (notice-x-val wire x-val)
	      (incf y-delta delta)))
	  io-wires
	  (input-x-coordinates circ))))

(defun draw-outputs (circ stream)
  (let* ((io-wires (outputs circ))
	 (delta (/ 1.0 (+ 1 (length io-wires))))
	 (y-delta delta))
    (mapc (lambda (wire x-val)
	    (let ((io-y (- 1.0 y-delta)))
	      (draw-line* stream (right-border circ) io-y x-val io-y)
	      (draw-line* stream x-val io-y x-val (assoc-value wire (wire-y-coordinates circ)))
	      (notice-x-val wire x-val)
	      (incf y-delta delta)))
	  io-wires
	  (output-x-coordinates circ))))

(defun notice-x-val (wire x)
  (maxf (wire-max-x wire) x)
  (minf (wire-min-x wire) x))

(emacs-indent filling-output 1)
(emacs-indent indenting-output 1)

(defun white-space (n)
  (make-string n :initial-element #\space))

(defun string-trunc (string len)
  (subseq string 0 (min (length string) len)))

(defun draw-component (circ comp stream)
  (let ((x (component-x-coordinate comp))
	(y (component-y-coordinate comp)))
    (when (and x y)
      (basic-draw-comp comp stream x y)
      (draw-component-inputs circ comp stream x y)
      (draw-component-outputs circ comp stream x y)
      (when (component-register? comp)
	(let ((register-init (find (component-name comp) (register-inits circ) :key 'register-part)))
	  (when register-init
	      (draw-string* stream (string-trunc (format nil "~s" (initial-value register-init)) 12)
			    (+ x (* .3 *component-width*))
			    (- y *io-delta*))))))))

(defun basic-draw-comp (comp stream x y)
  (draw-rectangle* stream x y
		   (+ x *component-width*)
		   (- y (component-height comp))
		   :filled nil
		   :line-width 3)
  (let* ((start-x (+ x (* .02 *component-width*)))
	 (start-pos (floor (transform-width start-x)))
	 (char-width (text-style-width (medium-default-text-style stream)
				       stream))
	 (initial-space (white-space (floor (1+ (/ start-pos char-width)))))
	 (text-width (* 15 char-width)))
    (filling-output (stream :fill-width (+ start-pos text-width)
			    :break-characters '(#\-)
			    :after-line-break initial-space)
      (draw-string* stream (format nil "~A" (subseq initial-space 7))
		    0 
		    (- y (* .01 *io-delta*)))
      (if (primitive-name? (component-name comp))
	  (draw-string* stream (format nil "~s" (or (component-id comp)
						  (component-name comp)))
		      start-x
		      (- y (* .01 *io-delta*)))
	  (with-output-as-presentation (:stream stream
						:object (component-id comp)
						:type 'component)
	    (draw-string* stream (format nil "~s" (or (component-id comp)
						  (component-name comp)))
			  start-x
			  (- y (* .01 *io-delta*)))))))
  (let ((y2 (- y (+ (* .02 *io-delta*)
		    (stream-line-height stream)))))
    (draw-line* stream
		x y2
		(+ x *component-width*) y2)))

(defun draw-component-inputs (circ comp stream x y)
  (let ((in-y (- y *io-delta*))
	(parity t))
    (mapc (lambda (wire in-x)
	    (draw-line* stream x in-y in-x in-y)
	    (draw-line* stream in-x in-y in-x (cdr (assoc wire (wire-y-coordinates circ))))
	    (when (not (or (member wire (inputs circ))
			   (some (lambda (comp) (member wire (component-outputs comp))) (all-components circ))))
	      (mvlet (((transformed-pos-x transformed-pos-y) (transform-point* *circuit-transformation* x (+ 0.002 in-y))))
		(let ((string-len (* (1+ (length (string wire)))
				     (text-style-width (medium-default-text-style stream)
						       stream))))
		  (mvlet (((write-x write-y) (transform-point* (invert-transformation *circuit-transformation*)
							       (- transformed-pos-x string-len) transformed-pos-y)))
		    (draw-string* stream (string wire) write-x write-y)))))

	    (notice-x-val wire in-x)
	    (when (and (component-register? comp) parity)
	      (draw-line* stream
			  (- x (* .5 *label-space*))
			  (+ in-y .002)
			  (- x (* .5 *label-space*))
			  (- in-y (+ *io-delta* .002))))
	    (decf in-y *io-delta*)
	    (setf parity (not parity)))
	  (component-inputs comp)
	  (component-input-x-coordinates comp))))

(defun draw-component-outputs (circ comp stream x y)
  (let ((out-y (- y *io-delta*)))
    (mapc (lambda (wire out-x)
	    (draw-line* stream (+ x *component-width*) out-y out-x out-y)
	    (draw-line* stream out-x out-y out-x (cdr (assoc wire (wire-y-coordinates circ))))
	    (notice-x-val wire out-x)
	    (decf out-y *io-delta*))
	  (component-outputs comp)
	  (component-output-x-coordinates comp))))

      

(defun label-wires (circ stream)
  (map-on-circuit-inputs circ
      (lambda (wire y-val)
	(with-output-as-presentation (:stream stream
					      :object (wire-name wire)
					      :type 'wires)
	  (draw-string* stream (format nil "~s" (wire-name wire)) .005 y-val))))
  (dolist (comp (all-components circ))
    (map-on-outputs comp
      (lambda (wire y-val)
	(with-output-as-presentation (:stream stream
					      :object (wire-name wire)
					      :type 'wires)
	  (draw-text* stream (format nil "~s" wire)
		      (+ (component-x-coordinate comp)
			 *component-width*
			 .005)
		      (+ y-val .005)
		      :text-family :variable
		      :text-face :roman
		      :text-size :tiny))))))



			       

;(define-application-frame test ()
;  ((circuit :initform nil :accessor editor-circuit))
;  (:panes ((display :application
;		    :default-text-style '(:variable :roman :huge)
;		    :text-style '(:variable :roman :huge)
;		    :display-function 'test-draw
;		    :scroll-bars t)
;	   (menu :command-menu))))
;
;(defun run-test-app ()
;  (let ((frame
;	 (make-application-frame 'test
;				 :parent *root-w*
;				 :left 100 :right 1100 :top 10 :bottom 800)))
;    (run-frame-top-level frame)
;    frame))
;
;
;(defmethod test-draw ((application test) stream)
;  (with-drawing-options (stream :transformation *circuit-transformation*)
;    (draw-rectangle* stream 0 0 1.0 1.0 :filled nil :line-thickness 2)))




;========================================================================
;File Interface
;========================================================================

(defvar *modified-files* nil)

(defun notice-modification! (circ)
  (let ((file (source-file circ)))
    (when file
      (pushnew file *modified-files* :test 'string-equal)))
  (compute-wires circ))

(defun compute-wires (circ)
  (let ((wires nil))
    (labels ((add-wire (wire)
	       (pushnew wire wires)))
      (mapc #'add-wire (inputs circ))
      (mapc #'add-wire (outputs circ))
      (create-register-components circ)
      (dolist (comp (all-components circ))
	(mapc #'add-wire (component-inputs comp))
	(mapc #'add-wire (component-outputs comp))))
    (setf (wires circ) wires)))

(defvar *file-to-circuit-alist* nil)

(definline file-loaded? (file-name)
  (member file-name *file-to-circuit-alist* :key 'car :test 'string-equal))

(definline loaded-files ()
  (mapcar 'car *file-to-circuit-alist*))

(definline circuits-in (file-name)
  (cdr (assoc file-name *file-to-circuit-alist* :test 'string-equal)))

(defvar *current-circuits* nil)

(shadow 'file-forms)

(define-circ-editor-command (load-demo-file :menu T) ()
  (load-primitive "util.prim")
  (load-circuit "util.circ")
  (load-primitive "demo.prim")
  (load-circuit "demo.circ"))

(defun load-circuit (file-name)
  (let ((circuits nil))
    (dolist (form (file-forms file-name))
      (selectmatch form
	((define-circuit ?name . ?body)
	 (push ?name circuits)
	 (dam-ignore-errors
	  (let ((circuit (circuit-for-specs ?name ?body)))
	    (setf (source-file circuit) file-name))))
	(:anything
	 (print-on-explainer "Warning: non-circuit forms found in file"))))
    (unless (file-loaded? file-name)
      (push (cons file-name nil) *file-to-circuit-alist*))
    (setf (circuits-in file-name) circuits))
  (when (current-circuit) (setf (current-circuit) (circuit-named (circuit-print-name (current-circuit)))))
  t)


(define-circ-editor-command (com-edit-file :name "Load Circuit File") ((file-name 'string))
  (let ((circuits nil))
    (dolist (form (file-forms file-name))
      (selectmatch form
	((define-circuit ?name . ?body)
	 (push ?name circuits)
	 (dam-ignore-errors
	  (let ((circuit (circuit-for-specs ?name ?body)))
	    (setf (source-file circuit) file-name))))
	(:anything
	 (print-on-explainer "Warning: non-circuit forms found in file"))))
    (unless (file-loaded? file-name)
      (push (cons file-name nil) *file-to-circuit-alist*))
    (setf (circuits-in file-name) circuits))
  (when (current-circuit) (setf (current-circuit) (circuit-named (circuit-print-name (current-circuit)))))
  t)

(defun load-primitive (file-name)
  (mapc 'eval (file-forms file-name)))

(define-circ-editor-command (com-evaluate-file :name "Load Primitive File") ((file-name 'string))
  (mapc 'eval (file-forms file-name)))

(defun file-forms (filename)
  (let ((forms nil)
	(eof-marker (list 'eof)))
    (with-open-file (istream filename :direction :input :if-does-not-exist nil)
      (when istream
	(iterate loop ()
		 (let ((form (read istream nil eof-marker)))
		   (unless (eq form eof-marker)
		     (push form forms)
		     (loop))))))
    (nreverse forms)))




(define-circ-editor-command (com-visit-circuit :menu T) ()
  (print-on-command (format nil "Enter the circuit name you want to visit : "))
  (setq circuit-name (accept 'symbol :prompt nil))
  (let ((circuit (or (circuit-named circuit-name)
		     (new-circuit circuit-name))))
    (setf (current-circuit) circuit)
    (clear-path)))



(define-presentation-type component ())


(define-circ-editor-command (visit-component) ((component-id 'symbol))
  (let ((circ (current-circuit)))
    (let ((comp (find component-id (components circ) :key 'component-id)))
      (if (null comp)
	  (print-on-explainer (format nil "Error: there is no component with id ~s" component-id))
	  (progn
	    (push circ *current-path-circuits*)
	    (push (component-id comp) *current-path*)
	    (setf (current-circuit) (circuit-named (component-name comp))))))))

(define-presentation-to-command-translator visit-the-component
    (component visit-component circ-editor)
  (object)
  (list object))

(define-presentation-type wires ())


(define-presentation-to-command-translator wire-commands
    (wires wire-menu circ-editor)
  (object)
  (list object))



(define-circ-editor-command (wire-menu) ((wire-name 'symbol))
  (let ((all '(track-signal clear-tracked-signal track-vector clear-tracked-vector nil)))
  (with-menu (menu *root-w*)
    (let ((choice (menu-choose-from-drawer menu
			     'menu-item
			     #'(lambda (stream ptype)
				 (dolist (item all nil)
				   (with-output-as-presentation
				       (:stream stream
						:object item
						:type ptype)
				     (format stream "~A" item)
				   (terpri stream)))))))
      (case choice
	(track-signal (track-signal wire-name))
	(clear-tracked-signal (clear-tracked-signal))
	(track-vector (track-vector wire-name))
	(clear-tracked-vector (clear-tracked-vector))
	(otherwise nil))))))
	       
						
		  
			     
  

(define-circ-editor-command (com-return-to-parent :menu T) ()
  (if (null *current-path*)
      (print-on-explainer "Error: There is no parent")
      (progn (pop *current-path*)     
	     (setf (current-circuit) (pop *current-path-circuits*)))))

(define-circ-editor-command (rename-circuit :menu T) ()
  (print-on-command (format nil "Enter the name of circuit : "))
  (setq name (accept 'symbol :prompt nil))
  (let ((circ (copy-circuit (current-circuit))))
    (setf (circuit-print-name circ) name)
    (setf (circuit-named name) circ)
    (pushnew (source-file circ) *modified-files* :test 'string-equal)
    (when (source-file circ) (push name (circuits-in (source-file circ))))
    (clear-path)
    (setf (current-circuit) circ)))

(defun clear-path ()
  (setf *current-path* nil)
  (setf *current-path-circuits* nil))
	    

(defun new-circuit (name)
  (let ((circuit (make-circuit :circuit-print-name name)))
    (setf (circuit-named name) circuit)
    circuit))

(define-circ-editor-command (com-place-in-file :menu T) ()
  (print-on-command (format nil "Enter the file name : "))
  (setq file-name (accept 'string :prompt nil))
  (if (not (file-loaded? file-name))
      (print-on-explainer "that file has not been loaded")
      (let ((circ (editor-circuit *application-frame*)))
	(if (null circ)
	    (print-on-explainer "There is no current circuit")
	    (let ((old-file (source-file circ)))
	      (when old-file
		(print-on-explainer (format nil "Removing ~s from file ~A" (circuit-print-name circ) old-file))
		(pushnew old-file *modified-files* :test 'string-equal)
		(setf (circuits-in old-file)
		      (remove (circuit-print-name circ) (circuits-in old-file) :test 'string-equal)))
	      (setf (source-file circ) file-name)
	      (pushnew file-name *modified-files* :test 'string-equal)
	      (push (circuit-print-name circ)
		    (cdr (assoc file-name *file-to-circuit-alist* :test 'string-equal))))))))

(define-circ-editor-command (com-list-circuits :menu T) ()
  (print-on-command (format nil "Enter the file name : "))
  (setq file-name (accept 'string :prompt nil))
  (dolist (circ-name (cdr (assoc file-name *file-to-circuit-alist*)))
    (print-on-explainer (Format nil "~%~S" circ-name))))

(define-circ-editor-command (com-save-files :menu T) ()
  (save-files))

(defun save-files ()
;  (save-constants)
  (mapc 'save-circuit-file *modified-files*)
  (setf *modified-files* nil))

(defun save-circuit-file (file)
  (print-on-explainer (format nil "~%Writing ~A" file))
  (write-forms-newversion (mapcar 'circuit-expression (circuits-in file))
			  file))

(defexport write-forms-newversion (forms filename)
    (let ((*print-level* 1000)
	  (*print-length* 1000)
	  (*print-circle* t))
      (with-open-file (istream filename :direction :output :if-exists :new-version
			       :if-does-not-exist :create)
	(dolist (form forms)
	  (pprint form istream))))
  t)

(defun circuit-expression (name)
  (let ((circ (circuit-named name)))
    `(define-circuit ,(circuit-print-name circ)
      (:inputs ,@(inputs circ))
      (:outputs ,@(outputs circ))
      ,@(mapcar (lambda (init)
		  `(:register-init ,(register-part init) ,(initial-value init)))
	 (register-inits circ))
      ,@(mapcar (lambda (comp)
		  `(:component ,(component-id comp) ,@(component-outputs comp) (,(component-name comp) ,@(component-inputs comp))))
	 (components circ))
      ,@(mapcar (lambda (input)
		  `(:register-input ,(register-part input) ,(data-part input) ,(clock-part input)))
	 (register-inputs circ)))))



;;; simulator


(defvar *tracked-vectors* nil)
(defvar *tracked-names* nil)
(defvar *tracked-signals* nil)
(defvar *simulation-graphs* nil)

(property-macro previous-value)

(property-macro x-scale)
(property-macro y-scale)
(property-macro z-scale)
(property-macro signal-scale)



(define-circ-editor-command (simulate-circuit :menu T) ()
  (dam-ignore-errors
   (let* ((root-circ (root-circuit))
	  (name (when root-circ (circuit-print-name root-circ))))
     (when *tracked-vectors*
       (unless *simulation-vector-w*
	 (setf *simulation-vector-w* (open-window-stream :parent *root-w* :left 0 :top 0 :width 600 :height 425)))
       (window-expose *simulation-vector-w*)
       (window-stack-on-top *simulation-vector-w*)
       (window-clear *simulation-vector-w*)
       (when (not (and root-circ
		       (timeout name)
		       (clock-alist name)))
	 (dam-error "Error: simulation parameters not specified"))

       (when (null (x-scale name))
	 (setf (x-scale name) 1))
       (when (null (y-scale name))
	 (setf (y-scale name) 1))
       (when (null (z-scale name))
	 (setf (z-scale name) 1)))
     (when *tracked-signals*
       (unless *simulation-signal-w*
	 (setf *simulation-signal-w* (open-window-stream :parent *root-w* :left 0 :top 450 :width 600 :height 425)))
       (window-expose *simulation-signal-w*)
       (window-stack-on-top *simulation-signal-w*)
       (window-clear *simulation-signal-w*)
       (when (not (and root-circ
		       (timeout name)
		       (clock-alist name)))
	 (dam-error "Error: simulation parameters not specified"))
       (dolist (wire *tracked-signals*)
	 (when (null (signal-scale wire))
	   (setf (signal-scale wire) 1)))
       (let* ((size (ceiling (sqrt (length *tracked-signals*))))
	      (width (/ (window-inside-width *simulation-signal-w*) size))
	      (height (/ (window-inside-height *simulation-signal-w*) size)))
	 (setf *simulation-graphs* nil)
	 (dotimes (i size)
	   (dotimes (j size)
	     (let ((wire-name (nth (+ j (* i size)) *tracked-signals*)))
	       (push (make-sim-graph :left (+ (* i width) 15)
				     :top (+ (* j height) 15)
				     :right (- (* (1+ i) width) 15)
				     :bottom (- (* (1+ j) height) 15)
				     :title wire-name
				     :stream *simulation-signal-w*
				     :scale-x (/ (- width 30) (timeout name))
				     :scale-y (signal-scale wire-name))
		     *simulation-graphs*)
	       (draw-graph (car *simulation-graphs*)))))
	 (setf *simulation-graphs* (reverse *simulation-graphs*))))
     (check-circuit-top-level root-circ)
     (simulate-fun name
		   (clock-alist name)
		   (timeout name)
		   'draw-samples))))


(define-circ-editor-command (com-check-circuit :menu T) ()
  (dam-ignore-errors (check-circuit-top-level (current-circuit))))

(defun check ()
  (dam-ignore-errors (check-circuit-top-level (current-circuit))))

(defun root-circuit ()
  (if *current-path-circuits*
      (car (last *current-path-circuits*))
      (editor-circuit *application-frame*)))

(define-circ-editor-command (draw-vector :menu T) ()
  (print-on-command (format nil "Enter the x coordinate : "))
  (setq x (accept 'number :prompt nil))
  (print-on-command (format nil "Enter the y coordinate : "))
  (setq y (accept 'number :prompt nil))
  (print-on-command (format nil "Enter the z coordinate : "))
  (setq z (accept 'number :prompt nil))
  (draw-3-vector *simulation-vector-w* x y z x y 0))

(defstruct sim-graph
  left top right bottom
  title
  scale-x scale-y
  stream
  previous-x previous-y)

(defun draw-graph (graph)
  (draw-rectangle* (sim-graph-stream graph)
		   (sim-graph-left graph)
		   (sim-graph-top graph)
		   (sim-graph-right graph)
		   (sim-graph-bottom graph)
		   :filled nil)
  (let ((x-axis-y (/ (+ (sim-graph-top graph) (sim-graph-bottom graph)) 2)))
    (draw-line* (sim-graph-stream graph)
		(sim-graph-left graph)
		x-axis-y
		(sim-graph-right graph)
		x-axis-y))
  (draw-string* (sim-graph-stream graph)
		(string (sim-graph-title graph))
		(sim-graph-left graph)
		(- (sim-graph-top graph) 2)))


(defun draw-samples (simtime)
  (mapc (lambda (wire-name display-name)
	  (display-track *simulation-vector-w* wire-name display-name))
	*tracked-vectors*
	*tracked-names*)
  (mapc (lambda (signal-name graph)
	  (next-point simtime (symbol-value signal-name) graph))
	*tracked-signals*
	*simulation-graphs*))

(defvar *min-drawing-length* 1)
(defun next-point (time val graph)
  (let* ((new-x (+ (sim-graph-left graph) (* (sim-graph-scale-x graph) time)))
	 (half-height (/ (- (sim-graph-bottom graph) (sim-graph-top graph)) 2))
	 (new-y (- (- (sim-graph-bottom graph) (* half-height (sim-graph-scale-y graph) val))
		   half-height)))
    (if (and (sim-graph-previous-x graph)
	     (inside new-x new-y graph)
	     (inside (sim-graph-previous-x graph) (sim-graph-previous-y graph) graph))
	(unless (<= (dist (sim-graph-previous-x graph) (sim-graph-previous-y graph)
			  new-x new-y)
		    *min-drawing-length*)
	  (draw-line* (sim-graph-stream graph)
		      (sim-graph-previous-x graph)
		      (sim-graph-previous-y graph)
		      new-x
		      new-y)
	  (setf (sim-graph-previous-x graph) new-x)
	  (setf (sim-graph-previous-y graph) new-y))
	(progn
	  (setf (sim-graph-previous-x graph) new-x)
	  (setf (sim-graph-previous-y graph) new-y)))))

(defun dist (x1 y1 x2 y2)
  (let ((x-dist (- x2 x1))
	(y-dist (- y2 y1)))
    (sqrt (+ (* x-dist x-dist) (* y-dist y-dist)))))

(defun inside (x y graph)
  (and (<= (sim-graph-left graph) x)
       (<= x (sim-graph-right graph))
       (<= (sim-graph-top graph) y)
       (<= y (sim-graph-bottom graph))))


(property-macro last-x)
(property-macro last-y)
(property-macro last-z)
(defvar *vector-dist-threshold* nil)
(setf *vector-dist-threshold* .015)
(defvar *draw-count* 0)

(defun display-track (stream simvar display-name)
  (declare (ignore display-name))
  (let ((vec (symbol-value simvar)))
      (let ((x (* (x-scale (circuit-print-name (root-circuit))) (3-vector-x vec)))
	    (y (* (y-scale (circuit-print-name (root-circuit))) (3-vector-y vec)))
	    (z (* (z-scale (circuit-print-name (root-circuit))) (3-vector-z vec))))
	(when (or (null (last-x simvar))
		  (> (+ (abs (- x (last-x simvar)))
			(abs (- y (last-y simvar)))
			(abs (- z (last-z simvar))))
		     *vector-dist-threshold*))
	  (setf (last-x simvar) x)
	  (setf (last-y simvar) y)
	  (setf (last-z simvar) z)
	  (incf *draw-count*)
	  (draw-3-vector stream x y z x y 0)))))

(defun draw-3-vector (stream x1 y1 z1 x2 y2 z2)
  (mvlet (((xp1 yp1) (project stream x1 y1 z1))
	  ((xp2 yp2) (project stream x2 y2 z2)))
    (draw-line* stream xp1 yp1 xp2 yp2)))

(defvar *alpha-xp* 1)
(defvar *beta-xp* 0)
(defvar *gamma-xp* 0)

(defvar *alpha-yp* 0)
(defvar *beta-yp* (- (sin (/ 3.14159  6.0))))
(defvar *gamma-yp* (cos (/ 3.14159 6.0)))

(defun project (stream x y z)
  (let ((height (window-inside-height stream)))
    (let ((xp (+ (* *alpha-xp* x)
		 (* *beta-xp* y)
		 (* *gamma-xp* z)
		 .3))
	  (yp (+ (* *alpha-yp* x)
		 (* *beta-yp* y)
		 (* *gamma-yp* z)
		 .3)))
      (setq xp (max 0 (min 1 xp)))
      (setq yp (max 0 (min 1 yp)))
      (let ((sx (* xp height))
	    (sy (* (- 1 yp) height)))
	(values sx sy)))))

(define-circ-editor-command (set-clock-rate :menu T) ()
  (print-on-command (format nil "Enter the clock-name : "))
  (setq clock-name (accept 'symbol :prompt nil))
  (print-on-command (format nil "Enter the clock rate : "))
  (setq clock-rate (accept 'number :prompt nil))
  (cond (*current-path*
	 (print-on-explainer "Error: not at top level circuit"))
	((not (member clock-name (inputs (editor-circuit *application-frame*))))
	 (print-on-explainer (format nil "Error: no such input as '~s'" clock-name)))
	(t (setf (assoc-value clock-name (clock-alist (circuit-print-name (root-circuit))))
		 clock-rate))))

(define-circ-editor-command (show-clock-rates :menu T) ()
  (cond (*current-path*
	 (print-on-explainer "Error: not at top level circuit"))
	(t (rprint-on-explainer (clock-alist (circuit-print-name (editor-circuit *application-frame*)))))))

(define-circ-editor-command (set-simulator-timeout :menu T) ()
  (print-on-command (format nil "Enter the time out : "))
  (setq timeout (accept 'number :prompt nil))
  (cond (*current-path*
	 (print-on-explainer "Error: not at top level circuit"))
	(t (setf (timeout (circuit-print-name (current-circuit)))
		 timeout))))

(define-circ-editor-command (show-simulator-timeout :menu T) ()
  (cond (*current-path*
	 (print-on-explainer "Error: not at top level circuit"))
	(t (rprint-on-explainer (timeout (circuit-print-name (editor-circuit *application-frame*)))))))

(defun track-vector (wire-name)
  (print-on-command (format nil "Enter the display name : "))
  (setq display-name (accept 'symbol :prompt nil))
  (cond ((not (member wire-name (wires (editor-circuit *application-frame*))))
	 (print-on-explainer "Error: no such wire in current circuit"))
	(t
	 (push (component-wire->variable-name wire-name *current-path* *current-path-circuits*)
	       *tracked-vectors*)
	 (push display-name *tracked-names*))))

(defun track-signal (wire-name)
  (cond ((not (member wire-name (wires (editor-circuit *application-frame*))))
	 (print-on-explainer "Error: no such wire in current circuit"))
	(t
	 (push (component-wire->variable-name wire-name *current-path* *current-path-circuits*)
	       *tracked-signals*))))

(defun clear-tracked-vector ()
  (setf *tracked-vectors* nil)
  (setf *tracked-names* nil))

(defun clear-tracked-signal ()
  (setf *tracked-signals* nil))

(defun component-wire->variable-name (wire path path-circuits)
  (if (null path)
      wire
      (let* ((component (find (first path) (components (first path-circuits)) :key #'component-id))
	     (prototype (circuit-named (component-name component)))
	     (input-pos (position wire (inputs prototype)))
	     (output-pos (position wire (outputs prototype))))
	(cond (input-pos (component-wire->variable-name (nth input-pos (component-inputs component)) (cdr path) (cdr path-circuits)))
	      (output-pos (component-wire->variable-name (nth output-pos (component-outputs component))
							 (cdr path)
							 (cdr path-circuits)))
	      (t (combine-symbol-list (append (reverse path) (list wire)) *package* :inserting "."))))))

(define-circ-editor-command (set-vector-scale :menu T) ()
  (print-on-command (format nil "Enter the x value : "))
  (setq x-scale (accept 'number :prompt nil))
  (print-on-command (format nil "Enter the y value : "))
  (setq y-scale (accept 'number :prompt nil))
  (print-on-command (format nil "Enter the z value : "))
  (setq z-scale (accept 'number :prompt nil))
  (let* ((root (root-circuit))
	 (name (when root (circuit-print-name root))))
    (if root
	(progn
	  (setf (x-scale name) x-scale)
	  (setf (y-scale name) y-scale)
	  (setf (z-scale name) z-scale))
	(print-on-explainer "No Circuit!"))))

(define-circ-editor-command (set-signal-scale :menu T) ()
  (print-on-command (format nil "Enter the wire : "))
  (setq wire (accept 'symbol :prompt nil))
  (print-on-command (format nil "Enter the scaling number : "))
  (setq scale (accept 'number :prompt nil))
  (if (root-circuit)
      (setf (signal-scale (component-wire->variable-name wire *current-path* *current-path-circuits*)) scale)
      (print-on-explainer "No Circuit!")))

;
;(defun load-constants ()
;  (dolist (form (file-forms *constant-file-name*))
;    (selectmatch form
;      ((defvar ?var ?val) (push (cons ?var ?val) *constant-values*)))))
;
;
;(defun save-constants ()
;  (write-forms-newversion (mapcar (lambda (pair) `(defvar ,(car pair) ,(cdr pair))) *constant-values*)
;			  *constant-file-name*))
;


(define-circ-editor-command (define-constant :menu T) ()
  (print-on-command (format nil "Enter the constant name : "))
  (setq constant-name (accept 'symbol :prompt nil))
  (print-on-command (format nil "Enter the value : "))
  (setq value (accept 'expression :prompt nil))
  (setf (assoc-value constant-name *constant-values*) value))

(define-circ-editor-command (show-tracked-vectors :menu T) ()
  (print-on-explainer (format nil "~s" *tracked-vectors*)))

(define-circ-editor-command (show-tracked-signals :menu T) ()
  (print-on-explainer (format nil "~s" *tracked-signals*)))

(defun reset-windows ()
  (setf *root-w* (open-root-window :clx))
  (setf *simulation-signal-w* nil)
  (setf *simulation-vector-w* nil))