add sort-by

3 files changed, 28 insertions, 3 deletions

diff --git a/mew.scm b/mew.scm
index d0de5e0..70bcff6 100644
--- a/mew.scm
+++ b/mew.scm
@@ -19,7 +19,7 @@
      per pop! prn proj push! puts
      rand range rep repeat
      sample scan scan-right sing? search seq set set-at sgn
-     shuffle shuffle! sort sort! str slurp
+     shuffle shuffle! sort sort-by sort! str slurp
      tally-accumulator tbl time
      while
      uniq-accumulator unlist until
@@ -1361,6 +1361,21 @@
                     (chicken-sort! xs less?)
                     (error "can only sort! vectors")))))
 
+  (define sort-by
+    (case-lambda
+      ((sequence transform) (sort-by sequence transform <?))
+      ((sequence transform less?)
+       (let ((t (tbl)))
+         (define (cached k)
+           (hash-table-ref t k
+                           (lambda ()
+                             (let ((v (transform k)))
+                               (hash-table-set! t k v)
+                               v))))
+         (sort sequence (lambda (a b)
+                          (less? (cached a) (cached b))))))))
+
+
   (let ((old-repl-prompt (repl-prompt)))
     (repl-prompt (lambda ()
                    (let ((old-prompt (old-repl-prompt)))
diff --git a/mew.svnwiki b/mew.svnwiki
index 2ac6cfe..d3adc99 100644
--- a/mew.svnwiki
+++ b/mew.svnwiki
@@ -384,13 +384,19 @@ It is an error to compare uncomparable values.
 
 <procedure>(sort <obj> [<less?>])</procedure>
 
-Sort the list/vector {{<obj>}} according to the relation {{less?}}
+Sort the list/vector {{<obj>}} according to the relation {{<less?>}}
 (by default: {{<?}}).
 
 <procedure>(sort! <obj> [<less?>])</procedure>
 
 Sort the vector {{<obj>}} destructively according to the relation
-{{less?}} (by default: {{<?}}).
+{{<less>?}} (by default: {{<?}}).
+
+<procedure>(sort-by <obj> <f> [<less?>])</procedure>
+
+Sort the items of the list/vector {{<obj>}} by their image under {{f}},
+according to the relation {{<less?>}} (by default: {{<?}}).
+This uses a Schwartzian transform and evaluates {{f}} only once per item.
 
 
 == Data types
diff --git a/tests/test.mew b/tests/test.mew
index ba9c223..13817b0 100644
--- a/tests/test.mew
+++ b/tests/test.mew
@@ -803,3 +803,7 @@
   (test #(1 2 3) (loc (v #(3 1 2)) (sort! v) v))
   (test #(3 2 1) (loc (v #(3 1 2)) (sort! v >) v))
   (test-error (sort! '(3 2 1))))
+
+(test-group "sort-by"
+  (test '("foobar" "zing" "baz") (sort-by '("foobar" "zing" "baz")
+                                          (op - (len _)))))