diff options
Diffstat (limited to 'vikalpa.scm')
| -rw-r--r-- | vikalpa.scm | 58 |
1 files changed, 35 insertions, 23 deletions
diff --git a/vikalpa.scm b/vikalpa.scm index f45a571..671082a 100644 --- a/vikalpa.scm +++ b/vikalpa.scm @@ -280,17 +280,16 @@ (mat-preconds (cdr rlps) (let search ((ps preconds)) - (when (equal? rl '(rule (x y) ((natural? y) (natural? x)) (quote #t) (natural? (+ x y)))) - (format #t "search~% rl: ~s~% rlps: ~s~% ps: ~s~% env: ~s~%" rl rlps ps (cdr k+env))) (if (null? ps) - ((car k+env) #f) + (shift k ((car k+env) #f)) (let ((env (mat-begin (car rlps) (car ps) (cdr k+env)))) (cond ((mat-begin (car rlps) (car ps) (cdr k+env)) => (lambda (env) (shift k0 - (reset (or (shift k (k0 (cons k env))) - (k0 (search (cdr ps)))))))) + (reset + (or (shift k (k0 (cons k env))) + (k0 (search (cdr ps)))))))) (else (search (cdr ps)))))))))) (define (valid? env expr) (cond ((expr-quoted? expr) #t) @@ -847,7 +846,6 @@ (else (fail 'apply-theorem cmd expr))))) -;; (rewrite system? rewriter? expression? procedure?) -> expr (define (rewrite1 sys expr fail r) (let* ((cmd (rewriter-command r)) (cmd/name (command-name cmd))) @@ -861,7 +859,19 @@ (('equal? `(quote ,x) `(quote ,y)) (expr-quote (equal? x y))) (else - (fail 'equal? 'extracted-expr)))) + (fail 'equal? extracted-expr)))) + ((eq? 'pair? cmd/name) + (match extracted-expr + (('pair? `(quote ,x)) + (expr-quote (pair? x))) + (else + (fail 'pair? extracted-expr)))) + ((eq? 'not cmd/name) + (match extracted-expr + (('not `(quote ,x)) + (expr-quote (not x))) + (else + (fail 'not extracted-expr)))) ((eq? 'error cmd/name) (fail extracted-expr)) ((and (symbol? cmd/name) (lookup cmd/name sys)) @@ -879,21 +889,19 @@ (fail 'invalid-command cmd extracted-expr))))) (else (fail 'command-not-found cmd extracted-expr))))))) -(define/guard (rewrite (sys system?) (expr expression?) (seq sequence?)) - (debug "rewrite ~y~%" expr) - (let loop ((expr expr) - (seq seq)) - (debug "~y~%" expr) - #;(format #t "~y~%" expr) - (reset - (if (null? seq) - expr - (loop (rewrite1 sys - expr - (lambda args - (shift k (cons 'error args))) - (car seq)) - (cdr seq)))))) +(define/guard (rewrite (sys system?) (expr (const #t)) (seq sequence?)) + (let ((expr (convert-to-expression expr))) + (let loop ((expr expr) + (seq seq)) + (reset + (if (null? seq) + expr + (loop (rewrite1 sys + expr + (lambda args + (shift k (cons 'error args))) + (car seq)) + (cdr seq))))))) (define (expr-not x) (list 'not x)) @@ -928,7 +936,10 @@ (expression->rules vars (cons (prop-not (if-form-test expr)) preconds) - (if-form-else expr))) + (if-form-else expr)) + (expression->rules vars + preconds + (if-form-test expr))) (if (expr-equal? expr) (list (rule vars preconds @@ -1063,6 +1074,7 @@ (parameterize ((current-system parent)) (define-primitive-function not (x)) (define-primitive-function equal? (x y)) + (define-primitive-function pair? (x y)) (define-primitive-function cons (x y)) (define-primitive-function car (x)) (define-primitive-function cdr (x)) |