# HG changeset patch # User Steve Losh # Date 1556658406 14400 # Node ID 28724d30efef19dacec09f446d6b9a2b76ec8f85 # Parent 861b0bbcb3198f5cc5b911fa95baf6e51a6941c8# Parent 71b34a9a34137f752b911fd6201e53e2d4809365 Merge. diff -r 861b0bbcb319 -r 28724d30efef DOCUMENTATION.markdown --- a/DOCUMENTATION.markdown Tue Apr 30 17:06:11 2019 -0400 +++ b/DOCUMENTATION.markdown Tue Apr 30 17:06:46 2019 -0400 @@ -24,16 +24,18 @@ ### `BISECT-LEFT` (function) - (BISECT-LEFT PREDICATE VECTOR TARGET) - -Bisect `vector` based on `(predicate el target)` and return the LEFT element. + (BISECT-LEFT PREDICATE VECTOR TARGET &KEY (KEY #'IDENTITY) (START 0) (END (LENGTH VECTOR))) + +Bisect `vector` with `predicate` and return the LEFT element. + + Only the subsequence of `vector` bounded by `start` and `end` is considered. `vector` must be sorted (with `predicate`) before this function is called (this is not checked). You can think of this function as partitioning the elements into two halves: - those that satisfy `(predicate el target)` and those that don't, and then - selecting the element on the LEFT side of the split: + those that satisfy `(predicate (funcall key element) target)` and those that + don't, and then selecting the element on the LEFT side of the split: satisfying not statisfying #(.......... ...............) @@ -46,28 +48,32 @@ Examples: - ; index - ; 0 1 2 3 4 5 val index - (bisect #'< #(1 3 5 7 7 9) 5) ; => 3, 1 - (bisect #'<= #(1 3 5 7 7 9) 5) ; => 5, 2 - (bisect #'<= #(1 3 5 7 7 9) 7) ; => 7, 4 - (bisect #'< #(1 3 5 7 7 9) 1) ; => nil, nil - (bisect #'> #(9 8 8 8 1 0) 5) ; => 8, 3 + ; index + ; 0 1 2 3 4 5 val index + (bisect-left '< #(1 3 5 7 7 9) 5) ; => 3, 1 + (bisect-left '<= #(1 3 5 7 7 9) 5) ; => 5, 2 + (bisect-left '<= #(1 3 5 7 7 9) 7) ; => 7, 4 + (bisect-left '< #(1 3 5 7 7 9) 1) ; => nil, nil + (bisect-left '> #(9 8 8 8 1 0) 5) ; => 8, 3 + (bisect-left '< #((1) (2 2) (3 3 3)) 2 :key #'length) ; => (1), 0 + (bisect-left '<= #((1) (2 2) (3 3 3)) 2 :key #'length) ; => (2 2), 1 ### `BISECT-RIGHT` (function) - (BISECT-RIGHT PREDICATE VECTOR TARGET) - -Bisect `vector` based on `(predicate el target)` and return the RIGHT element. + (BISECT-RIGHT PREDICATE VECTOR TARGET &KEY (KEY #'IDENTITY) (START 0) (END (LENGTH VECTOR))) + +Bisect `vector` with `predicate` and return the RIGHT element. + + Only the subsequence of `vector` bounded by `start` and `end` is considered. `vector` must be sorted (with `predicate`) before this function is called (this is not checked). You can think of this function as partitioning the elements into two halves: - those that satisfy `(predicate el target)` and those that don't, and then - selecting the element on the RIGHT side of the split: + those that satisfy `(predicate (funcall key element) target)` and those that + don't, and then selecting the element on the RIGHT side of the split: satisfying not statisfying #(.......... ...............) @@ -80,13 +86,15 @@ Examples: - ; index - ; 0 1 2 3 4 5 val index - (rbisect #'< #(1 3 5 7 7 9) 5) ; => 5, 2 - (rbisect #'<= #(1 3 5 7 7 9) 5) ; => 7, 3 - (rbisect #'<= #(1 3 5 7 7 9) 7) ; => 9, 5 - (rbisect #'< #(1 3 5 7 7 9) 10) ; => nil, nil - (rbisect #'> #(9 8 8 8 1 0) 5) ; => 1, 4 + ; index + ; 0 1 2 3 4 5 val index + (bisect-right '< #(1 3 5 7 7 9) 5) ; => 5, 2 + (bisect-right '<= #(1 3 5 7 7 9) 5) ; => 7, 3 + (bisect-right '<= #(1 3 5 7 7 9) 7) ; => 9, 5 + (bisect-right '< #(1 3 5 7 7 9) 10) ; => nil, nil + (bisect-right '> #(9 8 8 8 1 0) 5) ; => 1, 4 + (bisect-right '< #((1) (2 2) (3 3 3)) 2 :key #'length) ; => (2 2), 1 + (bisect-right '<= #((1) (2 2) (3 3 3)) 2 :key #'length) ; => (3 3 3), 2 @@ -313,6 +321,35 @@ Thread the given forms, with `<>` as a placeholder. +### `DO-IRANGE` (macro) + + (DO-IRANGE RANGES + &BODY + BODY) + +Perform `body` on the given inclusive `ranges`. + + Each range in `ranges` should be of the form `(variable from to)`. During + iteration `body` will be executed with `variable` bound to successive values + in the range [`from`, `to`]. + + If multiple ranges are given they will be iterated in a nested fashion. + + Example: + + (do-irange ((x 0 2) + (y 10 11)) + (pr x y)) + ; => + ; 0 10 + ; 0 11 + ; 1 10 + ; 1 11 + ; 2 10 + ; 2 11 + + + ### `DO-RANGE` (macro) (DO-RANGE RANGES @@ -463,7 +500,7 @@ This macro combines `if` and `let`. It takes a list of bindings and binds them like `let` before executing the `then` branch of `body`, but if any - binding's value evaluate to `nil` the process stops there and the `else` + binding's value evaluates to `nil` the process stops there and the `else` branch is immediately executed (with no bindings in effect). If any `optional-declarations` are included they will only be in effect for @@ -779,12 +816,6 @@ -### `PHT` (function) - - (PHT HASH-TABLE &OPTIONAL (STREAM T)) - -Synonym for `print-hash-table` for less typing at the REPL. - ### `PR` (function) (PR &REST ARGS) @@ -798,25 +829,9 @@ -### `PRINT-HASH-TABLE` (function) - - (PRINT-HASH-TABLE HASH-TABLE &OPTIONAL (STREAM T)) - -Print a pretty representation of `hash-table` to `stream.` - - Respects `*print-length*` when printing the elements. - - - -### `PRINT-HASH-TABLE-CONCISELY` (function) - - (PRINT-HASH-TABLE-CONCISELY HASH-TABLE &OPTIONAL (STREAM T)) - -Print a concise representation of `hash-table` to `stream.` - - Should respect `*print-length*` when printing the elements. - - +### `PRETTY-PRINT-HASH-TABLE` (function) + + (PRETTY-PRINT-HASH-TABLE *STANDARD-OUTPUT* HT) ### `PRINT-TABLE` (function) @@ -957,14 +972,71 @@ Utilities for working with higher-order functions. +### `FIXED-POINT` (function) + + (FIXED-POINT FUNCTION DATA &KEY (TEST 'EQL) (LIMIT NIL)) + +Find a fixed point of `function`, starting with `data`. + + Successive runs of `function` will be compared with `test`. Once `test` + returns true the last result will be returned. + + `limit` can be an integer to limit the maximum number of iterations performed. + + A second value is also returned: `t` if a fixed point was found or `nil` if + the iteration limit was reached. + + + +### `JUXT` (function) + + (JUXT &REST FUNCTIONS) + +Return a function that will juxtapose the results of `functions`. + + This is like Clojure's `juxt`. Given functions `(f0 f1 ... fn)`, this will + return a new function which, when called with some arguments, will return + `(list (f0 ...args...) (f1 ...args...) ... (fn ...args...))`. + + Example: + + (funcall (juxt #'list #'+ #'- #'*) 1 2) + => ((1 2) 3 -1 2) + + + +### `NULLARY` (function) + + (NULLARY FUNCTION &OPTIONAL RESULT) + +Return a new function that acts as a nullary-patched version of `function`. + + The new function will return `result` when called with zero arguments, and + delegate to `function` otherwise. + + Examples: + + (max 1 10 2) ; => 10 + (max) ; => invalid number of arguments + + (funcall (nullary #'max)) ; => nil + (funcall (nullary #'max 0)) ; => 0 + (funcall (nullary #'max 0) 1 10 2) ; => 10 + + (reduce #'max nil) ; => invalid number of arguments + (reduce (nullary #'max) nil) ; => nil + (reduce (nullary #'max :empty) nil) ; => :empty + (reduce (nullary #'max) '(1 10 2)) ; => 10 + + + ## Package `LOSH.GNUPLOT` Utilities for plotting data with gnuplot. ### `GNUPLOT` (function) - (GNUPLOT DATA &REST ARGS &KEY (X #'CAR) (Y #'CDR) (SPEW-OUTPUT NIL) - &ALLOW-OTHER-KEYS) + (GNUPLOT DATA &REST ARGS &KEY (X #'CAR) (Y #'CDR) (SPEW-OUTPUT NIL) &ALLOW-OTHER-KEYS) Plot `data` to `filename` with gnuplot. @@ -983,12 +1055,11 @@ ### `GNUPLOT-ARGS` (function) - (GNUPLOT-ARGS &KEY (OUTPUT :QT) (FILENAME plot.png) (STYLE :LINES) - (SIZE-X 1200) (SIZE-Y 800) (LABEL-X) (LABEL-Y) - (LINE-TITLE 'DATA) (LINE-WIDTH 4) (SMOOTH NIL) (AXIS-X NIL) - (AXIS-Y NIL) (MIN-X NIL) (MAX-X NIL) (MIN-Y NIL) (MAX-Y NIL) - (TICS-X NIL) (GRAPH-TITLE) (LOGSCALE-X NIL) (LOGSCALE-Y NIL) - (BOX-WIDTH NIL) &ALLOW-OTHER-KEYS) + (GNUPLOT-ARGS &KEY (OUTPUT :QT) (FILENAME plot.png) (STYLE :LINES) (SIZE-X 1200) (SIZE-Y 800) + (LABEL-X) (LABEL-Y) (LINE-TITLE 'DATA) (LINE-WIDTH 4) (SMOOTH NIL) (AXIS-X NIL) + (AXIS-Y NIL) (MIN-X NIL) (MAX-X NIL) (MIN-Y NIL) (MAX-Y NIL) (TICS-X NIL) + (TICS-Y NIL) (GRAPH-TITLE) (LOGSCALE-X NIL) (LOGSCALE-Y NIL) (BOX-WIDTH NIL) + &ALLOW-OTHER-KEYS) Return the formatted command line arguments for the given gnuplot arguments. @@ -997,22 +1068,12 @@ -### `GNUPLOT-EXPR` (macro) - - (GNUPLOT-EXPR EXPR &REST ARGS) - -Plot `expr` (an expression involving `x`) with gnuplot. - - See the docstring of `gnuplot-args` for other keyword arguments. - - - ### `GNUPLOT-FUNCTION` (function) - (GNUPLOT-FUNCTION FUNCTION &REST ARGS &KEY (START 0.0) (END 1.0) (STEP 0.1) - (INCLUDE-END NIL) &ALLOW-OTHER-KEYS) - -Plot `function` over [`start`, `end`) by `step` with gnuplot. + (GNUPLOT-FUNCTION FUNCTION &REST ARGS &KEY (START 0.0) (END 1.0) (STEP 0.1) (INCLUDE-END NIL) + &ALLOW-OTHER-KEYS) + +Plot `function` over `[start, end)` by `step` with gnuplot. If `include-end` is `t` the `end` value will also be plotted. @@ -1022,7 +1083,7 @@ ### `GNUPLOT-HISTOGRAM` (function) - (GNUPLOT-HISTOGRAM DATA &KEY (BIN-WIDTH 1) SPEW-OUTPUT) + (GNUPLOT-HISTOGRAM DATA &REST ARGS &KEY (BIN-WIDTH 1) &ALLOW-OTHER-KEYS) Plot `data` as a histogram with gnuplot. @@ -1244,6 +1305,12 @@ Utilities for input/output/reading/etc. +### `READ-ALL` (function) + + (READ-ALL STREAM) + +Read all forms from `stream` and return them as a fresh list. + ### `READ-ALL-FROM-FILE` (function) (READ-ALL-FROM-FILE PATH) @@ -1675,8 +1742,7 @@ ### `RANDOM-GAUSSIAN-INTEGER` (function) - (RANDOM-GAUSSIAN-INTEGER MEAN STANDARD-DEVIATION &OPTIONAL - (GENERATOR #'RANDOM)) + (RANDOM-GAUSSIAN-INTEGER MEAN STANDARD-DEVIATION &OPTIONAL (GENERATOR #'RANDOM)) Return a random integer from a gaussian distribution. NOT THREAD-SAFE (yet)! @@ -1863,18 +1929,30 @@ ### `PRODUCT` (function) - (PRODUCT SEQUENCE &KEY KEY) + (PRODUCT SEQUENCE &KEY KEY (INITIAL-VALUE 1) MODULO) Return the product of all elements of `sequence`. If `key` is given, it will be called on each element to compute the multiplicand. + If `initial-value` is given, it will be used instead of 1 to seed the + multiplication. + + If `modulo` is given the successive products will be modulo'ed by it along the + way, which can prevent the need for bignums if you don't need the full result. + Examples: (product #(1 2 3)) ; => 6 + (product #(1 2 3) :modulo 5) + ; => 1 + + (product #(1 2 3) :modulo 5 :initial-value 2) + ; => 2 + (product '("1" "2" "3") :key #'parse-integer) ; => 6 @@ -1906,14 +1984,33 @@ +### `STRING-JOIN` (function) + + (STRING-JOIN SEPARATOR SEQUENCE) + +Join a `sequence` of objects into a string, separated by `separator`. + + All objects in `sequence` (and `separator`) will be `princ-to-string`ed before + joining. + + This is implemented simply, not efficiently, so consider implementing your own + if you're joining a lot of stuff. + + + ### `SUMMATION` (function) - (SUMMATION SEQUENCE &KEY KEY) + (SUMMATION SEQUENCE &KEY KEY (INITIAL-VALUE 0) MODULO) Return the sum of all elements of `sequence`. If `key` is given, it will be called on each element to compute the addend. + If `initial-value` is given, it will be used instead of 0 to seed the addition. + + If `modulo` is given the successive sums will be modulo'ed by it along the + way, which can prevent the need for bignums if you don't need the full result. + This function's ugly name was chosen so it wouldn't clash with iterate's `sum` symbol. Sorry. diff -r 861b0bbcb319 -r 28724d30efef losh.asd --- a/losh.asd Tue Apr 30 17:06:11 2019 -0400 +++ b/losh.asd Tue Apr 30 17:06:46 2019 -0400 @@ -54,7 +54,9 @@ "hash-tables")) (:file "iterate" :depends-on ("control-flow" - "sequences")) + "sequences" + "iterate-pre" + "hash-sets")) (:file "gnuplot" :depends-on ("control-flow" "debugging" "sequences")) diff -r 861b0bbcb319 -r 28724d30efef package.lisp --- a/package.lisp Tue Apr 30 17:06:11 2019 -0400 +++ b/package.lisp Tue Apr 30 17:06:46 2019 -0400 @@ -82,6 +82,7 @@ (:use :cl :iterate :losh.quickutils) (:documentation "Utilities for input/output/reading/etc.") (:export + :read-all :read-all-from-file :read-all-from-string)) @@ -323,6 +324,7 @@ (defpackage :losh.iterate (:use :cl :iterate :losh.quickutils :losh.iterate-pre + :losh.hash-sets :losh.control-flow ;; always needed because we need a single RECURSIVELY symbol :losh.sequences) (:documentation "Custom `iterate` drivers and clauses.") @@ -332,8 +334,10 @@ :anding :averaging :collect-hash + :collect-set :cycling :every-nth + :finding-all :for-nested :in-array :in-hashset @@ -351,9 +355,11 @@ :real-time :recursively :run-time + :seed :since-start-into :skip-origin :test + :then :timing :within-radius diff -r 861b0bbcb319 -r 28724d30efef src/debugging.lisp --- a/src/debugging.lisp Tue Apr 30 17:06:11 2019 -0400 +++ b/src/debugging.lisp Tue Apr 30 17:06:46 2019 -0400 @@ -192,12 +192,12 @@ (dump-profile filename)) #+sbcl -(defmacro profile (&body body) - "Profile `body` and dump the report to `lisp.prof`." +(defmacro profile (form &key (mode :cpu)) + "Profile `form` and dump the report to `lisp.prof`." `(progn - (start-profiling) + (start-profiling :mode ,mode) (unwind-protect - (time (progn ,@body)) + (time ,form) (stop-profiling)))) diff -r 861b0bbcb319 -r 28724d30efef src/gnuplot.lisp --- a/src/gnuplot.lisp Tue Apr 30 17:06:11 2019 -0400 +++ b/src/gnuplot.lisp Tue Apr 30 17:06:46 2019 -0400 @@ -5,7 +5,7 @@ (remove nil args))) (defun gnuplot-args (&key - (output :wxt) + (output :qt) (filename "plot.png") (style :lines) (size-x 1200) @@ -22,6 +22,7 @@ (min-y nil) (max-y nil) (tics-x nil) + (tics-y nil) (graph-title) (logscale-x nil) (logscale-y nil) @@ -33,12 +34,28 @@ the list of possible gnuplot arguments all in one place. " + (check-type axis-x boolean) + (check-type axis-y boolean) + (check-type logscale-x boolean) + (check-type logscale-y boolean) + (check-type line-width (or integer float)) + (check-type box-width (or null integer float)) + (check-type min-x (or null integer float)) + (check-type min-y (or null integer float)) + (check-type max-x (or null integer float)) + (check-type max-y (or null integer float)) + (check-type tics-x (or null integer float)) + (check-type tics-y (or null integer float)) + (check-type graph-title (or null string)) + (check-type label-x (or null string)) + (check-type label-y (or null string)) + (check-type smooth (member nil :unique :frequency :csplines :acsplines :bezier :sbezier)) (flet ((esc (string) (remove #\' (aesthetic-string string))) (f (&rest args) (apply #'format nil (substitute "" nil args)))) (gnuplot-args% (ccase output ((:x :x11) (f "set terminal x11 persist")) - (:qt (f "set terminal qt persist")) + (:qt (f "set terminal qt")) (:wxt (f "set terminal wxt persist")) (:png (f "set terminal pngcairo dashed size ~D,~D font \"Lucida Grande,20\"" @@ -47,8 +64,9 @@ (f "set border linewidth 1") (f "set style line 10 dashtype 2 linewidth 3 linecolor \"#666666\"") (when axis-x (f "set xzeroaxis linestyle 10")) + (when axis-y (f "set yzeroaxis linestyle 10")) (when tics-x (f "set xtics ~A" tics-x)) - (when axis-y (f "set yzeroaxis linestyle 10")) + (when tics-y (f "set ytics ~A" tics-y)) (when box-width (f "set boxwidth ~A" box-width)) (when graph-title (f "set title '~A'" (esc graph-title))) (when label-x (f "set xlabel '~A'" (esc label-x))) @@ -59,12 +77,11 @@ (f "set yrange [~A:~A]" min-y max-y) (f "plot '-' using 1:2 title '~A' with ~(~A~) linewidth ~D ~A" (esc line-title) style line-width - (when smooth (f "smooth ~(~A~)" smooth)))))) + (when smooth (f "smooth ~(~A~)" smooth))) + (f "pause mouse close")))) -(defun gnuplot (data - &rest args - &key +(defun gnuplot (data &rest args &key (x #'car) (y #'cdr) (spew-output nil) @@ -83,16 +100,14 @@ See the docstring of `gnuplot-args` for other keyword arguments. " - (uiop/package:symbol-call :ql :quickload 'external-program :silent t) - (let* ((process (uiop/package:symbol-call - :external-program :start - "gnuplot" - (apply #'gnuplot-args args) - :input :stream - :output (if spew-output *standard-output* nil))) - (in (uiop/package:symbol-call - :external-program :process-input-stream - process))) + (funcall (read-from-string "ql:quickload") 'external-program :silent t) + (let* ((process (funcall (read-from-string "external-program:start") + "gnuplot" + (apply #'gnuplot-args args) + :input :stream + :output (if spew-output *standard-output* nil))) + (in (funcall (read-from-string "external-program:process-input-stream") + process))) (unwind-protect (progn (iterate (for item :in-whatever data) @@ -101,15 +116,13 @@ (close in)) process)) -(defun gnuplot-function (function - &rest args - &key +(defun gnuplot-function (function &rest args &key (start 0.0) (end 1.0) (step 0.1) (include-end nil) &allow-other-keys) - "Plot `function` over [`start`, `end`) by `step` with gnuplot. + "Plot `function` over `[start, end)` by `step` with gnuplot. If `include-end` is `t` the `end` value will also be plotted. @@ -126,9 +139,8 @@ (apply #'gnuplot data args))) -(defun gnuplot-histogram (data - &rest args - &key (bin-width 1) +(defun gnuplot-histogram (data &rest args &key + (bin-width 1) &allow-other-keys) "Plot `data` as a histogram with gnuplot. diff -r 861b0bbcb319 -r 28724d30efef src/io.lisp --- a/src/io.lisp Tue Apr 30 17:06:11 2019 -0400 +++ b/src/io.lisp Tue Apr 30 17:06:46 2019 -0400 @@ -1,5 +1,11 @@ (in-package :losh.io) +(defun read-all (stream) + "Read all forms from `stream` and return them as a fresh list." + (iterate + (for v :in-stream stream) + (collect v))) + (defun read-all-from-string (string) "Read all forms from `string` and return them as a fresh list." (iterate @@ -14,10 +20,4 @@ (defun read-all-from-file (path) "Read all forms from the file at `path` and return them as a fresh list." (with-open-file (file path :direction :input) - (iterate - (with done = (gensym)) - (for form = (read file nil done)) - (while (not (eq form done))) - (collect form)))) - - + (read-all file))) diff -r 861b0bbcb319 -r 28724d30efef src/iterate.lisp --- a/src/iterate.lisp Tue Apr 30 17:06:11 2019 -0400 +++ b/src/iterate.lisp Tue Apr 30 17:06:46 2019 -0400 @@ -249,7 +249,6 @@ (elt ,source ,i)))))))) - (defclause-sequence ACROSS-FLAT-ARRAY INDEX-OF-FLAT-ARRAY :access-fn 'row-major-aref :size-fn 'array-total-size @@ -596,6 +595,28 @@ (with ,hash-table = (make-hash-table :test ,test)) (setf (gethash ,key ,hash-table) ,value))))) +(defmacro-clause (COLLECT-SET element &optional + INTO var + TEST (test '#'eql)) + "Collect elements into a hash set at `var`. + + If `var` is omitted the hash set will be returned instead. + + `test` specifies the test used for the hash set. + + Example: + + (iterate (for y :in '(a b a)) + (collect-set y)) + ; => {a b} + + " + (let ((hash-set (or var iterate::*result-var*))) + `(progn + (with ,hash-set = (make-hash-set :test ,test)) + (hset-insert! ,hash-set ,element)))) + + (defmacro-clause (ORING expr &optional INTO var) (let ((result (or var iterate::*result-var*))) `(reducing ,expr :by #'or :into ,result :initial-value nil))) @@ -665,3 +686,124 @@ (,kwd ,var = ,expr)))) +(defmacro-driver (FOR var SEED seed THEN then) + "Bind `var` to `seed` initially, then to `then` on every iteration. + + This differs from `(FOR … FIRST … THEN …)` and `(FOR … INITIALLY … THEN …)` + because `then` is evaluated on every iteration, *including* the first. + + Example: + + (iterate + (repeat 3) + (for x :first 0 :then (1+ x)) + (for y :initially 0 :then (1+ y)) + (for z :seed 0 :then (1+ z)) + (collect (list x y z))) + ; => + ((0 0 1) + (1 1 2) + (2 2 3)) + + " + (let ((kwd (if generate 'generate 'for))) + `(progn + (,kwd ,var :next ,then) + (initially (setf ,var ,seed))))) + + +(defmacro-clause (FINDING-ALL expr MINIMIZING m-expr &optional INTO var) + "Collect all `expr`s minimizing `m-expr` into a list at `var`. + + The partial list at `var` is available for inspection at any point in the loop. + + If `m-expr` is a sharp-quoted function, then it is called on `expr` instead of + being evaluated and compared itself. + + " + ;; TODO: result-type + (alexandria:with-gensyms (min value m-value tail) + (let ((result (or var iterate::*result-var*))) + `(progn + (with ,result = '()) + (with ,tail = nil) + (with ,min = nil) + ,(typecase m-expr + ((cons (eql function) (cons t null)) + `(progn + (for ,value = ,expr) + (for ,m-value = (funcall ,m-expr ,value)) + (cond + ((or (null ,min) + (< ,m-value ,min)) (setf ,result (list ,value) + ,tail ,result + ,min ,m-value)) + ((= ,m-value ,min) (setf (cdr ,tail) (cons ,value nil) + ,tail (cdr ,tail)))))) + (t `(progn + (for ,m-value = ,m-expr) + (cond + ((or (null ,min) + (< ,m-value ,min)) (setf ,result (list ,expr) + ,tail ,result + ,min ,m-value)) + ((= ,m-value ,min) (setf (cdr ,tail) (cons ,expr nil) + ,tail (cdr ,tail))))))))))) + +(defmacro-clause (FINDING-ALL expr MAXIMIZING m-expr &optional INTO var) + "Collect all `expr`s maximizing `m-expr` into a list at `var`. + + The partial list at `var` is available for inspection at any point in the loop. + + If `m-expr` is a sharp-quoted function, then it is called on `expr` instead of + being evaluated and compared itself. + + " + ;; TODO: result-type + (alexandria:with-gensyms (max value m-value tail) + (let ((result (or var iterate::*result-var*))) + `(progn + (with ,result = '()) + (with ,tail = nil) + (with ,max = nil) + ,(typecase m-expr + ((cons (eql function) (cons t null)) + `(progn + (for ,value = ,expr) + (for ,m-value = (funcall ,m-expr ,value)) + (cond + ((or (null ,max) + (> ,m-value ,max)) (setf ,result (list ,value) + ,tail ,result + ,max ,m-value)) + ((= ,m-value ,max) (setf (cdr ,tail) (cons ,value nil) + ,tail (cdr ,tail)))))) + (t `(progn + (for ,m-value = ,m-expr) + (cond + ((or (null ,max) + (> ,m-value ,max)) (setf ,result (list ,expr) + ,tail ,result + ,max ,m-value)) + ((= ,m-value ,max) (setf (cdr ,tail) (cons ,expr nil) + ,tail (cdr ,tail))))))))))) + +(defmacro-clause (FINDING-ALL expr SUCH-THAT test &optional INTO var RESULT-TYPE result-type) + "Collect all `expr`s for which `test` is true. + + If `test` is a sharp-quoted function, then it is called on `expr` instead of + being evaluated and compared itself. + + " + (let ((result (or var iterate::*result-var*))) + (typecase test + ((cons (eql function) (cons t null)) + (alexandria:with-gensyms (value) + `(progn + (for ,value = ,expr) + (when (funcall ,test ,value) + (collect ,value :into ,result + ,@(when result-type `(:result-type ,result-type))))))) + (t `(when ,test + (collect ,expr :into ,result + ,@(when result-type `(:result-type ,result-type))))))))