Excise the interface and pure directories from fare-utils.
authorFrancois-Rene Rideau <tunes@google.com>
Tue, 12 Jun 2012 00:52:33 +0000 (20:52 -0400)
committerFrancois-Rene Rideau <tunes@google.com>
Tue, 12 Jun 2012 01:00:29 +0000 (21:00 -0400)
Deactivate some stateful datastructures that depend on interface;
probably nobody uses them, and they ought to be merged into cl-containers or such.

22 files changed:
build.xcvb
fare-utils.asd
interface/box.lisp [deleted file]
interface/eq.lisp [deleted file]
interface/interface.lisp [deleted file]
interface/order.lisp [deleted file]
pure/alist.lisp [deleted file]
pure/encoded-key-map.lisp [deleted file]
pure/fmim.lisp [deleted file]
pure/hash-table.lisp [deleted file]
pure/map.lisp [deleted file]
pure/package.lisp [deleted file]
pure/tree.lisp [deleted file]
pure/updatef-expanders.lisp [deleted file]
pure/updatef.lisp [deleted file]
stateful/binary-heap.lisp
stateful/container.lisp
stateful/package.lisp
test/build.xcvb
test/fare-utils-test.asd
test/functional-map.lisp [deleted file]
test/updatef.lisp [deleted file]

index b035fa7..02cb427 100644 (file)
    "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")))
index 69aab8d..a40211b 100644 (file)
@@ -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 (file)
index 8ff8f6f..0000000
+++ /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 <box> (<interface>) ())
-
-(defgeneric make-box (<box> generator &key &allow-other-keys)
-  (:documentation "Make a box from a generator for the value inside the box"))
-
-(defgeneric unbox (<box> box)
-  (:documentation "Return the value inside the box"))
-
-
-;;; Classy box: same, based on a class
-(define-interface <classy-box> (<box> <classy>) ())
-
-(defmethod make-box ((i <classy-box>) generator &rest keys &key &allow-other-keys)
-  (apply 'instantiate i :generator generator keys))
-
-(defmethod unbox ((i <classy-box>) 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 <value-box> (<classy-box>)
-  ((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 <thunk-box> (<classy-box>)
-  ((class :initform 'simple-thunk-box)))
-
-
-;;;; Boxes that hold a promise
-
-(defclass promise-box (value-box simple-thunk-box immutable-box) ())
-
-(define-interface <promise-box> (<value-box> <simple-thunk-box>)
-  ((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 <one-use-box> (<classy-box>)
-  ((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 <one-use-value-box> (<one-use-box> <value-box>)
-  ((class :initform 'one-use-value-box)))
-
-(defclass one-use-thunk-box (one-use-box thunk-box) ())
-(define-interface <one-use-thunk-box> (<one-use-box> <thunk-box>)
-  ((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 <emptyable-box> (<box>) ())
-
-(defgeneric empty (<emptyable-box>)
-  (:documentation "Return an empty box"))
-
-(defgeneric empty-p (<emptyable-box> 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 <mutable-box> (<box>) ())
-
-(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> box value))
-
-(defmethod set-box! ((i <classy-box>) box value)
-  (declare (ignorable i))
-  (box-set! box value))
-
-(defclass box! (mutable-box emptyable-box value-box) ())
-
-(define-interface <box!> (<mutable-box> <classy-box> <emptyable-box>)
-  ((class :initform 'box!)))
-
-(defmethod box-set! ((box box!) value)
-  (setf (slot-value box 'value) value))
-
-(defmethod empty-p ((i <box!>) box)
-  (declare (ignorable i))
-  (slot-boundp box 'value))
-
-(defmethod empty ((i <box!>))
-  (declare (ignorable i))
-  (make-instance 'box!))
diff --git a/interface/eq.lisp b/interface/eq.lisp
deleted file mode 100644 (file)
index db20c16..0000000
+++ /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
-   #:<eq> #:<eq-simple> #:<eq-slot>
-   #:<equal>
-   #:== #:test-function
-   #:<hashable>
-   #:hash
-   ))
-
-(in-package :eq)
-
-(define-interface <eq> () ())
-(defparameter <eq> (fmemo:memoized-funcall 'make-instance '<eq>))
-(defgeneric == (i x y))
-(defgeneric test-function (i)
-  (:documentation "test function for <eq> interface"))
-
-(defmethod == ((i <eq>) x y)
-  (eql x y))
-(defmethod test-function ((i <eq>))
-  #'eql)
-
-(define-interface <eq-simple> (<eq>) ())
-(defmethod test-function ((i <eq-simple>))
-  #'(lambda (x y) (== i x y)))
-
-(define-interface <eq-slot> (<eq>)
-  ((test :initform #'eql :initarg :test :reader test-function)))
-(defmethod == ((i <eq-slot>) x y)
-  (funcall (test-function i) x y))
-
-(define-interface <hashable> (<eq>) ())
-(defgeneric hash (i x))
-(defmethod hash ((i <hashable>) x)
-  (sxhash x))
-
-(define-interface <equal> (<hashable>) () (:singleton))
-(defmethod == ((i <equal>) x y)
-  (equal x y))
-(defmethod test-function ((i <equal>))
-  #'equal)
diff --git a/interface/interface.lisp b/interface/interface.lisp
deleted file mode 100644 (file)
index 43a4609..0000000
+++ /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
-   #:<interface>
-   #:<type>
-   #:<classy>
-
-   ;;; Macros
-   #:define-interface
-   #:make-interface
-
-   ;;; General purpose gfs
-   #:check-invariant
-   #:make
-   #:update
-   #:base-interface
-   #:instantiate
-
-   ;;; Boxes!
-   #:box #:box-ref #:box-set!
-   #:<box> #:make-box #:unbox
-   #:<classy-box>
-   #:<value-box> #:value-box #:simple-value-box
-   #:<thunk-box> #:thunk-box #:simple-thunk-box
-   #:<promise-box> #:promise-box #:delay #:force
-   #:<one-use-box> #:one-use-box
-   #:<one-use-value-box> #:one-use-value-box
-   #:<one-use-thunk-box> #:one-use-thunk-box
-   #:make-one-use-function #:one-use-lambda
-   #:<emptyable-box> #:empty #:empty-p
-   #:<mutable-box> #:mutable-box #:immutable-box #:set-box!
-   #:<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 <interface> ()
-  ()
-  (:documentation "An interface, encapsulating an algorithm"))
-
-(define-interface <type> (<interface>) ()
-  (:documentation "An interface encapsulating a particular type of objects"))
-
-(defgeneric make (<type> &key)
-  (:documentation "Given a <type>, create an object conforming to the interface
-based on provided initarg keywords, returning the object."))
-
-(defgeneric update (<type> object &key)
-  (:documentation "Update OBJECT by overriding some of its slots
-with those specified as initarg keywords, returning a new object."))
-
-(defgeneric check-invariant (<type> 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 (<interface>)
-  (:documentation "from the parametric variant of a mixin, extract the base interface"))
-
-
-;;; Classy Interface (i.e. has some associated class)
-
-(define-interface <classy> (<interface>)
-  ((class :reader interface-class :allocation :class)))
-
-(defgeneric instantiate (<interface> &key &allow-other-keys))
-
-(defmethod instantiate ((i <classy>) &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 (file)
index 3a0198d..0000000
+++ /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> #:<number> #:<string> #:<char>
-   #:<order-from-lessp> #:<lessp>
-   #:<order-from-compare> #:<compare>
-   #:<key> #:<order-parameter>
-   #:order< #:order<= #:order> #:order>= #:== #:compare
-   #:order-interface))
-
-(in-package :order)
-
-(define-interface <order> (<eq>) ())
-(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 <order-from-lessp> (<order>) ())
-(defmethod order<= ((i <order-from-lessp>) x y)
-  (not (order< i y x)))
-(defmethod order> ((i <order-from-lessp>) x y)
-  (order< i y x))
-(defmethod order>= ((i <order-from-lessp>) x y)
-  (not (order< i x y)))
-(defmethod == ((i <order-from-lessp>) x y)
-  (not (or (order< i x y) (order< i y x))))
-(defmethod compare ((i <order-from-lessp>) x y)
-  (cond
-    ((order< i x y) -1)
-    ((order> i x y) 1)
-    (t 0)))
-
-(define-interface <order-from-compare> (<order>) ())
-(defmethod order< ((i <order-from-compare>) x y)
-  (ecase (compare i x y)
-    ((-1) t)
-    ((0 1) nil)))
-(defmethod order<= ((i <order-from-compare>) x y)
-  (ecase (compare i x y)
-    ((-1 0) t)
-    (1 nil)))
-(defmethod order> ((i <order-from-compare>) x y)
-  (ecase (compare i x y)
-    ((-1 0) nil)
-    ((1) t)))
-(defmethod order>= ((i <order-from-compare>) x y)
-  (ecase (compare i x y)
-    ((-1) nil)
-    ((0 1) t)))
-(defmethod == ((i <order-from-compare>) x y)
-  (ecase (compare i x y)
-    ((-1 1) nil)
-    ((0) t)))
-
-(define-interface <compare> (<order-from-compare>)
-  ((compare :initarg :compare :reader compare-function))
-  (:parametric (compare) (make-interface :compare compare)))
-(defmethod compare ((i <compare>) x y)
-  (funcall (compare-function i) x y))
-
-(define-interface <lessp> (<order-from-lessp>)
-  ((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 <lessp>) 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 (<order>) () (: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 <number> "")
-  (builtin <char> char)
-  (builtin <string> string))
-
-(define-interface <key> ()
-  ((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 <key>) 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-parameter> ()
-  ((order-interface :initarg :order :reader order-interface)))
-(macrolet ((delegate (&rest names)
-             `(progn
-                ,@(loop :for name :in names :collect
-                    `(defmethod ,name ((i <order-parameter>) 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 <number>))
-  (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 (file)
index c5125ed..0000000
+++ /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 <alist>
-    (<map>
-     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:<eq>
-    :reader eq-interface)))
-
-(defmethod check-invariant ((i <alist>) 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 <alist> (&optional (eq eq:<eq>))
-  (fmemo:memoized-funcall 'make-instance '<alist> :eq eq))
-
-(defparameter <alist> (<alist>))
-
-(defmethod lookup ((i <alist>) 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 <alist>) map key value)
-  (acons key value (drop i map key)))
-
-(defmethod drop ((i <alist>) 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 <alist>) map)
-  (values (caar map) (cdar map) (not (null map))))
-
-(defmethod fold-left ((i <alist>) map f seed)
-  (reduce #'(lambda (acc pair) (funcall f acc (car pair) (cdr pair)))
-          map :initial-value seed))
-
-(defmethod fold-right ((i <alist>) 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 <alist>) map f)
-  (loop :for (key . val) :in map :do (funcall f key val))
-  (values))
-
-(defmethod divide ((i <alist>) map)
-  (let* ((l (length map))
-         (l1 (ceiling l 2)))
-    (values (subseq map 0 l1) (nthcdr l1 map))))
-
-(defmethod size ((i <alist>) map)
-  (length map))
diff --git a/pure/encoded-key-map.lisp b/pure/encoded-key-map.lisp
deleted file mode 100644 (file)
index de23493..0000000
+++ /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 <encoded-key-map>
-    (<map>)
-  ())
-
-(defgeneric encode-key (<interface> plain-key))
-(defgeneric decode-key (<interface> 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 <encoded-key-map>) m &key)
-    (check-invariant (bi) m))
-  (defmethod empty ((i <encoded-key-map>))
-    (empty (bi)))
-  (defmethod empty-p ((i <encoded-key-map>) map)
-    (empty-p (bi) map))
-  (defmethod lookup ((i <encoded-key-map>) map key)
-    (lookup (bi) map (encode-key i key)))
-  (defmethod insert ((i <encoded-key-map>) map key value)
-    (insert (bi) map (encode-key i key) value))
-  (defmethod drop ((i <encoded-key-map>) map key)
-    (drop (bi) map (encode-key i key)))
-  (defmethod first-key-value ((i <encoded-key-map>) map)
-    (kvf (first-key-value (bi) map)))
-  (defmethod decons ((i <encoded-key-map>) map)
-    (mkvf (decons (bi) map)))
-  (defmethod fold-left ((i <encoded-key-map>) map f seed)
-    (fold-left (bi) map #'(lambda (acc k v) (funcall f acc (decode-key i k) v)) seed))
-  (defmethod fold-right ((i <encoded-key-map>) map f seed)
-    (fold-right (bi) map #'(lambda (k v acc) (funcall f (decode-key i k) v acc)) seed))
-  (defmethod for-each ((i <encoded-key-map>) map f)
-    (for-each (bi) map #'(lambda (k v) (funcall f (decode-key i k) v))))
-  (defmethod join ((i <encoded-key-map>) map1 map2)
-    (join (bi) map1 map2))
-  (defmethod divide ((i <encoded-key-map>) map)
-    (divide (bi) map))
-  (defmethod size ((i <encoded-key-map>) map)
-    (size (bi) map))
-  (defmethod join/list ((i <encoded-key-map>) maplist)
-    (join/list (bi) maplist))
-  (defmethod divide/list ((i <encoded-key-map>) map)
-    (divide/list (bi) map))
-  (defmethod update-key ((i <encoded-key-map>) map key fun)
-    (update-key (bi) map (encode-key i key) fun))
-  (defmethod map/2 ((i <encoded-key-map>) 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 <parametric-encoded-key-map> (<encoded-key-map>)
-  ((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 <parametric-encoded-key-map>) k)
-  (funcall (key-encoder i) k))
-(defmethod decode-key ((i <parametric-encoded-key-map>) k)
-  (funcall (key-decoder i) k))
-
-(defun <encoded-key-map> (&key base-interface key-encoder key-decoder)
-  (fmemo:memoized-funcall
-   'make-instance '<parametric-encoded-key-map>
-   :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 (file)
index 634a9e7..0000000
+++ /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 <fmim>
-    (<map> <tree>
-     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 <fmim> (make-instance '<fmim>))
-
-;;; (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 <fmim>) (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 <fmim>) 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 <fmim>) 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 <fmim>) 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 <fmim>) map)
-  (leftmost i map))
-
-(defmethod fold-left ((i <fmim>) 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 <fmim>) 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 <fmim>) 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 <fmim>) 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 <fmim>) 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 <fmim>) 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 "#<fmim ~S>" (convert <alist> <fmim> object)))
-
-(defmethod print-object ((trie trie-branch) stream)
-  (format stream "#<tb ~S ~S>" (left trie) (right trie)))
-
-(defmethod print-object ((trie trie-skip) stream)
-  (format stream "#<ts ~S ~S ~S>"
-          (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 (file)
index ef80105..0000000
+++ /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 <hash-table>
-    (<map>
-     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 <hash-table> (&key (key eq:<equal>)
-                     (hashmap <number-map>)
-                     (bucketmap (<alist> key)))
-  (assert (typep key 'eq:<hashable>))
-  (assert (typep hashmap '<map>))
-  (assert (typep bucketmap '<map>))
-  (fmemo:memoized-funcall
-   'make-instance '<hash-table>
-   :key key :hashmap hashmap :bucketmap bucketmap))
-
-(defparameter <hash-table> (<hash-table>))
-
-(defmethod check-invariant ((i <hash-table>) 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 <hash-table>))
-  (empty (hashmap-interface i)))
-
-(defmethod empty-p ((i <hash-table>) map)
-  (empty-p (hashmap-interface i) map))
-
-(defmethod lookup ((i <hash-table>) map key)
-  (let ((bucket (lookup (hashmap-interface i) map
-                        (eq:hash (key-interface i) key))))
-    (lookup (bucketmap-interface i) bucket key)))
-
-(defmethod insert ((i <hash-table>) 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 <hash-table>) 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 <hash-table>) 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 <hash-table>) 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 <hash-table>) 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 <hash-table>) 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 <hash-table>) map f)
-  (for-each
-   (hashmap-interface i) map
-   #'(lambda (hash bucket)
-       (declare (ignore hash))
-       (for-each (bucketmap-interface i) bucket f))))
-
-(defmethod divide ((i <hash-table>) 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 <hash-table>) 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 <hash-table>) 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 (file)
index 01c329d..0000000
+++ /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 <map> () ())
-
-#| ;; Already defined in interface for boxes.
-(defgeneric empty (<map>)
-  (:documentation "Return an empty map"))
-
-(defgeneric empty-p (<map> map)
-  (:documentation "Return a boolean indicating whether the map was empty"))
-|#
-
-(defgeneric lookup (<map> 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> 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> 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> 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> 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> 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> 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> map f)
-  (:documentation "For every key value pair in map, (funcall f k v)"))
-
-(defgeneric join (<map> map1 map2)
-  (:documentation "Join two maps, returning a joined map.
-Mappings from MAP1 override those from MAP2."))
-
-(defgeneric divide (<map> 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> map)
-  (:documentation "Size the number of elements in a map"))
-
-(defgeneric join/list (<map> 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> 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> 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 (<map> 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 (<map>2 <map>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 <map>) (i1 <map>) 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 (file)
index d4493d3..0000000
+++ /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
-   #:<tree>
-   #:node #:locate #:join
-   #:left #:right #:leftmost #:rightmost
-
-   ;;; Functional Maps and Containers: classes
-   #:<map> #:<alist>
-   #:<binary-tree> #:<avl-tree>
-   #:<number-map> #:<nm>
-   #:<hash-table>
-   #:<fmim> #:<encoded-key-map>
-   #: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 (file)
index 870b2ba..0000000
+++ /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 <tree> (<type>) ()
-  (:documentation "abstract interface for trees"))
-
-#|
-(defclass <node> (<type>) ()
-  (:documentation "abstract interface for nodes of trees"))
-(defgeneric node-interface (<tree>)
-  (:documentation "returns the interface for nodes of given tree interface"))
-(defgeneric key-interface (<interface>)
-  (:documentation "returns the interface for keys of given tree interface"))
-|#
-
-(defgeneric leftmost (<tree> tree)
-  (:documentation "key, value and foundp from the leftmost node in TREE"))
-
-(defgeneric rightmost (<tree> tree)
-  (:documentation "key, value and foundp from rightmost node in TREE"))
-
-(defgeneric locate (<tree> tree key path)
-  (:documentation "lookup a tree for a key, return a path to the proper node."))
-
-(defgeneric node (<tree> &key)
-  (:documentation "make a node for a tree interface"))
-
-;;; Vanilla Binary Tree
-
-(defclass <binary-tree>
-    (<tree> <map>
-     order:<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 <binary-tree>) (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 <tree>) &rest keys &key &allow-other-keys)
-;;  (apply #'make (node-interface i) keys))
-(defmethod node ((i <binary-tree>) &key left right key value)
-  (make-instance 'binary-tree-node
-                 :key key :value value :left left :right right))
-
-;;(defmethod compare-key ((i <map>) key1 key2)
-;;  (compare (key-interface i) key1 key2))
-
-(defmethod locate ((i <binary-tree>) 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 <binary-tree>) 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 <binary-tree>) 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 <binary-tree>) 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 <binary-tree>) map)
-  "Return key and value with the least key"
-  (leftmost i map))
-
-(defmethod fold-left ((i <binary-tree>) 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 <binary-tree>) 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 <binary-tree>) 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 <binary-tree>) 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 <binary-tree>) 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 <binary-tree>) 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 <binary-tree>) 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 <avl-tree> (<binary-tree>) ())
-
-(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 <avl-tree>) (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 <avl-tree>) &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 <number-map> (<avl-tree> order:<number>) ())
-
-(defparameter <number-map>
-  (fmemo:memoized-funcall 'make-instance '<number-map>))
-
-(defparameter <nm> <number-map>)
-
-(defmethod print-object ((object binary-tree-node) stream)
-  (format stream "#<bt ~S>" (convert <alist> <nm> object)))
-
-(defmethod print-object ((object avl-tree-node) stream)
-  (format stream "#<at ~S>" (convert <alist> <nm> object)))
diff --git a/pure/updatef-expanders.lisp b/pure/updatef-expanders.lisp
deleted file mode 100644 (file)
index 05813fe..0000000
+++ /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 (file)
index 79fbefa..0000000
+++ /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
index 59c60b4..a0f7f39 100644 (file)
@@ -25,7 +25,7 @@
 
 (in-package :stateful)
 
-(def*class binary-heap (heap order:<order-parameter>
+(def*class binary-heap (heap #|order:<order-parameter>|#
                         vector-container-mixin sized-container-mixin)
   ())
 
index a938852..3a28c94 100644 (file)
@@ -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:<order> container)
+(defclass heap (#|order:<order>|# container)
   ())
 
 ;;; containers with nodes
index 767058e..7ea82c7 100644 (file)
@@ -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
index 5997d4a..a031647 100644 (file)
@@ -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")))
index a58f399..6149ce2 100644 (file)
@@ -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 (file)
index cc443d3..0000000
+++ /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 <alist> i map))
-
-(defun from-alist (i map)
-  (check-invariant i (convert i <alist> map)))
-
-(defgeneric interface-test (<interface>))
-
-(defmethod interface-test ((i <map>))
-  ;;; 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 <alist> *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> *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> *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 <alist> i (empty i))))
-  (is (equal-alist *alist-10-latin*
-                   (convert <alist> i (convert i <alist> *alist-10-latin*))))
-  t)
-
-(defmethod interface-test :after ((i <number-map>))
-  (let* ((a1 (make-alist 1000 "~@R"))
-         (a2 (shuffle-list a1))
-         (m1 (convert i <alist> a1))
-         (m2 (convert i <alist> 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 <denm> (<encoded-key-map>
-                      :base-interface <number-map>
-                      :key-encoder #'(lambda (dk) (* dk 2))
-                      :key-decoder #'(lambda (ek) (/ ek 2))))
-
-(deftest test-pure-map-interfaces ()
-  (dolist (i (list <alist> <number-map> <hash-table> <fmim> <denm>))
-    (interface-test i)))
diff --git a/test/updatef.lisp b/test/updatef.lisp
deleted file mode 100644 (file)
index 50322b0..0000000
+++ /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))
-