;;;; Wire up a circuit and construct the constraint network for it.

;;; part-type just saves up its arguments for later

(define (part-type type-name #!optional
		   terminal-names parameter-names models relations overlays)
  (assert (symbol? type-name))
  (if (default-object? terminal-names) (set! terminal-names '()))
  (if (default-object? parameter-names) (set! parameter-names '()))
  (if (default-object? models) (set! models '()))
  (if (default-object? relations) (set! relations '()))
  (if (default-object? overlays) (set! overlays '()))

  (eq-put! type-name 'type 'part-type)
  (eq-put! type-name 'terminal-names terminal-names)
  (eq-put! type-name 'parameter-names parameter-names)
  (eq-put! type-name 'models models)
  (eq-put! type-name 'relations relations)
  (eq-put! type-name 'overlay-specs overlays)
  type-name)

;;; To instantiate a circuit for a set of models.

(define (create-circuit name type models-required)
  (assert (eq? (eq-get type 'type) 'part-type))
  (assert (null? (eq-get type 'terminal-names)))
  (let ((part (list '*circuit* name)))
    (eq-put! part 'type type)
    (eq-put! part 'name name)
    (eq-put! part 'constraint-network
             (create-constraint-network (symbol->string name)))
    (for-each (lambda (model-required)
                (let ((m (list '*model* model-required)))
                  (eq-put! m 'type 'model)
                  (eq-put! m 'name model-required)
                  (eq-put! m 'parent part)
                  (eq-put! part model-required m)))
              models-required)
    (eq-put! part 'overlay-specs (eq-get type 'overlay-specs))
    (instantiate-model part type 'dummy-model '())
    (for-each (lambda (overlay-spec)
		(instantiate-overlay part
				     (cadr overlay-spec)
				     'dummy-model
				     '()))
	      (eq-get type 'overlay-specs))
    ;; Make required models
    (for-each (lambda (model-required)
                (instantiate-model part type model-required '())
		(for-each (lambda (overlay-spec)
			    (instantiate-overlay part
						 (cadr overlay-spec)
						 model-required
						 '()))
			  (eq-get type 'overlay-specs)))
              models-required)
    ;; Make inter-model relations
    (instantiate-intermodel part type models-required)
    part))

(define (instantiate-intermodel part type models-required)
  (for-each (lambda (overlay-spec)
	      (instantiate-relation part
				    (cadr overlay-spec)
				    models-required))
	    (eq-get part 'overlay-specs))
  (for-each (lambda (subpartname)
	      (let ((subpart (eq-get part subpartname)))
		(instantiate-intermodel subpart
					(eq-get subpart 'type)
					models-required)))
	    (eq-get part 'part-names))
  (instantiate-relation part type models-required))

(define (instantiate-relation part type models-required)
  (for-each (lambda (relation) (make-relation part relation))
	    (filter (lambda (relspec)
		      (eq-set/subset? (caddr relspec) models-required))
		    (eq-get type 'relations))))

(define (instantiate-overlay part overlay-type model-required nodes)
  (let ((model (or (eq-get part model-required) part)))
    ;; Make global parameter cells for this part
    (for-each (lambda (parameter-name)
		(create-parameter part parameter-name))
              (eq-get overlay-type 'parameter-names))
    ;; Create terminals
    (for-each (lambda (terminal-name node)
		(create-electrical-terminal model terminal-name node))
	      (eq-get overlay-type 'terminal-names)
	      nodes)
    ;(breakpoint "foo")
    (assert (eq? (eq-get overlay-type 'type) 'part-type))
    (if (and (eq? model-required 'dummy-model)
	     (not (assq 'any-model (eq-get overlay-type 'models))))
	'done
	(let ((model-found
	       (let lp ((models-available (eq-get overlay-type 'models)))
		 (cond ((null? models-available)
			(error "Model not available"
			       model-required overlay-type))
		       ((or (eq? 'any-model (caar models-available))
			    (eq? model-required (caar models-available))
			    (and (pair? (caar models-available))
				 (memq model-required
				       (caar models-available)))
			    (eq? 'else (caar models-available)))
			(cdar models-available))
		       (else (lp (cdr models-available)))))))
	  ;; Create model nodes
	  (for-each (lambda (node-name)
		      (create-electrical-node model node-name))
		    (model-node-names model-found))
	  ;; Create model parameters
	  (for-each (lambda (parameter-name)
		      (create-internal-parameter model parameter-name))
		    (model-parameter-names model-found))
	  ;; Create parts
	  (eq-put! model 'part-names
		   (map part-spec-name (model-part-specs model-found)))
	  (for-each (lambda (part-spec)
		      (create-part model
				   (part-spec-name part-spec)
				   (part-spec-type-name part-spec)
				   (map (lambda (node-name)
					  (eq-get model node-name))
					(part-spec-node-names part-spec))
				   model-required))
		    (model-part-specs model-found))
	  ;; Create model-specific relations
	  (for-each (lambda (relation-spec)
		      (make-relation model relation-spec))
		    (model-relation-specs model-found))
	  (for-each (lambda (node-name)
		      (sum-up-and-cap-off (eq-get model node-name)))
		    (model-node-names model-found))))
    (for-each (lambda (terminal-name)
		(sum-up (eq-get model terminal-name)))
	      (eq-get overlay-type 'terminal-names))
    model))


(define (instantiate-model part part-type model-required nodes)
  (let ((model (or (eq-get part model-required) part)))
    ;; Make global parameter cells for this part
    (for-each (lambda (parameter-name)
		(create-parameter part parameter-name))
              (eq-get part-type 'parameter-names))
    ;; Create terminals
    (for-each (lambda (terminal-name node)
		(create-electrical-terminal model terminal-name node))
	      (eq-get part-type 'terminal-names)
	      nodes)
    (assert (eq? (eq-get part-type 'type) 'part-type))
    (if (and (eq? model-required 'dummy-model)
	     (not (assq 'any-model (eq-get part-type 'models))))
	'done
	(let ((model-found
	       (let lp ((models-available (eq-get part-type 'models)))
		 (cond ((null? models-available)
			(error "Model not available"
			       model-required part-type))
		       ((or (eq? 'any-model (caar models-available))
			    (eq? model-required (caar models-available))
			    (and (pair? (caar models-available))
				 (memq model-required
				       (caar models-available)))
			    (eq? 'else (caar models-available)))
			(cdar models-available))
		       (else (lp (cdr models-available)))))))
	  ;; Create model nodes
	  (for-each (lambda (node-name)
		      (create-electrical-node model node-name))
		    (model-node-names model-found))
	  ;; Create model parameters
	  (for-each (lambda (parameter-name)
		      (create-internal-parameter model parameter-name))
		    (model-parameter-names model-found))
	  ;; Create parts
	  (eq-put! model 'part-names
		   (map part-spec-name (model-part-specs model-found)))
	  (for-each (lambda (part-spec)
		      (create-part model
				   (part-spec-name part-spec)
				   (part-spec-type-name part-spec)
				   (map (lambda (node-name)
					  (eq-get model node-name))
					(part-spec-node-names part-spec))
				   model-required))
		    (model-part-specs model-found))
	  ;; Create model-specific relations
	  (for-each (lambda (relation-spec)
		      (make-relation model relation-spec))
		    (model-relation-specs model-found))
	  (for-each (lambda (node-name)
		      (sum-up-and-cap-off (eq-get model node-name)))
		    (model-node-names model-found))))
    (for-each (lambda (terminal-name)
		(sum-up (eq-get model terminal-name)))
	      (eq-get part-type 'terminal-names))
    model))

(define (sum-up-and-cap-off node)
  (let ((contributors (eq-get node 'terminals))
	(cn (constraint-network node)))
    (cond ((= (length contributors) 0)
	   ;;(error "Node with no terminals connected?" (name-of node))
	   'done)
	  ((= (length contributors) 1)
	   (let ((z (create-constraint cn
				       'kcl-node
				       (constant-constraint 0)
				       (list (eq-get (car contributors)
						     'current)))))
	     (eq-put! z 'parent node)
	     (eq-put! node 'kcl-node z)))
	  ((= (length contributors) 2)
	   (let ((z (create-constraint cn
				       'kcl-node
				       negate-constraint
				       (map (lambda (con)
					      (eq-get con 'current))
					    contributors))))	     
	     (eq-put! z 'parent node)
	     (eq-put! node 'kcl-node z)))
	  ((> (length contributors) 2)
	   (let ((z (create-constraint cn
				       'kcl-node
				       sums-to-zero-constraint
				       (map (lambda (con)
					      (eq-get con 'current))
					    contributors))))	     
	     (eq-put! z 'parent node)
	     (eq-put! node 'kcl-node z)))
	  (else
	   ;; Should never get here...
	   (let* ((z (create-connector cn 'kcl-zero))
		  (k (create-constraint cn 'kcl-node-zero
					(constant-constraint 0)
					(list z)))
		  (a (create-constraint cn
					'kcl-node
					n-ary-adder-constraint
					(cons z
					      (map (lambda (con)
						     (eq-get con 'current))
						   contributors)))))
	     (eq-put! z 'parent node)
	     (eq-put! node 'kcl-zero z)
	     (eq-put! k 'parent node)
	     (eq-put! node 'kcl-node-zero k)
	     (eq-put! a 'parent node)
	     (eq-put! node 'kcl-node a))))))

(define (sum-up terminal)
  (let ((contributors (eq-get terminal 'terminals))
	(cn (constraint-network terminal)))
    (let ((z
	   (cond ((= (length contributors) 0) 'done)
		 ((= (length contributors) 1)
		  (create-constraint cn
				     'kcl-terminal
				     equality-constraint
				     (list (eq-get terminal 'current)
					   (eq-get (car contributors)
						   'current))))
		 ((= (length contributors) 2)
		  (create-constraint cn
				     'kcl-terminal
				     adder-constraint
				     (cons (eq-get terminal 'current)
					   (map (lambda (con)
						  (eq-get con 'current))
						contributors))))
		 (else
		  (create-constraint cn
				     'kcl-terminal
				     n-ary-adder-constraint
				     (cons (eq-get terminal 'current)
					   (map (lambda (con)
						  (eq-get con 'current))
						contributors)))))))
      (eq-put! z 'parent terminal)
      (eq-put! terminal 'kcl-terminal z))))

(define (create-parameter part parameter-name)
  (let ((a (in-the-dummy-model? part parameter-name)))
    (if a
	(begin (eq-put! part parameter-name a) a)
	(create-internal-parameter part parameter-name))))


(define (create-internal-parameter part parameter-name)
  (let ((p (eq-get part parameter-name)))
    (if p
	p
	(let* ((cn (constraint-network part))
	       (a (create-connector cn parameter-name)))
	  ;; These subsume the constraint-network naming
	  (eq-rem! cn parameter-name)
	  (eq-put! a 'type 'parameter)
	  (eq-put! a 'name parameter-name)
	  (eq-put! a 'parent part)
	  (eq-put! part parameter-name a)
	  a))))

(define (in-the-dummy-model? part parameter-name)
  (let ((fullpath (name-of part)))
    (if (> (length fullpath) 1)
	(let ((path (butlast (name-of part))))
	  ((eq-path (cons parameter-name path)) (top-level part)))
	#f)))

(define (create-electrical-node part node-name)
  (let ((n (eq-get part node-name)))
    (if n
	n
	(let ((node (list '*electrical-node* node-name)))
	  (eq-put! node 'type 'node)
	  (eq-put! node 'name node-name)
	  (eq-put! node 'parent part)
	  (eq-put! part node-name node)
	  (let* ((cn (constraint-network part))
		 (e (create-connector cn 'potential)))
	    (eq-rem! cn 'potential)
	    (eq-put! e 'type 'potential)
	    (eq-put! e 'name 'potential)
	    (eq-put! e 'parent node)
	    (eq-put! node 'potential e)
	    (eq-put! node 'terminals '()))
	  node))))

(define (create-electrical-terminal part terminal-name node)
  (let ((t (eq-get part terminal-name)))
    (if t
	t
	(let ((terminal (list '*electrical-terminal* terminal-name)))
	  (eq-put! terminal 'type 'terminal)
	  (eq-put! terminal 'name terminal-name)
	  (eq-put! terminal 'parent part)
	  (eq-put! part terminal-name terminal)
	  (eq-put! terminal 'node node)
	  ;; Propagate potential inward
	  (eq-put! terminal 'potential (eq-get node 'potential))
	  (let* ((cn (constraint-network part))
		 (i (create-connector cn 'current)))
	    (eq-rem! cn 'current)
	    (eq-put! i 'type 'current)
	    (eq-put! i 'name 'current)
	    (eq-put! i 'parent terminal)
	    (eq-put! terminal 'current i)
	    ;; Propagate the current outward
	    (eq-adjoin! node 'terminals terminal)
	    (eq-put! terminal 'terminals '()))
	  terminal))))

(define (create-part parent part-name part-type nodes model-required)
  (assert (eq? (eq-get part-type 'type) 'part-type))
  (let ((p (eq-get parent part-name)))
    (if p
	p
	(let ((part (list '*part* part-name)))
	  (eq-put! part 'type part-type)
	  (eq-put! part 'name part-name)
	  (eq-put! part 'parent parent)
	  (eq-put! parent part-name part)
	  (eq-put! part 'overlay-specs (eq-get part-type 'overlay-specs))
	  (instantiate-model part part-type model-required nodes)
	  (for-each (lambda (overlay-spec)
		      (instantiate-overlay part
					   (cadr overlay-spec)
					   model-required
					   nodes))
		    (eq-get part-type 'overlay-specs))
	  part))))

(define (make-relation part relation-spec)
  ((relation->constraints part (symbol->string (car relation-spec)))
   (cadr relation-spec) #f ""))

(define *path-base*)

(define (chase-path path)
  ((eq-path path) *path-base*))

(define (with-path-base path-base thunk)
  (fluid-let ((*path-base* path-base))
    (thunk)))

(define (model-node-names m) (car m))
(define (model-part-specs m) (cadr m))
(define (model-parameter-names m) (caddr m))
(define (model-relation-specs m) (cadddr m))

(define (part-spec-name s) (car s))
(define (part-spec-type-name s) (cadr s))
(define (part-spec-node-names s) (cddr s))

    
(define (top-level thing)
  (let ((p (eq-get thing 'parent)))
    (if p (top-level p) thing)))

(define (constraint-network obj)
  (if obj
      (or (eq-get obj 'constraint-network)
          (constraint-network (eq-get obj 'parent)))
      (error "No constraint network found")))

(define (circuit-object node)
  (or (eq-get node 'connector)
      (eq-get node 'constraint)
      node))