3 ;;; pacage for set of natural number.
4 ;; (natural number includes zero.)
8 (defun natset-empty-p (ns)
9 "Returns t if NS is empty."
12 (defun natset-full-p (ns)
13 "Returns t if NS is full."
16 (defun natset-closed-p (ns)
17 "Returns t if NS is closed."
18 (= (logand (length ns) 1) 0))
20 (defun natset-open-p (ns)
21 "Returns t if NS is open."
22 (= (logand (length ns) 1) 1))
24 (defun natset-has-p (ns i)
25 "Returns t if I is in NS."
26 (not (natset-empty-p (natset-intersection (natset-single i) ns))))
28 (defun natset-has-intersection-p (ns1 ns2)
29 "Returns t if the intersection of NS1 and NS2 is not empty."
30 (not (natset-empty-p (natset-intersection ns1 ns2))))
32 (defun natset-include-p (ns1 ns2)
33 "Returns t if NS1 includes NS2."
34 (equal ns1 (natset-union ns1 ns2)))
38 (defun natset-start (ns)
39 "Returns start element in NS."
40 (if (natset-empty-p ns)
41 (error "natset empty" ns))
44 ;;; primitive constructor
46 (defun natset-empty ()
56 (defun natset-single (&rest elts)
57 "Returns a set contains singleton elements.
59 (let ((ns (natset-empty)))
61 (setq ns (natset-union ns (natset-seg (car elts) (car elts)))
65 (defun natset-seg (start &optional end)
66 "Returns a set contains one segment.
67 {i | START <= i and i <= END}
69 If END is nil, Return the set {i | START <= i}"
74 ;;; complex constructor
76 (defun natset-start-set (ns)
77 "Returns a set contains start boundaries for NS.
78 {i | NS does not contains i-1 and NS contains i}"
81 (setq res (cons (1+ (car ns)) (cons (car ns) res))
85 (defun natset-end-set (ns)
86 "Returns a set contains end boundaries for NS.
87 {i | NS contains i-1 and NS does not contains i}"
91 (setq res (cons (1+ (car ns)) (cons (car ns) res))
95 (defun natset-boundary-set (ns)
96 "Returns a set contains start and end boundaries for NS.
97 {i | NS contains i-1 xor NS does not contains i}"
98 (natset-union (natset-start-set ns) (natset-end-set ns)))
100 (defun natset-minmax (ns)
101 "Returns a set contains a range from minimum to maximam of NS.
102 {i | There exists j, k in NS, j <= i <= k}"
105 ((natset-open-p ns) (list (car ns)))
107 (list (car ns) (nth (1- (length ns)) ns)))))
111 (defun natset-negate (ns)
112 "Returns negated set.
113 {i | 0 <= i and NS does not contains i}"
114 (if (and (consp ns) (= (car ns) 0))
118 (defun natset-union (&rest nss)
119 "Returns unioned set.
120 {i | There exists ns in NSS s.t ns contains i}"
121 (let ((ns (natset-empty)))
123 (setq ns (natset-union2 ns (car nss))
127 (defun natset-intersection (&rest nss)
128 "Returns intersectioned set.
129 {i | For all ns in NSS, ns contains i}"
130 (natset-negate (apply 'natset-union (mapcar 'natset-negate nss))))
132 (defun natset-sub (ns &rest nss)
133 "Returns subtracted set.
134 {i | NS contains i and for all ns in NSS, ns does not contains i}"
135 (setq ns (natset-intersection ns (natset-negate (apply 'natset-union nss)))))
139 (defun natset-enum (ns)
140 (if (natset-open-p ns)
141 (error "natset open" ns))
148 (setq res (cons i res)
154 (defun natset-take-seg (ns)
156 ((null ns) (error "NS empty" ns))
157 ((null (cdr ns)) (cons ns ()))
158 (t (cons (list (car ns) (cadr ns)) (cddr ns)))))
160 (defun natset-valid-filter (ns valid)
161 "Returns a filtered set R.
162 R includes intersection between VALID and NS.
163 R does not include intersecton between VALID and negated NS.
164 Element does not contained in VALID is unspecified."
165 (let* ((res (natset-intersection valid ns))
167 (u-set (natset-negate valid))
170 (setq tmp1 (natset-take-seg u-set))
171 (setq tmp2 (natset-union (car tmp1) res)
173 (if (or (< tmpl len) (and (= tmpl len) (equal 0 (car tmp2))))
176 (setq u-set (cdr tmp1)))
179 (defun natset-gen-pred-exp (ns var &optional valid)
180 "Returns a expression to test value of variable VAR is in NS or not.
182 If VALID is not nil, the condition value of VAR is in VALID is assumed.
183 It is impossible to set VALID to empty set because empty set is represented as nil."
184 (if valid (setq ns (natset-valid-filter ns valid)))
187 ((= (car ns) 0) (natset-gen-pred-exp-internal (cdr ns) var nil 0))
188 (t (natset-gen-pred-exp-internal ns var t 0))))
190 (defun natset-gen-ccl-branch256 (reg fail &rest clauses)
191 (let ((i 255) tmp blocks)
194 (if (setq tmp (natset-assoc i clauses))
199 `(branch ,reg ,@blocks)))
201 (defun natset-gen-ccl-branch (reg fail &rest clauses)
202 (let* ((natsets (mapcar 'car clauses)))
203 (let ((range (apply 'natset-union natsets)) tmp)
204 (unless (natset-empty-p range)
205 (setq natsets (cons (natset-negate range)
207 clauses (cons (cons (car natsets)
210 (setq range (natset-full)
217 (setq range (natset-sub range (car tmp))
219 (let ((b (natset-enum
226 (natset-single 0)))))
227 (natset-gen-ccl-branch-internal reg 0 b clauses))))
229 (defun natset-gen-ccl-branch-internal (reg s b clauses)
232 (cdr (natset-assoc s clauses)))
234 `(if (,reg < ,(car b))
235 ,(cdr (natset-assoc s clauses))
236 ,(cdr (natset-assoc (car b) clauses))))
238 (let* ((div (natset-divide (length b)))
240 (g (nthcdr (1- div) l))
242 (setq g (prog1 (cddr g) (setcdr g ())))
244 ,(natset-gen-ccl-branch-internal reg s l clauses)
245 ,(natset-gen-ccl-branch-internal reg m g clauses))))))
247 (defun natset-assoc (key alist)
250 (when (natset-has-p (caar alist) key)
251 (throw 'return (car alist)))
252 (setq alist (cdr alist)))
255 ;;; internal primitive
257 (defun natset-union2 (ns1 ns2)
258 (let (res start (end t))
259 (while (and end (or (consp ns1) (consp ns2)))
260 (if (and (consp ns1) (or (null ns2) (<= (car ns1) (car ns2))))
261 (setq start (car ns1)
264 (setq start (car ns2)
268 (or (and (consp ns1) (<= (car ns1) end))
269 (and (consp ns2) (<= (car ns2) end))))
270 (if (and (consp ns1) (<= (car ns1) end))
272 (if (or (null (cadr ns1)) (< end (cadr ns1))) (setq end (cadr ns1)))
273 (setq ns1 (cddr ns1)))
275 (if (or (null (cadr ns2)) (< end (cadr ns2))) (setq end (cadr ns2)))
276 (setq ns2 (cddr ns2)))))
277 (setq res (cons start res))
278 (if end (setq res (cons end res))))
281 ; n is greater or equal 2.
282 ; returns one of 1 .. n-1
283 ; (In reality, returns greatest 2^i - 1)
284 (defun natset-divide (n)
286 (while (< (setq tmp (lsh l 1)) n)
290 (defun natset-gen-pred-exp-internal (ns var bool base)
292 ((null ns) (not bool))
294 (if (<= (car ns) base)
296 (if bool `(<= ,(car ns) ,var) `(< ,var ,(car ns)))))
298 (let* ((div (natset-divide (length ns)))
300 (g (nthcdr (1- div) l))
303 (setq g (prog1 (cddr g) (setcdr g ())))
305 ,(natset-gen-pred-exp-internal l var bool base)
306 ,(natset-gen-pred-exp-internal
307 g var (if (= (logand div 1) 1) bool (not bool)) m))))))