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
112
113
114
115
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Mike Sperber
; The (rnrs enums (6)) library.
(define (make-enum-type members)
(let* ((table (make-constant-table
(map cons members (iota (length members)))
symbol-hash))
(find-index
(lambda (symbol)
(constant-table-lookup table symbol))))
(big:make-enum-set-type 'r6rs-enum
(lambda (symbol)
(and (find-index symbol) #t))
(list->vector members)
find-index)))
(define (iota n)
(let loop ((n n) (r '()))
(if (zero? n)
r
(loop (- n 1)
(cons (- n 1) r)))))
(define (make-enum-set type symbols)
(big:elements->enum-set type symbols))
(define (enum-type->enum-set et)
(big:enum-set-negation
(big:elements->enum-set et '())))
(define (make-enumeration symbols)
(enum-type->enum-set (make-enum-type symbols)))
(define (enum-set-universe es)
(enum-type->enum-set (big:enum-set-type es)))
(define (enum-set-indexer es)
(lambda (symbol)
(big:enum-set-type-element-index (big:enum-set-type es) symbol)))
(define (enum-set-constructor es)
(let ((et (big:enum-set-type es)))
(lambda (symbols)
(make-enum-set et symbols))))
(define enum-set->list big:enum-set->list)
(define (enum-set-member? symbol es)
(big:enum-set-member? es symbol))
(define (enum-set-subset? es1 es2)
(if (eq? (big:enum-set-type es1)
(big:enum-set-type es2))
(big:enum-set-subset? es1 es2)
;; slow case
(every? (lambda (member)
(enum-set-member? member es2))
(enum-set->list es1))))
(define (enum-set=? es1 es2)
(if (eq? (big:enum-set-type es1)
(big:enum-set-type es2))
(big:enum-set=? es1 es2)
;; slow case
(and (enum-set-subset? es1 es2)
(enum-set-subset? es2 es1))))
(define enum-set-union big:enum-set-union)
(define enum-set-intersection big:enum-set-intersection)
(define enum-set-difference big:enum-set-difference)
(define enum-set-complement big:enum-set-negation)
(define (enum-set-projection es1 es2)
(if (eq? (big:enum-set-type es1)
(big:enum-set-type es2))
es1
(let ((et2 (big:enum-set-type es2)))
(big:elements->enum-set et2
(filter (lambda (element)
(and (big:enum-set-type-member? et2 element)
(enum-set-member? element es2)))
(enum-set->list es1))))))
(define-syntax define-type-name-keyword
(lambda (form0 rename0 compare0)
(let ((%define-syntax (rename0 'define-syntax))
(%lambda (rename0 'lambda))
(%desyntaxify (rename0 'desyntaxify))
(%code-quote (rename0 'code-quote))
(%quote (rename0 'quote)))
`(,%define-syntax ,(cadr form0)
(,%lambda (form rename compare)
(let ((id (,%desyntaxify (cadr form))))
(let loop ((members ',(cddr form0)))
(cond
((null? members) form)
((eq? (car members) id) (list (,%code-quote ,%quote) id))
(else (loop (cdr members)))))))))))
(define-syntax define-enumeration
(syntax-rules ()
((define-enumeration ?type-name
(?member ...)
?constructor)
(begin
(define-type-name-keyword ?type-name ?member ...)
(define type (make-enum-type '(?member ...)))
(define (make elements)
(big:elements->enum-set type elements))
(big:define-enum-set-maker ?constructor make ?type-name)))))
|
