;
; Solving resistor networks
; see http://www.lispology.com/show?29VK
;
(defparameter *circuit* '((a d ?) (a b 10) (b a 15) (b d 5) (a c 5) (c d 6)))
(defparameter *c2* '((a d ?) (a b 32) (b c 24) (a c 25) (b d 32) (c d 40)))
(defun split-set (list i)
(let (in out (ll (reverse list)))
(dotimes (j (length list))
(if (oddp i) (push (nth j ll) in) (push (nth j ll) out))
(setq i (ash i -1)))
(values in out)))
(defun series-parallel (l x y)
(cond
((or (eq (caddr x) '?) (eq (caddr y) '?))
nil)
;; Check four possible labellings
((dolist (x (list x (list (second x) (first x) (third x))))
(dolist (y (list y (list (second y) (first y) (third y))))
;; Resistors in parallel
(when (and (eq (first x) (first y))
(eq (second x) (second y)))
(return-from series-parallel
(list
(list
(first x) (second x) (/ (+ (/ (third x)) (/ (third y))))))))
;; Resistors in series
(when (and (eq (first x) (first y))
(= (countlinks l (first x)) 2)
(not (eq (second x) (second y))))
(return-from series-parallel
(list (list (second x) (second y) (+ (third x) (third y)))))))))
(t nil)))
(defun countlinks (l x)
(count-if #'(lambda (i) (or (eq x (first i)) (eq x (second i)))) l))
(defun simplify (list function n)
(let* ((l (length list))
(k (expt 2 l)))
(dotimes (i k list)
(multiple-value-bind (in out) (split-set list i)
(when (= (length in) n)
(let ((c (apply function list in)))
(when c (return (append c out)))))))))
(defun delta-wye (l x y z)
(declare (ignore l))
(cond
((or (eq (caddr x) '?) (eq (caddr y) '?) (eq (caddr z) '?))
nil)
;; Check eight possible labellings
((dolist (x (list x (list (second x) (first x) (third x))))
(dolist (y (list y (list (second y) (first y) (third y))))
(dolist (z (list z (list (second z) (first z) (third z))))
(when (and (eq (first x) (second z))
(eq (first y) (second x))
(eq (first z) (second y)))
(let ((sum (+ (third x) (third y) (third z)))
(newsymbol (gensym)))
(return-from delta-wye
(list
(list
(first x) newsymbol (/ (* (third x) (third z)) sum))
(list
(first y) newsymbol (/ (* (third x) (third y)) sum))
(list
(first z) newsymbol (/ (* (third y) (third z)) sum))))))))))
(t nil)))
(defun floating (l)
(remove-if #'(lambda (x)
(or
(= (countlinks l (first x)) 1)
(= (countlinks l (second x)) 1)))
l))
(defun solve (circuit)
(let (len)
(loop
(setq len (length circuit))
(setq circuit (simplify circuit #'delta-wye 3))
(setq circuit (simplify circuit #'series-parallel 2))
(setq circuit (floating circuit))
(when (= (length circuit) len) (return)))
circuit))