; ; 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))