-
Notifications
You must be signed in to change notification settings - Fork 5
/
util.scm
71 lines (60 loc) · 1.55 KB
/
util.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
(define-macro (record args parm . exprs)
`(apply (lambda ,parm
,@exprs)
,args))
(define-macro (record-case x . args)
(let ((g1 (gensym)))
`(let ((,g1 ,x))
(case (car ,g1)
,@(map (lambda (e)
(let ((key (car e))
(vars (cadr e))
(exprs (cddr e)))
(if (eq? key 'else)
e
`((,key)
(record (cdr ,g1) ,vars ,@exprs)))))
args)))))
(define-macro (recur . args)
`(let ,@args))
;;; dotted pair -> proper list
(define (dotted->proper ls)
(if (list? ls)
ls
(let loop ((p ls)
(acc '()))
(if (pair? p)
(loop (cdr p)
(cons (car p) acc))
(reverse! (cons p acc))))))
;;;; set
(define set-member?
(lambda (x s)
(cond
((null? s) #f)
((eq? x (car s)) #t)
(else (set-member? x (cdr s))))))
(define set-cons
(lambda (x s)
(if (set-member? x s)
s
(cons x s))))
(define set-union
(lambda (s1 s2)
(if (null? s1)
s2
(set-union (cdr s1) (set-cons (car s1) s2)))))
(define set-minus
(lambda (s1 s2)
(if (null? s1)
'()
(if (set-member? (car s1) s2)
(set-minus (cdr s1) s2)
(cons (car s1) (set-minus (cdr s1) s2))))))
(define set-intersect
(lambda (s1 s2)
(if (null? s1)
'()
(if (set-member? (car s1) s2)
(cons (car s1) (set-intersect (cdr s1) s2))
(set-intersect (cdr s1) s2)))))