(define (numerical-quantities-equal? x y)
  (if (and (number? x) (number? y))
      (= x y)
      (eqv? x y)))

(define (choose-numerical-quantity ns)
  (or (find-matching-item ns number?)
      (car ns)))

;;; Celsius-Farenheit conversion example

(define network
  (cp:make-network 'network
		   (cp:make-value-model numerical-quantity?
					numerical-quantities-equal?
					choose-numerical-quantity)))

(define c (cp:make-connector 'c network))
(define f (cp:make-connector 'f network))
(define u (cp:make-connector 'u network))
(define v (cp:make-connector 'v network))

(define nine (cp:make-connector 'nine network))
(define five (cp:make-connector 'five network))
(define thirty-two (cp:make-connector 'thirty-two network))

(cp:assume-value nine 9)
(cp:assume-value five 5)
(cp:assume-value thirty-two 32)

(cp:make-constraint cp:multiplier #f network u c nine)
(cp:make-constraint cp:multiplier #f network u v five)
(cp:make-constraint cp:adder #f network f v thirty-two)

(cp:assume-value c 100)
;Unspecified return value

(cp:has-value? f)
;Value: #t

(cp:value-of f)
;Value: 212

(cp:retract-value c)
;Value: #t

(cp:has-value? f)
;Value: #f

(cp:assume-value c -40)
;Unspecified return value

(cp:has-value? f)
;Value: #t

(cp:value-of f)
;Value: -40

(cp:retract-value c)
;Value: #t

(cp:assume-value f 32)
;Unspecified return value

(cp:has-value? c)
;Value: #t

(cp:value-of c)
;Value: 0

(cp:why? c)
;(n25 (c = 0) (multiplier n24 n23) (n21 n22 n23))
;(n24 (u = 0) (multiplier n26) (n21 n22))
;(n23 (nine = 9) (premise) (n23))
;(n26 (v = 0) (multiplier n21 n22) (n21 n22))
;(n21 (f = 32) (premise) (n21))
;(n22 (thirty-two = 32) (premise) (n22))
;Unspecified return value

(cp:retract-value f)
;Value: #t

(cp:assume-value f 98.6)
;Unspecified return value

(cp:has-value? c)
;Value: #t

(cp:value-of c)
;Value: 37.

(cp:why? c)
;(n30 (c = 37.) (multiplier n29 n23) (n27 n22 n28 n23))
;(n29 (u = 333.) (multiplier n31 n28) (n27 n22 n28))
;(n23 (nine = 9) (premise) (n23))
;(n31 (v = 66.6) (multiplier n27 n22) (n27 n22))
;(n28 (five = 5) (premise) (n28))
;(n27 (f = 98.6) (premise) (n27))
;(n22 (thirty-two = 32) (premise) (n22))
;Unspecified return value

;;; Simple Electrical Circuit : source and resistor

(define ckt1
  (cp:make-network 'ckt1
		   (cp:make-value-model numerical-quantity?
					numerical-quantities-equal?
					choose-numerical-quantity)))

;;; terminal potentials

(define es1 (cp:make-connector 'es1 ckt1))
(define es2 (cp:make-connector 'es2 ckt1))

(define er1 (cp:make-connector 'er1 ckt1))
(define er2 (cp:make-connector 'er2 ckt1))


;;; terminal currents

(define is1 (cp:make-connector 'is1 ckt1))
(define is2 (cp:make-connector 'is2 ckt1))

(define ir1 (cp:make-connector 'ir1 ckt1))
(define ir2 (cp:make-connector 'ir2 ckt1))


;;; branch voltages

(define vs (cp:make-connector 'vs ckt1))
(define vr (cp:make-connector 'vr ckt1))


;;; parameters

(define vss (cp:make-connector 'vss ckt1))
(define r (cp:make-connector 'r ckt1))

;;; utility
(define zero-i (cp:make-connector 'zero-i ckt1))
(cp:assume-value zero-i 0)


;;; KVL
;;;   Nodes
(cp:make-constraint cp:B=A 'KVL-N ckt1 es1 er1)
(cp:make-constraint cp:B=A 'KVL-N ckt1 es2 er2)

;;;   Elements
(cp:make-constraint cp:adder 'KVL-E ckt1 es1 vs es2)
(cp:make-constraint cp:adder 'KVL-E ckt1 er1 vr er2)


;;; KCL
;;;   Nodes
(cp:make-constraint cp:adder 'KCL-N ckt1 zero-i is1 ir1)
(cp:make-constraint cp:adder 'KCL-N ckt1 zero-i is2 ir2)

;;;   Elements
(cp:make-constraint cp:adder 'KCL-E ckt1 zero-i is1 is2)
(cp:make-constraint cp:adder 'KCL-E ckt1 zero-i ir1 ir2)

;;; VIC
;;;   Voltage-source
(cp:make-constraint cp:B=A 'Voltage-source ckt1 vss vs)

;;;   Resistor
(cp:make-constraint cp:multiplier 'OHM ckt1 vr ir1 r)

;;; Specific situation
(cp:assume-value vss 12)
(cp:assume-value r 6)

(cp:has-value? ir1)
;Value: #f

;;; Declare ground.
(cp:assume-value es1 0)

(cp:has-value? ir1)
;Value: #t

(cp:value-of ir1)
;Value: 2

;;; Correct!

(cp:retract-value r)
;Value: #t

(cp:assume-value is2 3)

(cp:value-of r)
;Value: 4

;;; Yup...

;;; Ground potential should be a CP hypothetical...
;;; Note: algebra works under scmutils.

(cp:retract-value es1)
;Value: #t

(cp:assume-value es1 'E)

(cp:why? r)
;(n48 (r = 4) (OHM n46 n47) (n42 n43 n44 n45))
;(n46 (vr = 12) (KVL-E n49 n50) (n42 n43))
;(n47 (ir1 = 3) (KCL-N n44 n51) (n44 n45))
;(n49 (er1 = E) (KVL-N n42) (n42))
;(n50 (er2 = (+ -12 E)) (KVL-N n52) (n42 n43))
;(n44 (zero-i = 0) (premise) (n44))
;(n51 (is1 = -3) (KCL-E n44 n45) (n44 n45))
;(n42 (es1 = E) (premise) (n42))
;(n52 (es2 = (+ -12 E)) (KVL-E n42 n53) (n42 n43))
;(n45 (is2 = 3) (premise) (n45))
;(n53 (vs = 12) (Voltage-source n43) (n43))
;(n43 (vss = 12) (premise) (n43))
;Unspecified return value

;;; If an expression derived from a variable plunk premise
;;; does not contain the plunk variable, we may conclude
;;; that the assumption of the plunk variable is not
;;; an essential ingredient of that expression and edit the
;;; dependencies to eliminate the plunk premise.


;;; Now make a contradiction.

(cp:retract-value es1)
;Value: #t

(cp:has-value? r)
;Value: #f

(cp:assume-value r 6)
;Unspecified return value

(cp:assume-value es2 0)
;Warning: Contradiction: #[tms:node 54]

(cp:explain-contradiction ckt1)
;(n54 contradiction (vss n57 n43) (n44 n45 n55 n43 n56))
;(n57 (vss = 18) (Voltage-source n58) (n44 n45 n55 n56))
;(n43 (vss = 12) (premise) (n43))
;(n58 (vs = 18) (KVL-E n59 n56) (n44 n45 n55 n56))
;(n59 (es1 = 18) (KVL-N n60) (n44 n45 n55 n56))
;(n56 (es2 = 0) (premise) (n56))
;(n60 (er1 = 18) (KVL-E n61 n62) (n44 n45 n55 n56))
;(n61 (vr = 18) (OHM n47 n55) (n44 n45 n55))
;(n62 (er2 = 0) (KVL-N n56) (n56))
;(n47 (ir1 = 3) (KCL-N n44 n51) (n44 n45))
;(n55 (r = 6) (premise) (n55))
;(n44 (zero-i = 0) (premise) (n44))
;(n51 (is1 = -3) (KCL-E n44 n45) (n44 n45))
;(n45 (is2 = 3) (premise) (n45))
;Unspecified return value

;;; Still under development: solve, handler, plunker.

;;; Simple Electrical Circuit : source and voltage divider

(define algebra)

(define ckt2
  (let ((alg (algebraic-solver #f)))
    (set! algebra alg)
    (cp:make-network 'ckt2 (alg 'value-model))))

(define cp:plunk-connector (algebra 'plunk-connector))



;;; terminal potentials

(define esh (cp:make-connector 'esh ckt2))
(define esl (cp:make-connector 'esl ckt2))

(define er1h (cp:make-connector 'er1h ckt2))
(define er1l (cp:make-connector 'er1l ckt2))

(define er2h (cp:make-connector 'er2h ckt2))
(define er2l (cp:make-connector 'er2l ckt2))


;;; terminal currents

(define ish (cp:make-connector 'ish ckt2))
(define isl (cp:make-connector 'isl ckt2))

(define ir1h (cp:make-connector 'ir1h ckt2))
(define ir1l (cp:make-connector 'ir1l ckt2))

(define ir2h (cp:make-connector 'ir2h ckt2))
(define ir2l (cp:make-connector 'ir2l ckt2))


;;; branch voltages

(define vs (cp:make-connector 'vs ckt2))
(define vr1 (cp:make-connector 'vr1 ckt2))
(define vr2 (cp:make-connector 'vr2 ckt2))


;;; parameters

(define vss (cp:make-connector 'vss ckt2))
(define r1 (cp:make-connector 'r1 ckt2))
(define r2 (cp:make-connector 'r2 ckt2))

;;; utility
(define zero-i (cp:make-connector 'zero-i ckt2))
(cp:assume-value zero-i 0)


;;; KVL
;;;   Nodes
(cp:make-constraint cp:B=A 'KVL-N ckt2 esh er1h)
(cp:make-constraint cp:B=A 'KVL-N ckt2 er1l er2h)
(cp:make-constraint cp:B=A 'KVL-N ckt2 esl er2l)

;;;   Elements
(cp:make-constraint cp:adder 'KVL-E ckt2 esh vs esl)
(cp:make-constraint cp:adder 'KVL-E ckt2 er1h vr1 er1l)
(cp:make-constraint cp:adder 'KVL-E ckt2 er2h vr2 er2l)


;;; KCL
;;;   Nodes
(cp:make-constraint cp:adder 'KCL-N ckt2 zero-i ish ir1h)
(cp:make-constraint cp:adder 'KCL-N ckt2 zero-i ir1l ir2h)
(cp:make-constraint cp:adder 'KCL-N ckt2 zero-i isl ir2l)

;;;   Elements
(cp:make-constraint cp:adder 'KCL-E ckt2 zero-i ish isl)
(cp:make-constraint cp:adder 'KCL-E ckt2 zero-i ir1h ir1l)
(cp:make-constraint cp:adder 'KCL-E ckt2 zero-i ir2h ir2l)

;;; VIC
;;;   Voltage-source
(cp:make-constraint cp:B=A 'Voltage-source ckt2 vss vs)

;;;   Resistor
(cp:make-constraint cp:multiplier 'OHM ckt2 vr1 ir1h r1)
(cp:make-constraint cp:multiplier 'OHM ckt2 vr2 ir1h r2)

;;; Specific situation
(cp:assume-value vss 12)
(cp:assume-value r1 9)
(cp:assume-value r2 3)


;;; Declare ground.  
(cp:assume-value esl 0)

(cp:has-value? er2h)
;Value: #f

(cp:plunk-connector er2h)

(pp-comment (algebra 'equations))
;(((+ -12 (* 4 x-er2h)) (#[tms:node 28]) (x-er2h)))
;Unspecified return value

(cp:value-of er2h)
;Value: 3

;;; Correct!

(for-each (lambda (conn)
	    (pp-comment `(,(cp:connector-name conn) ,(cp:value-of conn))))
	  (cp:network-connectors ckt2))
;(zero-i 0)
;(r2 3)
;(r1 9)
;(vss 12)
;(vr2 3)
;(vr1 9)
;(vs 12)
;(ir2l -1)
;(ir2h 1)
;(ir1l -1)
;(ir1h 1)
;(isl 1)
;(ish -1)
;(er2l 0)
;(er2h 3)
;(er1l 3)
;(er1h 12)
;(esl 0)
;(esh 12)
;Unspecified return value

(cp:why? er2h)
;(n33 (er2h = 3) (equation-solver n28) (n29 n30 n31 n32))
;(n28 (+ -12 (* 4 x-er2h)) (additional n35 n30) (n29 n30 n31 n32 n34))
;(n35 (r1 = (+ -3 (/ 36 x-er2h))) (OHM n36 n37) (n31 n34 n32 n29))
;(n30 (r1 = 9) (premise) (n30))
;(n36 (vr1 = (+ 12 (* -1 x-er2h))) (KVL-E n38 n39) (n31 n32 n34))
;(n37 (ir1h = (* 1/3 x-er2h)) (OHM n40 n29) (n34 n32 n29))
;(n38 (er1h = 12) (KVL-N n41) (n31 n32))
;(n39 (er1l = x-er2h) (KVL-N n34) (n34))
;(n40 (vr2 = x-er2h) (KVL-E n34 n42) (n34 n32))
;(n29 (r2 = 3) (premise) (n29))
;(n41 (esh = 12) (KVL-E n43 n32) (n31 n32))
;(n34 (er2h = x-er2h) (premise) (n34))
;(n42 (er2l = 0) (KVL-N n32) (n32))
;(n43 (vs = 12) (Voltage-source n31) (n31))
;(n32 (esl = 0) (premise) (n32))
;(n31 (vss = 12) (premise) (n31))
;Unspecified return value