# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1617993960 14400
# Node ID 40d63316cd3c120b115f30dc65450894d88ce9e0
# Parent  4e5867a99afe1427c3ceb2228f06efc5de5b423b# Parent  2db6543352b624d553d6575a4b83eb2ab753b00b
Merge

diff -r 4e5867a99afe -r 40d63316cd3c DOCUMENTATION.markdown
--- a/DOCUMENTATION.markdown	Thu Apr 08 20:30:18 2021 -0400
+++ b/DOCUMENTATION.markdown	Fri Apr 09 14:46:00 2021 -0400
@@ -278,6 +278,7 @@
 ### `DEFUN-INLINE` (macro)
 
     (DEFUN-INLINE NAME
+        ARGS
       &BODY
       BODY)
 
@@ -453,7 +454,7 @@
 
 ### `GATHERING-VECTOR` (macro)
 
-    (GATHERING-VECTOR OPTIONS
+    (GATHERING-VECTOR (&KEY (SIZE 16) (ELEMENT-TYPE T))
       &BODY
       BODY)
 
@@ -845,6 +846,12 @@
 
   
 
+### `PHR` (function)
+
+    (PHR)
+
+Print a horizontal rule to aid in visual debugging.
+
 ### `PR` (function)
 
     (PR &REST ARGS)
@@ -1433,6 +1440,42 @@
 
 Utilities for operating on lists.
 
+### `0..` (function)
+
+    (0.. BELOW)
+
+Return a fresh list of the range `[0, below)`.
+
+### `0...` (function)
+
+    (0... TO)
+
+Return a fresh list of the range `[0, to]`.
+
+### `1..` (function)
+
+    (1.. BELOW)
+
+Return a fresh list of the range `[1, below)`.
+
+### `1...` (function)
+
+    (1... TO)
+
+Return a fresh list of the range `[1, to]`.
+
+### `N..` (function)
+
+    (N.. FROM BELOW)
+
+Return a fresh list of the range `[from, below)`.
+
+### `N...` (function)
+
+    (N... FROM TO)
+
+Return a fresh list of the range `[from, to]`.
+
 ### `SOMELIST` (function)
 
     (SOMELIST PREDICATE LIST &REST MORE-LISTS)
@@ -1656,6 +1699,12 @@
 
 Remainder `place` by `divisor` in-place.
 
+### `TRUNCATEF` (macro)
+
+    (TRUNCATEF PLACE DIVISOR)
+
+Truncate `place` by `divisor` in-place.
+
 ### `ZAPF` (macro)
 
     (ZAPF &REST PLACE-EXPR-PAIRS)
@@ -1851,6 +1900,51 @@
 
 Utilities for operating on sequences.
 
+### `DEFINE-SORTING-PREDICATE` (macro)
+
+    (DEFINE-SORTING-PREDICATE NAME PREDICATE-SPEC &REST MORE-PREDICATE-SPECS)
+
+Define `name` as a predicate that composes the given predicates.
+
+  This function takes one or more predicates and composes them into a single
+  predicate suitable for passing to `sort`.  Earlier predicates will take
+  precedence over later ones — later predicates will only be called to break
+  ties for earlier predicates.  This is useful if you want to do something like
+  "sort customers by last name, then by first name, then by ID number".
+
+  `predicate-spec` can be one of:
+
+  * `(function ...)`
+  * `(lambda ...)`
+  * A list of `(predicate &key key)`.
+  * Any other object, which will be treated as a predicate.
+
+  If a `key` is specified, it will be called on arguments before passing them to
+  `predicate`.  Note that the `key` only affects the predicate it's consed to,
+  not later predicates.
+
+  See `make-sorting-predicate` for a functional version.
+
+  Examples:
+
+    ;; Sort shorter strings first, breaking ties lexicographically:
+    (define-sorting-predicate fancy<
+      (#< :key #'length)
+      #'string<)
+
+    (sort (list "zz" "abc" "yy") #'fancy<)
+    ; => ("yy" "zz" "abc")
+
+    ;; Sort customers by last name, then first name, then ID number:
+    (define-sorting-predicate customer<
+       (#string< :key #'last-name)
+       (#string< :key #'first-name)
+       (#< :key #'id))
+
+    (sort (find-customers) #'customer<)
+
+  
+
 ### `DOSEQ` (macro)
 
     (DOSEQ (VAR SEQUENCE)
@@ -1994,16 +2088,63 @@
 
   
 
+### `MAKE-SORTING-PREDICATE` (function)
+
+    (MAKE-SORTING-PREDICATE PREDICATE-SPEC &REST MORE-PREDICATE-SPECS)
+
+Compose the given predicates into a single predicate and return it.
+
+  This function takes one or more predicates and composes them into a single
+  predicate suitable for passing to `sort`.  Earlier predicates will take
+  precedence over later ones — later predicates will only be called to break
+  ties for earlier predicates.  This is useful if you want to do something like
+  "sort customers by last name, then by first name, then by ID number".
+
+  `predicate-spec` can be either a function or a cons of `(predicate . key)`,
+  in which case the key will be called on arguments before passing them to
+  `predicate`.  Note that the `key` only affects the predicate it's consed to,
+  not later predicates.
+
+  See `define-sorting-predicate` for a convenient way to define named sorting
+  predicates.
+
+  Examples:
+
+    ;; Trivial example:
+    (sort (list "zz" "abc")
+          (make-sorting-predicate #'string<))
+    ; => ("abc" "zz")
+
+    ;; Sort shorter strings first, breaking ties lexicographically:
+    (sort (list "zz" "abc" "yy")
+          (make-sorting-predicate (cons #'< #'length) #'string<))
+    ; => ("yy" "zz" "abc")
+
+    ;; Sort customers by last name, then first name, then ID number:
+    (sort (find-customers)
+          (make-sorting-predicate
+            (cons #'string< #'last-name)
+            (cons #'string< #'first-name)
+            (cons #'< #'id)))
+
+  
+
 ### `PREFIX-SUMS` (function)
 
-    (PREFIX-SUMS SEQUENCE)
-
-Return a list of the prefix sums of the numbers in `sequence`.
+    (PREFIX-SUMS SEQUENCE &KEY KEY (RESULT-TYPE 'LIST))
+
+Return the prefix sums of the elements of `sequence`.
+
+  If `key` is given, it will be called on the elements before summing.
+  `result-type` must be a type suitable for passing to `map`.
 
   Example:
 
     (prefix-sums '(10 10 10 0 1))
-    => (10 20 30 30 31)
+    ; => (10 20 30 30 31)
+
+    (prefix-sums "ABCD" :key #'char-code :result-type '(vector fixnum))
+    ; => #(65 131 198 266)
 
   
 
@@ -2073,11 +2214,7 @@
 
 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.
+  All objects in `sequence` (and `separator`) will be `princ`ed before joining.
 
   
 
@@ -2099,13 +2236,13 @@
 
   Examples:
 
-    (sum #(1 2 3))
+    (summation #(1 2 3))
     ; => 6
 
-    (sum '("1" "2" "3") :key #'parse-integer)
+    (summation '("1" "2" "3") :key #'parse-integer)
     ; => 6
 
-    (sum '("1" "2" "3") :key #'length)
+    (summation '("1" "2" "3") :key #'length)
     ; => 3
 
   
@@ -2154,6 +2291,14 @@
 
 Utilities for interacting with external programs.
 
+### `*PBCOPY-COMMAND*` (variable)
+
+The shell command to use for `pbcopy`.  When run, this command should set the clipboard contents to its standard input.
+
+### `*PBPASTE-COMMAND*` (variable)
+
+The shell command to use for `pbpaste`.  When run, this command should print the clipboard contents on standard output.
+
 ### `PBCOPY` (function)
 
     (PBCOPY OBJECT)
diff -r 4e5867a99afe -r 40d63316cd3c losh.asd
--- a/losh.asd	Thu Apr 08 20:30:18 2021 -0400
+++ b/losh.asd	Fri Apr 09 14:46:00 2021 -0400
@@ -88,6 +88,7 @@
                              (:file "base")
                              (:file "arrays")
                              (:file "lists")
+                             (:file "sequences")
                              (:file "control-flow"))))
 
   :perform (asdf:test-op (op system)
diff -r 4e5867a99afe -r 40d63316cd3c package.lisp
--- a/package.lisp	Thu Apr 08 20:30:18 2021 -0400
+++ b/package.lisp	Fri Apr 09 14:46:00 2021 -0400
@@ -367,7 +367,9 @@
     :summation
     :product
     :doseq
-    :string-join))
+    :string-join
+    :define-sorting-predicate
+    :make-sorting-predicate))
 
 (defpackage :losh.debugging
   (:use :cl :iterate :losh.quickutils
diff -r 4e5867a99afe -r 40d63316cd3c src/sequences.lisp
--- a/src/sequences.lisp	Thu Apr 08 20:30:18 2021 -0400
+++ b/src/sequences.lisp	Fri Apr 09 14:46:00 2021 -0400
@@ -373,15 +373,155 @@
 (defun 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.
+  All objects in `sequence` (and `separator`) will be `princ`ed before joining.
 
   "
   (unless (stringp separator)
     (callf separator #'princ-to-string))
-  (flet ((concat (current next)
-           (concatenate 'string current separator next)))
-    (reduce (nullary #'concat "") sequence :key #'princ-to-string)))
+  (with-output-to-string (s)
+    (let ((first t))
+      (map nil (lambda (el)
+                 (if first
+                   (setf first nil)
+                   (write-string separator s))
+                 (princ el s))
+           sequence))))
+
+
+(defun make-sorting-predicate (predicate-spec &rest more-predicate-specs)
+  "Compose the given predicates into a single predicate and return it.
+
+  This function takes one or more predicates and composes them into a single
+  predicate suitable for passing to `sort`.  Earlier predicates will take
+  precedence over later ones — later predicates will only be called to break
+  ties for earlier predicates.  This is useful if you want to do something like
+  \"sort customers by last name, then by first name, then by ID number\".
+
+  `predicate-spec` can be either a function or a cons of `(predicate . key)`,
+  in which case the key will be called on arguments before passing them to
+  `predicate`.  Note that the `key` only affects the predicate it's consed to,
+  not later predicates.
+
+  See `define-sorting-predicate` for a convenient way to define named sorting
+  predicates.
+
+  Examples:
+
+    ;; Trivial example:
+    (sort (list \"zz\" \"abc\")
+          (make-sorting-predicate #'string<))
+    ; => (\"abc\" \"zz\")
+
+    ;; Sort shorter strings first, breaking ties lexicographically:
+    (sort (list \"zz\" \"abc\" \"yy\")
+          (make-sorting-predicate (cons #'< #'length) #'string<))
+    ; => (\"yy\" \"zz\" \"abc\")
+
+    ;; Sort customers by last name, then first name, then ID number:
+    (sort (find-customers)
+          (make-sorting-predicate
+            (cons #'string< #'last-name)
+            (cons #'string< #'first-name)
+            (cons #'< #'id)))
+
+  "
+  (let (predicate key)
+    (if (consp predicate-spec)
+      (setf predicate (car predicate-spec)
+            key (cdr predicate-spec))
+      (setf predicate predicate-spec
+            key nil))
+    (if (null more-predicate-specs)
+      (if key
+        (lambda (x y)
+          (funcall predicate (funcall key x) (funcall key y)))
+        predicate)
+      (let ((next (apply #'make-sorting-predicate more-predicate-specs)))
+        (if key
+          (lambda (x y)
+            (let ((kx (funcall key x))
+                  (ky (funcall key y)))
+              (cond
+                ((funcall predicate kx ky) t)
+                ((funcall predicate ky kx) nil)
+                (t (funcall next x y)))))
+          (lambda (x y)
+            (cond
+              ((funcall predicate x y) t)
+              ((funcall predicate y x) nil)
+              (t (funcall next x y)))))))))
+
+(defmacro define-sorting-predicate (name predicate-spec &rest more-predicate-specs)
+  "Define `name` as a predicate that composes the given predicates.
+
+  This function takes one or more predicates and composes them into a single
+  predicate suitable for passing to `sort`.  Earlier predicates will take
+  precedence over later ones — later predicates will only be called to break
+  ties for earlier predicates.  This is useful if you want to do something like
+  \"sort customers by last name, then by first name, then by ID number\".
+
+  `predicate-spec` can be one of:
+
+  * `(function ...)`
+  * `(lambda ...)`
+  * A list of `(predicate &key key)`.
+  * Any other object, which will be treated as a predicate.
+
+  If a `key` is specified, it will be called on arguments before passing them to
+  `predicate`.  Note that the `key` only affects the predicate it's consed to,
+  not later predicates.
+
+  See `make-sorting-predicate` for a functional version.
+
+  Examples:
+
+    ;; Sort shorter strings first, breaking ties lexicographically:
+    (define-sorting-predicate fancy<
+      (#\< :key #'length)
+      #'string<)
+
+    (sort (list \"zz\" \"abc\" \"yy\") #'fancy<)
+    ; => (\"yy\" \"zz\" \"abc\")
+
+    ;; Sort customers by last name, then first name, then ID number:
+    (define-sorting-predicate customer<
+       (#\string< :key #'last-name)
+       (#\string< :key #'first-name)
+       (#\< :key #'id))
+
+    (sort (find-customers) #'customer<)
+
+  "
+  (with-gensyms (x y kx ky)
+    (labels
+        ((parse-spec (spec)
+           (if (consp spec)
+             (if (member (first spec) '(function lambda))
+               (values spec nil)
+               (destructuring-bind (predicate &key key) spec
+                 (values predicate key)))
+             (values spec nil)))
+         (expand (spec more-specs)
+           (multiple-value-bind (predicate key) (parse-spec spec)
+             (once-only (predicate)
+               (if (null more-specs)
+                 `(if ,(if key
+                         (once-only (key)
+                           `(funcall ,predicate (funcall ,key ,x) (funcall ,key ,y)))
+                         `(funcall ,predicate ,x ,y))
+                    t
+                    nil)
+                 (if key
+                   (once-only (key)
+                     `(let ((,kx (funcall ,key ,x))
+                            (,ky (funcall ,key ,y)))
+                        (cond
+                          ((funcall ,predicate ,kx ,ky) t)
+                          ((funcall ,predicate ,ky ,kx) nil)
+                          (t ,(expand (first more-specs) (rest more-specs))))))
+                   `(cond
+                      ((funcall ,predicate ,x ,y) t)
+                      ((funcall ,predicate ,y ,x) nil)
+                      (t ,(expand (first more-specs) (rest more-specs))))))))))
+      `(defun ,name (,x ,y)
+         ,(expand predicate-spec more-predicate-specs)))))
diff -r 4e5867a99afe -r 40d63316cd3c test/sequences.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/sequences.lisp	Fri Apr 09 14:46:00 2021 -0400
@@ -0,0 +1,86 @@
+(in-package :losh.test)
+
+
+(define-test make-sorting-predicate
+  (flet ((check (original expected &rest preds)
+           (let ((actual (sort (copy-seq original)
+                               (apply #'make-sorting-predicate preds))))
+             (is (equalp expected actual)))))
+    (check '("zz" "yy" "abc")
+           '("abc" "yy" "zz")
+           #'string<)
+    (check '("zz" "yy" "abc")
+           '("yy" "zz" "abc")
+           (cons #'< #'length)
+           #'string<)
+    (check '("yy" "zz" "abc")
+           '("zz" "yy" "abc")
+           (cons #'< #'length)
+           #'string>)
+    (check '("az" "by" "aby" "zzy")
+           '("by" "aby" "zzy" "az")
+           (lambda (x y)
+             (char< (char x (1- (length x)))
+                    (char y (1- (length y)))))
+           (cons #'< #'length)
+           #'string<)
+    (check '("az" "by" "aby" "zzy")
+           '("by" "aby" "zzy" "az")
+           (cons #'char< (lambda (s) (char s (1- (length s)))))
+           (cons #'< #'length)
+           #'string<)))
+
+
+(define-sorting-predicate sort-trivial<
+  #'string<)
+
+(define-sorting-predicate sort-short<
+  (#'< :key #'length)
+  #'string<)
+
+(define-sorting-predicate sort-short>
+  (#'< :key #'length)
+  #'string>)
+
+(define-sorting-predicate sort-last-char<
+  (lambda (x y)
+    (char< (char x (1- (length x)))
+           (char y (1- (length y)))))
+  (#'< :key #'length)
+  #'string<)
+
+(define-sorting-predicate sort-fancy<
+  (#'char< :key (lambda (s) (char s (1- (length s)))))
+  (#'< :key #'length)
+  #'string<)
+
+
+(define-test define-sorting-predicate
+  (flet ((check (original expected pred)
+           (let ((actual (sort (copy-seq original) pred)))
+             (is (equalp expected actual)))))
+    (check '("zz" "yy" "abc")
+           '("abc" "yy" "zz")
+           #'sort-trivial<)
+    (check '("zz" "yy" "abc")
+           '("yy" "zz" "abc")
+           #'sort-short<)
+    (check '("yy" "zz" "abc")
+           '("zz" "yy" "abc")
+           #'sort-short>)
+    (check '("az" "by" "aby" "zzy")
+           '("by" "aby" "zzy" "az")
+           #'sort-last-char<)
+    (check '("az" "by" "aby" "zzy")
+           '("by" "aby" "zzy" "az")
+           #'sort-fancy<)))
+
+
+(define-test string-join
+  (is (string= "" (string-join #\x '())))
+  (is (string= "A" (string-join #\x '(a))))
+  (is (string= "AxB" (string-join #\x '(a b))))
+  (is (string= "AxBxC" (string-join #\x '(a b c))))
+  (is (string= "A, B, C" (string-join ", " #(a b c))))
+  (is (string= "foo" (string-join #\space '("foo"))))
+  (is (string= "f o o" (string-join #\space "foo"))))