XPost: comp.lang.scheme

Suppose I have:

(defvar *list*
'((1 2)
(3 4)
(5 6)
(1 7)))

Now, suppose I want the "keys" of the list, defined by the first element
of the list. Is there a Lisp function which is callable something like: (keys *list* :key #'first) ; => '(1 3 5)

Suppose further that I want to accumulate totals based on keys. The
first element in the list is the key, and the second element in the list
is the value. Is there a Lisp function which is callable something like: (accum *list*) ; => '( (1 9) (3 4) (5 6) )

What we can do is define a somewhat general function for processing this type of associative list.

(defun histogram (assoc-list reduce-func &rest reduce-args)
(let ((hash (make-hash-table :test #'eql)))
(loop for (key value) in assoc-list
do (push value (gethash key hash)))
(loop for key being the hash-keys of hash
using (hash-value value-list)
collect `(,key
,(apply #'reduce reduce-func value-list reduce-args)))))

What HISTOGRAM does is collates the values that share the same key into lists, and then it processes each list through REDUCE, so that you can summarize the values using arbitrary arithmetic, not only addition.

Some tests:

Add:

(histogram '((1 2) (3 4) (5 6) (1 7)) #'+)

((5 6) (3 4) (1 9))

Multiply:

(histogram '((1 2) (3 4) (5 6) (1 7)) #'*)

((5 6) (3 4) (1 14))

Add, supplying initial value for each summation:

(histogram '((1 2) (3 4) (5 6) (1 7)) #'+ :initial-value 100)

((5 106) (3 104) (1 109))

Gauche Scheme:

(define data '((a 2) (b 5) (a 4) (b 3) (c 9)))

(rlet1 result '()
(dolist (xs data)
(ainc! result (car xs) (last xs))))

((c . 9) (b . 8) (a . 6))

(rlet1 result '()
(dolist (xs data)
(ainc! result (car xs) (last xs) * 1)))

((c . 9) (b . 15) (a . 8))

(rlet1 result '()
(dolist (xs data)
(ainc! result (car xs) (last xs) + 7000)))

((c . 7009) (b . 7008) (a . 7006))

(rlet1 result '()
(dolist (xs data)
(ainc! result (car xs) (last xs) cons '())))

((c 9) (b 3 5) (a 4 2))


Given:

(define-syntax ainc!
(syntax-rules ()
[(_ alist key val func default)
(let ((pair (assoc key alist)))
(if pair
(set-cdr! pair (func val (cdr pair)))
(set! alist (cons (cons key (func val default)) alist))))]
[(_ alist key val func)
(ainc! alist key val func 0)]
[(_ alist key val)
(ainc! alist key val +)]
[(_ alist key)
(ainc! alist key 1)]))

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)