# HG changeset patch # User Steve Losh # Date 1472053400 0 # Node ID 45622a0c4e96eb774ed302a0642201ee8b1dcf08 # Parent 9da17791e5dad0f84635db3b7b91def31423f09a Set up the basic framework for the benchmark diff -r 9da17791e5da -r 45622a0c4e96 contrib/gdl-benchmark/run-temperance.ros --- a/contrib/gdl-benchmark/run-temperance.ros Wed Aug 24 14:45:17 2016 +0000 +++ b/contrib/gdl-benchmark/run-temperance.ros Wed Aug 24 15:43:20 2016 +0000 @@ -15,6 +15,7 @@ (defpackage #:temperance.contrib.gdl-benchmark (:use #:cl + #:cl-arrows #:losh #:temperance.quickutils #:temperance)) @@ -23,11 +24,133 @@ ;;;; Benchmarking ------------------------------------------------------------- +(defun read-file (path) + (with-open-file (file path :direction :input) + (loop :for form = (read file nil 'eof) + :until (eq form 'eof) + :collect form))) + +(defun read-gdl (path) + (read-file path)) + +(defun read-trace (path) + ;; (moves m1 m2 ...) -> (m1 m2 ...) + (mapcar #'rest (read-file path))) + + +(defun load-gdl-preamble () + (push-logic-frame-with t + (rule t (not ?x) (call ?x) ! fail) + (fact t (not ?x)) + + (rule t (or ?x ?y) (call ?x)) + (rule t (or ?x ?y) (call ?y)) + + (rule t (distinct ?x ?x) ! fail) + (fact t (distinct ?x ?y)))) + +(defun build-clause (clause) + (if (and (consp clause) + (eq (first clause) '<=)) + (destructuring-bind (arrow head . body) + clause + (declare (ignore arrow)) + (apply #'invoke-rule t head body)) + (invoke-fact t clause))) + +(defun build-database (gdl) + (reset-standard-database) + (load-gdl-preamble) + (push-logic-frame-with t + (mapc #'build-clause gdl))) + + +(defun normalize-state (state) + ;; TODO: should this be excluded from the benchmark? + (remove-duplicates state :test 'equal)) + +(defun initial-state () + (normalize-state + (query-map t (lambda (r) (getf r '?what)) + (init ?what)))) + +(defun terminalp () + (prove t terminal)) + +(defun roles () + (query-map t (lambda (r) (getf r '?role)) + (role ?role))) + +(defun goal-values () + (remove-duplicates (query-all t (goal ?role ?goal)) + :test 'equal)) + + +(defun next-state () + (normalize-state + (query-map t (lambda (r) (getf r '?what)) + (next ?what)))) + + +(defun apply-state (state) + (push-logic-frame-with t + (loop :for fact :in state + :do (invoke-fact t `(true ,fact))))) + +(defun apply-moves (moves) + (push-logic-frame-with t + (loop :for (role . action) :in moves + :do (invoke-fact t `(does ,role ,action))))) + +(defun clear-state () + (pop-logic-frame t)) + +(defun clear-moves () + (pop-logic-frame t)) + + +(defun move= (move1 move2) + (equal move1 move2)) + +(defun move-role= (move1 move2) + (eq (car move1) (car move2))) + + +(defun legal-moves () + (let* ((individual-moves + (remove-duplicates + (query-map t (lambda (move) + (cons (getf move '?role) + (getf move '?action))) + (legal ?role ?action)) + :test #'move=)) + (player-moves + (equivalence-classes #'move-role= individual-moves)) + (joint-moves + (apply #'map-product #'list player-moves))) + joint-moves)) + + +(defun build-traces (traces) + (loop + :with roles = (roles) ;; ugly to depend on the logic here but whatever idc + :for trace :in traces + :collect (loop :for move :in trace + :for role :in roles + :collect (cons role move)))) + + (defun run (modes limit gdl-file trace-file) - (print modes) - (print limit) - (print gdl-file) - (print trace-file)) + (declare (ignore modes limit)) + (build-database (read-gdl gdl-file)) + (build-traces ()) + (print (roles)) + (print (build-traces (read-trace trace-file))) + (print (initial-state)) + (print (terminalp)) + (apply-state (initial-state)) + (print (legal-moves)) + ) ;;;; CLI ---------------------------------------------------------------------- @@ -72,36 +195,50 @@ (defun usage () (let ((prog (program-name))) (opts:describe - :prefix (format nil "~A - benchmark Temperance for GDL reasoning" prog) + :prefix (format nil "~A - Benchmark Temperance for GDL reasoning." prog) :suffix *required-options* :usage-of prog :args "SEARCH-MODES LIMIT GDL-FILE TRACE-FILE"))) (defun die (message &rest args) + (terpri) (apply #'format *error-output* message args) #+sbcl (sb-ext:exit :code 1) #-sbcl (quit)) -(defun main (&rest argv) - (block nil - (multiple-value-bind (options arguments) - (opts:get-opts argv) +(defun parse-modes (modes) + (-<> modes + (split-sequence:split-sequence #\space <> + :remove-empty-subseqs t) + (mapcar #'string-upcase <>) + (mapcar #'ensure-keyword <>))) - (setf *verbose* (getf options :verbose)) - (when (or (getf options :help) - (not (= 4 (length arguments)))) - (usage) - (return)) +(defun parse-limit (limit) + (handler-case + (parse-integer limit) + (parse-error (e) + (declare (ignore e)) + (die "ERROR: limit '~A' is not an integer.~%" limit)))) + - (destructuring-bind (modes limit gdl-file trace-file) arguments - (run (split-sequence:split-sequence #\space modes - :remove-empty-subseqs t) - (handler-case - (parse-integer limit) - (parse-error (e) - (declare (ignore e)) - (die "ERROR: limit '~A' is not an integer~%" limit))) - gdl-file - trace-file))))) +(defun main (&rest argv) + (multiple-value-bind (options arguments) + (opts:get-opts argv) + + (setf *verbose* (getf options :verbose)) + + (when (getf options :help) + (usage) + (return-from main)) + (when (not (= 4 (length arguments))) + (usage) + (die "ERROR: All arguments are required.~%")) + + (destructuring-bind (modes limit gdl-file trace-file) arguments + (run (parse-modes modes) + (parse-limit limit) + gdl-file + trace-file)))) + diff -r 9da17791e5da -r 45622a0c4e96 vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Wed Aug 24 14:45:17 2016 +0000 +++ b/vendor/make-quickutils.lisp Wed Aug 24 15:43:20 2016 +0000 @@ -2,26 +2,32 @@ (qtlc:save-utils-as "quickutils.lisp" - :utilities '(:define-constant - :set-equal + :utilities '( + + :alist-plist + :alist-to-hash-table :curry - :rcurry - :switch + :define-constant :ensure-boolean - :while - :until + :ensure-gethash + :ensure-keyword + :equivalence-classes + :map-product + :map-tree + :once-only + :rcurry + :read-file-into-string + :set-equal + :switch :tree-member-p - :with-gensyms - :once-only - :zip - :alist-to-hash-table - :map-tree + :until :weave :when-let - :alist-plist - :equivalence-classes - :ensure-gethash - :map-product) + :while + :with-gensyms + :zip + + ) :package "TEMPERANCE.QUICKUTILS") (quit) diff -r 9da17791e5da -r 45622a0c4e96 vendor/quickutils.lisp --- a/vendor/quickutils.lisp Wed Aug 24 14:45:17 2016 +0000 +++ b/vendor/quickutils.lisp Wed Aug 24 15:43:20 2016 +0000 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :RCURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :WITH-GENSYMS :ONCE-ONLY :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE :WEAVE :WHEN-LET :ALIST-PLIST :EQUIVALENCE-CLASSES :ENSURE-GETHASH :MAP-PRODUCT) :ensure-package T :package "TEMPERANCE.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:ALIST-PLIST :ALIST-TO-HASH-TABLE :CURRY :DEFINE-CONSTANT :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-KEYWORD :EQUIVALENCE-CLASSES :MAP-PRODUCT :MAP-TREE :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :SET-EQUAL :SWITCH :TREE-MEMBER-P :UNTIL :WEAVE :WHEN-LET :WHILE :WITH-GENSYMS :ZIP) :ensure-package T :package "TEMPERANCE.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "TEMPERANCE.QUICKUTILS") @@ -13,65 +13,52 @@ (in-package "TEMPERANCE.QUICKUTILS") (when (boundp '*utilities*) - (setf *utilities* (union *utilities* '(:DEFINE-CONSTANT :SET-EQUAL - :MAKE-GENSYM-LIST :ENSURE-FUNCTION - :CURRY :RCURRY :STRING-DESIGNATOR - :WITH-GENSYMS :EXTRACT-FUNCTION-NAME - :SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE - :TREE-MEMBER-P :ONCE-ONLY :TRANSPOSE - :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE - :WEAVE :WHEN-LET :SAFE-ENDP - :ALIST-PLIST :EQUIVALENCE-CLASSES - :ENSURE-GETHASH :MAPPEND :MAP-PRODUCT)))) + (setf *utilities* (union *utilities* '(:SAFE-ENDP :ALIST-PLIST + :ALIST-TO-HASH-TABLE :MAKE-GENSYM-LIST + :ENSURE-FUNCTION :CURRY + :DEFINE-CONSTANT :ENSURE-BOOLEAN + :ENSURE-GETHASH :ENSURE-KEYWORD + :EQUIVALENCE-CLASSES :MAPPEND + :MAP-PRODUCT :MAP-TREE :ONCE-ONLY + :RCURRY :WITH-OPEN-FILE* + :WITH-INPUT-FROM-FILE + :READ-FILE-INTO-STRING :SET-EQUAL + :STRING-DESIGNATOR :WITH-GENSYMS + :EXTRACT-FUNCTION-NAME :SWITCH + :TREE-MEMBER-P :UNTIL :WEAVE :WHEN-LET + :WHILE :TRANSPOSE :ZIP)))) - (defun %reevaluate-constant (name value test) - (if (not (boundp name)) - value - (let ((old (symbol-value name)) - (new value)) - (if (not (constantp name)) - (prog1 new - (cerror "Try to redefine the variable as a constant." - "~@<~S is an already bound non-constant variable ~ - whose value is ~S.~:@>" name old)) - (if (funcall test old new) - old - (restart-case - (error "~@<~S is an already defined constant whose value ~ - ~S is not equal to the provided initial value ~S ~ - under ~S.~:@>" name old new test) - (ignore () - :report "Retain the current value." - old) - (continue () - :report "Try to redefine the constant." - new))))))) - - (defmacro define-constant (name initial-value &key (test ''eql) documentation) - "Ensures that the global variable named by `name` is a constant with a value -that is equal under `test` to the result of evaluating `initial-value`. `test` is a -function designator that defaults to `eql`. If `documentation` is given, it -becomes the documentation string of the constant. - -Signals an error if `name` is already a bound non-constant variable. - -Signals an error if `name` is already a constant variable whose value is not -equal under `test` to result of evaluating `initial-value`." - `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test) - ,@(when documentation `(,documentation)))) + (declaim (inline safe-endp)) + (defun safe-endp (x) + (declare (optimize safety)) + (endp x)) - (defun set-equal (list1 list2 &key (test #'eql) (key nil keyp)) - "Returns true if every element of `list1` matches some element of `list2` and -every element of `list2` matches some element of `list1`. Otherwise returns false." - (let ((keylist1 (if keyp (mapcar key list1) list1)) - (keylist2 (if keyp (mapcar key list2) list2))) - (and (dolist (elt keylist1 t) - (or (member elt keylist2 :test test) - (return nil))) - (dolist (elt keylist2 t) - (or (member elt keylist1 :test test) - (return nil)))))) + (defun alist-plist (alist) + "Returns a property list containing the same keys and values as the +association list ALIST in the same order." + (let (plist) + (dolist (pair alist) + (push (car pair) plist) + (push (cdr pair) plist)) + (nreverse plist))) + + (defun plist-alist (plist) + "Returns an association list containing the same keys and values as the +property list PLIST in the same order." + (let (alist) + (do ((tail plist (cddr tail))) + ((safe-endp tail) (nreverse alist)) + (push (cons (car tail) (cadr tail)) alist)))) + + + (defun alist-to-hash-table (kv-pairs) + "Create a hash table populated with `kv-pairs`." + (let ((hashtab (make-hash-table :test #'equal))) + (loop + :for (i j) :in kv-pairs + :do (setf (gethash i hashtab) j) + :finally (return hashtab)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun make-gensym-list (length &optional (x "G")) @@ -117,6 +104,169 @@ (apply ,fun ,@curries more))))) + (defun %reevaluate-constant (name value test) + (if (not (boundp name)) + value + (let ((old (symbol-value name)) + (new value)) + (if (not (constantp name)) + (prog1 new + (cerror "Try to redefine the variable as a constant." + "~@<~S is an already bound non-constant variable ~ + whose value is ~S.~:@>" name old)) + (if (funcall test old new) + old + (restart-case + (error "~@<~S is an already defined constant whose value ~ + ~S is not equal to the provided initial value ~S ~ + under ~S.~:@>" name old new test) + (ignore () + :report "Retain the current value." + old) + (continue () + :report "Try to redefine the constant." + new))))))) + + (defmacro define-constant (name initial-value &key (test ''eql) documentation) + "Ensures that the global variable named by `name` is a constant with a value +that is equal under `test` to the result of evaluating `initial-value`. `test` is a +function designator that defaults to `eql`. If `documentation` is given, it +becomes the documentation string of the constant. + +Signals an error if `name` is already a bound non-constant variable. + +Signals an error if `name` is already a constant variable whose value is not +equal under `test` to result of evaluating `initial-value`." + `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test) + ,@(when documentation `(,documentation)))) + + + (defun ensure-boolean (x) + "Convert `x` into a Boolean value." + (and x t)) + + + (defmacro ensure-gethash (key hash-table &optional default) + "Like `gethash`, but if `key` is not found in the `hash-table` saves the `default` +under key before returning it. Secondary return value is true if key was +already in the table." + `(multiple-value-bind (value ok) (gethash ,key ,hash-table) + (if ok + (values value ok) + (values (setf (gethash ,key ,hash-table) ,default) nil)))) + + + (defun ensure-keyword (x) + "Ensure that a keyword is returned for the string designator `x`." + (values (intern (string x) :keyword))) + + + (defun equivalence-classes (equiv seq) + "Partition the sequence `seq` into a list of equivalence classes +defined by the equivalence relation `equiv`." + (let ((classes nil)) + (labels ((find-equivalence-class (x) + (member-if (lambda (class) + (funcall equiv x (car class))) + classes)) + + (add-to-class (x) + (let ((class (find-equivalence-class x))) + (if class + (push x (car class)) + (push (list x) classes))))) + (declare (dynamic-extent (function find-equivalence-class) + (function add-to-class)) + (inline find-equivalence-class + add-to-class)) + + ;; Partition into equivalence classes. + (map nil #'add-to-class seq) + + ;; Return the classes. + classes))) + + + (defun mappend (function &rest lists) + "Applies `function` to respective element(s) of each `list`, appending all the +all the result list to a single list. `function` must return a list." + (loop for results in (apply #'mapcar function lists) + append results)) + + + (defun map-product (function list &rest more-lists) + "Returns a list containing the results of calling `function` with one argument +from `list`, and one from each of `more-lists` for each combination of arguments. +In other words, returns the product of `list` and `more-lists` using `function`. + +Example: + + (map-product 'list '(1 2) '(3 4) '(5 6)) + => ((1 3 5) (1 3 6) (1 4 5) (1 4 6) + (2 3 5) (2 3 6) (2 4 5) (2 4 6))" + (labels ((%map-product (f lists) + (let ((more (cdr lists)) + (one (car lists))) + (if (not more) + (mapcar f one) + (mappend (lambda (x) + (%map-product (curry f x) more)) + one))))) + (%map-product (ensure-function function) (cons list more-lists)))) + + + (defun map-tree (function tree) + "Map `function` to each of the leave of `tree`." + (check-type tree cons) + (labels ((rec (tree) + (cond + ((null tree) nil) + ((atom tree) (funcall function tree)) + ((consp tree) + (cons (rec (car tree)) + (rec (cdr tree))))))) + (rec tree))) + + + (defmacro once-only (specs &body forms) + "Evaluates `forms` with symbols specified in `specs` rebound to temporary +variables, ensuring that each initform is evaluated only once. + +Each of `specs` must either be a symbol naming the variable to be rebound, or of +the form: + + (symbol initform) + +Bare symbols in `specs` are equivalent to + + (symbol symbol) + +Example: + + (defmacro cons1 (x) (once-only (x) `(cons ,x ,x))) + (let ((y 0)) (cons1 (incf y))) => (1 . 1)" + (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY")) + (names-and-forms (mapcar (lambda (spec) + (etypecase spec + (list + (destructuring-bind (name form) spec + (cons name form))) + (symbol + (cons spec spec)))) + specs))) + ;; bind in user-macro + `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n))))) + gensyms names-and-forms) + ;; bind in final expansion + `(let (,,@(mapcar (lambda (g n) + ``(,,g ,,(cdr n))) + gensyms names-and-forms)) + ;; bind in user-macro + ,(let ,(mapcar (lambda (n g) (list (car n) g)) + names-and-forms gensyms) + ,@forms))))) + + (defun rcurry (function &rest arguments) "Returns a function that applies the arguments it is called with and `arguments` to `function`." @@ -127,6 +277,71 @@ (multiple-value-call fn (values-list more) (values-list arguments))))) + (defmacro with-open-file* ((stream filespec &key direction element-type + if-exists if-does-not-exist external-format) + &body body) + "Just like `with-open-file`, but `nil` values in the keyword arguments mean to use +the default value specified for `open`." + (once-only (direction element-type if-exists if-does-not-exist external-format) + `(with-open-stream + (,stream (apply #'open ,filespec + (append + (when ,direction + (list :direction ,direction)) + (when ,element-type + (list :element-type ,element-type)) + (when ,if-exists + (list :if-exists ,if-exists)) + (when ,if-does-not-exist + (list :if-does-not-exist ,if-does-not-exist)) + (when ,external-format + (list :external-format ,external-format))))) + ,@body))) + + + (defmacro with-input-from-file ((stream-name file-name &rest args + &key (direction nil direction-p) + &allow-other-keys) + &body body) + "Evaluate `body` with `stream-name` to an input stream on the file +`file-name`. `args` is sent as is to the call to `open` except `external-format`, +which is only sent to `with-open-file` when it's not `nil`." + (declare (ignore direction)) + (when direction-p + (error "Can't specifiy :DIRECTION for WITH-INPUT-FROM-FILE.")) + `(with-open-file* (,stream-name ,file-name :direction :input ,@args) + ,@body)) + + + (defun read-file-into-string (pathname &key (buffer-size 4096) external-format) + "Return the contents of the file denoted by `pathname` as a fresh string. + +The `external-format` parameter will be passed directly to `with-open-file` +unless it's `nil`, which means the system default." + (with-input-from-file + (file-stream pathname :external-format external-format) + (let ((*print-pretty* nil)) + (with-output-to-string (datum) + (let ((buffer (make-array buffer-size :element-type 'character))) + (loop + :for bytes-read = (read-sequence buffer file-stream) + :do (write-sequence buffer datum :start 0 :end bytes-read) + :while (= bytes-read buffer-size))))))) + + + (defun set-equal (list1 list2 &key (test #'eql) (key nil keyp)) + "Returns true if every element of `list1` matches some element of `list2` and +every element of `list2` matches some element of `list1`. Otherwise returns false." + (let ((keylist1 (if keyp (mapcar key list1) list1)) + (keylist2 (if keyp (mapcar key list2) list2))) + (and (dolist (elt keylist1 t) + (or (member elt keylist2 :test test) + (return nil))) + (dolist (elt keylist2 t) + (or (member elt keylist1 :test test) + (return nil)))))) + + (deftype string-designator () "A string designator type. A string designator is either a string, a symbol, or a character." @@ -221,24 +436,6 @@ (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH."))) - (defun ensure-boolean (x) - "Convert `x` into a Boolean value." - (and x t)) - - - (defmacro until (expression &body body) - "Executes `body` until `expression` is true." - `(do () - (,expression) - ,@body)) - - - (defmacro while (expression &body body) - "Executes `body` while `expression` is true." - `(until (not ,expression) - ,@body)) - - (defun tree-member-p (item tree &key (test #'eql)) "Returns `t` if `item` is in `tree`, `nil` otherwise." (labels ((rec (tree) @@ -249,76 +446,11 @@ (rec tree))) - (defmacro once-only (specs &body forms) - "Evaluates `forms` with symbols specified in `specs` rebound to temporary -variables, ensuring that each initform is evaluated only once. - -Each of `specs` must either be a symbol naming the variable to be rebound, or of -the form: - - (symbol initform) - -Bare symbols in `specs` are equivalent to - - (symbol symbol) - -Example: - - (defmacro cons1 (x) (once-only (x) `(cons ,x ,x))) - (let ((y 0)) (cons1 (incf y))) => (1 . 1)" - (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY")) - (names-and-forms (mapcar (lambda (spec) - (etypecase spec - (list - (destructuring-bind (name form) spec - (cons name form))) - (symbol - (cons spec spec)))) - specs))) - ;; bind in user-macro - `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n))))) - gensyms names-and-forms) - ;; bind in final expansion - `(let (,,@(mapcar (lambda (g n) - ``(,,g ,,(cdr n))) - gensyms names-and-forms)) - ;; bind in user-macro - ,(let ,(mapcar (lambda (n g) (list (car n) g)) - names-and-forms gensyms) - ,@forms))))) - - - (defun transpose (lists) - "Analog to matrix transpose for a list of lists given by `lists`." - (apply #'mapcar #'list lists)) - - - (defun zip (&rest lists) - "Take a tuple of lists and turn them into a list of -tuples. Equivalent to `unzip`." - (transpose lists)) - - - (defun alist-to-hash-table (kv-pairs) - "Create a hash table populated with `kv-pairs`." - (let ((hashtab (make-hash-table :test #'equal))) - (loop - :for (i j) :in kv-pairs - :do (setf (gethash i hashtab) j) - :finally (return hashtab)))) - - - (defun map-tree (function tree) - "Map `function` to each of the leave of `tree`." - (check-type tree cons) - (labels ((rec (tree) - (cond - ((null tree) nil) - ((atom tree) (funcall function tree)) - ((consp tree) - (cons (rec (car tree)) - (rec (cdr tree))))))) - (rec tree))) + (defmacro until (expression &body body) + "Executes `body` until `expression` is true." + `(do () + (,expression) + ,@body)) (defun weave (&rest lists) @@ -389,98 +521,27 @@ ,@(bind (cdr binding-list) forms)))))) - (declaim (inline safe-endp)) - (defun safe-endp (x) - (declare (optimize safety)) - (endp x)) + (defmacro while (expression &body body) + "Executes `body` while `expression` is true." + `(until (not ,expression) + ,@body)) - (defun alist-plist (alist) - "Returns a property list containing the same keys and values as the -association list ALIST in the same order." - (let (plist) - (dolist (pair alist) - (push (car pair) plist) - (push (cdr pair) plist)) - (nreverse plist))) - - (defun plist-alist (plist) - "Returns an association list containing the same keys and values as the -property list PLIST in the same order." - (let (alist) - (do ((tail plist (cddr tail))) - ((safe-endp tail) (nreverse alist)) - (push (cons (car tail) (cadr tail)) alist)))) + (defun transpose (lists) + "Analog to matrix transpose for a list of lists given by `lists`." + (apply #'mapcar #'list lists)) - (defun equivalence-classes (equiv seq) - "Partition the sequence `seq` into a list of equivalence classes -defined by the equivalence relation `equiv`." - (let ((classes nil)) - (labels ((find-equivalence-class (x) - (member-if (lambda (class) - (funcall equiv x (car class))) - classes)) - - (add-to-class (x) - (let ((class (find-equivalence-class x))) - (if class - (push x (car class)) - (push (list x) classes))))) - (declare (dynamic-extent (function find-equivalence-class) - (function add-to-class)) - (inline find-equivalence-class - add-to-class)) - - ;; Partition into equivalence classes. - (map nil #'add-to-class seq) - - ;; Return the classes. - classes))) - - - (defmacro ensure-gethash (key hash-table &optional default) - "Like `gethash`, but if `key` is not found in the `hash-table` saves the `default` -under key before returning it. Secondary return value is true if key was -already in the table." - `(multiple-value-bind (value ok) (gethash ,key ,hash-table) - (if ok - (values value ok) - (values (setf (gethash ,key ,hash-table) ,default) nil)))) - - - (defun mappend (function &rest lists) - "Applies `function` to respective element(s) of each `list`, appending all the -all the result list to a single list. `function` must return a list." - (loop for results in (apply #'mapcar function lists) - append results)) - - - (defun map-product (function list &rest more-lists) - "Returns a list containing the results of calling `function` with one argument -from `list`, and one from each of `more-lists` for each combination of arguments. -In other words, returns the product of `list` and `more-lists` using `function`. - -Example: - - (map-product 'list '(1 2) '(3 4) '(5 6)) - => ((1 3 5) (1 3 6) (1 4 5) (1 4 6) - (2 3 5) (2 3 6) (2 4 5) (2 4 6))" - (labels ((%map-product (f lists) - (let ((more (cdr lists)) - (one (car lists))) - (if (not more) - (mapcar f one) - (mappend (lambda (x) - (%map-product (curry f x) more)) - one))))) - (%map-product (ensure-function function) (cons list more-lists)))) + (defun zip (&rest lists) + "Take a tuple of lists and turn them into a list of +tuples. Equivalent to `unzip`." + (transpose lists)) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(define-constant set-equal curry rcurry switch eswitch cswitch - ensure-boolean while until tree-member-p with-gensyms - with-unique-names once-only zip alist-to-hash-table map-tree weave - when-let when-let* alist-plist plist-alist equivalence-classes - ensure-gethash map-product))) + (export '(alist-plist plist-alist alist-to-hash-table curry define-constant + ensure-boolean ensure-gethash ensure-keyword equivalence-classes + map-product map-tree once-only rcurry read-file-into-string + set-equal switch eswitch cswitch tree-member-p until weave when-let + when-let* while with-gensyms with-unique-names zip))) ;;;; END OF quickutils.lisp ;;;;