blob: d291870721a855856e87ac7f77ab3ae06b9f2bc7 (
plain) (
blame)
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
101
102
103
104
105
106
107
108
109
110
111
|
(define plist-dtd
(let ()
(define (plist? dtd l)
(and (list? l)
(or (null? l)
(symbol? (car l)))))
(define (plist-map dtd proc plist)
(let loop ((pl plist)
(new-pl/rev '()))
(cond
((null? pl) (reverse new-pl/rev))
((null? (cdr pl)) (error "Malformed plist" plist))
(else
(let ((key (car pl))
(value (cadr pl))
(rest (cddr pl)))
(loop rest
(append (list (proc key value) key) new-pl/rev)))))))
(define (plist-filter dtd pred plist)
(let loop ((pl plist)
(new-pl/rev '()))
(cond
((null? pl) (reverse new-pl/rev))
((null? (cdr pl)) (error "Malformed plist" plist))
(else
(let ((key (car pl))
(value (cadr pl))
(rest (cddr pl)))
(if (pred key value)
(loop rest
(append (list value key) new-pl/rev))
(loop rest
new-pl/rev)))))))
(define (find-plist-entry key plist)
(cond
((null? plist) #f)
((eq? key (car plist)) plist)
(else (find-plist-entry key (cddr plist)))))
(define (plist-delete key-to-delete plist)
(let loop ((pl plist)
(new-pl/rev '()))
(cond
((null? pl) (reverse new-pl/rev))
((null? (cdr pl)) (error "Malformed plist"))
(else (let ((key (car pl))
(value (cadr pl))
(rest (cddr pl)))
(if (eq? key-to-delete key)
(loop rest new-pl/rev)
(loop rest (append (list value key) new-pl/rev))))))))
(define (plist-alter dtd plist key failure success)
(define (handle-success pair)
(define old-key (car pair))
(define old-value (cadr pair))
(define (update new-key new-value)
(cond
((and (eq? old-key
new-key)
(eq? old-value
new-value))
plist)
(else
(let ((new-list
(append (list new-key new-value)
(plist-delete old-key plist))))
new-list))))
(define (remove)
(plist-delete old-key plist))
(success old-key old-value update remove))
(define (handle-failure)
(define (insert value)
(append (list key value) plist))
(define (ignore)
plist)
(failure insert ignore))
(cond
((find-plist-entry key plist) => handle-success)
(else (handle-failure))))
(define (plist-size dtd plist)
(/ (length plist) 2))
(define (plist-foreach dtd proc plist)
(let loop ((pl plist))
(if (null? pl) #t
(begin
(proc (car pl) (cadr pl))
(loop (cddr pl))))))
(define (plist-mutable? dtd plist)
#f)
(define (plist-comparator dtd plist)
#f)
(make-dtd
dictionary?-id plist?
dict-mutable?-id plist-mutable?
dict-map-id plist-map
dict-filter-id plist-filter
dict-alter-id plist-alter
dict-size-id plist-size
dict-for-each-id plist-foreach
dict-comparator-id plist-comparator)))
|
