Changeset 35102 in project

Timestamp:

02/01/18 07:33:54 (9 months ago)

Author:

kon

Message:

test other ex , add xtra , mk solver own mod

Location:

release/4/amb/trunk

Files:

• amb-dwelling.scm (modified) (2 diffs)
• amb-extras.scm (modified) (4 diffs)
• amb-kalotan.scm (modified) (2 diffs)
• amb-money.scm (modified) (3 diffs)
• amb-pl-solver.scm (added)
• amb-pythagorean.scm (modified) (1 diff)
• amb-sat-solve.scm (modified) (1 diff)
• amb.meta (modified) (1 diff)
• amb.scm (modified) (4 diffs)
• tests/amb-test.scm (added)
• tests/run.scm (modified) (1 diff)

release/4/amb/trunk/amb-dwelling.scm

@@ -1 +1 @@
 ;;;; amb-dwelling.scm
 
-(require-extension amb amb-extras)
+(use amb amb-extras)
 
 ;; Baker, Cooper, Fletcher, Miller, and Smith live on different
@@ -14 +14 @@
 
 (define (solve-dwelling-puzzle)
-
-  (let ((baker (amb 1 2 3 4 5))
-        (cooper (amb 1 2 3 4 5))
-        (fletcher (amb 1 2 3 4 5))
-        (miller (amb 1 2 3 4 5))
-        (smith (amb 1 2 3 4 5)))
-
+  ;
+  (let (
+    (baker (amb 1 2 3 4 5))
+    (cooper (amb 1 2 3 4 5))
+    (fletcher (amb 1 2 3 4 5))
+    (miller (amb 1 2 3 4 5))
+    (smith (amb 1 2 3 4 5)) )
+    ;
     ;; They live on different floors.
     (required (distinct? (list baker cooper fletcher miller smith)))
-
+    ;
     ;; Baker does not live on the top floor.
     (required (not (= baker 5)))
-
+    ;
     ;; Cooper does not live on the bottom floor.
     (required (not (= cooper 1)))
-
+    ;
     ;; Fletcher does not live on either the top or the bottom floor.
     (required (not (= fletcher 5)))
     (required (not (= fletcher 1)))
-
+    ;
     ;; Miller lives on a higher floor than does Cooper.
     (required (> miller cooper))
-
-    ;; Smith does not live on a floor adjacent to Fletcher's. 
+    ;
+    ;; Smith does not live on a floor adjacent to Fletcher's.
     (required (not (= (abs (- smith fletcher)) 1)))
-
+    ;
     ;; Fletcher does not live on a floor adjacent to Cooper's.
     (required (not (= (abs (- fletcher cooper)) 1)))
-
-    `((baker ,baker) (cooper ,cooper) (fletcher ,fletcher) (miller ,miller) (smith ,smith))) )
+    ;
+    `((baker ,baker)
+      (cooper ,cooper)
+      (fletcher ,fletcher)
+      (miller ,miller)
+      (smith ,smith))) )

release/4/amb/trunk/amb-extras.scm

@@ -12 +12 @@
   all-of
   required
+  xor
   implies
   distinct?
-  ;
   count-member
+  only-member?
   list-constantly)
 
-(import scheme)
-
-(import chicken)
-
-(import
+(import scheme chicken)
+(use
   (only extras random)
-  (only data-structures sort! constantly))
-(require-library extras data-structures)
-
-(import (only (srfi 1) count every))
-(require-library (srfi 1))
-
-(import (only type-checks check-list check-procedure))
-(require-library type-checks)
-
-(require-extension amb)
+  (only data-structures sort! constantly)
+  (only (srfi 1) count every)
+  amb)
 
 ;;;
 
-;;
+;; Convenience
 
 (define-syntax amb1
@@ -57 +48 @@
       (amb-thunks-shuffled (list-constantly ?ls) (amb-random-function)) ) ) )
 
+;; Aliases
+
 (define-syntax one-of
   (syntax-rules ()
@@ -72 +65 @@
      (amb-assert ?expr) ) ) )
 
-;;
+;; Logic Control
 
