Commit | Line | Data |
---|---|---|
ace75ab7 JG |
1 | ;;; enums.scm --- The R6RS enumerations library |
2 | ||
3 | ;; Copyright (C) 2010 Free Software Foundation, Inc. | |
4 | ;; | |
5 | ;; This library is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 3 of the License, or (at your option) any later version. | |
9 | ;; | |
10 | ;; This library is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;; Lesser General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | \f | |
19 | ||
20 | (library (rnrs enums (6)) | |
21 | (export make-enumeration enum-set-universe enum-set-indexer | |
22 | enum-set-constructor enum-set->list enum-set-member? enum-set-subset? | |
23 | enum-set=? enum-set-union enum-set-intersection enum-set-difference | |
24 | enum-set-complement enum-set-projection define-enumeration) | |
25 | (import (only (guile) and=>) | |
26 | (rnrs base (6)) | |
27 | (rnrs conditions (6)) | |
28 | (rnrs exceptions (6)) | |
29 | (rnrs records procedural (6)) | |
30 | (rnrs syntax-case (6)) | |
31 | (srfi :1)) | |
32 | ||
33 | (define enum-set-rtd (make-record-type-descriptor | |
34 | 'enum-set #f #f #f #f '#((mutable universe) | |
35 | (immutable set)))) | |
36 | ||
37 | (define make-enum-set | |
38 | (record-constructor | |
39 | (make-record-constructor-descriptor enum-set-rtd #f #f))) | |
40 | ||
41 | (define enum-set-universe-internal (record-accessor enum-set-rtd 0)) | |
42 | (define enum-set-universe-set! (record-mutator enum-set-rtd 0)) | |
43 | ||
44 | (define enum-set-set (record-accessor enum-set-rtd 1)) | |
45 | ||
46 | (define (make-enumeration symbol-list) | |
47 | (let ((es (make-enum-set #f symbol-list))) | |
48 | (enum-set-universe-set! es es))) | |
49 | ||
50 | (define (enum-set-universe enum-set) | |
51 | (or (enum-set-universe-internal enum-set) | |
52 | enum-set)) | |
53 | ||
54 | (define (enum-set-indexer enum-set) | |
55 | (let* ((symbols (enum-set->list (enum-set-universe enum-set))) | |
56 | (cardinality (length symbols))) | |
57 | (lambda (x) | |
58 | (and=> (memq x symbols) | |
59 | (lambda (probe) (- cardinality (length probe))))))) | |
60 | ||
61 | (define (enum-set-constructor enum-set) | |
62 | (lambda (symbol-list) | |
63 | (make-enum-set (enum-set-universe enum-set) | |
64 | (list-copy symbol-list)))) | |
65 | ||
66 | (define (enum-set->list enum-set) | |
67 | (lset-intersection eq? | |
68 | (enum-set-set (enum-set-universe enum-set)) | |
69 | (enum-set-set enum-set))) | |
70 | ||
71 | (define (enum-set-member? symbol enum-set) | |
72 | (and (memq symbol (enum-set-set enum-set)) #t)) | |
73 | ||
74 | (define (enum-set-subset? enum-set-1 enum-set-2) | |
75 | (and (lset<= eq? | |
76 | (enum-set-set (enum-set-universe enum-set-1)) | |
77 | (enum-set-set (enum-set-universe enum-set-2))) | |
78 | (lset<= eq? (enum-set-set enum-set-1) (enum-set-set enum-set-2)))) | |
79 | ||
80 | (define (enum-set=? enum-set-1 enum-set-2) | |
81 | (and (enum-set-subset? enum-set-1 enum-set-2) | |
82 | (enum-set-subset? enum-set-2 enum-set-1))) | |
83 | ||
84 | (define (enum-set-union enum-set-1 enum-set-2) | |
015a4aae JG |
85 | (if (equal? (enum-set-universe enum-set-1) |
86 | (enum-set-universe enum-set-2)) | |
ace75ab7 JG |
87 | (make-enum-set (enum-set-universe enum-set-1) |
88 | (lset-union eq? | |
89 | (enum-set-set enum-set-1) | |
90 | (enum-set-set enum-set-2))) | |
91 | (raise (make-assertion-violation)))) | |
92 | ||
93 | (define (enum-set-intersection enum-set-1 enum-set-2) | |
015a4aae JG |
94 | (if (equal? (enum-set-universe enum-set-1) |
95 | (enum-set-universe enum-set-2)) | |
ace75ab7 JG |
96 | (make-enum-set (enum-set-universe enum-set-1) |
97 | (lset-intersection eq? | |
98 | (enum-set-set enum-set-1) | |
99 | (enum-set-set enum-set-2))) | |
100 | (raise (make-assertion-violation)))) | |
101 | ||
102 | (define (enum-set-difference enum-set-1 enum-set-2) | |
015a4aae JG |
103 | (if (equal? (enum-set-universe enum-set-1) |
104 | (enum-set-universe enum-set-2)) | |
ace75ab7 JG |
105 | (make-enum-set (enum-set-universe enum-set-1) |
106 | (lset-difference eq? | |
107 | (enum-set-set enum-set-1) | |
108 | (enum-set-set enum-set-2))) | |
109 | (raise (make-assertion-violation)))) | |
110 | ||
111 | (define (enum-set-complement enum-set) | |
112 | (let ((universe (enum-set-universe enum-set))) | |
113 | (make-enum-set universe | |
114 | (lset-difference | |
115 | eq? (enum-set->list universe) (enum-set-set enum-set))))) | |
116 | ||
117 | (define (enum-set-projection enum-set-1 enum-set-2) | |
118 | (make-enum-set (enum-set-universe enum-set-2) | |
119 | (lset-intersection eq? | |
120 | (enum-set-set enum-set-1) | |
121 | (enum-set->list | |
122 | (enum-set-universe enum-set-2))))) | |
123 | ||
124 | (define-syntax define-enumeration | |
125 | (syntax-rules () | |
126 | ((_ type-name (symbol ...) constructor-syntax) | |
127 | (begin | |
128 | (define-syntax type-name | |
129 | (lambda (s) | |
130 | (syntax-case s () | |
131 | ((type-name sym) | |
132 | (if (memq (syntax->datum #'sym) '(symbol ...)) | |
133 | #'(quote sym) | |
134 | (syntax-violation (symbol->string 'type-name) | |
135 | "not a member of the set" | |
136 | #f)))))) | |
137 | (define-syntax constructor-syntax | |
138 | (lambda (s) | |
139 | (syntax-case s () | |
ace75ab7 JG |
140 | ((_ sym (... ...)) |
141 | (let* ((universe '(symbol ...)) | |
142 | (syms (syntax->datum #'(sym (... ...)))) | |
143 | (quoted-universe | |
144 | (datum->syntax s (list 'quote universe))) | |
145 | (quoted-syms (datum->syntax s (list 'quote syms)))) | |
146 | (or (every (lambda (x) (memq x universe)) syms) | |
147 | (syntax-violation (symbol->string 'constructor-syntax) | |
148 | "not a subset of the universe" | |
149 | #f)) | |
150 | #`((enum-set-constructor (make-enumeration #,quoted-universe)) | |
151 | #,quoted-syms)))))))))) | |
152 | ) |