--- a/package.lisp Wed Nov 23 11:08:33 2016 +0000
+++ b/package.lisp Thu Nov 24 16:08:20 2016 +0000
@@ -5,12 +5,23 @@
:iterate
:cl-arrows
:temperance
+ :trivia
+ :named-readtables
:scully.quickutils)
(:export
:gensym-ggp
:read-gdl
:load-rules
- :dump-gdl))
+ :dump-gdl
+ :normalize-rules
+ :bare-term
+ :negationp
+ :term-predicate
+ :term<
+ :rule-head
+ :rule-body
+ :rule-predicate
+ :rule-head=))
(defpackage :scully.graphviz
@@ -23,16 +34,6 @@
:trivialib.bdd
:scully.quickutils))
-(defpackage :scully.dag
- (:use
- :cl
- :losh
- :iterate
- :cl-arrows
- :trivia
- :scully.quickutils)
- (:export))
-
(defpackage :scully.zdd
(:use
:cl
@@ -53,6 +54,7 @@
:cl-arrows
:trivia
:named-readtables
+ :scully.gdl
:scully.quickutils)
(:export))
@@ -64,8 +66,11 @@
:cl-arrows
:trivia
:named-readtables
+ :scully.gdl
:scully.quickutils)
- (:export))
+ (:export
+ :integerize-rules
+ :stratify-layer))
(defpackage :scully.logic
(:use
@@ -75,6 +80,7 @@
:cl-arrows
:scully.quickutils))
+
(defpackage :scully.reasoners.prolog
(:use
:cl
--- a/src/gdl.lisp Wed Nov 23 11:08:33 2016 +0000
+++ b/src/gdl.lisp Thu Nov 24 16:08:20 2016 +0000
@@ -1,13 +1,16 @@
(in-package :scully.gdl)
+(in-readtable :fare-quasiquote)
+
+;;;; Utils --------------------------------------------------------------------
(defvar *ggp-gensym-counter* 0)
-
(defun gensym-ggp ()
"Return a unique symbol in the `ggp-rules` package."
(values (intern (mkstr 'rule- (incf *ggp-gensym-counter*))
(find-package :ggp-rules))))
+;;;; Files --------------------------------------------------------------------
(defun read-gdl (filename)
"Read GDL from the given file"
(let ((*package* (find-package :ggp-rules)))
@@ -18,6 +21,12 @@
:while (not (eq form done))
:collect form))))
+(defun dump-gdl (rules &optional stream)
+ (let ((*package* (find-package :ggp-rules)))
+ (format stream "~(~{~S~%~}~)" rules)))
+
+
+;;;; Temperance ---------------------------------------------------------------
(defun load-rules (database rules)
(push-logic-frame-with database
(mapc (lambda (rule)
@@ -27,6 +36,63 @@
(invoke-fact database rule)))
rules)))
-(defun dump-gdl (rules)
- (let ((*package* (find-package :ggp-rules)))
- (format nil "~(~{~S~%~}~)" rules)))
+
+;;;; Normalization ------------------------------------------------------------
+;;; Normalization takes a set of clauses from raw GDL format and turns them into
+;;; friendlier Lispy clauses of the form:
+;;;
+;;; (head . body)
+;;;
+;;; * (<= head .body) becomes (head . body)
+;;; * (fact) becomes ((fact)), i.e. ((fact) . nil)
+;;; * Nullary predicates like terminal have their parens added back.
+;;;
+;;; So something like (<= terminal (true foo) (not bar)) would become:
+;;;
+;;; ((terminal)
+;;; (true foo)
+;;; (not (bar)))
+(defun-match normalize-term (term)
+ (`(ggp-rules::not ,body) `(ggp-rules::not ,(normalize-term body)))
+ (`(,_ ,@_) term)
+ (sym `(,sym)))
+
+(defun-match normalize-rule (rule)
+ (`(ggp-rules::<= ,head ,@body)
+ `(,(normalize-term head) ,@(mapcar #'normalize-term body)))
+ (fact `(,(normalize-term fact))))
+
+(defun normalize-rules (gdl-rules)
+ (mapcar #'normalize-rule gdl-rules))
+
+
+;;;; Rule Data Access ---------------------------------------------------------
+(defun-match bare-term (term)
+ (`(ggp-rules::not ,x) x)
+ (_ term))
+
+(defun-match negationp (term)
+ (`(ggp-rules::not ,_) t)
+ (_ nil))
+
+(defun-ematch term-predicate (term)
+ (`(ggp-rules::not (,predicate ,@_)) predicate)
+ (`(,predicate ,@_) predicate))
+
+(defun term< (a b &optional (predicate #'<))
+ (funcall predicate (bare-term a) (bare-term b)))
+
+
+(defun-ematch rule-head (rule)
+ (`(,head ,@_) head))
+
+(defun-ematch rule-body (rule)
+ (`(,_ ,@body) body))
+
+(defun rule-predicate (rule)
+ (term-predicate (rule-head rule)))
+
+(defun rule-head= (rule term &optional (predicate #'=))
+ (funcall predicate (rule-head rule) term))
+
+
--- a/src/graphviz.lisp Wed Nov 23 11:08:33 2016 +0000
+++ b/src/graphviz.lisp Thu Nov 24 16:08:20 2016 +0000
@@ -51,7 +51,7 @@
;;;; ZDDs ---------------------------------------------------------------------
(defparameter *draw-unique-sinks* nil)
(defparameter *draw-unique-nodes* nil)
-(defparameter *draw-hex-p* #'never)
+(defparameter *draw-hex-p* #'no)
(defparameter *draw-label-fn* #'identity)
@@ -106,7 +106,7 @@
(filename "zdd.png")
(unique-sinks nil)
(unique-nodes t)
- (hexp #'never)
+ (hexp #'no)
(label-fn #'identity))
(let ((*draw-unique-sinks* unique-sinks)
(*draw-unique-nodes* unique-nodes)
--- a/src/logic.lisp Wed Nov 23 11:08:33 2016 +0000
+++ b/src/logic.lisp Thu Nov 24 16:08:20 2016 +0000
@@ -48,7 +48,47 @@
)))
)
-(make-rule-forest *rules*)
+; (make-rule-forest *rules*)
+
+
+; (defun apply-rule-tree (zdd rule-tree head-bound)
+; "Apply the logical rules in `rule-tree` to the sets in `zdd`.
+
+; `zdd` is assumed to contain sets of logical axioms. This function will update
+; each of these sets to add any rule heads derivable from the axioms in the set.
+
+; "
+; (recursively ((zdd zdd)
+; (rule-tree rule-tree))
+; (ematch* (zdd rule-tree)
+; ;; If Z = ∅ there are no sets to cons heads onto, bail.
+; (((sink nil) _) zdd)
+
+; ;; If R = ∅ or {∅} we've bottomed out of the rule tree and there are no
+; ;; heads to cons, we're done.
+; ((_ (sink)) zdd)
+
+; ;; If we've passed the head boundary on the rule tree side then we're done
+; ;; filtering and just need to cons in all the heads.
+; ((_ (guard (node var _ _)
+; (>= var head-bound)))
+; (zdd-join zdd rule-tree))
+
+; ;; If Z = {∅} we might have some heads we need to cons later in the rule
+; ;; tree, so recur down the lo side of it.
+; (((sink t) (node _ _ lo))
+; (recur zdd lo))
+
+; ;; Otherwise we need to filter.
+; (((node var-z hi-z lo-z) (node var-r hi-r lo-r))
+; (cond
+; ((= var-z var-r) (zdd-node var-z
+; (recur hi-z hi-r)
+; (recur lo-z lo-r)))
+; ((< var-z var-r) (zdd-node var-z
+; (recur hi-z rule-tree)
+; (recur lo-z rule-tree)))
+; ((> var-z var-r) (recur zdd lo-r)))))))
--- a/src/rule-trees.lisp Wed Nov 23 11:08:33 2016 +0000
+++ b/src/rule-trees.lisp Thu Nov 24 16:08:20 2016 +0000
@@ -8,33 +8,34 @@
bottom)
-(defun rule-head (rule)
- (first rule))
-
-(defun rule-body (rule)
- (rest rule))
-
-(defun-match bare-term (term)
- (`(ggp-rules::not ,contents) contents)
- (_ term))
+(defun find-smallest-body-term (bodies)
+ "Find the smallest body term in `bodies`.
-(defun term< (a b)
- (< (bare-term a) (bare-term b)))
-
+ Each body in `bodies` must already be sorted. No body should be empty.
-(defun find-smallest-body-term (bodies)
- (-<> bodies
- (mapcar #'first <>)
- (sort <> #'term<)
- (first <>)))
+ "
+ (first (extremum bodies #'term< :key #'first)))
(defun partition (bodies)
- (let ((element (bare-term (find-smallest-body-term bodies))))
+ "Partition `bodies` into exclusive groups based on the smallest element.
+
+ `bodies` must each be already sorted.
+
+ Four values will be returned:
+
+ 1. The smallest element in any body.
+ 2. All bodies that DISALLOW that element.
+ 3. All bodies that REQUIRE that element.
+ 4. All bodies that DON'T CARE about that element.
+
+ "
+ (let* ((element (bare-term (find-smallest-body-term bodies)))
+ (negation `(ggp-rules::not ,element)))
(labels
- ((requires (body)
+ ((disallows (body)
+ (equal (first body) negation))
+ (requires (body)
(equal (first body) element))
- (disallows (body)
- (equal (first body) `(ggp-rules::not ,element)))
(ignores (body)
(not (or (requires body)
(disallows body)))))
@@ -50,13 +51,20 @@
(ensure-gethash (list term hi lo) cache
(node term hi lo))))
+(defun sort-body (body)
+ (sort body #'term<))
+
(defun make-rule-tree (rules)
+ "Make a rule tree for `rules`.
+
+ All rules must have the same head (this is not checked). Bodies do not need
+ to be sorted.
+
+ "
(let* ((head (rule-head (first rules)))
(top (top head))
(cache (make-hash-table :test #'equal)))
- (recursively ((bodies (-<> rules
- (mapcar #'rule-body <>)
- (mapcar (rcurry #'sort #'term<) <>))))
+ (recursively ((bodies (mapcar (compose #'sort-body #'rule-body) rules)))
(cond
((null bodies) bottom)
((some #'null bodies) top)
--- a/src/terms.lisp Wed Nov 23 11:08:33 2016 +0000
+++ b/src/terms.lisp Thu Nov 24 16:08:20 2016 +0000
@@ -1,7 +1,6 @@
(in-package :scully.terms)
(in-readtable :fare-quasiquote)
-
;;;; Overview -----------------------------------------------------------------
;;; We start with a set of grounded rules like: ((next bar) x y (true foo)).
;;;
@@ -24,65 +23,59 @@
;;; relies on the negation of a rule Y, then Y must come before X.
-;;;; Utils --------------------------------------------------------------------
-(defun-match bare-term (term)
- (`(ggp-rules::not ,x) x)
- (x x))
-
-(defun-match negationp (term)
- (`(ggp-rules::not ,_) t)
- (_ nil))
-
-
-(defun-match normalize-term (term)
- (`(ggp-rules::not ,body) `(ggp-rules::not ,(normalize-term body)))
- (`(,_) term)
- (`(,head ,@body) (cons head (mapcar #'normalize-term body)))
- (sym `(,sym)))
-
-(defun-match normalize-term (term)
- (`(ggp-rules::not ,body) `(ggp-rules::not ,(normalize-term body)))
- (`(,constant) constant)
- (`(,head ,@body) (cons head (mapcar #'normalize-term body)))
- (`,constant constant))
-
-(defun-match normalize-rule (rule)
- (`(ggp-rules::<= ,head ,@body) `(,(normalize-term head)
- ,@(mapcar #'normalize-term body)))
- (fact `(,(normalize-term fact))))
-
-(defun normalize-rules (rules)
- (mapcar #'normalize-rule rules))
-
-
;;;; Dependency Graph ---------------------------------------------------------
(defun build-dependency-graph (rules &key includep)
+ "Build a dependency graph of the given `rules`.
+
+ All rule heads will be included as vertices.
+
+ A head will have a dependency on each of its body terms for which
+ `(funcall includep term)` returns `t`. If `includep` is `nil` all
+ dependencies will be included.
+
+ Only body terms upon which there is a dependency will be included in the graph
+ -- if a body term is discarded by `includep` there will be no vertex for it.
+
+ "
(let ((graph (digraph:make-digraph :test #'equal)))
(labels
((mark-dependency (head dep)
(digraph:insert-vertex graph dep)
(digraph:insert-edge graph head dep))
(mark-dependencies (head body)
+ (digraph:insert-vertex graph head)
(iterate (for b :in body)
(when (or (null includep)
(funcall includep b))
(mark-dependency head (bare-term b))))))
- (iterate (for rule :in rules)
- (for (head . body) = (ensure-list rule))
- (digraph:insert-vertex graph head)
+ (iterate (for (head . body) :in rules)
(mark-dependencies head body)))
graph))
;;;; Layer Partitioning -------------------------------------------------------
+;;; We want to partition the terms of the rules into layers. The result will be
+;;; a hash table containing two types of entries, for convenience:
+;;;
+;;; term -> layer keyword
+;;; layer keyword -> list of terms in the layer
+
(defun mark (layers layer term)
(setf (gethash term layers) layer)
(pushnew term (gethash layer layers) :test #'equal))
(defun extract-simple (predicates layer layers terms)
+ "Extract simple terms for a given `layer` from `terms`.
+
+ Extract the terms with predicates in `predicates` and mark them appropriately
+ in the `layers` hash table.
+
+ Returns a list of remaining terms.
+
+ "
(iterate (for term :in terms)
- (if (member (car (ensure-list term)) predicates)
+ (if (member (term-predicate term) predicates)
(mark layers layer term)
(collect term))))
@@ -91,6 +84,8 @@
(let ((terms (extract-simple '(ggp-rules::true
ggp-rules::role)
:base layers terms)))
+ ;; In addition to the simple things, we need to make sure we've got
+ ;; a corresponding `(true *)` term for any `(init *)` term.
(iterate (for term :in terms)
(match term
(`(ggp-rules::init ,contents)
@@ -104,12 +99,14 @@
(defun extract-possible% (layers dependencies terms)
(labels ((find-dependencies (term)
+ "Return the layers of each of `term`s dependencies."
(mapcar (rcurry #'gethash layers)
(digraph:successors dependencies term)))
(find-eligible (terms)
+ "Find terms that depend only on things in `:base`/`:possible`."
(iterate (for term :in terms)
- (for deps = (find-dependencies term))
- (for unmet = (set-difference deps '(:base :possible)))
+ (for unmet = (set-difference (find-dependencies term)
+ '(:base :possible)))
(when (null unmet)
(collect term)))))
(iterate
@@ -121,6 +118,11 @@
(finally (return remaining)))))
(defun extract-possible (layers dependencies terms)
+ ;; At this point we've got the :base and :does layers finished. We then
+ ;; extract the simple things for the :possible layer.
+ ;;
+ ;; Once we've done this, rules that depend on ONLY things in the
+ ;; :base/:possible layers can also be extracted.
(-<> terms
(extract-simple '(ggp-rules::legal
ggp-rules::goal
@@ -130,11 +132,14 @@
(defun extract-early-happens (layers terms)
+ ;; We need to extract these early because we don't want them to get included
+ ;; in the `:possible` layer if they don't depend on anything.
(extract-simple '(ggp-rules::sees
ggp-rules::next)
:happens layers terms))
(defun extract-final-happens (layers terms)
+ ;; Everything left at the end must be in the `:happens` layer.
(mapcar (curry #'mark layers :happens) terms)
nil)
@@ -156,10 +161,15 @@
;;;; Intra-Layer Ordering -----------------------------------------------------
(defun sort-layer (negation-dependencies terms)
+ ;; We sort a layer by creating a digraph of only the terms in that layer,
+ ;; adding all negation dependencies between them, and topologically sorting.
(let ((layer (digraph:make-digraph :test #'equal)))
(flet ((add-dependencies (term)
(iterate
(for dep :in (digraph:successors negation-dependencies term))
+ ;; We only care about dependencies where both the head and body
+ ;; are in THIS layer -- we don't care about a dependency on an
+ ;; earlier layer.
(when (digraph:contains-vertex-p layer dep)
(digraph:insert-edge layer term dep)))))
(mapc (curry #'digraph:insert-vertex layer) terms)
@@ -167,7 +177,13 @@
;; todo: fix the roots/cycles issue in cl-digraph
(digraph:topological-sort layer)))
-(defun order-predicates (rules)
+(defun order-terms (rules)
+ "Find a linear ordering of all terms in `rules`.
+
+ Returns two values: a list of the terms, in order, and the final layer hash
+ table.
+
+ "
(let* ((dependencies (build-dependency-graph rules))
(negation-dependencies (build-dependency-graph rules
:includep #'negationp))
@@ -176,25 +192,50 @@
(does (gethash :does layers))
(possible (sort-layer negation-dependencies (gethash :possible layers)))
(happens (sort-layer negation-dependencies (gethash :happens layers))))
- ; (pr :base)
- ; (pr base)
- ; (terpri)
- ; (pr :does)
- ; (pr does)
- ; (terpri)
- ; (pr :possible)
- ; (pr possible)
- ; (terpri)
- ; (pr :happens)
- ; (pr happens)
- ; (terpri)
+ ;; base < possible < does < happens
(values (append base possible does happens)
layers))))
+;;;; Integerization -----------------------------------------------------------
+(defun integerize-term (term->number term)
+ (match term
+ (`(ggp-rules::not ,body)
+ `(ggp-rules::not ,(gethash body term->number)))
+ (_ (gethash term term->number))))
+
+(defun integerize-rule (term->number rule)
+ (mapcar (curry #'integerize-term term->number) rule))
+
+(defun integerize-rules (rules)
+ "Integerize `rules`.
+
+ `rules` should be a (normalized) list of rules.
+
+ A list of 3 hash tables will be returned:
+
+ (term->number number->term rule-layers)
+
+ "
+ (let ((term->number (make-hash-table :test #'equal))
+ (number->term (make-hash-table))
+ (rule-layers (make-hash-table)))
+ (multiple-value-bind (terms layers)
+ (order-terms rules)
+ (iterate (for i :from 0)
+ (for term :in terms)
+ (setf (gethash i number->term) term
+ (gethash term term->number) i))
+ (iterate (for rule :in rules)
+ (for layer = (gethash (rule-head rule) layers))
+ (push (integerize-rule term->number rule)
+ (gethash layer rule-layers))))
+ (list term->number number->term rule-layers)))
+
+
;;;; Stratification -----------------------------------------------------------
(defun build-single-layer-dependency-graph (rules)
- (let* ((layer-heads (remove-duplicates (mapcar #'first rules))))
+ (let* ((layer-heads (remove-duplicates (mapcar #'rule-head rules))))
(build-dependency-graph
rules
:includep (lambda (b)
@@ -202,6 +243,7 @@
(member (bare-term b) layer-heads))))))
(defun stratify-layer (rules)
+ "Stratify a single layer of rules into a list of strata."
(iterate
(with dependencies = (build-single-layer-dependency-graph rules))
; (initially (digraph.dot:draw dependencies))
@@ -212,61 +254,11 @@
(when (null next-heads)
(error "Cycle in negations detected!"))
- (for stratum = (remove-if-not (lambda (rule)
- (member (first rule) next-heads))
- remaining))
+ (for stratum = (remove-if-not (rcurry #'member next-heads)
+ remaining
+ :key #'rule-head))
(collect stratum)
- ;; TODO: do we want the full rules or just the heads here?
- ; (collect next-heads)
(setf remaining (set-difference remaining stratum))
(mapc (curry #'digraph:remove-vertex dependencies) next-heads)))
-
-;;;; API ----------------------------------------------------------------------
-(defun integerize-term (term->number term)
- (match term
- (`(ggp-rules::not ,body)
- `(ggp-rules::not ,(gethash body term->number)))
- (_ (gethash term term->number))))
-
-(defun integerize-rule (term->number rule)
- (mapcar (curry #'integerize-term term->number) rule))
-
-(defun integerize-rules (rules)
- (let ((rules (normalize-rules rules))
- (term->number (make-hash-table :test #'equal))
- (number->term (make-hash-table))
- (rule-layers (make-hash-table)))
- (multiple-value-bind (terms layers)
- (order-predicates rules)
- (iterate (for i :from 0)
- (for term :in terms)
- (setf (gethash i number->term) term
- (gethash term term->number) i))
- (iterate (for rule :in rules)
- (for head = (first rule))
- (for layer = (gethash head layers))
- (push (integerize-rule term->number rule)
- (gethash layer rule-layers))))
- (list term->number number->term rule-layers)))
-
-
-;;;; Scratch ------------------------------------------------------------------
-
-; (-<> '(
-; (ggp-rules::<= a (ggp-rules::true foo))
-; (ggp-rules::<= b (ggp-rules::true foo) (ggp-rules::true baz))
-; (ggp-rules::<= c (ggp-rules::true dogs) (ggp-rules::not a))
-; (ggp-rules::<= x (ggp-rules::not a) b)
-; (ggp-rules::<= y (ggp-rules::not a) (ggp-rules::not x))
-; (ggp-rules::<= y (ggp-rules::not c))
-; )
-; (integerize-rules <>)
-; (nth 2 <>)
-; (gethash :possible <>)
-; (stratify-layer <>)
-; (mapc (lambda (s) (format t "Stratum:~%~{ ~S~%~}" s)) <>)
-; ; (never <>)
-; ; (map nil #'print-hash-table <>)
-; )
--- a/src/zdd.lisp Wed Nov 23 11:08:33 2016 +0000
+++ b/src/zdd.lisp Thu Nov 24 16:08:20 2016 +0000
@@ -1,30 +1,6 @@
(in-package :scully.zdd)
-;;;; Utils --------------------------------------------------------------------
-(defun gcprint (thing &rest args)
- (let ((*print-circle* t))
- (apply #'print
- (prog1 thing
- (tg:gc :full t :verbose t))
- args)))
-
-(defun never (val)
- (declare (ignore val))
- (values))
-
-(defun print-through (function-or-object val)
- (if (functionp function-or-object)
- (pr (funcall function-or-object val))
- (pr function-or-object))
- val)
-
-(defun mapprint-through (function val)
- "Calling `function` on each item in `val` and print the result, return `val`."
- (mapc #'pr (funcall function val))
- val)
-
-
;;;; Bullshit -----------------------------------------------------------------
;;; The BDD lib defines a pattern for `node` but not for `leaf`. It's awkward
;;; to have two different syntaxes. But if we define a pattern for `leaf` and
@@ -337,58 +313,3 @@
"
(zdd-match% zdd (sort set #'<) lower-bound upper-bound))
-
-(defun apply-rule-tree (zdd rule-tree head-bound)
- "Apply the logical rules in `rule-tree` to the sets in `zdd`.
-
- `zdd` is assumed to contain sets of logical axioms. This function will update
- each of these sets to add any rule heads derivable from the axioms in the set.
-
- "
- (recursively ((zdd zdd)
- (rule-tree rule-tree))
- (ematch* (zdd rule-tree)
- ;; If Z = ∅ there are no sets to cons heads onto, bail.
- (((sink nil) _) zdd)
-
- ;; If R = ∅ or {∅} we've bottomed out of the rule tree and there are no
- ;; heads to cons, we're done.
- ((_ (sink)) zdd)
-
- ;; If we've passed the head boundary on the rule tree side then we're done
- ;; filtering and just need to cons in all the heads.
- ((_ (guard (node var _ _)
- (>= var head-bound)))
- (zdd-join zdd rule-tree))
-
- ;; If Z = {∅} we might have some heads we need to cons later in the rule
- ;; tree, so recur down the lo side of it.
- (((sink t) (node _ _ lo))
- (recur zdd lo))
-
- ;; Otherwise we need to filter.
- (((node var-z hi-z lo-z) (node var-r hi-r lo-r))
- (cond
- ((= var-z var-r) (zdd-node var-z
- (recur hi-z hi-r)
- (recur lo-z lo-r)))
- ((< var-z var-r) (zdd-node var-z
- (recur hi-z rule-tree)
- (recur lo-z rule-tree)))
- ((> var-z var-r) (recur zdd lo-r)))))))
-
-
-;;;; Scratch ------------------------------------------------------------------
-
-; (destructuring-bind (term->number number->term layers)
-; (scully.terms::integerize-rules *rules*)
-; ; (print-hash-table layers)
-; (with-zdd
-; (-<> (gethash :happens layers)
-; ; (mapprint-through #'pr <>)
-; (make-rule-tree <>)
-; ; (draw <> :unique-sinks nil :unique-nodes t
-; ; :label-fn (lambda (n)
-; ; (aesthetic-string (gethash n number->term))))
-; ; (print-through #'zdd-size <>)
-; (never <>))))
--- a/vendor/make-quickutils.lisp Wed Nov 23 11:08:33 2016 +0000
+++ b/vendor/make-quickutils.lisp Thu Nov 24 16:08:20 2016 +0000
@@ -10,6 +10,7 @@
:ensure-boolean
:ensure-gethash
:ensure-list
+ :extremum
:flatten-once
:hash-table-keys
:hash-table-values
@@ -21,6 +22,7 @@
:with-gensyms
:with-output-to-file
:write-string-into-file
+ :yes-no
)
:package "SCULLY.QUICKUTILS")
--- a/vendor/quickutils.lisp Wed Nov 23 11:08:33 2016 +0000
+++ b/vendor/quickutils.lisp Thu Nov 24 16:08:20 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :FLATTEN-ONCE :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-PRODUCT :MKSTR :ONCE-ONLY :RCURRY :SET-EQUAL :WITH-GENSYMS :WITH-OUTPUT-TO-FILE :WRITE-STRING-INTO-FILE) :ensure-package T :package "SCULLY.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM :FLATTEN-ONCE :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-PRODUCT :MKSTR :ONCE-ONLY :RCURRY :SET-EQUAL :WITH-GENSYMS :WITH-OUTPUT-TO-FILE :WRITE-STRING-INTO-FILE :YES-NO) :ensure-package T :package "SCULLY.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "SCULLY.QUICKUTILS")
@@ -16,14 +16,14 @@
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
:COMPOSE :COPY-HASH-TABLE :CURRY
:ENSURE-BOOLEAN :ENSURE-GETHASH
- :ENSURE-LIST :FLATTEN-ONCE
+ :ENSURE-LIST :EXTREMUM :FLATTEN-ONCE
:MAPHASH-KEYS :HASH-TABLE-KEYS
:MAPHASH-VALUES :HASH-TABLE-VALUES
:MAPPEND :MAP-PRODUCT :MKSTR
:ONCE-ONLY :RCURRY :SET-EQUAL
:STRING-DESIGNATOR :WITH-GENSYMS
:WITH-OPEN-FILE* :WITH-OUTPUT-TO-FILE
- :WRITE-STRING-INTO-FILE))))
+ :WRITE-STRING-INTO-FILE :YES-NO))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-gensym-list (length &optional (x "G"))
"Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
@@ -142,6 +142,50 @@
(list list)))
+ (defun extremum (sequence predicate &key key (start 0) end)
+ "Returns the element of `sequence` that would appear first if the subsequence
+bounded by `start` and `end` was sorted using `predicate` and `key`.
+
+`extremum` determines the relationship between two elements of `sequence` by using
+the `predicate` function. `predicate` should return true if and only if the first
+argument is strictly less than the second one (in some appropriate sense). Two
+arguments `x` and `y` are considered to be equal if `(funcall predicate x y)`
+and `(funcall predicate y x)` are both false.
+
+The arguments to the `predicate` function are computed from elements of `sequence`
+using the `key` function, if supplied. If `key` is not supplied or is `nil`, the
+sequence element itself is used.
+
+If `sequence` is empty, `nil` is returned."
+ (let* ((pred-fun (ensure-function predicate))
+ (key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity))
+ (ensure-function key)))
+ (real-end (or end (length sequence))))
+ (cond ((> real-end start)
+ (if key-fun
+ (flet ((reduce-keys (a b)
+ (if (funcall pred-fun
+ (funcall key-fun a)
+ (funcall key-fun b))
+ a
+ b)))
+ (declare (dynamic-extent #'reduce-keys))
+ (reduce #'reduce-keys sequence :start start :end real-end))
+ (flet ((reduce-elts (a b)
+ (if (funcall pred-fun a b)
+ a
+ b)))
+ (declare (dynamic-extent #'reduce-elts))
+ (reduce #'reduce-elts sequence :start start :end real-end))))
+ ((= real-end start)
+ nil)
+ (t
+ (error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
+ (length sequence)
+ :start start
+ :end end)))))
+
+
(defun flatten-once (list)
"Flatten `list` once."
(loop :for x :in list
@@ -377,10 +421,19 @@
:external-format external-format)
(write-sequence string file-stream)))
+
+ (defun yes (&rest ignored)
+ (declare (ignore ignored))
+ t)
+
+ (defun no (&rest ignored)
+ (declare (ignore ignored))
+ nil)
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(compose copy-hash-table curry ensure-boolean ensure-gethash
- ensure-list flatten-once hash-table-keys hash-table-values
+ ensure-list extremum flatten-once hash-table-keys hash-table-values
map-product mkstr once-only rcurry set-equal with-gensyms
- with-unique-names with-output-to-file write-string-into-file)))
+ with-unique-names with-output-to-file write-string-into-file yes no)))
;;;; END OF quickutils.lisp ;;;;