-(define (implies a b)
-  (or (not a) b) )
+(define-syntax xor
+  (syntax-rules ()
+    ((_ ?a ?b)
+      (let ((_a ?a) (_b ?b))
+        (if (and _a _b) #f (or _a _b)) ) ) ) )
 
-(define (distinct? xs #!optional (eql? equal?))
-  (check-procedure 'distinct? eql? '=?)
-  (every
-    (lambda (t) (fx= 1 (count-member t xs eql?)))
-    (check-list 'distinct? xs 'list)) )
+(define-syntax implies
+  (syntax-rules ()
+    ((_ ?a ?b)
+      (or (not ?a) ?b) ) ) )
 
 ;;;
@@ -90 +85 @@
   (count (cut eql? x <>) xs) )
 
+(define (only-member? x xs #!optional (eql? equal?))
+  (= 1 (count-member x xs eql?)) )
+
+;;
+
 (define (list-constantly ls)
   (map constantly ls) )
 
+;;
+
+(define (distinct? xs #!optional (eql? equal?))
+  (every (cut only-member? <> xs eql?) xs) )
+
 ) ;module amb-extras

release/4/amb/trunk/amb-kalotan.scm

@@ -1 +1 @@
 ;;;; amb-kalotan.scm
 
-(require-extension amb)
+(use amb amb-extras)
 
 ;; The following code is a rewrite of an example from the book "Teach Yourself
@@ -22 +22 @@
 
 (define (solve-kalotan-puzzle)
-
-  (define (xor a? b?) (if (and a? b?) #f (or a? b?)))
-
-  (let ((parent1 (amb 'male 'female))
-        (parent2 (amb 'male 'female))
-        (kibi (amb 'male 'female))
-        (kibi-self-desc (amb 'male 'female))
-        (kibi-lied? (amb #t #f)) )
-
+  ;
+  (let (
+    (parent1          (amb 'male 'female))
+    (parent2          (amb 'male 'female))
+    (kibi             (amb 'male 'female))
+    (kibi-self-desc   (amb 'male 'female))
+    (kibi-lied?       (amb #t #f)) )
+    ;
     (amb-assert (not (eq? parent1 parent2)))
-
+    ;
     (when kibi-lied?
-      (amb-assert (xor (and (eq? kibi-self-desc 'male)
-                            (eq? kibi 'female))
-                       (and (eq? kibi-self-desc 'female)
-                            (eq? kibi 'male)))) )
-
+      (amb-assert
+        (xor (and (eq? kibi-self-desc 'male)    (eq? kibi 'female))
+             (and (eq? kibi-self-desc 'female)  (eq? kibi 'male)))) )
+    ;
     (unless kibi-lied?
-      (amb-assert (xor (and (eq? kibi-self-desc 'male)
-                            (eq? kibi 'male))
-                       (and (eq? kibi-self-desc 'female)
-                            (eq? kibi 'female)))) )
-
+      (amb-assert
+        (xor (and (eq? kibi-self-desc 'male)    (eq? kibi 'male))
+             (and (eq? kibi-self-desc 'female)  (eq? kibi 'female)))) )
+    ;
     (when (eq? parent1 'male)
-      (amb-assert (and (eq? kibi-self-desc 'male)
-                       (xor (and (eq? kibi 'female)
-                                 (not kibi-lied?))
-                            (and (eq? kibi 'male)
-                                 kibi-lied?)))) )
-
+      (amb-assert
+        (and (eq? kibi-self-desc 'male)
+             (xor (and (eq? kibi 'female) (not kibi-lied?))
+                  (and (eq? kibi 'male)   kibi-lied?)))) )
+    ;
     (when (eq? parent1 'female)
-      (amb-assert (and (eq? kibi 'female)
-                       kibi-lied?)) )
-
+      (amb-assert (and (eq? kibi 'female) kibi-lied?)) )
+    ;
     (list parent1 parent2 kibi) ) )

release/4/amb/trunk/amb-money.scm

@@ -1 +1 @@
 ;;;; amb-money.scm
 
-(require-extension srfi-1 amb amb-extras)
+(use srfi-1 amb amb-extras)
 
 ;; Assign different numerals to different symbols
@@ -27 +27 @@
 
 (define (solve-money-puzzle)
-
-  (let ((trial 0)
-        (m 1) )
-
-    (let ((p1 (amb 0 1))
-          (p2 (amb 0 1))
-          (p3 (amb 0 1))
-          (d (choose '(0 1 2 3 4 5 6 7 8 9)) ) )
-
-      (let* ((e (choose (lset-difference equal? '(0 1 2 3 4 5 6 7 8 9) (list d))))
-             (y (modulo (+ d e (* -10 p1)) 10))
-             (n (choose (lset-difference equal? '(0 1 2 3 4 5 6 7 8 9) (list d e y))))
-             (r (modulo (+ (* 10 p2) e (- p1) (- n)) 10))
-             (o (modulo (+ (* 10 p3) n (- p2) (- e)) 10))
-             (s (modulo (+ (* 9 m) o (- p3)) 10) ) )
-
+  ;
+  (let (
+    (digits '(0 1 2 3 4 5 6 7 8 9))
+    (trial 0)
+    (m 1) )
+    ;
+    (let (
+      (p1 (amb 0 1))
+      (p2 (amb 0 1))
+      (p3 (amb 0 1))
+      (d (choose digits) ) )
+      ;
+      (let* (
+        (e (choose (lset-difference equal? digits (list d))))
+        (y (modulo (+ d e (* -10 p1)) 10))
+        (n (choose (lset-difference equal? digits (list d e y))))
+        (r (modulo (+ (* 10 p2) e (- p1) (- n)) 10))
+        (o (modulo (+ (* 10 p3) n (- p2) (- e)) 10))
+        (s (modulo (+ (* 9 m) o (- p3)) 10) ) )
+        ;
         (set! trial (add1 trial))
-
+        ;
         (required (distinct? (list s e n d m o r y)))
         (required (= (+ d e)    (+ (* 10 p1) y)))
@@ -50 +54 @@
         (required (= (+ p2 e o) (+ (* 10 p3) n)))
         (required (= (+ p3 s m) (+ (* 10 m)  o)))
-
+        ;
         ;; Result, including a number of recorded trials
         `((,trial trials)

release/4/amb/trunk/amb-pythagorean.scm

@@ -2 +2 @@
 ;;;; From "Continuations by example" ..." by Matt Might
 
-(require-extension amb)
+(use amb amb-extras)
 
-(let ((a (amb 1 2 3 4 5 6 7))
-      (b (amb 1 2 3 4 5 6 7))
-      (c (amb 1 2 3 4 5 6 7)))
-
-  ; We're looking for dimensions of a legal right
-  ; triangle using the Pythagorean theorem:
+(define (pythagorean)
   ;
-  (amb-assert (= (* c c) (+ (* a a) (* b b))))
-
-  ; And, we want the second side to be the shorter one:
-  ;
-  (amb-assert (< b a))
-
-  ; Print out the answer:
-  ;
-  (print " a = " a ", b = " b ", c = " c))
+  (let (
+    (a (amb 1 2 3 4 5 6 7))
+    (b (amb 1 2 3 4 5 6 7))
+    (c (amb 1 2 3 4 5 6 7)) )
+    ;
+    ; We're looking for dimensions of a legal right
+    ; triangle using the Pythagorean theorem:
+    ;
+    (amb-assert (= (* c c) (+ (* a a) (* b b))))
+    ;
+    ; And, we want the second side to be the shorter one:
+    ;
+    (amb-assert (< b a))
+    ;
+    ; the answer:
+    ;
+    (list a b c) ) )

release/4/amb/trunk/amb-sat-solve.scm

@@ -1 +1 @@
 ;;;; amb-sat-solve.scm
-;;;; From "Continuations by example" ..." by Matt Might
 
-(require-extension amb)
-
-(define (implies a b) (or (not a) b))
-
-;; The is not the most efficient implementation,
-;; because a continuation is captured for each
-;; occurrence of the same variable, instead of
-;; one for each variable.
-
-(define-syntax sat-solve
-  (syntax-rules (and or implies not)
-    ((_ ?formula ?body)
-     (sat-solve ?formula ?body ?formula) )
-
-    ((_ (not ?phi) ?body ?assertion)
-     (sat-solve ?phi ?body ?assertion) )
-
-    ((_ (and ?phi) ?body ?assertion)
-     (sat-solve ?phi ?body ?assertion) )
-
-    ((_ (and ?phi1 ?phi2 ...) ?body ?assertion)
-     (sat-solve ?phi1 (sat-solve (and ?phi2 ...) ?body ?assertion)) )
-
-    ((_ (or ?phi) ?body ?assertion)
-     (sat-solve ?phi ?body ?assertion) )
-
-    ((_ (or ?phi1 ?phi2 ...) ?body ?assertion)
-     (sat-solve ?phi1 (sat-solve (or ?phi2 ...) ?body ?assertion)) )
-
-    ((_ (implies ?phi1 ?phi2) ?body ?assertion)
-     (sat-solve ?phi1 (sat-solve ?phi2 ?body ?assertion)) )
-
-    ((_ #t ?body ?assertion)
-     ?body )
-
-    ((_ #f ?body ?assertion)
-     (amb-failure-continuation) )
-
-    ((_ v ?body ?assertion)
-     (let ((v (amb #t #f)))
-       (amb-assert ?assertion)
-       ?body ) ) ) )
-
+(include "../amb-pl-solver")
+(import amb-pl-solver)
 
 ; The following prints (#f #f #t)
-(sat-solve (and (implies a (not b))
-                 (not a)
-                 c)
-            (print "a = " a ", b = " b ", c = " c))
+(define (sat-solve)
+  (with-solution (and (implies a (not b)) (not a) c)
+    (list a b c) ) )

release/4/amb/trunk/amb.meta

@@ -13 +13 @@
         (condition-utils "1.0.0"))
  (test-depends test)
- (files "amb.meta" "amb.setup" "amb.scm" "amb-extras.scm"
- "amb-dwelling.scm" "amb.release-info" "amb-pythagorean.scm" "amb-money.scm" "amb-kalotan.scm" "amb-sat-solve.scm"
- "tests/run.scm") )
- 
+ (files
+  "amb.meta" "amb.setup"
+  "amb.scm" "amb-extras.scm"
+  "amb-pl-solver.scm"
+  "amb-dwelling.scm" "amb-pythagorean.scm" "amb-money.scm" "amb-kalotan.scm" "amb-sat-solve.scm"
+  "tests/run.scm" "tests/amb-test.scm") )

release/4/amb/trunk/amb.scm

@@ -22 +22 @@
   shuffle)
 
-(import scheme)
-
-(import chicken)
-
-(import
+(import scheme chicken)
+(use
   (only data-structures sort!)
-  (only extras random) )
-(require-library extras data-structures)
-
-(import (only (srfi 1) map!))
-(require-library (srfi 1))
-
-(import
+  (only extras random)
+  (only (srfi 1) map!)
   (only miscmacros let/cc define-parameter)
   (only type-errors warning-argument-type)
   (only condition-utils make-exn-condition+))
-(require-library
-  miscmacros type-errors condition-utils)
 
 ;;;
@@ -49 +39 @@
 
 (define make-amb-exhausted-condition
-  (let ((+cached-amb-exhausted-condition+
-          (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb)))
+  (let (
+    (+cached-amb-exhausted-condition+
+      (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb)))
+    ;
     (lambda () +cached-amb-exhausted-condition+) ) )
 
@@ -136 +128 @@
   (let ((afc #f))
     (dynamic-wind
+      ;
       (lambda ()
         (set! afc (amb-failure-continuation)) )
+      ;
       (lambda ()
         (let/cc return
-          (let* ((root (list #f))
-                 (head root) )
+          (let* (
+            (root (list #f))
+            (head root) )
+            ;
             (amb-failure-continuation (lambda () (return (cdr root))))
             (set-cdr! head (list (thunk)))
             (set! head (cdr head))
             ((amb-failure-continuation))) ) )
+      ;
       (lambda ()
         (amb-failure-continuation afc) ) ) ) )
@@ -152 +149 @@
 
 (define (shuffle ls random)
-  (let ((len (length ls)))
-    (map!
-      cdr
-      (sort!
-        (map (lambda (x) (cons (random len) x)) ls)
-        (lambda (x y) (< (car x) (car y)))) ) ) )
+  ;
+  (define (car< x y)
+  (fx< (car x) (car y)) )
+  ;
+  (let* (
+    (len (length ls))
+    (tagged-ls (map (lambda (x) (cons (random len) x)) ls)) )
+    ;
+    (map! cdr (sort! tagged-ls car<) ) ) )
 
 ) ;module amb

release/4/amb/trunk/tests/run.scm

@@ -1 @@
-;;;; amb test
-(use test)
 
-(test-begin "amb")
+(define EGG-NAME "amb")
 
-(include "../amb-kalotan")
-(test "kalotan"
-  '(female male female)
-  (solve-kalotan-puzzle))
+;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
 
-(include "../amb-money")
-(test "amb-money"
-  '(9 5 6 7 + 1 0 8 5 = 1 0 6 5 2)
-  (caddr (solve-money-puzzle)))
+(use files)
 
-(include "../amb-dwelling")
-(test "amb-dwelling"
-  '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
-  (solve-dwelling-puzzle))
+;no -disable-interrupts
+(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
 
-(test-end "amb")
+(define *args* (argv))
+
+(define (test-name #!optional (eggnam EGG-NAME))
+  (string-append eggnam "-test") )
+
+(define (egg-name #!optional (def EGG-NAME))
+  (cond
+    ((<= 4 (length *args*))
+      (cadddr *args*) )
+    (def
+      def )
+    (else
+      (error 'test "cannot determine egg-name") ) ) )
+
+;;;
+
+(set! EGG-NAME (egg-name))
+
+(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
+  (let ((tstnam (test-name eggnam)))
+    (print "*** csi ***")
+    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
+    (newline)
+    (print "*** csc (" cscopts ") ***")
+    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
+    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
+
+(define (run-tests eggnams #!optional (cscopts *csc-options*))
+  (for-each (cut run-test <> cscopts) eggnams) )
+
+;;;
+
+(run-test)