Changeset 35102 in project


Ignore:
Timestamp:
02/01/18 07:33:54 (7 months ago)
Author:
kon
Message:

test other ex , add xtra , mk solver own mod

Location:
release/4/amb/trunk
Files:
2 added
9 edited

Legend:

Unmodified
Added
Removed
  • release/4/amb/trunk/amb-dwelling.scm

    r13802 r35102  
    11;;;; amb-dwelling.scm
    22
    3 (require-extension amb amb-extras)
     3(use amb amb-extras)
    44
    55;; Baker, Cooper, Fletcher, Miller, and Smith live on different
     
    1414
    1515(define (solve-dwelling-puzzle)
    16 
    17   (let ((baker (amb 1 2 3 4 5))
    18         (cooper (amb 1 2 3 4 5))
    19         (fletcher (amb 1 2 3 4 5))
    20         (miller (amb 1 2 3 4 5))
    21         (smith (amb 1 2 3 4 5)))
    22 
     16  ;
     17  (let (
     18    (baker (amb 1 2 3 4 5))
     19    (cooper (amb 1 2 3 4 5))
     20    (fletcher (amb 1 2 3 4 5))
     21    (miller (amb 1 2 3 4 5))
     22    (smith (amb 1 2 3 4 5)) )
     23    ;
    2324    ;; They live on different floors.
    2425    (required (distinct? (list baker cooper fletcher miller smith)))
    25 
     26    ;
    2627    ;; Baker does not live on the top floor.
    2728    (required (not (= baker 5)))
    28 
     29    ;
    2930    ;; Cooper does not live on the bottom floor.
    3031    (required (not (= cooper 1)))
    31 
     32    ;
    3233    ;; Fletcher does not live on either the top or the bottom floor.
    3334    (required (not (= fletcher 5)))
    3435    (required (not (= fletcher 1)))
    35 
     36    ;
    3637    ;; Miller lives on a higher floor than does Cooper.
    3738    (required (> miller cooper))
    38 
    39     ;; Smith does not live on a floor adjacent to Fletcher's. 
     39    ;
     40    ;; Smith does not live on a floor adjacent to Fletcher's.
    4041    (required (not (= (abs (- smith fletcher)) 1)))
    41 
     42    ;
    4243    ;; Fletcher does not live on a floor adjacent to Cooper's.
    4344    (required (not (= (abs (- fletcher cooper)) 1)))
    44 
    45     `((baker ,baker) (cooper ,cooper) (fletcher ,fletcher) (miller ,miller) (smith ,smith))) )
     45    ;
     46    `((baker ,baker)
     47      (cooper ,cooper)
     48      (fletcher ,fletcher)
     49      (miller ,miller)
     50      (smith ,smith))) )
  • release/4/amb/trunk/amb-extras.scm

    r34422 r35102  
    1212  all-of
    1313  required
     14  xor
    1415  implies
    1516  distinct?
    16   ;
    1717  count-member
     18  only-member?
    1819  list-constantly)
    1920
    20 (import scheme)
    21 
    22 (import chicken)
    23 
    24 (import
     21(import scheme chicken)
     22(use
    2523  (only extras random)
    26   (only data-structures sort! constantly))
    27 (require-library extras data-structures)
    28 
    29 (import (only (srfi 1) count every))
    30 (require-library (srfi 1))
    31 
    32 (import (only type-checks check-list check-procedure))
    33 (require-library type-checks)
    34 
    35 (require-extension amb)
     24  (only data-structures sort! constantly)
     25  (only (srfi 1) count every)
     26  amb)
    3627
    3728;;;
    3829
    39 ;;
     30;; Convenience
    4031
    4132(define-syntax amb1
     
    5748      (amb-thunks-shuffled (list-constantly ?ls) (amb-random-function)) ) ) )
    5849
     50;; Aliases
     51
    5952(define-syntax one-of
    6053  (syntax-rules ()
     
    7265     (amb-assert ?expr) ) ) )
    7366
    74 ;;
     67;; Logic Control
    7568
    76 (define (implies a b)
    77   (or (not a) b) )
     69(define-syntax xor
     70  (syntax-rules ()
     71    ((_ ?a ?b)
     72      (let ((_a ?a) (_b ?b))
     73        (if (and _a _b) #f (or _a _b)) ) ) ) )
    7874
    79 (define (distinct? xs #!optional (eql? equal?))
    80   (check-procedure 'distinct? eql? '=?)
    81   (every
    82     (lambda (t) (fx= 1 (count-member t xs eql?)))
    83     (check-list 'distinct? xs 'list)) )
     75(define-syntax implies
     76  (syntax-rules ()
     77    ((_ ?a ?b)
     78      (or (not ?a) ?b) ) ) )
    8479
    8580;;;
     
    9085  (count (cut eql? x <>) xs) )
    9186
     87(define (only-member? x xs #!optional (eql? equal?))
     88  (= 1 (count-member x xs eql?)) )
     89
     90;;
     91
    9292(define (list-constantly ls)
    9393  (map constantly ls) )
    9494
     95;;
     96
     97(define (distinct? xs #!optional (eql? equal?))
     98  (every (cut only-member? <> xs eql?) xs) )
     99
    95100) ;module amb-extras
  • release/4/amb/trunk/amb-kalotan.scm

    r13802 r35102  
    11;;;; amb-kalotan.scm
    22
    3 (require-extension amb)
     3(use amb amb-extras)
    44
    55;; The following code is a rewrite of an example from the book "Teach Yourself
     
    2222
    2323(define (solve-kalotan-puzzle)
    24 
    25   (define (xor a? b?) (if (and a? b?) #f (or a? b?)))
    26 
    27   (let ((parent1 (amb 'male 'female))
    28         (parent2 (amb 'male 'female))
    29         (kibi (amb 'male 'female))
    30         (kibi-self-desc (amb 'male 'female))
    31         (kibi-lied? (amb #t #f)) )
    32 
     24  ;
     25  (let (
     26    (parent1          (amb 'male 'female))
     27    (parent2          (amb 'male 'female))
     28    (kibi             (amb 'male 'female))
     29    (kibi-self-desc   (amb 'male 'female))
     30    (kibi-lied?       (amb #t #f)) )
     31    ;
    3332    (amb-assert (not (eq? parent1 parent2)))
    34 
     33    ;
    3534    (when kibi-lied?
    36       (amb-assert (xor (and (eq? kibi-self-desc 'male)
    37                             (eq? kibi 'female))
    38                        (and (eq? kibi-self-desc 'female)
    39                             (eq? kibi 'male)))) )
    40 
     35      (amb-assert
     36        (xor (and (eq? kibi-self-desc 'male)    (eq? kibi 'female))
     37             (and (eq? kibi-self-desc 'female)  (eq? kibi 'male)))) )
     38    ;
    4139    (unless kibi-lied?
    42       (amb-assert (xor (and (eq? kibi-self-desc 'male)
    43                             (eq? kibi 'male))
    44                        (and (eq? kibi-self-desc 'female)
    45                             (eq? kibi 'female)))) )
    46 
     40      (amb-assert
     41        (xor (and (eq? kibi-self-desc 'male)    (eq? kibi 'male))
     42             (and (eq? kibi-self-desc 'female)  (eq? kibi 'female)))) )
     43    ;
    4744    (when (eq? parent1 'male)
    48       (amb-assert (and (eq? kibi-self-desc 'male)
    49                        (xor (and (eq? kibi 'female)
    50                                  (not kibi-lied?))
    51                             (and (eq? kibi 'male)
    52                                  kibi-lied?)))) )
    53 
     45      (amb-assert
     46        (and (eq? kibi-self-desc 'male)
     47             (xor (and (eq? kibi 'female) (not kibi-lied?))
     48                  (and (eq? kibi 'male)   kibi-lied?)))) )
     49    ;
    5450    (when (eq? parent1 'female)
    55       (amb-assert (and (eq? kibi 'female)
    56                        kibi-lied?)) )
    57 
     51      (amb-assert (and (eq? kibi 'female) kibi-lied?)) )
     52    ;
    5853    (list parent1 parent2 kibi) ) )
  • release/4/amb/trunk/amb-money.scm

    r14208 r35102  
    11;;;; amb-money.scm
    22
    3 (require-extension srfi-1 amb amb-extras)
     3(use srfi-1 amb amb-extras)
    44
    55;; Assign different numerals to different symbols
     
    2727
    2828(define (solve-money-puzzle)
    29 
    30   (let ((trial 0)
    31         (m 1) )
    32 
    33     (let ((p1 (amb 0 1))
    34           (p2 (amb 0 1))
    35           (p3 (amb 0 1))
    36           (d (choose '(0 1 2 3 4 5 6 7 8 9)) ) )
    37 
    38       (let* ((e (choose (lset-difference equal? '(0 1 2 3 4 5 6 7 8 9) (list d))))
    39              (y (modulo (+ d e (* -10 p1)) 10))
    40              (n (choose (lset-difference equal? '(0 1 2 3 4 5 6 7 8 9) (list d e y))))
    41              (r (modulo (+ (* 10 p2) e (- p1) (- n)) 10))
    42              (o (modulo (+ (* 10 p3) n (- p2) (- e)) 10))
    43              (s (modulo (+ (* 9 m) o (- p3)) 10) ) )
    44 
     29  ;
     30  (let (
     31    (digits '(0 1 2 3 4 5 6 7 8 9))
     32    (trial 0)
     33    (m 1) )
     34    ;
     35    (let (
     36      (p1 (amb 0 1))
     37      (p2 (amb 0 1))
     38      (p3 (amb 0 1))
     39      (d (choose digits) ) )
     40      ;
     41      (let* (
     42        (e (choose (lset-difference equal? digits (list d))))
     43        (y (modulo (+ d e (* -10 p1)) 10))
     44        (n (choose (lset-difference equal? digits (list d e y))))
     45        (r (modulo (+ (* 10 p2) e (- p1) (- n)) 10))
     46        (o (modulo (+ (* 10 p3) n (- p2) (- e)) 10))
     47        (s (modulo (+ (* 9 m) o (- p3)) 10) ) )
     48        ;
    4549        (set! trial (add1 trial))
    46 
     50        ;
    4751        (required (distinct? (list s e n d m o r y)))
    4852        (required (= (+ d e)    (+ (* 10 p1) y)))
     
    5054        (required (= (+ p2 e o) (+ (* 10 p3) n)))
    5155        (required (= (+ p3 s m) (+ (* 10 m)  o)))
    52 
     56        ;
    5357        ;; Result, including a number of recorded trials
    5458        `((,trial trials)
  • release/4/amb/trunk/amb-pythagorean.scm

    r34107 r35102  
    22;;;; From "Continuations by example" ..." by Matt Might
    33
    4 (require-extension amb)
     4(use amb amb-extras)
    55
    6 (let ((a (amb 1 2 3 4 5 6 7))
    7       (b (amb 1 2 3 4 5 6 7))
    8       (c (amb 1 2 3 4 5 6 7)))
    9 
    10   ; We're looking for dimensions of a legal right
    11   ; triangle using the Pythagorean theorem:
     6(define (pythagorean)
    127  ;
    13   (amb-assert (= (* c c) (+ (* a a) (* b b))))
    14 
    15   ; And, we want the second side to be the shorter one:
    16   ;
    17   (amb-assert (< b a))
    18 
    19   ; Print out the answer:
    20   ;
    21   (print " a = " a ", b = " b ", c = " c))
     8  (let (
     9    (a (amb 1 2 3 4 5 6 7))
     10    (b (amb 1 2 3 4 5 6 7))
     11    (c (amb 1 2 3 4 5 6 7)) )
     12    ;
     13    ; We're looking for dimensions of a legal right
     14    ; triangle using the Pythagorean theorem:
     15    ;
     16    (amb-assert (= (* c c) (+ (* a a) (* b b))))
     17    ;
     18    ; And, we want the second side to be the shorter one:
     19    ;
     20    (amb-assert (< b a))
     21    ;
     22    ; the answer:
     23    ;
     24    (list a b c) ) )
  • release/4/amb/trunk/amb-sat-solve.scm

    r23312 r35102  
    11;;;; amb-sat-solve.scm
    2 ;;;; From "Continuations by example" ..." by Matt Might
    32
    4 (require-extension amb)
    5 
    6 (define (implies a b) (or (not a) b))
    7 
    8 ;; The is not the most efficient implementation,
    9 ;; because a continuation is captured for each
    10 ;; occurrence of the same variable, instead of
    11 ;; one for each variable.
    12 
    13 (define-syntax sat-solve
    14   (syntax-rules (and or implies not)
    15     ((_ ?formula ?body)
    16      (sat-solve ?formula ?body ?formula) )
    17 
    18     ((_ (not ?phi) ?body ?assertion)
    19      (sat-solve ?phi ?body ?assertion) )
    20 
    21     ((_ (and ?phi) ?body ?assertion)
    22      (sat-solve ?phi ?body ?assertion) )
    23 
    24     ((_ (and ?phi1 ?phi2 ...) ?body ?assertion)
    25      (sat-solve ?phi1 (sat-solve (and ?phi2 ...) ?body ?assertion)) )
    26 
    27     ((_ (or ?phi) ?body ?assertion)
    28      (sat-solve ?phi ?body ?assertion) )
    29 
    30     ((_ (or ?phi1 ?phi2 ...) ?body ?assertion)
    31      (sat-solve ?phi1 (sat-solve (or ?phi2 ...) ?body ?assertion)) )
    32 
    33     ((_ (implies ?phi1 ?phi2) ?body ?assertion)
    34      (sat-solve ?phi1 (sat-solve ?phi2 ?body ?assertion)) )
    35 
    36     ((_ #t ?body ?assertion)
    37      ?body )
    38 
    39     ((_ #f ?body ?assertion)
    40      (amb-failure-continuation) )
    41 
    42     ((_ v ?body ?assertion)
    43      (let ((v (amb #t #f)))
    44        (amb-assert ?assertion)
    45        ?body ) ) ) )
    46 
     3(include "../amb-pl-solver")
     4(import amb-pl-solver)
    475
    486; The following prints (#f #f #t)
    49 (sat-solve (and (implies a (not b))
    50                  (not a)
    51                  c)
    52             (print "a = " a ", b = " b ", c = " c))
     7(define (sat-solve)
     8  (with-solution (and (implies a (not b)) (not a) c)
     9    (list a b c) ) )
  • release/4/amb/trunk/amb.meta

    r34138 r35102  
    1313        (condition-utils "1.0.0"))
    1414 (test-depends test)
    15  (files "amb.meta" "amb.setup" "amb.scm" "amb-extras.scm"
    16  "amb-dwelling.scm" "amb.release-info" "amb-pythagorean.scm" "amb-money.scm" "amb-kalotan.scm" "amb-sat-solve.scm"
    17  "tests/run.scm") )
    18  
     15 (files
     16  "amb.meta" "amb.setup"
     17  "amb.scm" "amb-extras.scm"
     18  "amb-pl-solver.scm"
     19  "amb-dwelling.scm" "amb-pythagorean.scm" "amb-money.scm" "amb-kalotan.scm" "amb-sat-solve.scm"
     20  "tests/run.scm" "tests/amb-test.scm") )
  • release/4/amb/trunk/amb.scm

    r34422 r35102  
    2222  shuffle)
    2323
    24 (import scheme)
    25 
    26 (import chicken)
    27 
    28 (import
     24(import scheme chicken)
     25(use
    2926  (only data-structures sort!)
    30   (only extras random) )
    31 (require-library extras data-structures)
    32 
    33 (import (only (srfi 1) map!))
    34 (require-library (srfi 1))
    35 
    36 (import
     27  (only extras random)
     28  (only (srfi 1) map!)
    3729  (only miscmacros let/cc define-parameter)
    3830  (only type-errors warning-argument-type)
    3931  (only condition-utils make-exn-condition+))
    40 (require-library
    41   miscmacros type-errors condition-utils)
    4232
    4333;;;
     
    4939
    5040(define make-amb-exhausted-condition
    51   (let ((+cached-amb-exhausted-condition+
    52           (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb)))
     41  (let (
     42    (+cached-amb-exhausted-condition+
     43      (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb)))
     44    ;
    5345    (lambda () +cached-amb-exhausted-condition+) ) )
    5446
     
    136128  (let ((afc #f))
    137129    (dynamic-wind
     130      ;
    138131      (lambda ()
    139132        (set! afc (amb-failure-continuation)) )
     133      ;
    140134      (lambda ()
    141135        (let/cc return
    142           (let* ((root (list #f))
    143                  (head root) )
     136          (let* (
     137            (root (list #f))
     138            (head root) )
     139            ;
    144140            (amb-failure-continuation (lambda () (return (cdr root))))
    145141            (set-cdr! head (list (thunk)))
    146142            (set! head (cdr head))
    147143            ((amb-failure-continuation))) ) )
     144      ;
    148145      (lambda ()
    149146        (amb-failure-continuation afc) ) ) ) )
     
    152149
    153150(define (shuffle ls random)
    154   (let ((len (length ls)))
    155     (map!
    156       cdr
    157       (sort!
    158         (map (lambda (x) (cons (random len) x)) ls)
    159         (lambda (x y) (< (car x) (car y)))) ) ) )
     151  ;
     152  (define (car< x y)
     153  (fx< (car x) (car y)) )
     154  ;
     155  (let* (
     156    (len (length ls))
     157    (tagged-ls (map (lambda (x) (cons (random len) x)) ls)) )
     158    ;
     159    (map! cdr (sort! tagged-ls car<) ) ) )
    160160
    161161) ;module amb
  • release/4/amb/trunk/tests/run.scm

    r34107 r35102  
    1 ;;;; amb test
    2 (use test)
    31
    4 (test-begin "amb")
     2(define EGG-NAME "amb")
    53
    6 (include "../amb-kalotan")
    7 (test "kalotan"
    8   '(female male female)
    9   (solve-kalotan-puzzle))
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    105
    11 (include "../amb-money")
    12 (test "amb-money"
    13   '(9 5 6 7 + 1 0 8 5 = 1 0 6 5 2)
    14   (caddr (solve-money-puzzle)))
     6(use files)
    157
    16 (include "../amb-dwelling")
    17 (test "amb-dwelling"
    18   '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
    19   (solve-dwelling-puzzle))
     8;no -disable-interrupts
     9(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
    2010
    21 (test-end "amb")
     11(define *args* (argv))
     12
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
     15
     16(define (egg-name #!optional (def EGG-NAME))
     17  (cond
     18    ((<= 4 (length *args*))
     19      (cadddr *args*) )
     20    (def
     21      def )
     22    (else
     23      (error 'test "cannot determine egg-name") ) ) )
     24
     25;;;
     26
     27(set! EGG-NAME (egg-name))
     28
     29(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
     30  (let ((tstnam (test-name eggnam)))
     31    (print "*** csi ***")
     32    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     33    (newline)
     34    (print "*** csc (" cscopts ") ***")
     35    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     36    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
     37
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
     40
     41;;;
     42
     43(run-test)
Note: See TracChangeset for help on using the changeset viewer.