-
Notifications
You must be signed in to change notification settings - Fork 0
/
cogen-labset.scm
108 lines (103 loc) · 2.78 KB
/
cogen-labset.scm
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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; a simple implementation of labset, should be replaced by a bitset impl
;;; (define (labset-first? e l))
(define (set-labset-size! n)
(set! *labset-size* n)
(set! empty-labset (new-labset)))
(define *labset-size* 'undefined-labset-size)
(define (new-labset) (make-string *labset-size* #\0))
(define empty-labset 'undefined-labset-size)
(define (labset-elem? e l)
(eq? (string-ref l e) #\1))
(define (labset-singleton e)
(let ((l (new-labset)))
(string-set! l e #\1)
l))
(define (labset-intersection l1 l2)
(let ((result (new-labset)))
(let loop ((i 0))
(if (= *labset-size* i)
result
(begin
(if (and (eq? (string-ref l1 i) #\1)
(eq? (string-ref l2 i) #\1))
(string-set! result i #\1))
(loop (+ i 1)))))))
(define (labset-empty? l)
(let loop ((i 0))
(if (= *labset-size* i)
#f
(if (eq? (string-ref l i) #\1)
#f
(loop (+ i 1))))))
(define (labset-remove e l)
(let ((result (new-labset)))
(let loop ((i 0))
(if (= *labset-size* i)
result
(begin
(if (not (= i e))
(string-set! result i (string-ref l i)))
(loop (+ i 1)))))))
(define (labset-add e l)
(let ((result (new-labset)))
(let loop ((i 0))
(if (= *labset-size* i)
result
(begin
(if (= i e)
(string-set! result i #\1)
(string-set! result i (string-ref l i)))
(loop (+ i 1)))))))
(define (labset-union l1 l2)
(let ((result (new-labset)))
(let loop ((i 0))
(if (= *labset-size* i)
result
(begin
(if (or (eq? (string-ref l1 i) #\1)
(eq? (string-ref l2 i) #\1))
(string-set! result i #\1))
(loop (+ i 1)))))))
(define (labset-union* ll)
(if (null? ll)
empty-labset
(let loop ((ll (cdr ll)) (result (car ll)))
(if (null? ll)
result
(loop (cdr ll) (labset-union result (car ll)))))))
(define (labset-subtract l1 l2)
(let ((result (new-labset)))
(let loop ((i 0))
(if (= *labset-size* i)
result
(begin
(if (and (eq? (string-ref l1 i) #\1)
(not (eq? (string-ref l2 i) #\1)))
(string-set! result i #\1))
(loop (+ i 1)))))))
(define (labset-subset? l1 l2)
(let loop ((i 0))
(if (= *labset-size* i)
#t
(if (and (eq? (string-ref l1 i) #\1)
(not (eq? (string-ref l2 i) #\1)))
#f
(loop (+ i 1))))))
(define (labset-equal? l1 l2)
(and (labset-subset? l1 l2)
(labset-subset? l2 l1)))
(define (labset-for-each proc labset)
(let loop ((i 0))
(if (< i *labset-size*)
(begin
(if (eq? (string-ref labset i) #\1)
(proc i))
(loop (+ i 1))))))
(define (labset->list labset)
(let loop ((i 0) (result '()))
(if (< i *labset-size*)
(if (eq? (string-ref labset i) #\1)
(loop (+ i 1) (cons i result))
(loop (+ i 1) result))
(reverse result))))