Add prolog module

d-/prolog.scm

@@ -0,0 +1,196 @@
+(define-module (d- prolog)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 control)
+  #:use-module (d- oop)
+  #:export (fresh fresh-anon deref rename-vars
+            unify! undo-bindings! trail-marker
+            *db* add-clause! add-primitive! clear-db! prove! solution-generator
+            with-db <- ?-))
+
+;;; Vars and variables
+(define (variable? x)
+  (and (symbol? x) (eq? #\? (string-ref (symbol->string x) 0))))
+
+(define unbound (make-symbol "unbound"))
+
+(define-record var name binding flags)
+
+(set-record-type-printer! <var>
+  (lambda (var port)
+    (format port "[?~a]" (var-name var))))
+
+(define (fresh name)
+  "Creates a new, unbound var with a name"
+  (make-var name unbound '()))
+
+(define (fresh-anon)
+  "Creates a new, unbound anonymous var"
+  (make-var (gensym "anon") unbound '(anon)))
+
+(define (bound? var)
+  (not (eq? (var-binding var) unbound)))
+
+(define (anon? var)
+  (or (eq? '? var)
+      (and (var? var) (memq 'anon (var-flags var)))))
+
+(define (deref exp)
+  "Recursively follow the bindings for exp to a non-var value"
+  (if (and (var? exp) (bound? exp))
+      (deref (var-binding exp))
+      exp))
+
+;; (define-syntax deref
+;;   (syntax-rules ()
+;;     [(_ exp)
+;;      (begin (while (and (var? exp) (bound? exp))
+;;               (set! exp (var-binding exp)))
+;;             exp)]))
+
+(define (rename-vars x)
+  "Assign a new name to all non-literals. 
+Accepts clauses with both vars and symbolic variables"
+  (define names '())
+  (define (rename x)
+    (cond
+     [(anon? x) (fresh-anon)]
+     [(assoc x names) => cdr]
+     [(or (variable? x) (var? x))
+      (let [($x (fresh (if (variable? x) (substring (symbol->string x) 1)
+                           (var-name x))))]
+        (set! names (assq-set! names x $x))
+        $x)]
+     [(pair? x) (cons (rename (car x)) (rename (cdr x)))]
+     [else x]))
+  (rename x))
+
+;;; Unification
+(define-once *trail* vlist-null)
+
+(define (unify! x y)
+  "(Destructively) unify two expressions. Bindings can be undone 
+by calling undo-bindings! with the value of trail-marker before the unification"
+  (let ([$x (deref x)]
+        [$y (deref y)])
+    (cond
+     [(equal? $x $y) #t]
+     [(and (var? $x) (not (bound? $x))) (set-binding! $x $y)]
+     [(and (var? $y) (not (bound? $y))) (set-binding! $y $x)]
+     [(and (pair? $x) (pair? $y))
+      (and (unify! (car $x) (car $y))
+           (unify! (cdr $x) (cdr $y)))]
+     [else #f])))
+
+(define (set-binding! var val)
+  (set! (var-binding var) val)
+  (set! *trail* (vlist-cons var *trail*))
+  #t)
+
+(define (undo-bindings! saved-marker)
+  "Undoes bindings since saved-marker. Always returns #f"
+  (unless (or (= (trail-marker) saved-marker)
+              (vlist-null? *trail*))
+    (set! (var-binding (vlist-head *trail*)) unbound)
+    (set! *trail* (vlist-tail *trail*))
+    (undo-bindings! saved-marker))
+  #f)
+
+(define (trail-marker)
+  "Returns the current marker on the undo trail"
+  (vlist-length *trail*))
+
+;;; Database operations
+(define* (prove! goals #:optional cb)
+  "Prove all goals by unifying with facts in the database.
+Accepts a callback which will be called when a solution is found"
+  (cond
+   [(and (null? goals) cb) (cb)]
+   [(null? goals) #t]
+   [else (let ([clauses/proc (get-clauses (predicate (car goals)))]
+               [marker (trail-marker)])
+           ((if (procedure? clauses/proc) prove-primitive! prove-rule!)
+            clauses/proc goals marker cb))]))
+
+(define (prove-primitive! proc goals trail cb)
+  (if (apply proc (cdar goals))
+      (prove! (cdr goals) cb)
+      (undo-bindings! trail)))
+
+(define (prove-rule! clauses goals trail cb)
+  (find
+   (lambda (clause)
+     (let ([renamed-clause (rename-vars clause)])
+       (if (and (unify! (car goals) (clause-head renamed-clause))
+                (prove! (append (clause-body renamed-clause) (cdr goals)) cb))
+           #t
+           (undo-bindings! trail))))
+   clauses))
+
+(define-once *db* (make-parameter '()))
+
+(define predicate car)
+(define clause-head car)
+(define clause-body cdr)
+
+(define (get-clauses pred)
+  (or (assq-ref (*db*) pred) '()))
+
+(define (add-clause! clause)
+  "Insert a clause into the rules database"
+  (let ([pred (predicate (clause-head clause))])
+    (*db* (assq-set! (*db*)
+                     pred
+                     (append (or (assq-ref (*db*) pred) '()) (list clause))))
+    (*db*)))
+
+(define (add-primitive! pred f)
+  "Insert a primitive that can be called with pred"
+  (*db* (assq-set! (*db*) pred f)))
+
+(define (clear-db!)
+  "Empty the rules database"
+  (*db* '()))
+
+(define (vars-in exp)
+  (cond
+   [(and (var? exp) (not (memq 'anon (var-flags exp))))
+    (list (cons (string->symbol (string-append "?" (var-name exp))) (deref exp)))]
+   [(pair? exp) (append (vars-in (car exp))
+                        (vars-in (cdr exp)))]
+   [else '()]))
+
+(define (solution-generator goals)
+  "Return a function that can be repeatedly called to obtain solutions to goals"
+  (define solution-tag (make-prompt-tag))
+  (define renamed-goals (rename-vars goals))
+  (define (thunk) (prove! renamed-goals (lambda () (abort-to-prompt solution-tag))))
+  (lambda ()
+    (call-with-prompt solution-tag
+      thunk
+      (lambda (k)
+        (set! thunk (lambda () (k #f)))
+        (vars-in renamed-goals)))))
+
+ ;;; Interface macros
+;; Note that these macros provide nothing that cannot be done via the lower level api
+(define-syntax with-db
+  (syntax-rules ()
+    [(_ db body ...)
+     (parameterize ([*db* db])
+       body ...
+       (cond
+        [(parameter? db) (db (*db*))]
+        [else
+         (set! db (*db*))
+         db]))]))
+
+(define-syntax <-
+  (syntax-rules ()
+    [(_ relations ...) (add-clause! '(relations ...))]))
+
+(define-syntax ?-
+  (syntax-rules ()
+    [(_ goals ...) (solution-generator '(goals ...))]))

test.scm

@@ -1,7 +1,8 @@
 (use-modules (d-)
-	     (d- json)
-	     (srfi srfi-1)
-	     (d- test))
+             (d- json)
+             (srfi srfi-1)
+             (d- test)
+             (d- prolog))
 
 (define-test-suite "~>"
   (define-test "unwrapped"
@@ -145,14 +146,57 @@
   (define-test "object"
     (assert-equal '() (json "{}"))
     (assert-equal '((cat . 1)
-		    (bat . #t)
-		    (rat . "yessir"))
-		  (json "{\"cat\": 1, \"bat\": true, \"rat\": \"yessir\"}"))
+                    (bat . #t)
+                    (rat . "yessir"))
+                  (json "{\"cat\": 1, \"bat\": true, \"rat\": \"yessir\"}"))
     (assert-equal '((butter . 1)
-		    (brownie))
-		  (json "{\"butter\": 1, \"brownie\": {}}"))
+                    (brownie))
+                  (json "{\"butter\": 1, \"brownie\": {}}"))
     (assert-equal '(1 2)
-		  (json "{\"hello\": 1, \"world\": 2}"
-			#:obj-acons
-			(lambda (_key value rest)
-			  (cons value rest))))))
+                  (json "{\"hello\": 1, \"world\": 2}"
+                        #:obj-acons
+                        (lambda (_key value rest)
+                          (cons value rest))))))
+
+(define-test-suite "prolog"
+  ;; Stolen verbatim from PAIP (Norvig 92)
+  (define-test "zebra"
+    (<- (member ?item (?item . ?rest)))
+    (<- (member ?item (?x . ?rest)) (member ?item ?rest))
+
+    (<- (nextto ?x ?y ?list) (iright ?x ?y ?list))
+    (<- (nextto ?x ?y ?list) (iright ?y ?x ?list))
+
+    (<- (iright ?left ?right (?left ?right . ?rest)))
+    (<- (iright ?left ?right (?x . ?rest))
+        (iright ?left ?right ?rest))
+
+    (<- (= ?x ?x))
+
+    (<- (zebra ?h ?w ?z)
+        (= ?h ((house norwegian ? ? ? ?)
+               ?
+               (house ? ? ? milk ?) ? ?))
+        (member (house englishman ? ? ? red) ?h)
+        (member (house spaniard dog ? ? ?) ?h)
+        (member (house ? ? ? coffee green) ?h)
+        (member (house ukrainian ? ? tea ?) ?h)
+        (iright (house ? ? ? ? ivory)
+                (house ? ? ? ? green) ?h)
+        (member (house ? snails winston ? ?) ?h)
+        (member (house ? ? kools ? yellow) ?h)
+        (nextto (house ? ? chesterfield ? ?)
+                (house ? fox ? ? ?) ?h)
+        (nextto (house ? ? kools ? ?)
+                (house ? horse ? ? ?) ?h)
+        (member (house ? ? luckystrike orange-juice ?) ?h)
+        (member (house japanese ? parliaments ? ?) ?h)
+        (nextto (house norwegian ? ? ? ?)
+                (house ? ? ? ? blue) ?h)
+
+        (member (house ?w ? ? water ?) ?h)
+        (member (house ?z zebra ? ? ?) ?h))
+    (define get-solution (?- (zebra ? ?water-drinker ?zebra-owner)))
+    (define solution (get-solution))
+    (assert-equal 'norwegian (assq-ref solution '?water-drinker))
+    (assert-equal 'japanese (assq-ref solution '?zebra-owner))))