1;; -*- mode:scheme; coding:utf-8; -*-
2(library (slib alist)
3    (export alist-for-each alist-map
4	    alist-remover alist-associator
5	    alist-inquirer predicate->asso)
6    (import (core)
7	    (core base))
8;;;"alist.scm", alist functions for Scheme.
9;;;Copyright (C) 1992, 1993, 2003 Aubrey Jaffer
10;
11;Permission to copy this software, to modify it, to redistribute it,
12;to distribute modified versions, and to use it for any purpose is
13;granted, subject to the following restrictions and understandings.
14;
15;1.  Any copy made of this software must include this copyright notice
16;in full.
17;
18;2.  I have made no warranty or representation that the operation of
19;this software will be error-free, and I am under no obligation to
20;provide any services, by way of maintenance, update, or otherwise.
21;
22;3.  In conjunction with products arising from the use of this
23;material, there shall be no use of my name in any advertising,
24;promotional, or sales literature without prior written consent in
25;each case.
26
27;;@code{(require 'alist)}
28;;@ftindex alist
29;;
30;;Alist functions provide utilities for treating a list of key-value pairs
31;;as an associative database.  These functions take an equality predicate,
32;;@var{pred}, as an argument.  This predicate should be repeatable,
33;;symmetric, and transitive.
34;;
35;;Alist functions can be used with a secondary index method such as hash
36;;tables for improved performance.
37
38;;@body
39;;Returns an @dfn{association function} (like @code{assq}, @code{assv}, or
40;;@code{assoc}) corresponding to @var{pred}.  The returned function
41;;returns a key-value pair whose key is @code{pred}-equal to its first
42;;argument or @code{#f} if no key in the alist is @var{pred}-equal to the
43;;first argument.
44(define (predicate->asso pred)
45  (cond ((eq? eq? pred) assq)
46	((eq? = pred) assv)
47	((eq? eqv? pred) assv)
48	((eq? char=? pred) assv)
49	((eq? equal? pred) assoc)
50	((eq? string=? pred) assoc)
51	(else (lambda (key alist)
52		(let l ((al alist))
53		  (cond ((null? al) #f)
54			((pred key (caar al)) (car al))
55			(else (l (cdr al)))))))))
56
57;;@body
58;;Returns a procedure of 2 arguments, @var{alist} and @var{key}, which
59;;returns the value associated with @var{key} in @var{alist} or @code{#f} if
60;;@var{key} does not appear in @var{alist}.
61(define (alist-inquirer pred)
62  (let ((assofun (predicate->asso pred)))
63    (lambda (alist key)
64      (let ((pair (assofun key alist)))
65	(and pair (cdr pair))))))
66
67;;@body
68;;Returns a procedure of 3 arguments, @var{alist}, @var{key}, and
69;;@var{value}, which returns an alist with @var{key} and @var{value}
70;;associated.  Any previous value associated with @var{key} will be
71;;lost.  This returned procedure may or may not have side effects on its
72;;@var{alist} argument.  An example of correct usage is:
73;;
74;;@lisp
75;;(define put (alist-associator string-ci=?))
76;;(define alist '())
77;;(set! alist (put alist "Foo" 9))
78;;@end lisp
79(define (alist-associator pred)
80  (let ((assofun (predicate->asso pred)))
81    (lambda (alist key val)
82      (let* ((pair (assofun key alist)))
83	(cond (pair (set-cdr! pair val)
84		    alist)
85	      (else (cons (cons key val) alist)))))))
86
87;;@body
88;;Returns a procedure of 2 arguments, @var{alist} and @var{key}, which
89;;returns an alist with an association whose @var{key} is key removed.
90;;This returned procedure may or may not have side effects on its
91;;@var{alist} argument.  An example of correct usage is:
92;;
93;;@lisp
94;;(define rem (alist-remover string-ci=?))
95;;(set! alist (rem alist "foo"))
96;;@end lisp
97(define (alist-remover pred)
98  (lambda (alist key)
99    (cond ((null? alist) alist)
100	  ((pred key (caar alist)) (cdr alist))
101	  ((null? (cdr alist)) alist)
102	  ((pred key (caadr alist))
103	   (set-cdr! alist (cddr alist)) alist)
104	  (else
105	   (let l ((al (cdr alist)))
106	     (cond ((null? (cdr al)) alist)
107		   ((pred key (caadr al))
108		    (set-cdr! al (cddr al)) alist)
109		   (else (l (cdr al)))))))))
110
111;;@body
112;;Returns a new association list formed by mapping @var{proc} over the
113;;keys and values of @var{alist}.   @var{proc} must be a function of 2
114;;arguments which returns the new value part.
115(define (alist-map proc alist)
116  (map (lambda (pair) (cons (car pair) (proc (car pair) (cdr pair))))
117       alist))
118
119;;@body
120;;Applies @var{proc} to each pair of keys and values of @var{alist}.
121;;@var{proc} must be a function of 2 arguments.  The returned value is
122;;unspecified.
123(define (alist-for-each proc alist)
124  (for-each (lambda (pair) (proc (car pair) (cdr pair))) alist))
125)