Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

updated unstable finite domain library, =, =/=, <=, < all supported

  • Loading branch information...
commit 679ed253a7c407e3e32bf179fdf19a682f4ff6d2 1 parent 8ce2f4c
@calvis authored
View
14 cKanren/src/constraints.rkt
@@ -35,8 +35,18 @@
;; splitting up the package
(define-syntax (lambda@ stx)
(syntax-parse stx
- [(_ (a:id) body:expr ...)
- (syntax/loc stx (-transformer (lambda (a) body ...)))]
+ [(k (a:id) body:expr ...)
+ (define/with-syntax src (build-srcloc-stx #'k))
+ (syntax/loc stx
+ (let ()
+ (define a-lambda@
+ (case-lambda
+ [(a) (let () body ...)]
+ [r (raise
+ (exn:goal-as-fn
+ (format "~s: misused lambda@" (format-source src))
+ (current-continuation-marks)))]))
+ (-transformer a-lambda@)))]
[(_ (a [s:id c:id q:id t:id e:id]) body:expr ...)
(syntax/loc stx
(lambda@ (a)
View
20 cKanren/src/events.rkt
@@ -162,17 +162,6 @@
(compose-events new-e (remove-chains e))))]
#:methods gen:compound-event [])
-(struct add-association-event (x v)
- #:transparent
- #:methods gen:event []
- #:methods gen:association-event
- [(define (contains-relevant-var? e vars)
- (match-define (add-association-event x v) e)
- (memq x vars))
- (define (walk/shortcut u e)
- (match-define (add-association-event x v) e)
- (and (eq? u x) v))])
-
(struct add-substitution-prefix-event (p)
#:transparent
#:methods gen:event
@@ -268,6 +257,8 @@
[(define (gen-optimistic-merge e e^ relation)
(match-define (build-chain-event r w tr new) e)
(cond
+ ;; only if we have totally removed the trigger can we
+ ;; cancel the chain build
[(empty-event? (optimistic-merge tr e^ relation))
(running-event (optimistic-merge r e^ relation)
(compose-events w new))]
@@ -326,3 +317,10 @@
#:transparent
#:methods gen:event []))
+
+(struct enforce-event (xs)
+ #:methods gen:event [])
+
+(struct enforce-in-event enforce-event ())
+(struct enforce-out-event enforce-event ())
+
View
26 cKanren/src/framework.rkt
@@ -25,8 +25,6 @@
racket/function
"syntax-classes.rkt"))
-(require (rename-in (only-in racket filter) [filter ls:filter]))
-
(provide send-event
fresh-aux
fresh
@@ -219,7 +217,7 @@
(cond
[(eq? x v) a]
[(not (var? x)) #f]
- [else (bindm a (send-event (add-association-event x v)))])))))
+ [else (bindm a (send-event (add-substitution-prefix-event `((,x . ,v)))))])))))
(define (add-constraint an-oc)
(match-define (oc rator rands) an-oc)
@@ -238,9 +236,9 @@
(lambda@ (a [s c q t e])
(make-a s (ext-c new-oc c) q t e)))
-(define (remove-from-c an-oc)
+(define (remove-from-c old-oc)
(lambda@ (a [s c q t e])
- (make-a s (remq-c an-oc c) q t e)))
+ (make-a s (remq-c old-oc c) q t e)))
(define (remove-constraint an-oc)
(match-define (oc rator rands) an-oc)
@@ -248,21 +246,20 @@
(define (enforce x)
(lambda@ (a [s c q t e])
- a
- #;
- (let ([x (filter*/var? (walk x (substitution-s s)))])
- (bindm a (conj (add-event (enforce-event x)) send-event)))))
+ (define xs (filter*/var? (walk* x s)))
+ (define ct
+ (conj (send-event (enforce-in-event xs))
+ (onceo (send-event (enforce-out-event xs)))))
+ (bindm a ct)))
(define (reify x)
(lambda@ (a [s c q t e])
(define v (walk* x s c e))
(define r (reify-s v empty-s))
(define v^ (reify-term v r))
- (define answer
- (cond
- [(null? r) v^]
- [else (reify-constraints v^ r c)]))
- answer))
+ (cond
+ [(null? r) v^]
+ [else (reify-constraints v^ r c)])))
;; reifies the substitution, returning the reified substitution
(define (reify-s v^ s)
@@ -348,7 +345,6 @@
;; Event -> ConstraintTransformer
(define/match (solidify-atomic-event e)
- [((add-association-event u v)) (update-s u v)]
[((add-substitution-prefix-event p)) (update-s p)]
[((add-constraint-event/internal rator rands))
(update-c (oc rator rands))]
View
9 cKanren/src/infs.rkt
@@ -48,9 +48,10 @@
(define choiceg cons)
(struct a #;a-inf (s c q t e)
- #:extra-constructor-name make-a/internal
- #:methods gen:custom-write
- [(define (write-proc . args) (apply write-package args))])
+ #:transparent
+ #:extra-constructor-name make-a/internal
+ #:methods gen:custom-write
+ [(define (write-proc . args) (apply write-package args))])
;; controls how packages are displayed
(define (write-package a port mode)
@@ -62,7 +63,7 @@
;; macro that delays expressions
(define-syntax lambdaf@
(syntax-rules ()
- ((_ () e) (lambda () e))))
+ ((_ () e) (let () (define (a-delay) e) a-delay))))
;; delays an expression
(define-syntax delay
View
7 cKanren/src/operators.rkt
@@ -22,6 +22,9 @@
(define onceo (lambda (g) (condu (g))))
+(define (succeed-iff bool)
+ (if bool succeed fail))
+
;; =============================================================================
;; shorthand for conjunction
@@ -81,7 +84,7 @@
(define-syntax ifa
(syntax-rules ()
- ((_) fail)
+ ((_) mzerom)
((_ (e g ...) b ...)
(let loop ((a-inf e))
(case-inf a-inf
@@ -98,7 +101,7 @@
(define-syntax ifu
(syntax-rules ()
- ((_) fail)
+ ((_) mzerom)
((_ (e g ...) b ...)
(let loop ((a-inf e))
(case-inf a-inf
View
16 cKanren/src/triggers.rkt
@@ -11,9 +11,11 @@
(provide (struct-out trigger)
define-trigger)
+;; some predefined triggers
(provide enter-scope
leave-scope
- any-association-event)
+ any-association-event
+ any-enforce)
(struct trigger (subs interp))
@@ -53,11 +55,6 @@
(=> abort) (unless (or (not x) (eq? x y)) (abort)) y])
(define-trigger (any-association-event x)
- [(add-association-event y z)
- (=> abort)
- (unless (or (eq? x y) (memq x (filter*/var? z)))
- (abort))
- (list (cons y z))]
[(add-substitution-prefix-event p)
(=> abort)
(define (assoc-contains-var? u/v)
@@ -67,3 +64,10 @@
=> (lambda (p) (when (null? p) (abort)) p)]
[else (abort)])])
+(define-trigger (any-enforce ls)
+ [(enforce-in-event ls^)
+ (=> abort)
+ (unless (ormap (curryr memq ls) ls^) (abort))]
+ [(enforce-out-event ls^)
+ (=> abort)
+ (when (ormap (curryr memq ls) ls^) (abort))])
View
12 cKanren/tester.rkt
@@ -30,13 +30,13 @@
(make-error #,(build-srcloc-stx x)
(string-append
"error while running tests\n"
- "expression: ~a~%Expected: ~a~%Computed: ~a~%")
+ "expression: ~a~%expected: ~a~%computed: ~a~%")
'#,te expected produced)]))))
(syntax-case x ()
((_ title tested-expression expected-result)
(quasisyntax/loc x
(begin
- (printf "Testing ~a\n" title)
+ (printf "warning: depricated testing format in ~a\n" title)
#,(test-syntax #'tested-expression #'expected-result))))
((_ tested-expression expected-result)
(quasisyntax/loc x
@@ -62,7 +62,7 @@
(syntax-rules ()
((_ title tested-expression)
(begin
- (printf "Testing ~a (engine with ~s ticks fuel)\n" title max-ticks)
+ (printf "testing ~a (engine with ~s ticks fuel)\n" title max-ticks)
(let ((eng (make-engine (lambda () tested-expression))))
(eng max-ticks
(lambda (t v)
@@ -74,7 +74,7 @@
(define-syntax test-disable
(syntax-rules ()
((_ title tested-expression expected-result)
- (printf "Disable testing ~s\n" title))))
+ (printf "disable testing ~s\n" title))))
(define-syntax (test-any-order x)
(define (test-syntax te er)
@@ -91,13 +91,13 @@
(make-error #,(build-srcloc-stx x)
(string-append
"error while running tests\n"
- "expression: ~a~%Expected: ~a~%Computed: ~a~%")
+ "expression: ~a~%expected: ~a~%computed: ~a~%")
'#,te expected produced)]))))
(syntax-case x ()
((_ title tested-expression expected-result)
(quasisyntax/loc x
(begin
- (printf "Testing ~a\n" title)
+ (printf "testing ~a\n" title)
#,(test-syntax #'tested-expression #'expected-result))))
((_ tested-expression expected-result)
(quasisyntax/loc x
View
73 cKanren/tests/fd.rkt
@@ -108,7 +108,6 @@
(test (run* (x) (infd x '(1 2)))
'(1 2))
- (printf "=============================\n")
(test (run* (x) (fresh (y) (infd x y '(1 2))))
'(1 2))
@@ -188,18 +187,7 @@
(=fd x y))
`((2 2)))
- #;
- (test
- (run* (q)
- (fresh (x y)
- (infd x '(1 2 3))
- (infd y '(0 1 2 3 4))
- (<fd x y)
- (=/=fd x 1)
- (=fd y 3)
- (== q `(,x ,y))))
- `((2 3)))
-
+
(test
(run* (q)
(fresh (x y z)
@@ -246,23 +234,52 @@
(fresh (x)
(<=fd x 5)
(infd x q (range 0 10))
- (prtm "==================================\n")
- (=fd q x)
- (prtm "==================================\n")))
+ (=fd q x)))
`(0 1 2 3 4 5))
-;; (test
-;; (run* (q)
-;; (fresh (x y z)
-;; (infd x y z q (range 0 9))
-;; (=/=fd x y)
-;; (=/=fd y z)
-;; (=/=fd x z)
-;; (=fd x 2)
-;; (=fd q 3)
-;; (plusfd y 3 z)))
-;; `(3))
-;;
+ (test
+ (run* (x y)
+ (infd x '(1 2 3))
+ (infd y '(0 1 2 3 4))
+ (<=fd x y))
+ `((1 1) (1 2) (1 3) (1 4) (2 2) (2 3) (3 3) (2 4) (3 4)))
+
+ (test
+ (run* (x y)
+ (infd x '(1 2 3))
+ (infd y '(0 1 2 3 4))
+ (<fd x y))
+ `((1 2) (1 3) (1 4) (2 3) (2 4) (3 4)))
+
+ (test
+ (run* (x y)
+ (infd x '(1 2 3))
+ (infd y '(0 1 2 3 4))
+ (<fd x y)
+ (=/=fd x 1)
+ (=fd y 3))
+ `((2 3)))
+
+ #;
+ (test
+ (run* (x y z)
+ (infd x y z (range 0 3))
+ (plusfd x y z))
+ 'error)
+
+ #;
+ (test
+ (run* (q)
+ (fresh (x y z)
+ (infd x y z q (range 0 9))
+ (=/=fd x y)
+ (=/=fd y z)
+ (=/=fd x z)
+ (=fd x 2)
+ (=fd q 3)
+ (plusfd y 3 z)))
+ `(3))
+
;; (test
;; (run* (q)
;; (distinctfd `(1 2 3 4 5)))
View
85 cKanren/tests/framework.rkt
@@ -28,9 +28,9 @@
(test
(compose-events
(constraint-event rator1 rands1)
- (running-event (add-association-event 'q 5) (empty-event)))
+ (running-event (add-substitution-prefix-event `((q . 5))) (empty-event)))
(running-event
- (add-association-event 'q 5)
+ (add-substitution-prefix-event `((q . 5)))
(constraint-event rator1 rands1)))
(test
@@ -188,18 +188,18 @@
(test
(compose-events
(build-chain-event
- (add-association-event 'q 5)
- (add-association-event 'q 5)
- (add-association-event 'q 5)
+ (add-substitution-prefix-event `((q . 5)))
+ (add-substitution-prefix-event `((q . 5)))
+ (add-substitution-prefix-event `((q . 5)))
(empty-event))
(constraint-event rator1 rands1))
(build-chain-event
- (add-association-event 'q 5)
- (add-association-event 'q 5)
- (add-association-event 'q 5)
+ (add-substitution-prefix-event `((q . 5)))
+ (add-substitution-prefix-event `((q . 5)))
+ (add-substitution-prefix-event `((q . 5)))
(constraint-event rator1 rands1)))
-(let ([trigger (add-association-event 'q 5)])
+(let ([trigger (add-substitution-prefix-event `((q . 5)))])
(test
(apply-chain
(build-chain-event
@@ -219,31 +219,29 @@
(constraint-event rator1 rands2)
(constraint-event rator1 rands1)))))))
-(let ([tr (add-association-event 'q 5)])
+(let ([tr (add-substitution-prefix-event `((q . 5)))])
(test
(solidify
(list tr)
- (chain-event tr (add-association-event 'q 6)))
- (add-association-event 'q 6)))
+ (chain-event tr (add-substitution-prefix-event `((q . 6)))))
+ (add-substitution-prefix-event `((q . 6)))))
-(let ([trigger1 (add-association-event 'q 5)]
+(let ([trigger1 (add-substitution-prefix-event `((q . 5)))]
[trigger2 (add-constraint-event/internal rator1 rands1)])
(test
(solidify
(list trigger1 trigger2)
(composite-event
- (list (chain-event trigger1 (add-association-event 'q 6))
- (chain-event trigger2 (chain-event trigger1 (add-association-event 'q 7))))))
- (composite-event
- (list (add-association-event 'q 7)
- (add-association-event 'q 6)))))
+ (list (chain-event trigger1 (add-substitution-prefix-event `((q . 6))))
+ (chain-event trigger2 (chain-event trigger1 (add-substitution-prefix-event `((q . 7))))))))
+ (add-substitution-prefix-event `((q . 7) (q . 6)))))
;; == WALK TESTS ===============================================================
(let ()
(define test-event
(build-chain-event
- (add-association-event u 'a)
+ (add-substitution-prefix-event `((,u . a)))
(empty-event)
(add-substitution-prefix-event '())
(composite-event
@@ -314,18 +312,63 @@
(let ()
(define a-inf (bindm empty-a (conj succeed (enforce (var 'x)))))
+ (define ans (car (let ([stream (generator () (take/lazy a-inf))])
+ (take 1 stream))))
+ (test (a-s ans) empty-s)
+ (test (a-c ans) empty-c)
+ (test (a-e ans) empty-e)
+ (test ans empty-a))
+
+(let ()
+ (define a-inf (bindm empty-a (conj succeed (enforce (var 'x)) (reify (var 'x)))))
(test
(let ([stream (generator () (take/lazy a-inf))])
(take 1 stream))
- (list empty-a)))
+ (list '_.0)))
(let ()
- (define a-inf (bindm empty-a (conj succeed (enforce (var 'x)) (reify (var 'x)))))
+ (define a-inf (bindm empty-a (conj (conde [succeed] [fail]) (enforce (var 'x)) (reify (var 'x)))))
(test
(let ([stream (generator () (take/lazy a-inf))])
(take 1 stream))
(list '_.0)))
+(let ()
+ (define a-inf (bindm empty-a (conj (conde [succeed] [succeed]) (enforce (var 'x)) (reify (var 'x)))))
+ (test
+ (let ([stream (generator () (take/lazy a-inf))])
+ (take 2 stream))
+ (list '_.0 '_.0)))
+
+(let ()
+ (define a-inf (bindm empty-a (conj (conde [succeed] [succeed]) (enforce (var 'x)) (reify (var 'x)))))
+ (test
+ (let ([stream (generator () (take/lazy a-inf))])
+ (take #f stream))
+ (list '_.0 '_.0)))
+
+(let ()
+ (define a-inf
+ (bindm empty-a
+ (conj (onceo (conde [succeed] [succeed]))
+ (enforce (var 'x))
+ (reify (var 'x)))))
+ (test
+ (let ([stream (generator () (take/lazy a-inf))])
+ (take #f stream))
+ (list '_.0)))
+
+(let ()
+ (define a-inf
+ (bindm empty-a
+ (conj (onceo fail)
+ (enforce (var 'x))
+ (reify (var 'x)))))
+ (test
+ (let ([stream (generator () (take/lazy a-inf))])
+ (take 1 stream))
+ (list)))
+
;; == RUN TESTS ================================================================
(test
View
6 cKanren/tree-unify.rkt
@@ -7,7 +7,6 @@
cKanren/src/triggers
cKanren/src/mk-structs
(only-in cKanren/src/events
- add-association-event
add-substitution-prefix-event
empty-event))
@@ -101,11 +100,6 @@
(define-trigger (unify-change thing)
#:package (a [s c e])
- [(add-association-event u v)
- (=> abort)
- (unless (memq u (filter*/var? thing))
- (abort))
- (unify-new-prefix thing s c e)]
[(add-substitution-prefix-event p)
(=> abort)
(unless (ormap (lambda (x) (memq (car x) (filter*/var? thing))) p)
View
163 cKanren/unstable/fd.rkt
@@ -4,7 +4,9 @@
cKanren/ck
cKanren/src/framework
cKanren/src/events
- cKanren/src/constraints)
+ cKanren/src/constraints
+ cKanren/src/triggers
+ cKanren/src/operators)
(provide (all-defined-out))
@@ -19,20 +21,11 @@
(define-constraint (dom v [d #:constant])
#:reaction
- [(enforce (list v))
+ [(any-enforce (list v))
(force-ans v d)]
#:package (a [s c e])
- ;; (printf "dom: ~a ~a\n" v d)
(cond
- [(and (value-dom? v)
- (memv-dom? v d))
- succeed]
- #;
- [(findf enforce-event? e)
- => (match-lambda
- [(enforce-event enforce-vars)
- (conj (add-constraint (dom v d))
- (enforce-domfd enforce-vars))])]
+ [(and (value-dom? v) (memv-dom? v d)) succeed]
[(var? v)
(cond
[(null-dom? d) fail]
@@ -44,38 +37,18 @@
(define-constraint-interaction
[(dom x d) (dom x d^)] => [(dom x (intersection-dom d d^))])
-(define (force-ans ocs)
- succeed
- #;
- (for/fold ([ct succeed]) ([an-oc ocs])
- (match-define (list v d) (oc-rands an-oc))
- (conj ((map-sum (curry update-s v)) d) ct)))
+(define (force-ans v d)
+ (map-sum (curry add-association v) d))
-(define (enforce-domfd enforce-vars)
- (transformer
- #:package (a [s c e])
- (define doms (filter/rator dom c))
- (define (relevant? oc)
- (match-define (list v d) (oc-rands oc))
- (memq v enforce-vars))
- (define-values (relevant-doms irrelevant-doms)
- (partition relevant? doms))
- (printf "enforce: ~a ~a\n" relevant-doms irrelevant-doms)
- (conj (force-ans relevant-doms)
- ;(onceo (force-ans irrelevant-doms))
- )))
+(define (<fd u v)
+ (conj (<=fd u v) (=/=fd u v)))
-;; (define (=/=fd u v)
-;; (=/=fd-c u v))
-;;
-;; (define (<fd u v)
-;; (conj (<=fd u v) (=/=fd u v)))
;;
;; (define (<=fd u v)
;; (<=fd-c u v))
;;
-;; (define (plusfd u v w)
-;; (plusfd-c u v w))
+;; (define (+fd u v w)
+;; (+fd-c u v w))
;;
;; (define (timesfd u v w)
;; (timesfd-c u v w))
@@ -141,42 +114,11 @@
(define-constraint (=/=fd u v)
(cond
- [(and (var? u) (var? v))
- (add-constraint (=/=fd u v))]
- [(value-dom? v)
- (cond
- [(value-dom? u)
- (cond
- [(eq? u v) fail]
- [else succeed])]
- [else (add-constraint (=/=fd u v))])]
- [else (add-constraint (=/=fd v u))])
-
- #;
- (let-dom (s c) ((u : d_u) (v : d_v))
- (cond
- ((or (not d_u) (not d_v))
- ((update-c (build-oc =/=fd-c u v)) a))
- ((and (singleton-dom? d_u)
- (singleton-dom? d_v)
- (= (singleton-element-dom d_u)
- (singleton-element-dom d_v)))
- mzerom)
- ((disjoint-dom? d_u d_v) a)
- (else
- (let ((oc (build-oc =/=fd-c u v)))
- (bindm a
- (conj
- (update-c oc)
- (cond
- [(singleton-dom? d_u)
- (process-dom v (diff-dom d_v d_u))]
- [(singleton-dom? d_v)
- (process-dom u (diff-dom d_u d_v))]
- [else identitym]))))))))
+ [(and (value-dom? u) (value-dom? v))
+ (succeed-iff (not (eq? u v)))]
+ [else (add-constraint (=/=fd u v))]))
(define-constraint-interaction
- =/=fd-interaction
[(=/=fd u v) (dom u d) (dom v d^)]
[(disjoint-dom? d d^) [(dom u d) (dom v d^)]])
@@ -247,13 +189,8 @@
(define-constraint (=fd u v)
(cond
- [(value-dom? u)
- (cond
- [(value-dom? v)
- (cond
- [(eq? u v) succeed]
- [else fail])]
- [else (add-association v u)])]
+ [(and (value-dom? u) (value-dom? v))
+ (succeed-iff (eq? u v))]
[(value-dom? v)
(add-association u v)]
[else (add-constraint (=fd u v))]))
@@ -269,50 +206,48 @@
(define-constraint (<=fd u v)
(cond
[(and (value-dom? u) (value-dom? v))
- (cond [(<= u v) succeed] [else fail])]
- [else (add-constraint (<=fd u v))])
- #;
- (c-op <=fd-c ([u : d_u] [v : d_v])
- (let ([umin (min-dom d_u)]
- [vmax (max-dom d_v)])
- (let ([new-u-dom (copy-before-dom (lambda (u) (< vmax u)) d_u)]
- [new-v-dom (drop-before-dom (lambda (v) (<= umin v)) d_v)])
- (conj
- (process-dom u new-u-dom)
- (process-dom v new-v-dom))))))
+ (succeed-iff (<= u v))]
+ [else (add-constraint (<=fd u v))]))
+;; if there are impossible elements in the high ranges of u's domain
+;; or the low ranges of v's dom, removes them
(define-constraint-interaction
- <=fd-interaction
[(<=fd u v) (dom u du) (dom v dv)]
- =>
- [(<=fd u v)
- (dom u (copy-before-dom (curry < (max-dom dv)) du))
- (dom v (drop-before-dom (curry <= (min-dom du)) dv))])
+ [(let ([du^ (copy-before-dom (curry < (max-dom dv)) du)]
+ [dv^ (drop-before-dom (curry <= (min-dom du)) dv)])
+ (or (not (equal? du du^))
+ (not (equal? dv dv^))))
+ [add (dom u (copy-before-dom (curry < (max-dom dv)) du))
+ (dom v (drop-before-dom (curry <= (min-dom du)) dv))]])
(define-constraint-interaction
- <=fd-interaction-u
[(<=fd u v) (dom u du)]
- [(value-dom? v)
- [(dom u (copy-before-dom (curry < v) du))]])
+ [(value-dom? v) [(dom u (copy-before-dom (curry < v) du))]])
(define-constraint-interaction
- <=fd-interaction-v
[(<=fd u v) (dom v dv)]
- [(value-dom? u)
- [(dom v (drop-before-dom (curry <= u) dv))]])
+ [(value-dom? u) [(dom v (drop-before-dom (curry <= u) dv))]])
+
+#;
+(define-constraint (+fd u v w)
+ (cond
+ [(andmap value-dom? (list u v w))
+ (succeed-iff (= (+ u v) w))]
+ [else (add-constraint (+fd u v w))])
+
+ #;
+ (c-op +fd-c ([u : d_u] [v : d_v] [w : d_w])
+ (let ([wmin (min-dom d_w)] [wmax (max-dom d_w)]
+ [umin (min-dom d_u)] [umax (max-dom d_u)]
+ [vmin (min-dom d_v)] [vmax (max-dom d_v)])
+ (let ([new-w-dom (range (+ umin vmin) (+ umax vmax))]
+ [new-u-dom (range (- wmin vmax) (- wmax vmin))]
+ [new-v-dom (range (- wmin umax) (- wmax umin))])
+ (conj
+ (process-dom w new-w-dom)
+ (process-dom u new-u-dom)
+ (process-dom v new-v-dom))))))
-;; (define (plusfd-c u v w)
-;; (c-op plusfd-c ([u : d_u] [v : d_v] [w : d_w])
-;; (let ([wmin (min-dom d_w)] [wmax (max-dom d_w)]
-;; [umin (min-dom d_u)] [umax (max-dom d_u)]
-;; [vmin (min-dom d_v)] [vmax (max-dom d_v)])
-;; (let ([new-w-dom (range (+ umin vmin) (+ umax vmax))]
-;; [new-u-dom (range (- wmin vmax) (- wmax vmin))]
-;; [new-v-dom (range (- wmin umax) (- wmax umin))])
-;; (conj
-;; (process-dom w new-w-dom)
-;; (process-dom u new-u-dom)
-;; (process-dom v new-v-dom))))))
;;
;; (define (timesfd-c u v w)
;; (let ((safe-div (lambda (n c a) (if (zero? n) c (quotient a n)))))
@@ -350,7 +285,7 @@
;; a))))))
;;
;; (define fd-cs '(=/=fd-c distinctfd-c distinct/fd-c
-;; <=fd-c =fd-c plusfd-c timesfd-c))
+;; <=fd-c =fd-c +fd-c timesfd-c))
;; (define (fd-c? oc) (memq (oc-rator oc) fd-cs))
;;
;; (define (verify-all-bound s c bound-x*)
View
23 cKanren/unstable/interval-domain.rkt
@@ -245,18 +245,17 @@
(disjoint-dom? dom1 (cdr dom2)))
(else #f))))
-(define map-sum
- (lambda (f)
- (letrec
- ((loop
- (lambda (dom)
- (cond
- [(null-dom? dom) fail]
- [else
- (conde
- [(f (car-dom dom))]
- [(loop (cdr-dom dom))])]))))
- loop)))
+(define (map-sum f dom)
+ (letrec
+ ((loop
+ (lambda (dom)
+ (cond
+ [(null-dom? dom) fail]
+ [else
+ (conde
+ [(f (car-dom dom))]
+ [(loop (cdr-dom dom))])]))))
+ (loop dom)))
;; Uncomment for interval test programs!
Please sign in to comment.
Something went wrong with that request. Please try again.