source: project/release/3/combinators/trunk/combinators-support.scm @ 8624

Last change on this file since 8624 was 8624, checked in by Kon Lovett, 13 years ago

Creation.

File size: 1.2 KB
Line 
1;;;;; combinators-support.scm
2;;;;; Graham Fawcett & Kon Lovett, Feb '08
3
4(eval-when (compile)
5  (define-extension combinators
6    (export
7      group-by
8      key-on ) )
9
10  (declare
11    (usual-integrations)
12    (generic)
13    (inline)
14    (no-procedure-checks-for-usual-bindings)
15    (no-bound-checks) ) )
16   
17;; Group a list of elements by some key attribute.
18;;
19;; The list must be in sorted order with respect to the key.
20;; examples:
21;; (group-by identity '(1 2 3 3 4 4 4)) --> ((1) (2) (3 3) (4 4 4))
22;; (group-by car '((a 1) (a 2) (b 1))) --> '(((a 1) (a 2)) ((b 1)))
23
24(define (group-by keyproc lst #!optional (is-equal equal?))
25  (let loop ((lst lst) (acc '()))
26    (if (null? lst)
27        (reverse acc) ;; possibly remove the reversal?
28        (let ((key (keyproc (car lst))))
29          (receive (grouped rest)
30              (span (lambda (item) (is-equal key (keyproc item))) lst)
31            (loop rest (cons grouped acc)))))))
32
33;; Define a comparator function for a sort. E.g. to sort a list of
34;; lists by their first items, using string-case-insensitive
35;; comparison: (sort lst (key-on first string-ci<?))
36
37(define (key-on proc #!optional (comparator <))
38  (lambda (a b) (comparator (proc a) (proc b))))
Note: See TracBrowser for help on using the repository browser.