srfi/225/alist-impl.sld


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100

(define-library
  (srfi 225 alist-impl)
  (import (scheme base)
          (srfi 1)
          (srfi 128)
          (srfi 225 core)
          (srfi 225 default-impl)
          (srfi 225 indexes))
  (export
    make-alist-dto
    eqv-alist-dto
    equal-alist-dto)

  (begin

    (define (alist? dto l)
      (and (list? l)
           (or (null? l)
               (pair? (car l)))))

    (define (alist-pure? dto alist)
      #t)

    (define (alist-map dto proc alist)
      (map
        (lambda (e)
          (define key (car e))
          (define value (cdr e))
          (cons key (proc key value)))
        alist))

    (define (alist-filter dto pred alist)
      (filter
        (lambda (e)
          (pred (car e) (cdr e)))
        alist))

    (define (make-alist-delete key=)
      (lambda (dto key alist)
        (filter
          (lambda (entry)
            (not (key= (car entry) key)))
          alist)))

    (define (make-alist-find-update key=)
      (define alist-delete (make-alist-delete key=))
      (lambda (dto alist key failure success)
        (define (handle-success pair)
          (define old-key (car pair))
          (define old-value (cdr pair))
          (define (update new-key new-value)
            (cond
              ((and (eq? old-key
                         new-key)
                    (eq? old-value
                         new-value))
               alist)
              (else
                (let ((new-list
                        (alist-cons
                          new-key new-value
                          (alist-delete dto old-key alist))))
                  new-list))))
          (define (remove)
            (alist-delete dto old-key alist))
          (success old-key old-value update remove))

        (define (handle-failure)
          (define (insert value)
            (alist-cons key value alist))
          (define (ignore)
            alist)
          (failure insert ignore))
        (cond
          ((assoc key alist key=) => handle-success)
          (else (handle-failure)))))


    (define (alist-size dto alist)
      (length alist))

    (define (alist->alist dto alist)
      alist)

    (define (alist-comparator dto dictionary)
      #f)

    (define (make-alist-dto key=)
      (make-dto
        dictionary?-id alist?
        dict-pure?-id alist-pure?
        dict-map-id alist-map
        dict-filter-id alist-filter
        dict-find-update-id (make-alist-find-update key=)
        dict-size-id alist-size
        dict->alist-id alist->alist
        dict-comparator-id alist-comparator))

    (define eqv-alist-dto (make-alist-dto eqv?))
    (define equal-alist-dto (make-alist-dto equal?))))