Browse files

Fixing some bugs in ck, and adding a new file for pref and preftests

  • Loading branch information...
1 parent f942702 commit 620bdfdc2552c624c49ba6f388f0066bf057eda5 @calvis committed Apr 16, 2012
Showing with 120 additions and 4 deletions.
  1. +4 −4 ck.scm
  2. +95 −0 pref.scm
  3. +21 −0 preftests.scm
View
8 ck.scm
@@ -10,7 +10,7 @@
;; mk
lhs rhs walk walk* var? lambdag@ mzerog unitg onceo
- conde conda condu ifa ifu project fresh succeed :)
+ conde conda condu ifa ifu project fresh succeed fail :)
(import
(rnrs)
@@ -229,10 +229,10 @@
(define run-reify-fns
(lambda (v r c)
- (let loop ((fns (reify-fns)) (c c))
+ (let loop ((fns (reify-fns)) (c^ `()))
(cond
- ((null? fns) c)
- (else (loop (cdr fns) ((cdar fns) v r c)))))))
+ ((null? fns) c^)
+ (else (loop (cdr fns) (append ((cdar fns) v r c) c^)))))))
;; ---MACROS-------------------------------------------------------
View
95 pref.scm
@@ -0,0 +1,95 @@
+;; prefo allows the user to assign a variable several acceptable
+;; values without generating extra answers.
+;;
+;; It is possible to assign a "preference" list to a variable, where
+;; the list is in order by preference. For example,
+;;
+;; ... (prefo x '(1 2 3)) ...
+;;
+;; will unify x and 1 if the program reaches the end with x still
+;; unground. It is also acceptable if x is unified with any value
+;; in the domain zbefore reification.
+;;
+;; This goal is not compatitble with =/= (from neq.scm)
+
+(library
+ (pref)
+ (export
+ prefo
+ usepref
+ get-dom
+ enforce-constraintspref)
+ (import
+ (rnrs)
+ (ck)
+ (mk))
+
+ (define prefo
+ (lambda (x l)
+ (goal-construct (prefo-c x l))))
+
+ (define prefo-c
+ (lambda (x l)
+ (lambdam@ (a : s d c)
+ ((process-prefdom (walk x s) l) a))))
+
+ (define process-prefdom
+ (lambda (x l)
+ (lambdam@ (a : s d c)
+ (cond
+ ((var? x)
+ (identitym (make-a s (ext-d x l d) c)))
+ ((memq x l) (identitym a))
+ (else #f)))))
+
+ (define get-dom
+ (lambda (x d)
+ (cond
+ ((assq x d) => rhs)
+ (else #f))))
+
+ (define (pick-prefs)
+ (lambdam@ (a : s d c)
+ ((letrec
+ ((loop
+ (lambda (d)
+ (cond
+ ((null? d) unitg)
+ (else
+ (let ((x (walk (caar d) s)))
+ (cond
+ ((var? x)
+ (fresh ()
+ (== x (cadar d))
+ (loop (cdr d))))
+ (else (loop (cdr d))))))))))
+ (loop d))
+ a)))
+
+ (define process-prefixpref
+ (lambda (p c)
+ (cond
+ ((null? p) identitym)
+ (else
+ (let ((x (lhs (car p))) (v (rhs (car p))))
+ (lambdam@ (a : s d c)
+ (cond
+ ((and (not (var? v)) (get-dom x d))
+ => (lambda (dom)
+ (and (memq v dom)
+ ((process-prefixpref (cdr p) c) a))))
+ (else ((process-prefixpref (cdr p) c) a)))))))))
+
+ (define reify-constraintspref identitym)
+
+ (define enforce-constraintspref
+ (lambda (x)
+ (goal-construct (pick-prefs))))
+
+ (define usepref
+ (lambda ()
+ (process-prefix process-prefixpref)
+ (reify-constraints reify-constraintspref)
+ (enforce-constraints enforce-constraintspref)))
+
+)
View
21 preftests.scm
@@ -0,0 +1,21 @@
+(library (cKanren preftests)
+ (export run-preftests)
+ (import
+ (rnrs)
+ (cKanren ck)
+ (cKanren tree-unify))
+
+ (define (run-preftests)
+
+ (test-check "pref 1"
+ (run* (q) (prefo q '(1 2 3)))
+ `(1))
+ (test-check "pref 2"
+ (run* (q) (prefo q '(1 2 3)) (== q 3))
+ `(3))
+ (test-check "pref 3"
+ (run* (q) (prefo q '(1 2 3)) (== q 4))
+ `())
+ )
+
+ )

0 comments on commit 620bdfd

Please sign in to comment.