all used gl- primitives now uses a state parameter all tests passes

parent 178434c6
......@@ -151,7 +151,8 @@
((match-two (abs ((car cdr pair? null? equal? id) pp)) s v ()
g+s (sk ...) fk i)
(let ((s (null? v s)))
(let* ((w (id v s))
(s (null? w s)))
(if s
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) (sk ... i))
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
......@@ -173,14 +174,14 @@
((match-two (abs ((ccar ccdr ppair? null? equal? id) rr)) s v
((unquote-splicing p) . ps) g+s sk fk i)
(let loop ((vv (id v))
(let loop ((vv (id v s))
(pp p))
(if (pair? pp)
(let ((s (ppair? vv s)))
(if s
(let ((s (equal? (ccar vv) (car pp) s)))
(if s
(loop (id (ccdr vv)) (cdr pp))
(loop (id (ccdr vv) s) (cdr pp))
(insert-abs (abs ((ccar ccdr ppair? null? equal? id)
rr)) fk)))
(insert-abs (abs ((ccar ccdr ppair? null? equal? id)
......@@ -290,12 +291,13 @@
(define-syntax match-three*
(syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
((match-two (abs ((car cdr pair? null? id) rr)) s v (p) g+s sk fk i)
(let ((w (id v)))
(let ((w (id v s)))
(let ((s (pair? w s)))
(if s
(let ((s (null? (cdr (id w)) s)))
(let ((s (null? (id (cdr (id w s)) s) s)))
(if s
(let ((w (car (id w))))
(let ((w (car (id w s))))
(match-one (abs ((car cdr pair? null? id) rr)) s w p
((car w)
(set-car! w)) sk fk i))
......@@ -310,10 +312,10 @@
((match-two (abs ((car cdr pair? null? equal? id) pp)) s v (p . q)
g+s sk fk i)
(let ((ww (id v)))
(let ((ww (id v s)))
(let ((s (pair? ww s)))
(if s
(let ((ww (id ww)))
(let ((ww (id ww s)))
(let ((w (car ww)) (x (cdr ww)))
(match-one (abs ((car cdr pair? null? equal? id) pp)) s w p
((car ww) (set-car! ww))
......
......@@ -6,7 +6,7 @@
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (system repl repl)
#:re-export (u-cons u-abort u-var! u-scm u-unify! u-unify-raw!)
#:re-export (gp-cons! gp-lookup gp-var! gp->scm gp-unify! gp-unify-raw! gp-m-unify!)
#:export (umatch))
(define-syntax umatch (syntax-rules () ((_ . l) (**um** . l))))
......
......@@ -47,10 +47,10 @@
(define succeed (lambda (s p cc) (cc s p))) ; eta-reduced
(define fail (lambda (s p cc) (p)))
(define sfail fail)
(define var? gp-var?)
(define var? gp-logical-var?)
(define reify (lambda (x)
(tr 'v. x)))
(tr 'v. x '())))
(define-syntax let-lv
(syntax-rules ()
......@@ -59,20 +59,19 @@
(define-syntax extend-relation-with-recur-limit
(syntax-rules ()
((_ limit ids rel ...)
((_ limit ids rel ...)
(let ((*counter* (gp-var!)))
(lambda ids
(let ((gl (any (rel . ids) ...)))
(if (gp-var? *counter*)
(begin
(gp-set! *counter* 0)
gl)
(let ((cnt (gp-lookup *counter*)))
(if (<= limit cnt)
sfail
(begin
(gp-set! *counter* (+ cnt 1))
gl))))))))))
(lambda (s p cc)
(if (gp-var? *counter* s)
(let ((s (gp-set! *counter* 0 s)))
(gl s p cc))
(let ((cnt (gp-lookup *counter* s)))
(if (<= limit cnt)
(sfail s p cc)
(let ((s (gp-set! *counter* (+ cnt 1) s)))
(gl s p cc))))))))))))
; The anonymous variable
(define-syntax _
......@@ -469,21 +468,23 @@
(define nonvar!
(lambda (t)
(if (gp-var? t)
(if (var? t)
(error "Logic variable found at lookup")
t)))
(define-syntax project
(syntax-rules ()
((_ (var ...) gl)
(let ((var (nonvar! (gp-lookup var))) ...)
gl))))
(lambda (s p cc)
(let ((var (nonvar! (gp-lookup var s))) ...)
(gl s p cc))))))
(define-syntax project/no-check
(syntax-rules ()
((_ (var ...) gl)
(let ((var (gp-lookup var)) ...)
gl))))
(lambda (s p cc)
(let ((var (gp-lookup var s)) ...)
(gl s p cc))))))
......
......@@ -51,26 +51,28 @@
(define tr
(case-lambda
((x) (tr (fluid-ref *gp-var-tr*) x))
((pre x)
((x s)
(tr (fluid-ref *gp-var-tr*) x s))
((pre x s)
(define a '())
(define n 0)
(let loop ((x (gp->scm x)))
(let loop ((x (gp->scm x s)))
(match x
((x . l)
(cons (loop x) (loop l)))
((? gp-var? x)
(let* ((m (gp-var-number (gp-lookup x)))
(r (assoc m a)))
(if r
(cdr r)
(let ((k (string->symbol
(format #f "~a~a" pre n))))
(set! a (cons (cons m k) a))
(set! n (+ n 1))
k))))
(else
x))))))
(x
(if (gp-var? x s)
(let* ((m (gp-var-number (gp-lookup x s)))
(r (assoc m a)))
(if r
(cdr r)
(let ((k (string->symbol
(format #f "~a~a" pre n))))
(set! a (cons (cons m k) a))
(set! n (+ n 1))
k)))
x)))))))
(define-syntax <run>
(syntax-rules (*)
......@@ -83,7 +85,7 @@
(gp-unwind fr)
(reverse ret))
(lambda (s p)
(ret-set! (cons (tr (gp->scm v)) ret))
(ret-set! (cons (tr (gp->scm v s) s) ret))
(p))))))
((_ (v ...) code ...)
......@@ -97,7 +99,7 @@
(gp-unwind fr)
(reverse r)))
(lambda (s p)
(ret-set! (cons (tr (gp->scm (list v ...))) ret))
(ret-set! (cons (tr (gp->scm (list v ...) s) s) ret))
(p))))))
......@@ -118,16 +120,16 @@
(let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '())
(p))))
(p))) s)
r)
(begin
(n-ret-set! (- n 1)
(cons (tr (gp->scm v)) ret))
(cons (tr (gp->scm v s) s) ret))
(if (= n 0)
(let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '())
(p))))
(p))) s)
r)
(p)))))))))
......@@ -147,16 +149,18 @@
(let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '())
(p))))
(p)))
s)
r)
(begin
(n-ret-set! (- n 1)
(cons (tr (list (gp->scm v) ...)) ret))
(cons (tr (list (gp->scm v s) ...) s) ret))
(if (= n 0)
(let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '())
(p))))
(p)))
s)
r)
(p)))))))))))
......@@ -386,24 +390,25 @@
(define-guile-log <pp>
(syntax-rules ()
((_ wc x) (begin (pp (gp->scm x))
(parse<> wc <cc>)))))
((_ (cut s p cc) x)
(begin (pp (gp->scm x s))
(parse<> (cut s p cc) <cc>)))))
(log-code-macro '<pp>)
(define-guile-log <pp-dyn>
(syntax-rules ()
((_ wc a b)
((_ (cut s p cc) a b)
(gp-dynwind
(lambda () (pp (gp->scm a)))
(lambda () (parse<> wc <cc>))
(lambda () (pp (gp->scm b)))))))
(lambda () (pp (gp->scm a s)))
(lambda () (parse<> (cut s p cc) <cc>))
(lambda () (pp (gp->scm b s)))))))
(define-guile-log <format>
(syntax-rules ()
((_ wc s str a ...)
((_ (cut s p cc) stream str a ...)
(begin
(format s str (gp-scm a) ...)
(parse<> wc <cc>)))))
(format stream str (gp->scm a s) ...)
(parse<> (cut s p cc) <cc>)))))
(log-code-macro '<format>)
(define-guile-log <tail-code>
......@@ -440,7 +445,8 @@
<cut>
<repl-vars> last)
((_ meta (<not> X )) (<%not%> meta X ))
((_ meta (<ret> code) ) (gp->scm code))
((_ (cut s p cc) (<ret> code) )
(gp->scm code s))
((_ meta <fail> ) (<%fail%> meta))
((_ meta (<fail> p) ) (<%fail%> meta p))
((_ meta <cc> ) (<%cc%> meta))
......@@ -716,7 +722,7 @@
(define (<funcall> S P CC F . L) (apply (gp->scm F) `(,S ,P ,CC ,@L)))
(define (<funcall> S P CC F . L) (apply (gp->scm F S) `(,S ,P ,CC ,@L)))
(define-syntax <def>
(syntax-rules ()
......
......@@ -29,15 +29,14 @@
gp->scm gp-print
gp-budy gp-swap-to-a gp-swap-to-b gp-m-unify!
gp-lookup
gp-var? gp-cons! gp-set! u-list
gp-var? gp-cons! gp-set!
gp-printer gp-var-number
gp-car gp-cdr gp-pair?
gp-store-state gp-restore-state gp-restore-wind
gp-make-fluid gp-fluid-set! gp-fluid-ref with-gp-fluids
gp-dynwind
u-prompt u-abort u-set! u-var! u-call u-deref gp-atomic?
u-context u-modded
u-unify! u-scm u-unify-raw! u-cons u-dynwind umatch
gp-atomic?
umatch gp-logical-var?
gp-copy **um** gp-get-stack
push-setup que-setup
with-guarded-states with-guarded-globals gp->scm))
......@@ -57,9 +56,21 @@
(gp-module-init)
(define gscm gp->scm)
(define (gp->scm x s)
(gscm x))
(define gset! gp-set!)
(define (gp-set! x v s)
(gset! x v))
(define gvar? gp-var?)
(define (gp-var? x s)
(gvar? x))
(define gpn gp-newframe)
(define (gp-newframe x)
(if x
(if (or (null? x) (pair? x))
(cons (gpn) (cdr x))
(cons (gpn) '())))
......@@ -70,6 +81,12 @@
(gpun (car x))
(do-setup))
(define (gp-logical-var? x)
(gvar? x))
(define glup gp-lookup)
(define (gp-lookup x s)
(glup x))
(define gpun! gp-unify!)
(define (gp-unify! x y s)
......@@ -211,7 +228,7 @@
(define (get-line x u)
(if (gp? x)
(let ((x (gp-lookup x)))
(let ((x (glup x)))
(if (and (gp? x) (gppair x))
(get-line (gp-cdr x) (cons (gp-car x) u))
(if (null? x)
......@@ -226,7 +243,7 @@
(format port "<#gp {~{~a~}~a}>" l d)
(format port "<#gp {~a ~{ ~a~}~a}>" (car l) (cdr l) d)))
(let ((x (gp-lookup x)))
(let ((x (glup x)))
(if (gp? x)
(if (gppair x)
(let-values (((l d) (get-line x '())))
......@@ -237,13 +254,16 @@
(format port "<#~a>" varn)))
(format port "<#gp ~a>" x))))
(define gp-fluid-ref gp-lookup)
(define gp-fluid-ref
(case-lambda
((x) (glup x))
((x s) (glup x s))))
(define-syntax with-gp-fluids
(syntax-rules ()
((_ ((f v) ...) code ...)
((_ s ((f v) ...) code ...)
(begin
(u-set! f v)
(gp-set! f v s)
...
code
...))))
......@@ -262,46 +282,6 @@
;;prompts will be just a continuation lambda
(define-syntax u-prompt
(syntax-rules ()
((_ x) x)))
(define-syntax u-abort
(syntax-rules ()
((_ x) (x))))
(define-syntax u-call
(syntax-rules ()
((_ g f ...) (f ...))))
(define-syntax u-var!
(syntax-rules ()
((_) (gp-var!))))
(define-syntax u-scm
(syntax-rules ()
((_ x) (gp->scm x))))
(define-syntax u-set!
(syntax-rules ()
((_ x y) (gp-set! x y))))
(define-syntax u-cons
(syntax-rules ()
((_ x y) (gp-cons! x y))))
(define-syntax u-unify!
(syntax-rules ()
((_ x y) (gp-unify! x y))))
(define-syntax u-unify-raw!
(syntax-rules ()
((_ x y) (gp-unify-raw! x y))))
(define-syntax u-modded
(syntax-rules ()
((_) #t)))
(define (id x) x)
......
......@@ -13,7 +13,7 @@
( _ (<var> (Q UnplacedQs1)
(<and> (selectq Q UnplacedQs UnplacedQs1)
(<not> (attack Q SafeQs))
(queens3 UnplacedQs1 (u-cons Q SafeQs) Qs))))
(queens3 UnplacedQs1 (gp-cons! Q SafeQs) Qs))))
('() (<=> SafeQs Qs))
( _ <fail>)))
......@@ -21,8 +21,8 @@
(<define> (attack3 X N V)
(<match> () (V)
((Y . _) (<or> (<when> (eq? (u-scm X) (+ (u-scm Y) N)))
(<when> (eq? (u-scm X) (- (u-scm Y) N)))))
((Y . _) (<or> (<when> (eq? (gp->scm X '()) (+ (gp->scm Y '()) N)))
(<when> (eq? (gp->scm X '()) (- (gp->scm Y '()) N)))))
((_ . Y) (attack3 X (+ N 1) Y))
(_ <fail>)))
......
......@@ -1345,7 +1345,7 @@
(addero 0 '(1) m r))
((<=> ('(1) '(1)) (n m))
(<var> (a c)
(<=> r ,`(,a ,c))
(<=> r (a c))
(full-addero d 1 1 a c)))
((<=> '(1) n)
(gen-addero d n m r))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment