"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")))
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")
: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)
+++ /dev/null
-;;; -*- 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!))
+++ /dev/null
-;;; -*- 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)
+++ /dev/null
-;;; -*- 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))
+++ /dev/null
-;;; -*- 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)))
+++ /dev/null
-;;; -*- 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))
+++ /dev/null
-;;; -*- 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))
+++ /dev/null
-;;; -*- 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
-|#
+++ /dev/null
-;;; -*- 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))
+++ /dev/null
-;;; -*- 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)))
+++ /dev/null
-;;; -*- 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
- ))
+++ /dev/null
-;;; -*- 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)))
+++ /dev/null
-(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))))
+++ /dev/null
-;;; 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
(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)
())
#+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)
;;;; Generic container mixins
;;; Heaps
-(defclass heap (order:<order> container)
+(defclass heap (#|order:<order>|# container)
())
;;; containers with nodes
#+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
(module
(:depends-on
("package"
- "strings"
- "functional-map"
- "updatef")
+ "strings")
:build-depends-on ((:build "/fare-utils") (:asdf "hu.dwim.stefil"))
:supersedes-asdf ("fare-utils-test")))
: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"))))
+++ /dev/null
-#+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)))
+++ /dev/null
-#+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))
-
common-lisp.net / users/frideau/fare-utils.git / commitdiff
