Skip to content
Browse files

lazy appendo for will

  • Loading branch information...
1 parent 4fe1ac5 commit b2f657412bb50cc0c8c2d4b45475a52570452d29 @calvis committed
Showing with 59 additions and 10 deletions.
  1. +1 −1 ck-lang.rkt
  2. +42 −0 tests/lazy-appendo.rkt
  3. +15 −8 tests/tester.rkt
  4. +1 −1 tree-unify.rkt
View
2 ck-lang.rkt
@@ -16,7 +16,7 @@
(define-syntax trace-define
(syntax-rules ()
[(_ (name a* ...) body)
- (trace-define-mk name (lambda (a* ...) body))]
+ (trace-define name (lambda (a* ...) body))]
[(_ name (λ (a* ...) body))
(define name
(λ (a* ...)
View
42 tests/lazy-appendo.rkt
@@ -0,0 +1,42 @@
+#lang racket
+
+(require "../ck.rkt" "../tree-unify.rkt")
+
+(define (appendo l s out)
+ (goal-construct (append-c l s out)))
+
+(define (append-c ls1 ls2 out)
+ (lambdam@ (a : s c)
+ ((update-c (build-oc append-c ls1 ls2 out)) a)))
+
+(define (enforce-appendo oc)
+ (let ([ls1 (car (oc-rands oc))]
+ [ls2 (cadr (oc-rands oc))]
+ [out (caddr (oc-rands oc))])
+ (conde
+ ((== ls1 '())
+ (== ls2 out))
+ ((fresh (a d res)
+ (appendo d ls2 res)
+ (== ls1 `(,a . , d))
+ (== out `(,a . ,res)))))))
+
+(define (do-enforce-appendo x)
+ (lambdag@ (a : s c)
+ ((let ([ocs (filter/rator 'append-c c)])
+ (let loop ([ocs ocs])
+ (cond
+ [(null? ocs) succeed]
+ [else
+ (fresh ()
+ (enforce-appendo (car ocs))
+ (loop (cdr ocs)))])))
+ a)))
+
+(define (append l s)
+ (cond
+ [(null? l) s]
+ [else (cons (car l) (append (cdr l s)))]))
+
+
+(extend-enforce-fns 'appendo do-enforce-appendo)
View
23 tests/tester.rkt
@@ -6,19 +6,26 @@
(define max-ticks 10000000)
(define-syntax (test x)
+ (define (test-syntax te er)
+ (quasisyntax/loc x
+ (let ([expected #,er] [produced #,te])
+ (cond
+ [(equal? expected produced) (void)]
+ [else
+ (make-error #,(build-srcloc x)
+ (string-append
+ "error while running tests\n"
+ "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)
- (let ([expected expected-result]
- [produced tested-expression])
- (cond
- [(equal? expected produced) (void)]
- [else
- (make-error #,(build-srcloc x)
- "error while running tests\nExpression: ~a~%Expected: ~a~%Computed: ~a~%"
- 'tested-expression expected produced)])))))))
+ #,(test-syntax #'tested-expression #'expected-result))))
+ ((_ tested-expression expected-result)
+ (quasisyntax/loc x
+ #,(test-syntax #'tested-expression #'expected-result)))))
(define (make-error src msg . exprs)
(cond
View
2 tree-unify.rkt
@@ -1,7 +1,7 @@
#lang racket
(require "ck.rkt")
-(provide == unify)
+(provide == ==-c unify)
;; ---UNIFICATION--------------------------------------------------

0 comments on commit b2f6574

Please sign in to comment.
Something went wrong with that request. Please try again.