# HG changeset patch # User Steve Losh # Date 1480003700 0 # Node ID 3cfc630a3e6e3b52b5d5bfab9aa9ba76371a35c7 # Parent e2fbd297f5c7861c978aec2c9f588749f79c928b Lots of cleanup, docstrings, comments diff -r e2fbd297f5c7 -r 3cfc630a3e6e package.lisp --- 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 diff -r e2fbd297f5c7 -r 3cfc630a3e6e src/gdl.lisp --- 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)) + + diff -r e2fbd297f5c7 -r 3cfc630a3e6e src/graphviz.lisp --- 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) diff -r e2fbd297f5c7 -r 3cfc630a3e6e src/logic.lisp --- 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))))))) diff -r e2fbd297f5c7 -r 3cfc630a3e6e src/rule-trees.lisp --- 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) diff -r e2fbd297f5c7 -r 3cfc630a3e6e src/terms.lisp --- 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 <>) -; ) diff -r e2fbd297f5c7 -r 3cfc630a3e6e src/zdd.lisp --- 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 <>)))) diff -r e2fbd297f5c7 -r 3cfc630a3e6e vendor/make-quickutils.lisp --- 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") diff -r e2fbd297f5c7 -r 3cfc630a3e6e vendor/quickutils.lisp --- 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 ;;;;