SketchyLISP Stuff | Copyright (C) 2006 Nils M Holm |
[ More Sketchy LISP Stuff ] |
Conformance: R5RS
Purpose:
This is a small subset of the KANREN logic programming system,
which embeds logic programming idioms into Scheme programs.
This implementation has been inspired by
"The Reason Schemer" by Daniel P. Friedman, et al
and by "Sokuza Mini-KANREN" by Oleg Kiselyov.
AMK is discussed in "Logic Programming in Symbolic LISP"
http://www.lulu.com/content/377265
Implementation:
(define amk #t) (package 'amk) ; ===== core ========================================== (define (fail x) ()) (define (succeed x) (list x)) (define failed null?) (define (var x) (cons '? x)) (define (var? x) (and (pair? x) (eq? (car x) '?))) (define empty-s ()) (define BOTTOM (var 'bottom)) (define (atom? x) (not (pair? x))) (define (ext-s x v s) (cons (cons x v) s)) (define (walk x s) (cond ((not (var? x)) x) (#t (let ((v (assq x s))) (cond (v (walk (cdr v) s)) (#t x)))))) (define (unify x y s) (let ((x (walk x s)) (y (walk y s))) (cond ((eq? x y) s) ((var? x) (ext-s x y s)) ((var? y) (ext-s y x s)) ((or (atom? x) (atom? y)) #f) (#t (let ((s (unify (car x) (car y) s))) (and s (unify (cdr x) (cdr y) s))))))) (define (== g1 g2) (lambda (s) (let ((s2 (unify g1 g2 s))) (if s2 (succeed s2) (fail s))))) (define (any* . gs) (lambda (s) (letrec ((try (lambda gs (cond ((null? gs) (fail s)) (#t (append ((car gs) s) (apply try (cdr gs)))))))) (apply try gs)))) (define (any2 g1 g2) (lambda (s) (append (g1 s) (g2 s)))) (define-syntax any (syntax-rules () ((_) (fail '())) ((_ g) (lambda (s) (g s))) ((_ g1 g2 ...) (any2 (lambda (s) (g1 s)) (any g2 ...))))) (define (all . gs) (lambda (s) (letrec ((try (lambda (gs subs) (cond ((null? gs) subs) (#t (try (cdr gs) (apply append (map (car gs) subs)))))))) (try gs (succeed s))))) (define (one . gs) (lambda (s) (letrec ((try (lambda gs (cond ((null? gs) (fail s)) (#t (let ((out ((car gs) s))) (cond ((failed out) (apply try (cdr gs))) (#t out)))))))) (apply try gs)))) (define (neg g) (lambda (s) (let ((out (g s))) (cond ((failed out) (succeed s)) (#t (fail s)))))) (define (occurs x y s) (let ((v (walk y s))) (cond ((var? y) (eq? x y)) ((var? v) (eq? x v)) ((atom? v) #f) (#t (or (occurs x (car v) s) (occurs x (cdr v) s)))))) (define (circular x s) (let ((v (walk x s))) (cond ((eq? x v) #f) (#t (occurs x (walk x s) s))))) (define (walk* x s) (letrec ((w* (lambda (x s) (let ((x (walk x s))) (cond ((var? x) x) ((atom? x) x) (#t (cons (w* (car x) s) (w* (cdr x) s)))))))) (cond ((circular x s) BOTTOM) ((eq? x (walk x s)) empty-s) (#t (w* x s))))) (define (preserve-bottom s) (if (occurs BOTTOM s s) () s)) (define (reify-name n) (string->symbol (string-append "_," (number->string n)))) (define (reify v) (letrec ((reify-s (lambda (v s) (let ((v (walk v s))) (cond ((var? v) (ext-s v (reify-name (length s)) s)) ((atom? v) s) (#t (reify-s (cdr v) (reify-s (car v) s)))))))) (reify-s v empty-s))) (define (_) (var '_)) (define (run* x g) (preserve-bottom (map (lambda (s) (walk* x (append s (reify (walk* x s))))) (g empty-s)))) ; ===== tools ========================================= (define vp (var 'p)) (define vq (var 'q)) (define vr (var 'r)) (define (conso a d p) (== (cons a d) p)) (define (caro p a) (let ((x (var 'x))) (conso a x p))) (define (cdro p d) (let ((x (var 'x))) (conso x d p))) (define (pairo p) (let ((x (var 'x)) (y (var 'y))) (conso x y p))) (define (eqo x y) (== x y)) (define (nullo a) (eqo a ())) (define (eq-caro x p) (caro p x)) (define (membero x l) (any (all (eq-caro x l) succeed) (let ((vt (var 't))) (all (cdro l vt) (membero x vt))))) (define (rev-membero x l) (any (let ((vt (var 't))) (all (cdro l vt) (rev-membero x vt))) (all (eq-caro x l) succeed))) (define (reverseo l r) (rev-membero r l)) (define (appendo x y r) (any (all (== x ()) (== y r)) (let ((vh (var 'h)) (vt (var 't)) (va (var 'a))) (all (conso vh vt x) (conso vh va r) (appendo vt y va))))) (define (memo x l r) (any (all (eq-caro x l) (== l r)) (let ((vt (var 't))) (all (cdro l vt) (memo x vt r))))) (package)
Example:
(run* vq (appendo vq (_) '(a b c))) => (() (a) (a b) (a b c))
[ More Sketchy LISP Stuff ] |