diff --git a/build.xcvb b/build.xcvb index b035fa78d24edbf51e8ff1d6f80e002d2ccea37a..02cb427da319e4b874a256a02829ee88edf85dda 100644 --- a/build.xcvb +++ b/build.xcvb @@ -19,22 +19,11 @@ "filesystem/files" "filesystem/atomic" "unbaked/msv" - "interface/interface" - "interface/box" - "interface/eq" - "interface/order" - "pure/package" - "pure/map" - "pure/alist" - "pure/tree" - "pure/hash-table" - "pure/fmim" - "pure/encoded-key-map" "stateful/package" "stateful/container" - "stateful/binary-heap" - "stateful/binomial-heap" + ;;"stateful/binary-heap" + ;;"stateful/binomial-heap" + ;;"stateful/sorting" "stateful/fifo" - "stateful/dllist" - "stateful/sorting") + "stateful/dllist") :supersedes-asdf ("fare-utils"))) diff --git a/fare-utils.asd b/fare-utils.asd index 69aab8dc4f354514c7cbe0c44cb44df9b7d53690..a40211beca867157b5f8e1813f9b6c19933ee134 100644 --- a/fare-utils.asd +++ b/fare-utils.asd @@ -5,7 +5,7 @@ It contains a lot of basic everyday functions and macros, but also a library of pure and stateful datastructures, and Lisp extensions for memoization and reader interception." - :depends-on ((:version :asdf "2.019") :fare-memoization) + :depends-on ((:version :asdf "2.019") :fare-memoization #|:lisp-interface-library|#) :components ((:file "package") @@ -39,40 +39,19 @@ and Lisp extensions for memoization and reader interception." :components ((:file "msv"))) ; Magic Special Variables - ;;; Interface-Passing Style generic libraries - (:module "interface" - :depends-on ("base") - :components - ((:file "interface") - (:file "box" :depends-on ("interface")) - (:file "eq" :depends-on ("interface")) - (:file "order" :depends-on ("eq")))) - - ;;; IPS pure functional datastructures - (:module "pure" - :depends-on ("interface") - :components - ((:file "package") - (:file "map" :depends-on ("package")) - (:file "updatef" :depends-on ("package")) - (:file "updatef-expanders" :depends-on ("updatef")) - (:file "alist" :depends-on ("map")) - (:file "tree" :depends-on ("map" "alist")) - (:file "hash-table" :depends-on ("tree")) - (:file "fmim" :depends-on ("map" "tree")) - (:file "encoded-key-map" :depends-on ("map")))) - ;;; Stateful containers (:module "stateful" - :depends-on ("interface") + :depends-on ("base") :components ((:file "package") (:file "container" :depends-on ("package")) + #|;; Instead of reimplementing that here, move any new code to cl-containers. (:file "binary-heap" :depends-on ("container")) (:file "binomial-heap" :depends-on ("container")) + |# (:file "fifo" :depends-on ("container")) (:file "dllist" :depends-on ("container")) - (:file "sorting" :depends-on ("binary-heap" "binomial-heap")))))) + #|(:file "sorting" :depends-on ("binary-heap" "binomial-heap"))|#)))) (defmethod perform ((op test-op) (system (eql (find-system :fare-utils)))) (asdf:load-system :fare-utils-test) diff --git a/interface/box.lisp b/interface/box.lisp deleted file mode 100644 index 8ff8f6f78b0a31d182ae80b6bdfe9acf6c2d321e..0000000000000000000000000000000000000000 --- a/interface/box.lisp +++ /dev/null @@ -1,167 +0,0 @@ -;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- - -#+xcvb (module (:depends-on ("interface/interface"))) - -(in-package :interface) - -;;;; Interface - -;;; A class for box objects themselves -(defclass box () ()) - -(defgeneric box-ref (box) - (:documentation "open a box and return its contents")) - -;;; An interface for boxes - -;;; A box: you can make it, or get something out of it -(define-interface () ()) - -(defgeneric make-box ( generator &key &allow-other-keys) - (:documentation "Make a box from a generator for the value inside the box")) - -(defgeneric unbox ( box) - (:documentation "Return the value inside the box")) - - -;;; Classy box: same, based on a class -(define-interface ( ) ()) - -(defmethod make-box ((i ) generator &rest keys &key &allow-other-keys) - (apply 'instantiate i :generator generator keys)) - -(defmethod unbox ((i ) box) - (declare (ignorable i)) - (box-ref box)) - - -;;;; Boxes that hold a value - -(defclass value-box (box) - ((value :initarg :value :reader box-value))) - -(defmethod box-ref ((box value-box)) - (if (slot-boundp box 'value) - (box-value box) - (call-next-method))) - -(defclass simple-value-box (value-box) - ((value :initarg :generator))) - -(defmethod box-ref ((box simple-value-box)) - (box-value box)) - -(define-interface () - ((class :initform 'simple-value-box))) - -;;;; Boxes that hold a computation - -(defclass thunk-box (box) - ((thunk :initarg :thunk :reader box-thunk))) - -(defclass simple-thunk-box (box) - ((thunk :initarg :generator))) - -(defmethod box-ref ((box simple-thunk-box)) - (funcall (box-thunk box))) - -(define-interface () - ((class :initform 'simple-thunk-box))) - - -;;;; Boxes that hold a promise - -(defclass promise-box (value-box simple-thunk-box immutable-box) ()) - -(define-interface ( ) - ((class :initform 'promise-box))) - -(defmacro delay (&body body) - `(make-instance 'promise-box :thunk #'(lambda () ,@body))) - -(defun force (promise) - (box-ref promise)) - - -;;;; Boxes that can only be used once -(defclass one-use-box (box) - ((usedp :type boolean :initform nil :accessor box-usedp))) - -(define-interface () - ((class :initform 'one-use-box))) - -(defmethod box-ref :before ((box one-use-box)) - (when (box-usedp box) - (error "Tried to use ~A more than once" box))) - -(defmethod box-ref :after ((box one-use-box)) - (setf (box-usedp box) t)) - -;;; Some concrete classes following that pattern. -(defclass one-use-value-box (one-use-box value-box) ()) -(define-interface ( ) - ((class :initform 'one-use-value-box))) - -(defclass one-use-thunk-box (one-use-box thunk-box) ()) -(define-interface ( ) - ((class :initform 'one-use-thunk-box))) - -(defun make-one-use-function (function &optional name) - (let ((usedp t)) - (lambda (&rest args) - (cond - ((not usedp) - (let ((fun function)) - (setf usedp t function nil) - (apply fun args))) - (t - (error "Function ~@[~A ~]already called once" name)))))) - -(defmacro one-use-lambda (formals &body body) - `(make-one-use-function #'(lambda ,formals ,@body))) - - -;;; Some boxes can be empty -(define-interface () ()) - -(defgeneric empty () - (:documentation "Return an empty box")) - -(defgeneric empty-p ( box) - (:documentation "Return a boolean indicating whether the box was empty")) - -;;; Some boxes can be refilled - -(defclass mutable-box (box) ()) -(defclass immutable-box (box) ()) - -(define-interface () ()) - -(defgeneric box-set! (box value) - (:documentation "set the contents of a box (if applicable)")) - -(defmethod box-set! ((box immutable-box) value) - (declare (ignorable box value)) - (error "Trying to set an immutable box")) - -(defgeneric set-box! ( box value)) - -(defmethod set-box! ((i ) box value) - (declare (ignorable i)) - (box-set! box value)) - -(defclass box! (mutable-box emptyable-box value-box) ()) - -(define-interface ( ) - ((class :initform 'box!))) - -(defmethod box-set! ((box box!) value) - (setf (slot-value box 'value) value)) - -(defmethod empty-p ((i ) box) - (declare (ignorable i)) - (slot-boundp box 'value)) - -(defmethod empty ((i )) - (declare (ignorable i)) - (make-instance 'box!)) diff --git a/interface/eq.lisp b/interface/eq.lisp deleted file mode 100644 index db20c16622f017c06148d8128e14f9cecc4244bf..0000000000000000000000000000000000000000 --- a/interface/eq.lisp +++ /dev/null @@ -1,49 +0,0 @@ -;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;;;; Equality - -#+xcvb (module (:depends-on ("interface/interface"))) - -(in-package :cl) - -(defpackage :eq - (:use :cl :interface) - (:export - #: #: #: - #: - #:== #:test-function - #: - #:hash - )) - -(in-package :eq) - -(define-interface () ()) -(defparameter (fmemo:memoized-funcall 'make-instance ')) -(defgeneric == (i x y)) -(defgeneric test-function (i) - (:documentation "test function for interface")) - -(defmethod == ((i ) x y) - (eql x y)) -(defmethod test-function ((i )) - #'eql) - -(define-interface () ()) -(defmethod test-function ((i )) - #'(lambda (x y) (== i x y))) - -(define-interface () - ((test :initform #'eql :initarg :test :reader test-function))) -(defmethod == ((i ) x y) - (funcall (test-function i) x y)) - -(define-interface () ()) -(defgeneric hash (i x)) -(defmethod hash ((i ) x) - (sxhash x)) - -(define-interface () () (:singleton)) -(defmethod == ((i ) x y) - (equal x y)) -(defmethod test-function ((i )) - #'equal) diff --git a/interface/interface.lisp b/interface/interface.lisp deleted file mode 100644 index 43a4609356e858b3b8b94e2b775e1640180b1c46..0000000000000000000000000000000000000000 --- a/interface/interface.lisp +++ /dev/null @@ -1,105 +0,0 @@ -;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;;;; Interfaces for Pure Functional Data-Structures - -#+xcvb (module (:depends-on ("package"))) - -;;; On this "Interface-Passing Style" of programming, see -;;; http://fare.livejournal.com/155094.html - -(in-package :cl) - -(defpackage :interface - (:use :cl :fare-utils) - (:export - - ;;; Classes - #: - #: - #: - - ;;; Macros - #:define-interface - #:make-interface - - ;;; General purpose gfs - #:check-invariant - #:make - #:update - #:base-interface - #:instantiate - - ;;; Boxes! - #:box #:box-ref #:box-set! - #: #:make-box #:unbox - #: - #: #:value-box #:simple-value-box - #: #:thunk-box #:simple-thunk-box - #: #:promise-box #:delay #:force - #: #:one-use-box - #: #:one-use-value-box - #: #:one-use-thunk-box - #:make-one-use-function #:one-use-lambda - #: #:empty #:empty-p - #: #:mutable-box #:immutable-box #:set-box! - #: #:box! - )) - -(in-package :interface) - -(defmacro define-interface (name super-interfaces slots &rest options) - (let ((class-options - (remove-if #'(lambda (x) (member x '(:singleton :parametric))) options :key 'car))) - `(progn - (defclass ,name ,super-interfaces ,slots ,@class-options) - ,@(let ((singleton (find :singleton options :key 'car))) - (when singleton `((defvar ,name (fmemo:memoized-funcall 'make-instance ',name))))) - ,@(let ((parametric (find :parametric options :key 'car))) - (when parametric - (destructuring-bind (formals &body body) (cdr parametric) - `((defun ,name ,formals - (flet ((make-interface (&rest r) - (fmemo:memoized-apply 'make-instance ',name r))) - ,@body)))))) - ',name))) - -(define-interface () - () - (:documentation "An interface, encapsulating an algorithm")) - -(define-interface () () - (:documentation "An interface encapsulating a particular type of objects")) - -(defgeneric make ( &key) - (:documentation "Given a , create an object conforming to the interface -based on provided initarg keywords, returning the object.")) - -(defgeneric update ( object &key) - (:documentation "Update OBJECT by overriding some of its slots -with those specified as initarg keywords, returning a new object.")) - -(defgeneric check-invariant ( object &key) ;; &allow-other-keys ??? - (:documentation "Check whether an OBJECT fulfills the invariant(s) required -to play a given ROLE with respect to the given INTERFACE. -Interface is an interface, role is a class or keyword, -object is whatever makes sense. -On success the OBJECT itself is returned. On failure an error is signalled.")) - -(defmethod check-invariant :around (type object &key #+sbcl &allow-other-keys) - ;; the #+sbcl works around SBCL bug https://bugs.launchpad.net/sbcl/+bug/537711 - (declare (ignorable type)) - (call-next-method) - object) - -(defgeneric base-interface () - (:documentation "from the parametric variant of a mixin, extract the base interface")) - - -;;; Classy Interface (i.e. has some associated class) - -(define-interface () - ((class :reader interface-class :allocation :class))) - -(defgeneric instantiate ( &key &allow-other-keys)) - -(defmethod instantiate ((i ) &rest keys &key &allow-other-keys) - (apply 'make-instance (interface-class i) keys)) diff --git a/interface/order.lisp b/interface/order.lisp deleted file mode 100644 index 3a0198d32c539e12c3c09a578c461a50f4d8eecf..0000000000000000000000000000000000000000 --- a/interface/order.lisp +++ /dev/null @@ -1,168 +0,0 @@ -;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;;;; Order - -#+xcvb -(module - (:depends-on - ("package" - "base/strings" - "base/symbols" - "interface/interface" - "interface/eq"))) - -(in-package :cl) - -(defpackage :order - (:use :interface :eq :cl :fare-utils) - (:export - #: #: #: #: - #: #: - #: #: - #: #: - #:order< #:order<= #:order> #:order>= #:== #:compare - #:order-interface)) - -(in-package :order) - -(define-interface () ()) -(defgeneric order< (i x y)) -(defgeneric order<= (i x y)) -(defgeneric order> (i x y)) -(defgeneric order>= (i x y)) -(defgeneric compare (i x y)) - -(define-interface () ()) -(defmethod order<= ((i ) x y) - (not (order< i y x))) -(defmethod order> ((i ) x y) - (order< i y x)) -(defmethod order>= ((i ) x y) - (not (order< i x y))) -(defmethod == ((i ) x y) - (not (or (order< i x y) (order< i y x)))) -(defmethod compare ((i ) x y) - (cond - ((order< i x y) -1) - ((order> i x y) 1) - (t 0))) - -(define-interface () ()) -(defmethod order< ((i ) x y) - (ecase (compare i x y) - ((-1) t) - ((0 1) nil))) -(defmethod order<= ((i ) x y) - (ecase (compare i x y) - ((-1 0) t) - (1 nil))) -(defmethod order> ((i ) x y) - (ecase (compare i x y) - ((-1 0) nil) - ((1) t))) -(defmethod order>= ((i ) x y) - (ecase (compare i x y) - ((-1) nil) - ((0 1) t))) -(defmethod == ((i ) x y) - (ecase (compare i x y) - ((-1 1) nil) - ((0) t))) - -(define-interface () - ((compare :initarg :compare :reader compare-function)) - (:parametric (compare) (make-interface :compare compare))) -(defmethod compare ((i ) x y) - (funcall (compare-function i) x y)) - -(define-interface () - ((lessp :initarg :lessp :reader lessp-function)) - (:parametric (lessp) (make-interface :lessp lessp))) - -(macrolet ((delegate (&rest names) - `(progn - ,@(loop :for (name suffix) :in names :collect - `(defmethod ,name ((i ) x y) - (,(conc-symbol :call suffix) (lessp-function i) - (funcall (key-function i) x) - (funcall (key-function i) y))))))) - (delegate (order< <) (order<= <=) (order> >) (order>= >=) - (== =) (compare -compare))) - -(defun call< (lessp x y) - (funcall lessp x y)) -(defun call<= (lessp x y) - (not (funcall lessp y x))) -(defun call> (lessp x y) - (funcall lessp y x)) -(defun call>= (lessp x y) - (not (funcall lessp x y))) -(defun call= (lessp x y) - (not (or (funcall lessp x y) (funcall lessp y x)))) -(defun call-compare (lessp x y) - (cond - ((funcall lessp x y) -1) - ((funcall lessp y x) 1) - (t 0))) - -(macrolet ((builtin (name prefix) - `(progn - (define-interface ,name () () (:singleton)) - ,@(loop :for n :in '(< <= > >=) :collect - `(defmethod ,(conc-symbol :order n) ((i ,name) x y) - (,(conc-symbol prefix n) x y))) - (defmethod == ((i ,name) x y) - (,(conc-symbol prefix '=) x y)) - (defmethod compare ((i ,name) x y) - (cond - ((,(conc-symbol prefix '<) x y) -1) - ((,(conc-symbol prefix '>) x y) 1) - (t 0)))))) - ;;(builtin function call) - (builtin "") - (builtin char) - (builtin string)) - -(define-interface () - ((order-key :initarg :key :reader key-function) - (order-key-interface :initarg :order :reader order-interface)) - (:parametric (&key key order) (make-interface :key key :order order))) -(macrolet ((delegate (&rest names) - `(progn - ,@(loop :for name :in names :collect - `(defmethod ,name ((i ) x y) - (,name (order-interface i) - (funcall (key-function i) x) - (funcall (key-function i) y))))))) - (delegate order< order<= order> order>= == compare)) - -(define-interface () - ((order-interface :initarg :order :reader order-interface))) -(macrolet ((delegate (&rest names) - `(progn - ,@(loop :for name :in names :collect - `(defmethod ,name ((i ) x y) - (,name (order-interface i) x y)))))) - (delegate order< order<= order> order>= == compare)) - - -;;; simple algorithm using order -(defun sorted-list-differences (list1 list2 &key (order )) - (labels - ((rec (list1 list2 only1 common only2) - (cond - ((and (null list1) (null list2)) - (values (nreverse only1) (nreverse common) (nreverse only2))) - ((null list1) - (values (nreverse only1) (nreverse common) (nreconc only2 list2))) - ((null list2) - (values (nreconc only1 list1) (nreverse common) (nreverse only2))) - (t - (let ((r (compare order (car list1) (car list2)))) - (cond - ((= r 0) - (rec (cdr list1) (cdr list2) only1 (cons (car list1) common) only2)) - ((< r 0) - (rec (cdr list1) list2 (cons (car list1) only1) common only2)) - (t ;(> r 0) - (rec list1 (cdr list2) only1 common (cons (car list2) only2))))))))) - (rec list1 list2 nil nil nil))) diff --git a/pure/alist.lisp b/pure/alist.lisp deleted file mode 100644 index c5125ed7e90b6a36743e7c4f5a54f700c9c06938..0000000000000000000000000000000000000000 --- a/pure/alist.lisp +++ /dev/null @@ -1,75 +0,0 @@ -;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; Trivial functional map implementation: alists. - -#+xcvb -(module - (:depends-on - ("interface/interface" - "interface/eq" - "pure/package" - "pure/map"))) - -(in-package :pure) - -(defclass - ( - map-simple-empty map-simple-decons map-simple-update-key map-simple-divide/list - map-simple-map/2 map-simple-join map-simple-join/list) - ((eq-interface - :initarg :eq - :initform eq: - :reader eq-interface))) - -(defmethod check-invariant ((i ) map &key) - (loop :for ((key . nil) . rest) :on map :do - (assert (not (member key rest - :key 'car - :test (eq:test-function (eq-interface i)))) - () "Key ~S is present twice in alist ~S" key map))) - -(defun (&optional (eq eq:)) - (fmemo:memoized-funcall 'make-instance ' :eq eq)) - -(defparameter ()) - -(defmethod lookup ((i ) map key) - (if (null map) - (values nil nil) - (let ((pair (assoc key map :test (eq:test-function (eq-interface i))))) - (if pair - (values (cdr pair) t) - (values nil nil))))) - -(defmethod insert ((i ) map key value) - (acons key value (drop i map key))) - -(defmethod drop ((i ) map key) - (if (null map) - (values nil nil nil) - (multiple-value-bind (v f) (lookup i map key) - (if f - (values (remove key map :key 'car :test (eq:test-function (eq-interface i))) v t) - (values map nil nil))))) - -(defmethod first-key-value ((i ) map) - (values (caar map) (cdar map) (not (null map)))) - -(defmethod fold-left ((i ) map f seed) - (reduce #'(lambda (acc pair) (funcall f acc (car pair) (cdr pair))) - map :initial-value seed)) - -(defmethod fold-right ((i ) map f seed) - (reduce #'(lambda (pair acc) (funcall f (car pair) (cdr pair) acc)) - map :initial-value seed :from-end t)) - -(defmethod for-each ((i ) map f) - (loop :for (key . val) :in map :do (funcall f key val)) - (values)) - -(defmethod divide ((i ) map) - (let* ((l (length map)) - (l1 (ceiling l 2))) - (values (subseq map 0 l1) (nthcdr l1 map)))) - -(defmethod size ((i ) map) - (length map)) diff --git a/pure/encoded-key-map.lisp b/pure/encoded-key-map.lisp deleted file mode 100644 index de2349369be7fcf7d07877018f3bc678b8a2392f..0000000000000000000000000000000000000000 --- a/pure/encoded-key-map.lisp +++ /dev/null @@ -1,93 +0,0 @@ -;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;;;; Functional mapping where key is encoded. -#+xcvb (module (:depends-on ("pure/map" "base/macros"))) - -(in-package :pure) - -(defclass - () - ()) - -(defgeneric encode-key ( plain-key)) -(defgeneric decode-key ( encoded-key)) - -;;; This ought to have been possible with some type-directed metaprogramming... - -(macrolet - ;; non-hygienic: i from context. - ((kv (form) - (with-gensyms (k v) - `(multiple-value-bind (,k ,v) ,form - (values (decode-key i ,k) ,v)))) - (kvf (form) - (with-gensyms (k v f) - `(multiple-value-bind (,k ,v ,f) ,form - (if ,f (values (decode-key i ,k) ,v t) (values nil nil nil))))) - (mkvf (form) - (with-gensyms (m k v f) - `(multiple-value-bind (,m ,k ,v ,f) ,form - (if ,f (values ,m (decode-key i ,k) ,v t) (values ,m nil nil nil))))) - (ki () - '(key-interface i)) - ;; (mki () - ;; '(mapped-key-interface i)) - ;; (vi () - ;; '(value-interface i)) |# - (bi () - '(base-interface i))) - - (defmethod check-invariant ((i ) m &key) - (check-invariant (bi) m)) - (defmethod empty ((i )) - (empty (bi))) - (defmethod empty-p ((i ) map) - (empty-p (bi) map)) - (defmethod lookup ((i ) map key) - (lookup (bi) map (encode-key i key))) - (defmethod insert ((i ) map key value) - (insert (bi) map (encode-key i key) value)) - (defmethod drop ((i ) map key) - (drop (bi) map (encode-key i key))) - (defmethod first-key-value ((i ) map) - (kvf (first-key-value (bi) map))) - (defmethod decons ((i ) map) - (mkvf (decons (bi) map))) - (defmethod fold-left ((i ) map f seed) - (fold-left (bi) map #'(lambda (acc k v) (funcall f acc (decode-key i k) v)) seed)) - (defmethod fold-right ((i ) map f seed) - (fold-right (bi) map #'(lambda (k v acc) (funcall f (decode-key i k) v acc)) seed)) - (defmethod for-each ((i ) map f) - (for-each (bi) map #'(lambda (k v) (funcall f (decode-key i k) v)))) - (defmethod join ((i ) map1 map2) - (join (bi) map1 map2)) - (defmethod divide ((i ) map) - (divide (bi) map)) - (defmethod size ((i ) map) - (size (bi) map)) - (defmethod join/list ((i ) maplist) - (join/list (bi) maplist)) - (defmethod divide/list ((i ) map) - (divide/list (bi) map)) - (defmethod update-key ((i ) map key fun) - (update-key (bi) map (encode-key i key) fun)) - (defmethod map/2 ((i ) fun map1 map2) - (map/2 (bi) #'(lambda (k v1 f1 v2 f2) - (funcall fun (decode-key i k) v1 f1 v2 f2)) - map1 map2))) - -(defclass () - ((base-interface :initarg :base-interface :reader base-interface) - (key-encoder :initarg :key-encoder :reader key-encoder) - (key-decoder :initarg :key-decoder :reader key-decoder))) - -(defmethod encode-key ((i ) k) - (funcall (key-encoder i) k)) -(defmethod decode-key ((i ) k) - (funcall (key-decoder i) k)) - -(defun (&key base-interface key-encoder key-decoder) - (fmemo:memoized-funcall - 'make-instance ' - :base-interface base-interface - :key-encoder key-encoder - :key-decoder key-decoder)) diff --git a/pure/fmim.lisp b/pure/fmim.lisp deleted file mode 100644 index 634a9e77028d8c26a0fa6869accfdd08c1af86b7..0000000000000000000000000000000000000000 --- a/pure/fmim.lisp +++ /dev/null @@ -1,481 +0,0 @@ -;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; "Fast Mergable Integer Maps" -;;; See article of same name by Chris Okasaki & Andrew Gill, 1998 -;;; http://www.eecs.usma.edu/webs/people/okasaki/ml98maps.ps -;;; Under the hood: Big Endian Patricia Trees (Tries). -;;; Note however that in our API, what they call "merge" is called "join". - -#+xcvb -(module - (:depends-on - ("interface/interface" "pure/package" "pure/map" "pure/alist" "pure/tree"))) - -(in-package :pure) - -(defclass - ( - map-simple-empty map-simple-decons map-simple-update-key - map-simple-map/2 map-simple-join/list map-simple-size - map-simple-for-each map-simple-divide/list) - () - (:documentation "Fast Merge Integer Maps")) - -(defparameter (make-instance ')) - -;;; (big-endian) patricia tree (aka trie) -(defclass trie-head (simple-value-box) - ((height - :type fixnum - :initform 0 - :initarg :height - :reader node-height))) - -(defclass trie-node () ()) - -(defclass trie-skip (trie-node box) - ((prefix-bits - :type (integer 0 *) - :initarg :prefix-bits - :reader node-prefix-bits) - (prefix-length - :type fixnum - :initarg :prefix-length - :reader node-prefix-length))) - -(defclass trie-branch (trie-node binary-branch) ()) - -(defclass full-trie-branch (trie-branch) ()) -;;; Not needed: position tells us! (defclass trie-leaf (trie-node box) ()) - -(defmethod check-invariant ((i ) (map trie-head) &key) - (trie-check-invariant (box-ref map) (node-height map) 0)) - -(defun trie-check-invariant (trie position key) - (declare (optimize (debug 3))) - (check-type position (unsigned-byte)) - (check-type key (unsigned-byte)) - (assert (zerop (ldb (byte position 0) key))) - (unless (zerop position) - (etypecase trie - (trie-skip - (let ((pbits (node-prefix-bits trie)) - (plen (node-prefix-length trie))) - (check-type pbits (unsigned-byte)) - (check-type plen (integer 1 *)) - (assert (<= (integer-length pbits) plen)) - (assert (<= plen position)) - (let ((pos (- position plen))) - (trie-check-invariant (box-ref trie) pos (dpb pbits (byte plen pos) key))))) - (trie-branch - (let ((pos (1- position))) - (trie-check-invariant (left trie) pos key) - (trie-check-invariant (right trie) pos (dpb 1 (byte 1 pos) key)))))) - (values)) - -(defmethod lookup ((i ) map key) - (check-type map (or null trie-head)) - (check-type key (integer 0 *)) - (if map - (let ((len (integer-length key)) - (height (node-height map))) - (if (< height len) - (values nil nil) - (trie-lookup (box-ref map) height key))) - (values nil nil))) - -(defun trie-lookup (trie position key) - (cond - ((zerop position) (values trie t)) - ((null trie) (values nil nil)) - (t - (check-type trie trie-node) - (assert (plusp position)) - (etypecase trie - (trie-skip - (let* ((pbits (node-prefix-bits trie)) - (plen (node-prefix-length trie)) - (pos (- position plen))) - (if (= pbits (ldb (byte plen pos) key)) - (trie-lookup (box-ref trie) pos key) - (values nil nil)))) - (trie-branch - (let ((pos (1- position))) - (trie-lookup - (if (zerop (ldb (byte 1 pos) key)) - (left trie) - (right trie)) - pos key))))))) - -(defun make-trie-leaf (position key value) - (if (zerop position) - value - (make-trie-skip position position (ldb (byte position 0) key) value))) - -(defun make-trie-skip (position length bits datum) - (cond - ((zerop length) - datum) - ((and (plusp position) (null datum)) - nil) - ((and (> position length) (typep datum 'trie-skip)) - (make-instance - 'trie-skip - :prefix-length (+ length (node-prefix-length datum)) - :prefix-bits (dpb bits (byte length (node-prefix-length datum)) - (node-prefix-bits datum)) - :datum (box-ref datum))) - (t - (make-instance - 'trie-skip - :prefix-length length - :prefix-bits bits - :datum datum)))) - -(defun make-trie-branch (pos left right) - (cond - ((or (zerop pos) - (and (typep left 'full-trie-branch) - (typep right 'full-trie-branch))) - (make-instance 'full-trie-branch :left left :right right)) - ((and left right) - (make-instance 'trie-branch :left left :right right)) - (left - (make-trie-skip pos 1 0 left)) - (right - (make-trie-skip pos 1 1 right)) - (t - nil))) - -(defun make-trie-head (height trie) - (cond - ((and (plusp height) (null trie)) - nil) - ((and (plusp height) - (typep trie 'trie-skip) - (zerop (ldb (byte 1 (1- (node-prefix-length trie))) (node-prefix-bits trie)))) - (let* ((plen (integer-length (node-prefix-bits trie))) - (datum (box-ref trie)) - (height (- height (- (node-prefix-length trie) plen))) - (trie (make-trie-skip height plen (node-prefix-bits trie) datum))) - (make-instance 'trie-head :height height :datum trie))) - (t - (make-instance 'trie-head :height height :datum trie)))) - -(defmethod insert ((i ) map key value) - (check-type map (or null trie-head)) - (check-type key (integer 0 *)) - (let ((len (integer-length key))) - (multiple-value-bind (l d) - (if (null map) - (values len (make-trie-skip len len key value)) - (let ((height (node-height map)) - (trie (box-ref map))) - (if (< height len) - (values len - (make-trie-branch - len - (make-trie-skip len (- len height 1) 0 trie) - (make-trie-leaf (1- len) key value))) - (values height - (trie-insert trie height key value))))) - (make-trie-head l d)))) - -(defun trie-insert (trie position key value) - (if (zerop position) value - (etypecase trie - (trie-skip - (let* ((pbits (node-prefix-bits trie)) - (plen (node-prefix-length trie)) - (pos (- position plen))) - (if (= pbits (ldb (byte plen pos) key)) - (make-trie-skip position plen pbits - (trie-insert (box-ref trie) pos key value)) - (let* ((datum (box-ref trie)) - (len (1- plen)) - (pos (1- position)) - (trie1 (make-trie-skip - position len (ldb (byte len 0) pbits) datum)) - (hb (ldb (byte 1 len) pbits)) - (new-hb (ldb (byte 1 pos) key))) - (if (= hb new-hb) - (make-trie-skip - position 1 hb - (trie-insert trie1 pos key value)) - (let ((leaf (make-trie-leaf pos key value))) - (if (zerop new-hb) - (make-trie-branch pos leaf trie1) - (make-trie-branch pos trie1 leaf)))))))) - (trie-branch - (let ((pos (1- position))) - (if (zerop (ldb (byte 1 pos) key)) - (make-trie-branch - pos - (trie-insert (left trie) pos key value) - (right trie)) - (make-trie-branch - pos - (left trie) - (trie-insert (right trie) pos key value)))))))) - -(defmethod drop ((i ) map key) - (check-type map (or null trie-head)) - (multiple-value-bind (v f) - (lookup i map key) - (if f - (values - (multiple-value-bind (datum non-empty-p) - (trie-drop (box-ref map) (node-height map) key) - (when non-empty-p - (make-trie-head (node-height map) datum))) - v f) - (values map nil nil)))) - -(defun trie-drop (trie position key) - ;; from our contract with drop, - ;; we do assume the key IS in fact in the trie. - (if (zerop position) - (values nil nil) - (etypecase trie - (trie-skip - (let* ((pbits (node-prefix-bits trie)) - (plen (node-prefix-length trie)) - (pos (- position plen))) - (assert (= pbits (ldb (byte plen pos) key))) - (multiple-value-bind (datum non-empty-p) - (trie-drop (box-ref trie) pos key) - (if non-empty-p - (values (make-trie-skip position plen pbits datum) t) - (values nil nil))))) - (trie-branch - (let* ((pos (1- position)) - (bit (ldb (byte 1 pos) key))) - (values - (cond - ((zerop pos) - (make-trie-skip 1 1 (- 1 bit) - (if (zerop bit) (right trie) (left trie)))) - ((zerop bit) - (make-trie-branch - position - (trie-drop (left trie) pos key) - (right trie))) - (t - (make-trie-branch - position - (left trie) - (trie-drop (right trie) pos key)))) - t)))))) - -(defmethod first-key-value ((i ) map) - (leftmost i map)) - -(defmethod fold-left ((i ) map f seed) - (if (null map) - seed - (trie-fold-left (box-ref map) (node-height map) 0 f seed))) - -(defun trie-fold-left (trie position key f seed) - (if (zerop position) - (funcall f seed key trie) - (etypecase trie - (trie-skip - (let* ((pbits (node-prefix-bits trie)) - (plen (node-prefix-length trie)) - (pos (- position plen))) - (trie-fold-left - (box-ref trie) pos (dpb pbits (byte plen pos) key) f seed))) - (trie-branch - (let ((pos (1- position))) - (trie-fold-left - (right trie) pos (dpb 1 (byte 1 pos) key) f - (trie-fold-left - (left trie) pos key f seed))))))) - -(defmethod fold-right ((i ) map f seed) - (if (null map) - seed - (trie-fold-right (box-ref map) (node-height map) 0 f seed))) - -(defun trie-fold-right (trie position key f seed) - (if (zerop position) - (funcall f key trie seed) - (etypecase trie - (trie-skip - (let* ((pbits (node-prefix-bits trie)) - (plen (node-prefix-length trie)) - (pos (- position plen))) - (trie-fold-right - (box-ref trie) pos (dpb pbits (byte plen pos) key) f seed))) - (trie-branch - (let ((pos (1- position))) - (trie-fold-right - (left trie) pos key f - (trie-fold-right - (right trie) pos (dpb 1 (byte 1 pos) key) f seed))))))) - -(defmethod leftmost ((i ) map) - (if (null map) - (values nil nil nil) - (trie-leftmost (box-ref map) (node-height map) 0))) - -(defun trie-leftmost (trie position key) - (if (zerop position) - (values key trie t) - (etypecase trie - (trie-skip - (let* ((pbits (node-prefix-bits trie)) - (plen (node-prefix-length trie)) - (pos (- position plen))) - (trie-leftmost - (box-ref trie) pos (dpb pbits (byte plen pos) key)))) - (trie-branch - (trie-leftmost (left trie) (1- position) key))))) - -(defmethod rightmost ((i ) map) - (if (null map) - (values nil nil nil) - (trie-rightmost (box-ref map) (node-height map) 0))) - -(defun trie-rightmost (trie position key) - (if (zerop position) - (values key trie t) - (etypecase trie - (trie-skip - (let* ((pbits (node-prefix-bits trie)) - (plen (node-prefix-length trie)) - (pos (- position plen))) - (trie-rightmost - (box-ref trie) pos (dpb pbits (byte plen pos) key)))) - (trie-branch - (let ((pos (1- position))) - (trie-rightmost (right trie) pos (dpb 1 (byte 1 pos) key))))))) - -(defmethod divide ((i ) map) - (etypecase map - (null - (values nil nil)) - (trie-head - (let ((height (node-height map)) - (datum (box-ref map))) - (if (zerop height) - (values map nil) - (etypecase datum - (trie-branch - (values - (make-trie-head (1- height) (left datum)) - (make-trie-head height - (make-trie-skip height 1 1 (right datum))))) - (trie-skip - (let* ((pbits (node-prefix-bits datum)) - (plen (node-prefix-length datum)) - (position (- height plen))) - (if (zerop position) - (values map nil) - (etypecase (box-ref datum) - (trie-branch - (flet ((f (bit datum) - (make-trie-head height - (make-trie-skip - height - (1+ plen) - (dpb pbits (byte plen 1) bit) - datum)))) - (f 0 (left datum)) - (f 1 (right datum)))))))))))))) - -;;; The whole point of fmim is that we could do a fast "append", -(defmethod join ((i ) a b) - (cond - ((null a) b) - ((null b) a) - (t - (check-type a trie-head) - (check-type b trie-head) - (let* ((ha (node-height a)) - (hb (node-height b)) - (h (max ha hb))) - (make-trie-head - h (trie-join (make-trie-skip h (- h ha) 0 (box-ref a)) - (make-trie-skip h (- h hb) 0 (box-ref b)) - h)))))) - -(defun trie-join (a b position) - (if (zerop position) a - (etypecase a - (full-trie-branch a) - (trie-branch - (let ((pos (1- position))) - (etypecase b - (trie-branch - (make-trie-branch - position - (trie-join (left a) (left b) pos) - (trie-join (right a) (right b) pos))) - (trie-skip - (let* ((pbits (node-prefix-bits b)) - (plen (node-prefix-length b)) - (bh (ldb (byte 1 (1- plen)) pbits)) - (b1 - (make-trie-skip - pos (1- plen) - (ldb (byte (1- plen) 0) pbits) (box-ref b)))) - (if (zerop bh) - (make-trie-branch - position (trie-join (left a) b1 pos) (right a)) - (make-trie-branch - position (left a) (trie-join (right a) b1 pos)))))))) - (trie-skip - (let* ((pbits (node-prefix-bits a)) - (plen (node-prefix-length a)) - (pos (1- position)) - (ah (ldb (byte 1 (1- plen)) pbits)) - (a1 - (make-trie-skip - pos (1- plen) - (ldb (byte (1- plen) 0) pbits) (box-ref a)))) - (etypecase b - (trie-branch - (if (zerop ah) - (make-trie-branch - position (trie-join a1 (left b) pos) (right b)) - (make-trie-branch - position (left b) (trie-join a1 (right b) pos)))) - (trie-skip - (let* ((pbitsb (node-prefix-bits b)) - (plenb (node-prefix-length b)) - (bh (ldb (byte 1 (1- plenb)) pbitsb)) - (b1 - (make-trie-skip - pos (1- plenb) - (ldb (byte (1- plenb) 0) pbitsb) (box-ref b)))) - (if (= ah bh) - (make-trie-skip position 1 0 (trie-join a1 b1 pos)) - (if (zerop ah) - (make-trie-branch position a1 b1) - (make-trie-branch position b1 a1))))))))))) - -(defmethod print-object ((object trie-head) stream) - (format stream "#" (convert object))) - -(defmethod print-object ((trie trie-branch) stream) - (format stream "#" (left trie) (right trie))) - -(defmethod print-object ((trie trie-skip) stream) - (format stream "#" - (node-prefix-bits trie) - (node-prefix-length trie) - (box-ref trie))) - -#| -You could implement sets of integers as bitmaps, -as a list of integers, as a binary tree, -or as big-endian patricia tries mapping integers to the unit type. -In the latter case, using multiple dispatch for sub-operations -instead of the typecases I used above would allow to easily add an -optimization to my patricia trie implementation in the case the -target type is the unit type (eql t), by i.e. short-circuiting -data representation and membership test on full subtrees. - -See also -http://paste.lisp.org/display/95321 -|# diff --git a/pure/hash-table.lisp b/pure/hash-table.lisp deleted file mode 100644 index ef80105f16ce28445ff3a1474012f7b8524064c3..0000000000000000000000000000000000000000 --- a/pure/hash-table.lisp +++ /dev/null @@ -1,155 +0,0 @@ -;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;;;; Pure trees - -#+xcvb -(module - (:depends-on - ("interface/interface" - "interface/eq" - "pure/package" - "pure/map" - "pure/alist" - "pure/tree"))) - -(in-package :pure) - -(defclass - ( - map-simple-join map-simple-update-key map-simple-map/2) - ((key-interface :reader key-interface :initarg :key) - (hashmap-interface :reader hashmap-interface :initarg :hashmap) - (bucketmap-interface :reader bucketmap-interface :initarg :bucketmap)) - (:documentation "pure hash table")) - -(defun (&key (key eq:) - (hashmap ) - (bucketmap ( key))) - (assert (typep key 'eq:)) - (assert (typep hashmap ')) - (assert (typep bucketmap ')) - (fmemo:memoized-funcall - 'make-instance ' - :key key :hashmap hashmap :bucketmap bucketmap)) - -(defparameter ()) - -(defmethod check-invariant ((i ) map &key) - (check-invariant (hashmap-interface i) map) - (for-each - (hashmap-interface i) map - #'(lambda (hash bucket) - (declare (ignore hash)) - (check-invariant (bucketmap-interface i) bucket)))) - -(defmethod empty ((i )) - (empty (hashmap-interface i))) - -(defmethod empty-p ((i ) map) - (empty-p (hashmap-interface i) map)) - -(defmethod lookup ((i ) map key) - (let ((bucket (lookup (hashmap-interface i) map - (eq:hash (key-interface i) key)))) - (lookup (bucketmap-interface i) bucket key))) - -(defmethod insert ((i ) node key value) - (let ((hash (eq:hash (key-interface i) key))) - (insert - (hashmap-interface i) node hash - (insert (bucketmap-interface i) - (multiple-value-bind (bucket foundp) - (lookup (hashmap-interface i) node hash) - (if foundp bucket (empty (bucketmap-interface i)))) - key value)))) - -(defmethod drop ((i ) map key) - (let ((hash (eq:hash (key-interface i) key))) - (multiple-value-bind (bucket hashfoundp) - (lookup (hashmap-interface i) map hash) - (if (null hashfoundp) - (values map nil nil) - (multiple-value-bind (new-bucket value foundp) - (drop (bucketmap-interface i) bucket key) - (if (null foundp) - (values map nil nil) - (values - (if (empty-p (bucketmap-interface i) new-bucket) - (drop (hashmap-interface i) map hash) - (insert (hashmap-interface i) map hash new-bucket)) - value t))))))) - -(defmethod decons ((i ) map) - (multiple-value-bind (hash bucket hashfoundp) - (first-key-value (hashmap-interface i) map) - (if (null hashfoundp) - (values map nil nil nil) - (multiple-value-bind (new-bucket key value foundp) - (decons (bucketmap-interface i) bucket) - (assert foundp) - (values - (if (empty-p (bucketmap-interface i) new-bucket) - (insert (hashmap-interface i) map hash new-bucket) - (drop (hashmap-interface i) map hash)) - key value t))))) - -(defmethod first-key-value ((i ) map) - (multiple-value-bind (hash bucket foundp) - (first-key-value (hashmap-interface i) map) - (declare (ignore hash)) - (if foundp - (first-key-value (bucketmap-interface i) bucket) - (values nil nil nil)))) - -(defmethod fold-left ((i ) node f seed) - (fold-left (hashmap-interface i) node - #'(lambda (a h bucket) - (declare (ignore h)) - (fold-left (bucketmap-interface i) bucket f a)) - seed)) - -(defmethod fold-right ((i ) node f seed) - (fold-right (hashmap-interface i) node - #'(lambda (h bucket a) - (declare (ignore h)) - (fold-right (bucketmap-interface i) bucket f a)) - seed)) - -(defmethod for-each ((i ) map f) - (for-each - (hashmap-interface i) map - #'(lambda (hash bucket) - (declare (ignore hash)) - (for-each (bucketmap-interface i) bucket f)))) - -(defmethod divide ((i ) map) - (if (empty-p (hashmap-interface i) map) - (values nil nil) - (multiple-value-bind (a b) (divide (hashmap-interface i) map) - (if (empty-p (hashmap-interface i) b) - (multiple-value-bind (hash bucket) - (first-key-value (hashmap-interface i) a) - (multiple-value-bind (x y) (divide (bucketmap-interface i) bucket) - (if (empty-p (bucketmap-interface i) y) - (values a b) - (values (insert (hashmap-interface i) b hash x) - (insert (hashmap-interface i) b hash y))))) - (values a b))))) - -(defmethod divide/list ((i ) node) - (let ((list (divide/list (hashmap-interface i) node))) - (if (cdr list) - list - (multiple-value-bind (a b) (divide i node) - (cond - ((empty-p (hashmap-interface i) a) - nil) - ((empty-p (hashmap-interface i) b) - (list a)) - (t - (list a b))))))) - -(defmethod size ((i ) map) - (fold-left (hashmap-interface i) map - #'(lambda (acc hash bucket) (declare (ignore hash)) - (+ acc (size (bucketmap-interface i) bucket))) - 0)) diff --git a/pure/map.lisp b/pure/map.lisp deleted file mode 100644 index 01c329de8bc1f389840ad3ea7ab23aec2e9da264..0000000000000000000000000000000000000000 --- a/pure/map.lisp +++ /dev/null @@ -1,218 +0,0 @@ -;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;;;; Functional mapping of keys to values - -#+xcvb (module (:depends-on ("interface/interface" "pure/package"))) - -(in-package :pure) - -(defclass () ()) - -#| ;; Already defined in interface for boxes. -(defgeneric empty () - (:documentation "Return an empty map")) - -(defgeneric empty-p ( map) - (:documentation "Return a boolean indicating whether the map was empty")) -|# - -(defgeneric lookup ( map key) - (:documentation "Lookup what map associates to a key, -return two values, the associated value and -a boolean that is true iff an association was found")) - -(defgeneric insert ( map key value) - (:documentation "Add a key-value pair to a map, -replacing any previous association for this key, -return a new map.")) - -(defgeneric drop ( map key) - (:documentation "Drop from a map the association corresponding to given key, -returning three values: -a new map without that association, -the value from the dropped association, -and a boolean that is true iff an association was found.")) - -(defgeneric first-key-value ( map) - (:documentation "Return three values: -a key, a value, and a boolean indicating -whether the map was already empty. -What first means here may depend on the particular map interface, -but generally means the element most easily accessible. -")) - -(defgeneric decons ( map) - (:documentation "Drop the first association from a map, -returning four values: -a new map, a key, a value, and a boolean indicating -whether the map was already empty. -What first means here may depend on the particular map interface, -but generally means the element most easily accessible. -")) - -(defgeneric fold-left ( map f seed) - (:documentation "Fold a map with a function, -by repeatedly deconstructing it as by decons, -yielding association k_1 v_1 .. k_n v_n, and computing -(f (f ... (f (f seed k_1 v_1) k2 v_2) ... k_n-1 v_n-1) k_n v_n)")) - -(defgeneric fold-right ( map f seed) - (:documentation "Fold a map with a function, -by repeatedly deconstructing it as by decons, -yielding association k_1 v_1 .. k_n v_n, and computing -(f k_1 v_1 (f k2 v_2 (f ... (f k_n-1 v_n-1 (f k_n v_n seed))...)))")) - -(defgeneric for-each ( map f) - (:documentation "For every key value pair in map, (funcall f k v)")) - -(defgeneric join ( map1 map2) - (:documentation "Join two maps, returning a joined map. -Mappings from MAP1 override those from MAP2.")) - -(defgeneric divide ( map) - (:documentation "Divide a map in two, -returning two maps MAP1 and MAP2 that each have strictly -fewer associations than MAP unless MAP is of size zero or one. -If MAP is of size one, then MAP1 is MAP and MAP2 is empty. -If MAP is of size zero, then both MAP1 and MAP2 are empty. -")) - -(defgeneric size ( map) - (:documentation "Size the number of elements in a map")) - -(defgeneric join/list ( list) - (:documentation "Join a list of maps, -returning a joined map where mappings from -earlier mappings override those from latter mappings.")) - -(defgeneric divide/list ( map) - (:documentation "Divide a map in a list of several submaps and return that list, -such that merging those maps with join/list -will return a map similar to the original one, -that the returned list is empty iff the initial map is empty, -that the returned list is of length one iff the initial map is a singleton, -and that otherwise, each element of the list is non-empty.")) - -(defgeneric update-key ( map key fun) - (:documentation "Update the association of a map for a given key and return a new map, -calling fun with the previous associated value and T if found, with NIL and NIL otherwise, -where fun will return two values, -the new value and a boolean, -the association being dropped if the boolean is NIL, -otherwise a new association being setup with the new value.")) - -(defgeneric map/2 ( fun map1 map2) - (:documentation "Join two maps, returning a joined map. -For each key K present in either MAP1 or MAP2, -the function FUN is called with arguments K V1 F1 V2 F2 where -V1 and F1 are the value and found flag for MAP1, and -V2 and F2 are the value and found flag for MAP2, -and FUN returns value V and found flag F, -that correspond the lookup for K in the result.")) - -(defgeneric convert (2 1 map1) - (:documentation "Convert a map from one interface to another.")) - -#| -Instead of divide and divide/list and in the spirit of fold-left and fold-right, -we could have a -(defgeneric monoid-fold (i map m-null m-singleton m-join m-join/list)) -|# - -;;; Simple cases for a lot of the above functions -(defclass map-simple-empty () ()) - -(defmethod check-invariant ((i map-simple-empty) (m null) &key) - m) - -(defmethod empty ((i map-simple-empty)) - '()) - -(defmethod empty-p ((i map-simple-empty) map) - (null map)) - -(defclass map-simple-decons () ()) - -(defmethod decons ((i map-simple-decons) map) - (multiple-value-bind (k v f) (first-key-value i map) - (if f - (values (drop i map k) k v f) - (values map nil nil nil)))) - -(defclass map-simple-update-key () ()) - -(defmethod update-key ((i map-simple-update-key) map key fun) - (multiple-value-bind (value foundp) (lookup i map key) - (multiple-value-bind (new-value new-foundp) (funcall fun value foundp) - (cond - (new-foundp - (insert i map key new-value)) - (foundp - (drop i map key)) - (t - map))))) - -(defclass map-simple-join () ()) - -(defmethod join ((i map-simple-join) map1 map2) - (fold-left i map1 #'(lambda (m k v) (insert i m k v)) map2)) - -(defclass map-simple-join/list () ()) - -(defmethod join/list ((i map-simple-join/list) maplist) - (reduce #'join maplist :from-end t)) - -(defclass map-simple-divide/list () ()) - -(defmethod divide/list ((i map-simple-divide/list) map) - (cond - ((null map) '()) - ((null (cdr map)) (list map)) - (t (multiple-value-list (divide i map))))) - -(defclass map-simple-map/2 () ()) - -(defmethod map/2 ((i map-simple-map/2) fun map1 map2) - (labels ((join1 (a k v1) - (let ((mm (car a)) - (m2 (cdr a))) - (multiple-value-bind (v2 f2) (lookup i m2 k) - (multiple-value-bind (v f) (funcall fun k v1 t v2 f2) - (let ((nmm (if f (insert i mm k v) mm)) - (nm2 (if f2 (drop i m2 k) m2))) - (cons nmm nm2)))))) - (join2 (mm k v2) - (multiple-value-bind (v f) (funcall fun k nil nil v2 t) - (if f (insert i mm k v) mm)))) - (destructuring-bind (mm . m2) - (fold-left i map1 #'join1 (cons (empty i) map2)) - (fold-left i m2 #'join2 mm)))) - -(defclass map-simple-fold-right () ()) - -(defmethod fold-right ((i map-simple-fold-right) map fun seed) - (funcall - (fold-left - i map - #'(lambda (f k v) #'(lambda (acc) (funcall f (funcall fun k v acc)))) - #'identity) - seed)) - -(defclass map-simple-for-each () ()) - -(defmethod for-each ((i map-simple-for-each) map fun) - (fold-left - i map - #'(lambda (s k v) (declare (ignore s)) (funcall fun k v)) - nil) - (values)) - -(defclass map-simple-size () ()) - -(defmethod size ((i map-simple-size) map) - (fold-left i map #'(lambda (x k v) (declare (ignore k v)) (1+ x)) 0)) - -(defmethod convert ((i2 ) (i1 ) map1) - (fold-right - i1 map1 - #'(lambda (k v map2) (insert i2 map2 k v)) - (empty i2))) diff --git a/pure/package.lisp b/pure/package.lisp deleted file mode 100644 index d4493d3531213a99e43579df520edd64e709ef38..0000000000000000000000000000000000000000 --- a/pure/package.lisp +++ /dev/null @@ -1,64 +0,0 @@ -;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;;;; Interfaces for Pure Functional Data-Structures - -#+xcvb -(module - (:depends-on - ("package" "interface/interface" "interface/eq" "interface/order"))) - -(in-package :cl) - -(defpackage :pure - (:nicknames #:pure-functional) - (:use :cl :fare-utils :interface :order :eq) - (:export - - ;;; Trees - #: - #:node #:locate #:join - #:left #:right #:leftmost #:rightmost - - ;;; Functional Maps and Containers: classes - #: #: - #: #: - #: #: - #: - #: #: - #:map-simple-empty #:map-simple-decons - #:map-simple-update-key #:map-simple-join - #:map-simple-join/list #:map-simple-divide/list - #:map-simple-map/2 #:map-simple-fold-right - #:map-simple-for-each #:map-simple-size - - ;;; Functional Maps and Containers: Generic Functions - #:empty - #:empty-p - #:lookup - #:insert - #:drop - #:first-key-value - #:decons - #:fold-left - #:fold-right - #:for-each - #:join - #:divide - #:size - #:join/list - #:divide/list - #:update-key - #:map/2 - #:convert - - #:check-invariant - - #:encode-key #:decode-key - - ;; updatef - #:updatef - #:define-updatef-expander - #:defupdatef - #:define-updatef-function - #:get-updatef-expansion - #:updatef-function - )) diff --git a/pure/tree.lisp b/pure/tree.lisp deleted file mode 100644 index 870b2baa97db45f7b11a9942861ff1ffd7397fb5..0000000000000000000000000000000000000000 --- a/pure/tree.lisp +++ /dev/null @@ -1,318 +0,0 @@ -;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;;;; Pure trees - -#+xcvb -(module - (:depends-on - ("interface/interface" - "interface/order" - "pure/package" - "pure/map" - "pure/alist"))) - -(in-package :pure) - -;;; Trees in general - -(defclass () () - (:documentation "abstract interface for trees")) - -#| -(defclass () () - (:documentation "abstract interface for nodes of trees")) -(defgeneric node-interface () - (:documentation "returns the interface for nodes of given tree interface")) -(defgeneric key-interface () - (:documentation "returns the interface for keys of given tree interface")) -|# - -(defgeneric leftmost ( tree) - (:documentation "key, value and foundp from the leftmost node in TREE")) - -(defgeneric rightmost ( tree) - (:documentation "key, value and foundp from rightmost node in TREE")) - -(defgeneric locate ( tree key path) - (:documentation "lookup a tree for a key, return a path to the proper node.")) - -(defgeneric node ( &key) - (:documentation "make a node for a tree interface")) - -;;; Vanilla Binary Tree - -(defclass - ( - order: ;; TODO: delegate that to a key interface? - map-simple-empty ;; handles all the null cases so we don't have to. - map-simple-decons map-simple-update-key - map-simple-join map-simple-map/2 map-simple-join/list - map-simple-size) - () - (:documentation "Keys in binary trees increase from left to right")) - -(defclass binary-branch () - ((left - :initarg :left - :initform nil - :reader left) - (right - :initarg :right - :initform nil - :reader right))) - -(defclass association-pair () - ((key - :initarg :key - :initform nil - :reader node-key) - (value - :initarg :value - :initform nil - :reader node-value))) - -(defclass binary-tree-node (binary-branch association-pair) - ;;; Or should we have a box instead of an association-pair ??? - ;;; Or let the user just inherit from binary-branch, - ;;; and use a node-interface with make and update? - ()) - -(defmethod check-invariant ((i ) (node binary-branch) &key - lower (lowerp lower) upper (upperp upper)) - (let ((key (node-key node))) - (when lowerp - (assert (order< i lower key))) - (when upperp - (assert (order< i key upper))) - (when (left node) - (check-invariant i (left node) :lowerp lowerp :lower lower :upperp t :upper key)) - (when (right node) - (check-invariant i (right node) :lowerp t :lower key :upperp upperp :upper upper)))) - -;;(defmethod node ((i ) &rest keys &key &allow-other-keys) -;; (apply #'make (node-interface i) keys)) -(defmethod node ((i ) &key left right key value) - (make-instance 'binary-tree-node - :key key :value value :left left :right right)) - -;;(defmethod compare-key ((i ) key1 key2) -;; (compare (key-interface i) key1 key2)) - -(defmethod locate ((i ) node key path) - (ecase (order:compare i key (node-key node)) ;; (compare-key i key (node-key node)) - (0 (values node path)) - (-1 (locate i (left node) key (cons 'left path))) - (1 (locate i (right node) key (cons 'right path))))) - -(defmethod lookup ((i ) node key) - (if (null node) - (values nil nil) - (ecase (order:compare i key (node-key node)) ;; (compare-key i key (node-key node)) - (0 (values (node-value node) t)) - (-1 (lookup i (left node) key)) - (1 (lookup i (right node) key))))) - -(defmethod insert ((i ) node key value) - (if (null node) - (node i :key key :value value) - (ecase (order:compare i key (node-key node)) - (0 (node i :key key :value value ;; (update-node i node :key key :value value) - :left (left node) :right (right node))) - (-1 (node i :key (node-key node) :value (node-value node) - :left (insert i (left node) key value) :right (right node))) - (1 (node i :key (node-key node) :value (node-value node) - :left (left node) :right (insert i (right node) key value)))))) - -(defmethod drop ((i ) node key) - (if (null node) - (values nil nil nil) - (let ((k (node-key node)) - (v (node-value node))) - (ecase (order:compare i key k) - (0 (values - (cond - ((null (left node)) (right node)) - ((null (right node)) (left node)) - (t - (multiple-value-bind (kk vv) - (leftmost i (right node)) - (node i :key kk :value vv - :left (left node) :right (drop i (right node) kk))))) - v t)) - (-1 - (multiple-value-bind (left value foundp) (drop i (left node) key) - (values (node i :key k :value v - :left left :right (right node)) - value foundp))) - (1 - (multiple-value-bind (right value foundp) (drop i (right node) key) - (values (node i :key k :value v - :left (left node) :right right) - value foundp))))))) - -(defmethod first-key-value ((i ) map) - "Return key and value with the least key" - (leftmost i map)) - -(defmethod fold-left ((i ) node f seed) - (if (null node) - seed - (fold-left i (right node) f - (funcall f - (fold-left i (left node) f seed) - (node-key node) (node-value node))))) - -(defmethod fold-right ((i ) node f seed) - (if (null node) - seed - (fold-right i (left node) f - (funcall f - (node-key node) (node-value node) - (fold-right i (right node) f seed))))) - -(defmethod for-each ((i ) node f) - (when node - (for-each i (left node) f) - (funcall f (node-key node) (node-value node)) - (for-each i (right node) f)) - (values)) - -(defmethod divide ((i ) node) - (cond - ((null node) - (values nil nil)) - ((null (left node)) - (values (node i :key (node-key node) :value (node-value node)) - (right node))) - (t - (values (left node) (insert i (right node) (node-key node) (node-value node)))))) - -(defmethod divide/list ((i ) node) - (if (null node) '() - (let* ((rlist (cons (node i :key (node-key node) :value (node-value node)) - (if (null (right node)) '() (list (right node)))))) - (if (null (left node)) rlist (cons (left node) rlist))))) - -(defmethod leftmost ((i ) node) - (cond - ((null node) (values nil nil nil)) - ((null (left node)) (values (node-key node) (node-value node) t)) - (t (leftmost i (left node))))) - -(defmethod rightmost ((i ) node) - (cond - ((null node) (values nil nil nil)) - ((null (right node)) (values (node-key node) (node-value node) t)) - (t (rightmost i (right node))))) - -;;; pure AVL-tree - -(defclass () ()) - -(defclass avl-tree-node (binary-tree-node) - ((height - :initarg :height - :initform 0 - :type integer - :reader node-height))) - -(defmethod node-height ((node null)) - 0) - -(defgeneric node-balance (node)) - -(defmethod node-balance ((node null)) - 0) - -(defmethod node-balance ((node avl-tree-node)) - (- (node-height (right node)) - (node-height (left node)))) - -(defmethod check-invariant :before ((i ) (node avl-tree-node) &key) - (assert (typep (node-height node) - `(integer 1 ,most-positive-fixnum))) - (assert (= (node-height node) - (1+ (max (node-height (left node)) - (node-height (right node)))))) - (assert (member (node-balance node) '(-1 0 1)))) - -#| Minimum number of nodes in a tree of height n (maximum is 2^n-1) -(fmemo:define-memo-function f (n) - (cond ((zerop n) 0) - ((= n 1) 1) - (t (+ 1 (f (1- n)) (f (- n 2)))))) -It's a variant of the fibonacci function, -and it grows exponentially like phi^n when n is big. -This ensures that even in the worst-case scenario, -a balanced tree is logarithmically shallow. - -Exercise: prove that the in the above algorithms, -node is always called with branches that are of comparable height... -|# - -(defmethod node ((i ) &key left right key value) - (flet ((mk (&key left right key value) - (let ((lh (node-height left)) - (rh (node-height right))) - (assert (member (- rh lh) '(-1 0 1))) - (make-instance 'avl-tree-node - :key key :value value - :left left :right right - :height (1+ (max lh rh)))))) - (ecase (- (node-height right) (node-height left)) - ((-1 0 1) (mk :key key :value value :left left :right right)) - ((-2) - (ecase (node-balance left) - ((-1 0) - ;; -1: LL rebalance: - ;; (LL2 KL LR1) K R1 ==> (LL2 KL (LR1 K R1)) - ;; 0: left rebalance during deletion - ;; (LL2 KL LR2) K R1 ==> (LL2 KL (LR2 K R1)) - (mk :left (left left) - :key (node-key left) :value (node-value left) - :right (mk :key key :value value :left (right left) :right right))) - ((1) - ;; LR rebalance: - ;; (LL1 KL (LRL21 KLR LRR21)) K R1 ==> (LL1 KL LRL21) KLR (LRR21 K R1) - (mk :left (mk :left (left left) - :key (node-key left) :value (node-value left) - :right (left (right left))) - :key (node-key (right left)) :value (node-value (right left)) - :right (mk :left (right (right left)) - :key key :value value - :right right))))) - ((2) - (ecase (node-balance right) - ((-1) - ;; RL rebalance: - ;; L1 K ((RLL21 KRL RLR21) KR RR1) ==> (L1 K RLL21) KRL (RLR21 KR RR1) - (mk :left (mk :left left - :key key :value value - :right (left (left right))) - :key (node-key (left right)) :value (node-value (left right)) - :right (mk :left (right (left right)) - :key (node-key right) :value (node-value right) - :right (right right)))) - ((0 1) - ;; -1: RR rebalance: - ;; L1 K (RL1 KR RR2) ==> (L1 K RL1) KR RR2 - ;; 0: right rebalance during deletion - ;; L1 K (RL2 KR RR2) ==> (L1 K RL2) KR RR2 - (mk :left (mk :left left - :key key :value value - :right (left right)) - :key (node-key right) :value (node-value right) - :right (right right)))))))) - -;;; Common special case: when keys are (real) numbers -(defclass ( order:) ()) - -(defparameter - (fmemo:memoized-funcall 'make-instance ')) - -(defparameter ) - -(defmethod print-object ((object binary-tree-node) stream) - (format stream "#" (convert object))) - -(defmethod print-object ((object avl-tree-node) stream) - (format stream "#" (convert object))) diff --git a/pure/updatef-expanders.lisp b/pure/updatef-expanders.lisp deleted file mode 100644 index 05813fee929c262c091bacd0514cb549df5f8fbd..0000000000000000000000000000000000000000 --- a/pure/updatef-expanders.lisp +++ /dev/null @@ -1,19 +0,0 @@ -(in-package :pure) - -(define-updatef-expander car (x) - (let ((subform-temp (gensym)) - (bind-temp (gensym))) - (values (list subform-temp) - (list x) - (list bind-temp) - `(cons ,bind-temp (cdr ,subform-temp)) - `(car ,subform-temp)))) - -(define-updatef-expander cdr (x) - (let ((subform-temp (gensym)) - (bind-temp (gensym))) - (values (list subform-temp) - (list x) - (list bind-temp) - `(cons (car ,subform-temp) ,bind-temp) - `(cdr ,subform-temp)))) diff --git a/pure/updatef.lisp b/pure/updatef.lisp deleted file mode 100644 index 79fbefa97cbc28b588325d2c29d471a0605d1573..0000000000000000000000000000000000000000 --- a/pure/updatef.lisp +++ /dev/null @@ -1,199 +0,0 @@ -;;; updatef: a pure alternative to setf. -;;; generic macro to update places in an extensible way - -(in-package :pure) - -#| -An updatef expansion is an ordered collection of five objects: - TEMP-VARS - a list of symbols naming temporary variables to be bound sequentially, - as if by let*, to values resulting from value forms. - TEMP-VALS - a list of forms (typically, subforms of the place) which when evaluated - yield the values to which the corresponding temporary variables - should be bound. - BIND-VARS - a list of symbols naming temporary store variables which are to hold - the new values that will be assigned to the place in the updated state - BINDER-FORM - a form which can reference both the temporary and the store variables, and - which returns an updated state in which the place has been assigned - the updated values, which is the correct value for updatef to return. - READER-FORM - a form which can reference the temporary variables, and which returns - the former value of the place in the state before the update. -|# - -(eval-when (:compile-toplevel :load-toplevel :execute) - -(defgeneric updatef-expansion (expander &key op args place environment)) - -(defun get-updatef-expansion (place &optional environment) - "pure analogue to (GET-SETF-EXPANSION PLACE ENVIRONMENT)" - (check-type place cons) - (destructuring-bind (op &rest args) place - (check-type op symbol) - (let ((expansion (get op 'updatef-expansion))) - (unless expansion - (error "No updatef expansion for ~S" op)) - (updatef-expansion expansion :op op :args args :place place :environment environment)))) - -(defmacro %define-updatef-expansion (access-fn value) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (setf (get ',access-fn 'updatef-expansion) ,value) - ',access-fn)) - -(defclass updatef-expander () - ((expander :reader updatef-expander :initarg :expander))) - -(defmethod updatef-expansion ((u updatef-expander) &key op args place environment) - (declare (ignore op)) - (apply (updatef-expander u) environment place args)) - -(defmacro define-updatef-expander (access-fn lambda-list &body body) - "pure analogue to (DEFINE-SETF-EXPANDER ACCESS-FN LAMBDA-LIST . BODY)" - (check-type access-fn symbol) - (with-gensyms (args) - (multiple-value-bind (destructuring-lambda-list wholevar wholep envvar envp) - (parse-macro-lambda-list lambda-list) - `(%define-updatef-expansion - ,access-fn - (make-instance - 'updatef-expander :expander - #'(lambda (,envvar ,wholevar &rest ,args) - ,@(unless wholep `((declare (ignore ,wholevar)))) - ,@(unless envp `((declare (ignore ,envvar)))) - (destructuring-bind (,@destructuring-lambda-list) ,args - ,@body))))))) - -(defun get-updatef-expansion-tmpvars (environment args) - (loop - :for arg :in args :for tmpvar = (gensym "ARG") - :when (constantp arg environment) - :collect arg :into actual-args - :else - :collect tmpvar :into actual-args :and - :collect tmpvar :into tmpvars :and - :collect arg :into inits - :finally (return (values tmpvars inits actual-args)))) - -(defun simple-updatef-expansion (environment op args updater updatef-fun-p) - (check-type updater symbol) - (multiple-value-bind (tmpvars inits actual-args) - (get-updatef-expansion-tmpvars environment args) - (let ((newvalvar (gensym "VAL"))) - (values tmpvars inits newvalvar - (if updatef-fun-p - `(,updater ,newvalvar ,@actual-args) - `(,updater ,@actual-args ,newvalvar)) - `(,op ,@actual-args))))) - -(defclass defupdatef-short-expander (updatef-expander) ()) - -(defmethod updatef-expansion ((u defupdatef-short-expander) &key op args place environment) - (declare (ignore place)) - (simple-updatef-expansion environment op args (updatef-expander u) nil)) - -(defclass defupdatef-function-expander (updatef-expander) ()) - -(defmethod updatef-expansion ((u defupdatef-function-expander) &key op args place environment) - (declare (ignore place)) - (simple-updatef-expansion environment op args (updatef-expander u) t)) - -(defclass defupdatef-long-expander (updatef-expander) - ((n-bind-vars :initarg :n-bind-vars :reader n-bind-vars))) - -(defmethod updatef-expansion ((u defupdatef-long-expander) &key op args place environment) - (declare (ignore place)) - (multiple-value-bind (tmpvars inits actual-args) - (get-updatef-expansion-tmpvars environment args) - (let* ((n (n-bind-vars u)) - (bind-vars (loop :repeat n :collect (gensym "VAL")))) - (assert (= n (length args))) - (values tmpvars inits bind-vars - (funcall (updatef-expander u) environment (append bind-vars actual-args)) - `(,op ,@actual-args))))) - -(defmacro defupdatef (access-fn &rest more) - "pure analogue to defsetf" - (etypecase (car more) - (symbol ; short form - (destructuring-bind (update-fn &optional docstring) more - (declare (ignore docstring)) - `(%define-updatef-expansion - ,access-fn - (make-instance 'defupdatef-short-expander :expander ',update-fn)))) - (list ; long form - (destructuring-bind (defsetf-lambda-list bind-vars &body body) more - (assert (every 'identifierp bind-vars)) - (multiple-value-bind (lambda-list environment envp) - (parse-defsetf-lambda-list defsetf-lambda-list) - `(%define-updatef-expansion - ,access-fn - (make-instance - 'defupdatef-long-expander :n-bind-vars (length bind-vars) :expander - #'(lambda (,environment ,@bind-vars ,@lambda-list) - ,@(unless envp `((declare (ignore ,environment)))) - ,@body)))))))) - -(defmacro define-updatef-function (access-fn lambda-list &body body) - "pure analogue to `(DEFUN (SETF ,FUNCTION) ,LAMBDA-LIST ,@BODY)" - (multiple-value-bind (body decls doc) (parse-body body :documentation t) - (declare (ignore doc)) - `(%define-updatef-expansion - ,access-fn - (make-instance - 'defupdatef-function-expander :expander - #'(lambda ,lambda-list - ,decls - (block ,access-fn ,@body)))))) - -(defun updatef-function (sym) - (assert (symbolp sym)) - (let ((u (get sym 'updatef-expansion))) - (typecase u - (defupdatef-function-expander - (updatef-expander u)) - (null - (error "No updatef function for symbol ~S" sym)) - (defupdatef-short-expander - (let ((i (updatef-expander u))) - (if (and (fboundp i) (not (macro-function i))) - #'(lambda (v &rest args) - (apply i (append args (list v)))) - (error "updatef inverse for ~S is not a function" sym)))) - (t - (error "Updater for symbol ~S is not a function" sym))))) - -(defmacro updatef (&rest uargs &environment env) - "pure analogue to SETF" - (let ((nargs (length uargs))) - (cond - ((= nargs 2) - (let ((place (first uargs)) - (value-form (second uargs))) - (when (atom place) - (error "A variable is not a suitable place for UPDATEF")) - (let* ((op (first place)) - (args (rest place)) - (expansion (get op 'updatef-expansion))) - (typecase expansion - (null - `(call-updatef-function ',op ,value-form ,args)) - (defupdatef-short-expander - `(,(updatef-expander expansion) ,args ,value-form)) - (defupdatef-function-expander - `(funcall (load-time-value (updatef-function ',op)) ,value-form ,args)) - (updatef-expander - (multiple-value-bind (dummies vals newval binder getter) - (updatef-expansion expansion :op op :args args :place place :environment env) - (declare (ignore getter)) - `(let* (,@(mapcar #'list dummies vals)) - (multiple-value-bind ,newval ,value-form - ,binder)))))))) - ((oddp nargs) - (error "odd number of args to UPDATEF")) - (t - `(values (loop :for (place value) :on uargs :by #'cddr :collect - `(updatef ,place ,value))))))) -);eval-when diff --git a/stateful/binary-heap.lisp b/stateful/binary-heap.lisp index 59c60b4ea0c8c3ab5093e08beb982d56c78fbf9c..a0f7f39444d0c513698465fc68feb723c4a66733 100644 --- a/stateful/binary-heap.lisp +++ b/stateful/binary-heap.lisp @@ -25,7 +25,7 @@ (in-package :stateful) -(def*class binary-heap (heap order: +(def*class binary-heap (heap #|order:|# vector-container-mixin sized-container-mixin) ()) diff --git a/stateful/container.lisp b/stateful/container.lisp index a93885203abb221c41d63852fa538a496049a6d0..3a28c945615f4680f17520d61de1761c0a5c95c4 100644 --- a/stateful/container.lisp +++ b/stateful/container.lisp @@ -4,7 +4,7 @@ #+xcvb (module (:depends-on - ("package" "base/utils" "base/macros" "interface/order" "stateful/package"))) + ("package" "base/utils" "base/macros" #|"interface/order"|# "stateful/package"))) (in-package :stateful) @@ -88,7 +88,7 @@ ;;;; Generic container mixins ;;; Heaps -(defclass heap (order: container) +(defclass heap (#|order:|# container) ()) ;;; containers with nodes diff --git a/stateful/package.lisp b/stateful/package.lisp index 767058ebab6acbc68a9a9403758caa2598f12c14..7ea82c78c519013119e7cbbcb267f60019b39f8f 100644 --- a/stateful/package.lisp +++ b/stateful/package.lisp @@ -4,12 +4,12 @@ #+xcvb (module (:depends-on - ("package" "interface/interface" "interface/eq" "interface/order"))) + ("package" #|"interface/interface" "interface/eq" "interface/order"|#))) (in-package :cl) (defpackage :stateful - (:use :cl :fare-utils :interface :eq :order) + (:use :cl :fare-utils #|:interface :eq :order|#) (:export #:container #:container-add-list! #:container-contents #:container-empty #:container-empty-p diff --git a/test/build.xcvb b/test/build.xcvb index 5997d4af25a48faa2501e6183eba7aed63846fd1..a031647799cc13a3495acce910d69e8c98c6ae72 100644 --- a/test/build.xcvb +++ b/test/build.xcvb @@ -2,8 +2,6 @@ (module (:depends-on ("package" - "strings" - "functional-map" - "updatef") + "strings") :build-depends-on ((:build "/fare-utils") (:asdf "hu.dwim.stefil")) :supersedes-asdf ("fare-utils-test"))) diff --git a/test/fare-utils-test.asd b/test/fare-utils-test.asd index a58f3994d08a027a97b43a1a7d884d6cfcb77aaf..6149ce25a33e95015e348d08f73c6de14bde4c69 100644 --- a/test/fare-utils-test.asd +++ b/test/fare-utils-test.asd @@ -4,6 +4,4 @@ :depends-on (:fare-utils :hu.dwim.stefil) :components ((:file "package") - (:file "strings" :depends-on ("package")) - (:file "functional-map" :depends-on ("package")) - (:file "updatef" :depends-on ("package")))) + (:file "strings" :depends-on ("package")))) diff --git a/test/functional-map.lisp b/test/functional-map.lisp deleted file mode 100644 index cc443d31d35626a4b66d21f45f8efeb00b68a036..0000000000000000000000000000000000000000 --- a/test/functional-map.lisp +++ /dev/null @@ -1,245 +0,0 @@ -#+xcvb (module (:depends-on ("package"))) -(in-package :fare-utils-test) - -(declaim (optimize (speed 1) (debug 3) (space 3))) - -(defsuite* (test-functional-map - :in test-suite - :documentation "Testing pure functional maps")) - -(defun sort-alist (alist) (sort (copy-seq alist) #'< :key #'car)) -(defun shuffle-list (list) - (mapcar #'cdr - (sort (mapcar #'(lambda (x) (cons (random most-positive-fixnum) x)) list) - #'< :key #'car))) -(defun make-alist (n &optional (formatter "~D")) - (loop :for i :from 1 :to n :collect - (cons i (format nil formatter i)))) -(defun equal-alist (x y) - (equal (sort-alist x) (sort-alist y))) - -(defparameter *alist-10-latin* (make-alist 10 "~@R")) -(defparameter *alist-100-decimal* (make-alist 100 "~D")) -(defparameter *alist-100-latin* (make-alist 100 "~@R")) -(defparameter *alist-100-english* (make-alist 100 "~R")) - -(defparameter *al-1* (shuffle-list *alist-100-decimal*)) -(defparameter *al-2* (remove-if-not #'evenp *alist-100-decimal* :key #'car)) -(defparameter *al-3* (remove-if-not #'(lambda (x) (< (length x) 5)) *alist-100-latin* :key #'cdr)) -(defparameter *al-5* (remove-duplicates (append *al-2* *al-3*) :key #'car :from-end t)) - -(defun alist-from (i map) - (convert i map)) - -(defun from-alist (i map) - (check-invariant i (convert i map))) - -(defgeneric interface-test ()) - -(defmethod interface-test ((i )) - ;;; TODO: test each and every function in the API - (is (null (alist-from i (empty i)))) - (is (empty-p i (from-alist i ()))) - (is (equal "12" - (lookup - i - (from-alist - i '((57 . "57") (10 . "10") (12 . "12"))) - 12))) - (loop :for (k . v) :in *al-1* :with m = (from-alist i *al-1*) :do - (is (eq v (lookup i m k)))) - (is (equal-alist *alist-10-latin* - (alist-from i (from-alist i *alist-10-latin*)))) - (is (equal-alist *alist-10-latin* - (alist-from i (from-alist i *alist-10-latin*)))) - (is (equal-alist *alist-100-decimal* - (alist-from i (from-alist i *al-1*)))) - (is (equal-alist *al-5* - (alist-from - i (check-invariant - i (join i (from-alist i *al-2*) - (from-alist i *al-3*)))))) - - ;; insert - (is (equal '((0)) (alist-from i (insert i (empty i) 0 nil)))) - (is (equal-alist - '((1 . "1") (2 . "2") (3 . "3")) - (alist-from i (insert i (from-alist i '((1 . "1") (3 . "3"))) 2 "2")))) - ;; insert and join - (is (equal-alist - '((0 . "0") (1 . "1") (2 . "2")) - (alist-from i (insert i (join i (from-alist i '((1 . "1"))) - (from-alist i'((2 . "2")))) 0 "0")))) - ;; insert and size - (is (= 101 (size i (insert i (from-alist i *al-1*) 101 "101")))) - - ;; drop - (is (equal '(nil nil nil) - (multiple-value-list (drop i (empty i) 0)))) - (multiple-value-bind (r d b) - (drop i (from-alist i '((1 . "1") (2 . "2"))) 1) - (is (equal '(((2 . "2")) "1" t) - (list (alist-from i r) d b)))) - (multiple-value-bind (r d b) - (drop i (from-alist i *al-1*) 42) - (is (equal d "42") - (is (equal b t))) - (is (= (size i r) 99))) - ;; drop and size - (multiple-value-bind (r d b) - (drop i (from-alist i *alist-100-decimal*) 57) - (is (= (size i r) 99)) - (is (equal d "57")) - (is (eql b t))) - - ;; first-key-value - (is (equal '(nil nil nil) - (multiple-value-list (first-key-value i (empty i))))) - (multiple-value-bind (k v b) - (first-key-value i (from-alist i *al-2*)) - (multiple-value-bind (vv bb) (lookup *al-2* k) - (is (equal b t)) - (is (equal bb t)) - (is (equal v vv)))) - (multiple-value-bind (k v b) - (first-key-value i (from-alist i *alist-100-latin*)) - (multiple-value-bind (vv bb) (lookup *alist-100-latin* k) - (is (equal b t)) - (is (equal bb t)) - (is (equal v vv)))) - - ;; decons - (is (equal '(() () () ()) (multiple-value-list (decons i (empty i))))) - (multiple-value-bind (m k v b) (decons i (from-alist i *alist-10-latin*)) - (is (eq b t)) - (is (equal (list v t) - (multiple-value-list (lookup *alist-10-latin* k)))) - (is (equal (list nil nil) - (multiple-value-list (lookup i m k)))) - (is (= (size i m) 9))) - - ;; fold-left - (is (eql nil (fold-left i (empty i) (constantly t) nil))) - (is (eql t (fold-left i (empty i) (constantly t) t))) - (is (equal-alist - '((2 . "2") (1 . "1") (20 . "20") (30 . "30")) - (alist-from i - (fold-left - i (from-alist i (make-alist 2)) - #'(lambda (m k v) (insert i m k v)) - (from-alist i '((20 . "20") (30 . "30"))))))) - ;; fold-left and size - (is (= 100 - (size i - (fold-left i (from-alist i *alist-100-decimal*) - #'(lambda (m k v) (insert i m k v)) - (from-alist i *alist-100-latin*))))) - - ;; fold-right - (is (eql nil (fold-right i (empty i) (constantly t) nil))) - (is (eql t (fold-right i (empty i) (constantly t) t))) - (is (equal-alist - '((1 . "1") (2 . "2") (20 . "20") (30 . "30")) - (alist-from i - (fold-right - i (from-alist i (make-alist 2)) - #'(lambda (k v m) (insert i m k v)) - (from-alist i '((20 . "20") (30 . "30"))))))) - - ;; for-each - (is (eql nil (while-collecting (c) - (for-each i (empty i) #'(lambda (k v) (c (cons k v))))))) - (is (equal-alist - *alist-10-latin* - (while-collecting (c) - (with-output-to-string (o) - (for-each i (from-alist i *alist-10-latin*) - #'(lambda (k v) (c (cons k v)))))))) - (is (= 1129 (length (with-output-to-string (o) - (for-each i (from-alist i *alist-100-english*) - #'(lambda (x y) - (format o "~A~A" x y))))))) - - ;; join - (is (equal '() (join i (empty i) (empty i)))) - (is (equal-alist '((1 . "1") (2 . "2") (5 . "5") (6 . "6")) - (alist-from - i - (join i - (from-alist i '((1 . "1") (2 . "2"))) - (from-alist i '((5 . "5") (6 . "6"))))))) - ;; join and size - (is (= 100 (size i - (join i - (from-alist i *alist-10-latin*) - (from-alist i *alist-100-latin*))))) - - ;; divide and join - (is (equal '(nil nil) (multiple-value-list (divide i (empty i))))) - (multiple-value-bind (x y) - (divide i (from-alist i *alist-10-latin*)) - (is (equal-alist *alist-10-latin* - (append (alist-from i x) (alist-from i y))))) - ;; divide and size - (multiple-value-bind (x y) - (divide i (from-alist i '())) - (is (empty-p i x)) - (is (empty-p i y))) - (multiple-value-bind (x y) - (divide i (from-alist i '((1 . "1")))) - (is (empty-p i y)) - (is (= 1 (size i x)))) - (multiple-value-bind (x y) - (divide i (from-alist i *alist-100-latin*)) - (let ((sx (size i x)) (sy (size i y))) - (is (plusp sx)) - (is (plusp sy)) - (is (= 100 (+ sx sy))))) - - ;; size - (is (= 0 (size i (empty i)))) - (is (= 100 (size i (from-alist i *alist-100-decimal*)))) - (is (= 99 (size i (decons i (from-alist i *alist-100-decimal*))))) - - ;; join/list - ;; TODO: add tests - - - ;; divide/list - ;; TODO: add more tests - (is (null (divide/list i (empty i)))) - - ;; update-key - ;; TODO: add more tests - (is (null (update-key i (empty i) 0 (constantly nil)))) - - ;; map/2 - ;; TODO: add more tests - (is (null (map/2 i (constantly t) (empty i) (empty i)))) - - ;; convert - (is (null (convert i (empty i)))) - (is (equal-alist *alist-10-latin* - (convert i (convert i *alist-10-latin*)))) - t) - -(defmethod interface-test :after ((i )) - (let* ((a1 (make-alist 1000 "~@R")) - (a2 (shuffle-list a1)) - (m1 (convert i a1)) - (m2 (convert i a2))) - (check-invariant i m1) - (check-invariant i m2) - (is (= 10 (pure::node-height m1))) - (is (<= 10 (pure::node-height m2) 15)) - (is (= 1000 (size i m1))) - (is (= 1000 (size i m2))))) - -(defparameter ( - :base-interface - :key-encoder #'(lambda (dk) (* dk 2)) - :key-decoder #'(lambda (ek) (/ ek 2)))) - -(deftest test-pure-map-interfaces () - (dolist (i (list )) - (interface-test i))) diff --git a/test/updatef.lisp b/test/updatef.lisp deleted file mode 100644 index 50322b0a41be09fb0bdc07106723c5d9511aa091..0000000000000000000000000000000000000000 --- a/test/updatef.lisp +++ /dev/null @@ -1,15 +0,0 @@ -#+xcvb (module (:depends-on ("package"))) -(in-package :fare-utils-test) - -(declaim (optimize (speed 1) (debug 3) (space 3))) - -(defsuite* (test-updatef - :in test-suite - :documentation "Testing pure update")) - -(deftest test-updatef () - (is (equal (updatef (car '(1 2)) 3) '(3 2))) - (is (equal (updatef (cdr '(1 2)) 3) '(1 . 3))) - (is (equal (updatef (car (cdr '(1 2))) 3) '(3))) ; and not (1 3) - Ahem. We need some way of composing updates... - (values)) -