commit 681f9021a83ef557a287758368ac08266b230103 parent 514d7e0cfe2ce783c37a13afb983ea187d4868d7 Author: Tomas Hlavaty <tom@logand.com> Date: Thu, 19 Jun 2014 23:37:26 +0200 reduce consing in bdd apply Diffstat:
| M | bdd.lisp | | | 42 | ++++++++++++++++++++++-------------------- |
1 file changed, 22 insertions(+), 20 deletions(-)
diff --git a/bdd.lisp b/bdd.lisp @@ -58,29 +58,31 @@ (defun app (op u1 u2) (let ((g (make-hash-table :test #'equal)) + (k (list nil)) (zero (mk 2 0 0)) (one (mk 2 1 1))) (labels ((rec (u1 u2) - (let ((k (cons u1 u2))) ;; TODO reduce consing - (or (gethash k g) - (setf (gethash k g) - (destructuring-bind (v1 l1 &rest h1) u1 - (destructuring-bind (v2 l2 &rest h2) u2 - (cond - ((and (or (eq zero u1) (eq one u1)) - (or (eq zero u2) (eq one u2))) - (if (ecase op - (and (and (eq one u1) (eq one u2))) - (or (or (eq one u1) (eq one u2))) - (eq (eq u1 u2))) - one - zero)) - ((= v1 v2) - (mk v1 (rec l1 l2) (rec h1 h2))) - ((< v1 v2) - (mk v1 (rec l1 u2) (rec h1 u2))) - (t - (mk v2 (rec u1 l2) (rec u1 h2))))))))))) + (rplaca k u1) + (rplacd k u2) + (or (gethash k g) + (setf (gethash (cons u1 u2) g) + (destructuring-bind (v1 l1 &rest h1) u1 + (destructuring-bind (v2 l2 &rest h2) u2 + (cond + ((and (or (eq zero u1) (eq one u1)) + (or (eq zero u2) (eq one u2))) + (if (ecase op + (and (and (eq one u1) (eq one u2))) + (or (or (eq one u1) (eq one u2))) + (eq (eq u1 u2))) + one + zero)) + ((= v1 v2) + (mk v1 (rec l1 l2) (rec h1 h2))) + ((< v1 v2) + (mk v1 (rec l1 u2) (rec h1 u2))) + (t + (mk v2 (rec u1 l2) (rec u1 h2)))))))))) (rec u1 u2)))) ;;(app 'and (mk 2 0 1) (mk 3 0 1))