source: project/release/4/amb/trunk/amb-extras.scm @ 35572

Last change on this file since 35572 was 35572, checked in by kon, 6 months ago

don't use typed-define here

File size: 1.9 KB
Line 
1;;;; amb-extras.scm
2;;;; Kon Lovett, Mar '09
3;;;; Kon Lovett, Mar '17
4;;;; Kon Lovett, Aug '17
5
6(module amb-extras
7
8(;export
9  amb1
10  choose
11  one-of
12  all-of
13  required
14  xor
15  implies
16  distinct?
17  count-member
18  only-member?
19  list-constantly)
20
21(import scheme chicken)
22(use
23  (only extras random)
24  (only data-structures sort! constantly)
25  (only (srfi 1) count every)
26  amb)
27
28;;;
29
30;; Convenience
31
32(define-syntax amb1
33  (syntax-rules ()
34    ;
35    ((_)
36     ((amb-failure-continuation)) )
37    ;
38    ((_ ?ls)
39     (amb-thunks (list-constantly ?ls)) ) ) )
40
41(define-syntax choose
42  (syntax-rules ()
43    ;
44    ((_)
45     ((amb-failure-continuation)) )
46    ;
47    ((_ ?ls)
48      (amb-thunks-shuffled (list-constantly ?ls) (amb-random-function)) ) ) )
49
50;; Aliases
51
52(define-syntax one-of
53  (syntax-rules ()
54    ((_ ?expr)
55      (amb-find ?expr) ) ) )
56
57(define-syntax all-of
58  (syntax-rules ()
59    ((_ ?expr)
60      (amb-collect ?expr) ) ) )
61
62(define-syntax required
63  (syntax-rules ()
64    ((_ ?expr)
65     (amb-assert ?expr) ) ) )
66
67;; Logic Control
68
69(define-syntax xor
70  (syntax-rules ()
71    ((_ ?a ?b)
72      (let ((_a ?a) (_b ?b))
73        (if (and _a _b) #f (or _a _b)) ) ) ) )
74
75(define-syntax implies
76  (syntax-rules ()
77    ((_ ?a ?b)
78      (or (not ?a) ?b) ) ) )
79
80;;;
81
82;;
83
84(: count-member (* (list-of *) #!rest (list procedure) --> fixnum))
85;
86(define (count-member x xs . opts)
87  (let ((eql? (optional opts equal?)))
88    (count (cut eql? x <>) xs) ) )
89
90(: only-member? (* (list-of *) #!rest (list procedure) --> boolean))
91;
92(define (only-member? x xs . opts)
93  (let ((eql? (optional opts equal?)))
94    (= 1 (count-member x xs eql?)) ) )
95
96;;
97
98(: list-constantly (list --> (list-of procedure)))
99;
100(define (list-constantly ls)
101  (map constantly ls) )
102
103;;
104
105(: distinct? ((list-of *) #!rest (list procedure) --> boolean))
106;
107(define (distinct? xs . opts)
108  (let ((eql? (optional opts equal?)))
109    (every (cut only-member? <> xs eql?) xs) ) )
110
111) ;module amb-extras
Note: See TracBrowser for help on using the repository browser.