# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1576433544 18000
# Node ID 765870ef20f77f58bb09b1f6df41a5eaca7fc01e
# Parent  164b3e41c13b649fd14c488cb637833ee59cddb3
Add `define-condition*`, allow `do-[i]range` to go down, add `key` to `frequencies` and `proportions`

diff -r 164b3e41c13b -r 765870ef20f7 package.lisp
--- a/package.lisp	Wed Dec 11 18:52:54 2019 -0500
+++ b/package.lisp	Sun Dec 15 13:12:24 2019 -0500
@@ -28,7 +28,8 @@
   (:use :cl :iterate :losh.quickutils)
   (:documentation "Utilities for working with CLOS.")
   (:export
-    :defclass*))
+    :defclass*
+    :define-condition*))
 
 (defpackage :losh.eldritch-horrors
   (:use :cl :iterate :losh.quickutils)
diff -r 164b3e41c13b -r 765870ef20f7 src/clos.lisp
--- a/src/clos.lisp	Wed Dec 11 18:52:54 2019 -0500
+++ b/src/clos.lisp	Sun Dec 15 13:12:24 2019 -0500
@@ -25,6 +25,9 @@
   This is like `defclass`, but the `:initarg` and `:accessor` slot options will
   automatically be filled in with sane values if they aren't given.
 
+  `name-and-options` can be a symbol or a list, which will be destructured
+  against `(name &key conc-name)`.
+
   "
   (destructuring-bind (name &key conc-name)
       (ensure-list name-and-options)
@@ -32,3 +35,19 @@
        ,(mapcar (curry #'build-slot-definition conc-name) slots)
        ,@options)))
 
+(defmacro define-condition* (name-and-options direct-superclasses slots &rest options)
+  "`define-condition` without the tedium.
+
+  This is like `define-condition`, but the `:initarg` and `:accessor` slot
+  options will automatically be filled in with sane values if they aren't given.
+
+  `name-and-options` can be a symbol or a list, which will be destructured
+  against `(name &key conc-name)`.
+
+  "
+  (destructuring-bind (name &key conc-name)
+      (ensure-list name-and-options)
+    `(define-condition ,name ,direct-superclasses
+       ,(mapcar (curry #'build-slot-definition conc-name) slots)
+       ,@options)))
+
diff -r 164b3e41c13b -r 765870ef20f7 src/control-flow.lisp
--- a/src/control-flow.lisp	Wed Dec 11 18:52:54 2019 -0500
+++ b/src/control-flow.lisp	Sun Dec 15 13:12:24 2019 -0500
@@ -440,20 +440,23 @@
   iteration `body` will be executed with `variable` bound to successive values
   in the range [`from`, `below`).
 
+  `from` can be larger than `below`, in which case the values will be stepped
+  down instead of up.
+
   If multiple ranges are given they will be iterated in a nested fashion.
 
   Example:
 
-    (do-range ((x  0  3)
-               (y 10 12))
+    (do-range ((x  0  6  2)
+               (y 12 10))
       (pr x y))
     ; =>
-    ; 0 10
+    ; 0 12
     ; 0 11
-    ; 1 10
-    ; 1 11
-    ; 2 10
+    ; 2 12
     ; 2 11
+    ; 4 12
+    ; 4 11
 
   "
   (assert (not (null ranges)) ()
@@ -461,32 +464,41 @@
   (recursively ((ranges ranges))
     (if (null ranges)
       `(progn ,@body)
-      (destructuring-bind (var from below) (first ranges)
-        `(loop
-           :for ,var :from ,from :below ,below
-           :do ,(recur (rest ranges)))))))
+      (destructuring-bind (var from to &optional by) (first ranges)
+        (with-gensyms (cmp)
+          (once-only (from to by)
+            `(do ((,cmp (if ,by
+                          (if (minusp ,by) #'<= #'>=)
+                          (if (< ,from ,to) #'>= #'<=)))
+                  (,by (or ,by (if (< ,from ,to) 1 -1)))
+                  (,var ,from (+ ,var ,by)))
+               ((funcall ,cmp ,var ,to))
+               ,(recur (rest ranges)))))))))
 
 (defmacro 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`].
+  Each range in `ranges` should be of the form `(variable from to &optional by)`.
+  During iteration `body` will be executed with `variable` bound to successive
+  values according to `by` in the range [`from`, `to`].
+
+  `from` can be larger than `to`, in which case the values will be stepped down
+  instead of up.
 
   If multiple ranges are given they will be iterated in a nested fashion.
 
   Example:
 
-    (do-irange ((x  0  2)
-                (y 10 11))
+    (do-irange ((x  0  4  2)
+                (y 11 10))
       (pr x y))
     ; =>
+    ; 0 11
     ; 0 10
-    ; 0 11
-    ; 1 10
-    ; 1 11
+    ; 2 11
     ; 2 10
-    ; 2 11
+    ; 4 11
+    ; 4 10
 
   "
   (assert (not (null ranges)) ()
@@ -494,9 +506,15 @@
   (recursively ((ranges ranges))
     (if (null ranges)
       `(progn ,@body)
-      (destructuring-bind (var from to) (first ranges)
-        `(loop
-           :for ,var :from ,from :to ,to
-           :do ,(recur (rest ranges)))))))
+      (destructuring-bind (var from to &optional by) (first ranges)
+        (with-gensyms (cmp)
+          (once-only (from to by)
+            `(do ((,cmp (if ,by
+                          (if (minusp ,by) #'< #'>)
+                          (if (< ,from ,to) #'> #'<)))
+                  (,by (or ,by (if (< ,from ,to) 1 -1)))
+                  (,var ,from (+ ,var ,by)))
+               ((funcall ,cmp ,var ,to))
+               ,(recur (rest ranges)))))))))
 
 
diff -r 164b3e41c13b -r 765870ef20f7 src/iterate.lisp
--- a/src/iterate.lisp	Wed Dec 11 18:52:54 2019 -0500
+++ b/src/iterate.lisp	Sun Dec 15 13:12:24 2019 -0500
@@ -957,6 +957,7 @@
           :next
           (multiple-value-bind (,start% ,end% ,@(unless single `(,reg-start% ,reg-end%)))
               (ppcre:scan ,scanner% ,string% :start ,pos% :end ,limit%)
+            (declare (ignorable ,end%))
             (if (null ,start%)
               (terminate)
               (progn (setf ,pos% ,(if overlap? `(1+ ,start%) end%))
diff -r 164b3e41c13b -r 765870ef20f7 src/sequences.lisp
--- a/src/sequences.lisp	Wed Dec 11 18:52:54 2019 -0500
+++ b/src/sequences.lisp	Sun Dec 15 13:12:24 2019 -0500
@@ -23,8 +23,11 @@
     (sum i :into s)
     (collect s)))
 
-(defun frequencies (sequence &key (test 'eql))
-  "Return a hash table containing the frequencies of the items in `sequence`.
+(defun frequencies (sequence &key (test #'eql) key)
+  "Return a hash table containing the frequencies of the elements of `sequence`.
+
+  When `key` is given, it will be called on the elements first before they are
+  counted.
 
   Uses `test` for the `:test` of the hash table.
 
@@ -35,12 +38,18 @@
         bar 1}
 
   "
-  (iterate (for i :in-whatever sequence)
-           (collect-frequencies i)))
+  (if key
+    (iterate (for i :in-whatever sequence)
+             (collect-frequencies (funcall key i) :test test))
+    (iterate (for i :in-whatever sequence)
+             (collect-frequencies i :test test))))
 
-(defun proportions (sequence &key (test 'eql) (float t))
+(defun proportions (sequence &key (test 'eql) (float t) key)
   "Return a hash table containing the proportions of the items in `sequence`.
 
+  When `key` is given, it will be called on the elements first before they are
+  counted.
+
   Uses `test` for the `:test` of the hash table.
 
   If `float` is `t` the hash table values will be coerced to floats, otherwise
@@ -57,7 +66,7 @@
         bar 1/3}
 
   "
-  (let* ((freqs (frequencies sequence :test test))
+  (let* ((freqs (frequencies sequence :test test :key key))
          (total (reduce #'+ (hash-table-values freqs)
                         :initial-value (if float 1.0 1))))
     (mutate-hash-values (lambda (v) (/ v total))