Commit 55231b97 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Excise the interface and pure directories from fare-utils.

Deactivate some stateful datastructures that depend on interface;
probably nobody uses them, and they ought to be merged into cl-containers or such.
parent 44e5c56a
......@@ -19,22 +19,11 @@
:supersedes-asdf ("fare-utils")))
......@@ -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|#)
((:file "package")
......@@ -39,40 +39,19 @@ and Lisp extensions for memoization and reader interception."
((:file "msv"))) ; Magic Special Variables
;;; Interface-Passing Style generic libraries
(:module "interface"
:depends-on ("base")
((: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")
((: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")
((: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)
;;; -*- 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)
(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)
((not usedp)
(let ((fun function))
(setf usedp t function nil)
(apply fun args)))
(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!))
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;;;; Equality
#+xcvb (module (:depends-on ("interface/interface")))
(in-package :cl)
(defpackage :eq
(:use :cl :interface)
#:<eq> #:<eq-simple> #:<eq-slot>
#:== #:test-function
(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>))
(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>))
;;; -*- 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
(in-package :cl)
(defpackage :interface
(:use :cl :fare-utils)
;;; Classes
;;; Macros
;;; General purpose gfs
;;; Boxes!
#:box #:box-ref #:box-set!
#:<box> #:make-box #:unbox
#:<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)))
(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)))
(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
(declare (ignorable type))
(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))
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;;;; Order
(in-package :cl)
(defpackage :order
(:use :interface :eq :cl :fare-utils)
#:<order> #:<number> #:<string> #:<char>
#:<order-from-lessp> #:<lessp>
#:<order-from-compare> #:<compare>
#:<key> #:<order-parameter>
#:order< #:order<= #:order> #:order>= #:== #:compare
(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)
((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)
,@(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)
((funcall lessp x y) -1)
((funcall lessp y x) 1)
(t 0)))
(macrolet ((builtin (name prefix)
(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)
((,(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)
,@(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)
,@(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>))
((rec (list1 list2 only1 common only2)
((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)))
(let ((r (compare order (car list1) (car list2))))
((= 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)))
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; Trivial functional map implementation: alists.
(in-package :pure)
(defclass <alist>
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)
: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))
(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))
;;; -*- 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>
(defgeneric encode-key (<interface> plain-key))
(defgeneric decode-key (<interface> encoded-key))
;;; This ought to have been possible with some type-directed metaprogramming...
;; 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