cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

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:
Mbdd.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))