Changeset 34107 in project


Ignore:
Timestamp:
05/30/17 00:18:35 (3 months ago)
Author:
kon
Message:

use test

Location:
release/4/amb
Files:
10 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/amb/tags/2.1.7/amb-extras.scm

    r27621 r34107  
    44(module amb-extras
    55
    6   (;export
    7     (choose shuffle)
    8     one-of
    9     all-of
    10     required
    11     distinct?)
     6(;export
     7  implies
     8  (choose shuffle)
     9  one-of
     10  all-of
     11  required
     12  distinct?)
    1213
    13   (import
    14     scheme
    15     chicken
    16     (only srfi-1 member)
    17     (only extras random)
    18     (only data-structures sort!)
    19     amb
    20     (only type-checks check-list check-procedure))
     14(import scheme chicken)
     15(import
     16  (only srfi-1 member)
     17  (only extras random)
     18  (only data-structures sort!))
    2119
    22   (require-library
    23     srfi-1 data-structures extras
    24     amb
    25     type-checks)
     20(import
     21  amb
     22  (only type-checks check-list check-procedure))
     23(require-library
     24  amb
     25  type-checks)
    2626
    2727;;
     28
     29(define (implies a b)
     30  (or (not a) b) )
    2831
    2932(define shuffle
     
    3134  (lambda (l random)
    3235    (let ((len (length l)))
    33       (map cdr
    34            (sort! (map (lambda (x) (cons (random len) x)) l)
    35                   (lambda (x y) (< (car x) (car y)))) ) ) ) )
     36      (map
     37        cdr
     38        (sort!
     39          (map (lambda (x) (cons (random len) x)) l)
     40          (lambda (x y) (< (car x) (car y)))) ) ) ) )
    3641
    3742(define-syntax choose
    3843  (syntax-rules ()
    39     ((_ ?ls) (amb-thunks (map (lambda (x) (lambda () x)) (shuffle ?ls random))) ) ) )
     44    ((_ ?ls)
     45      (amb-thunks (map (lambda (x) (lambda () x)) (shuffle ?ls random))) ) ) )
    4046
    4147(define-syntax one-of
    4248  (syntax-rules ()
    43     ((_ ?expr) (amb-find ?expr) ) ) )
     49    ((_ ?expr)
     50      (amb-find ?expr) ) ) )
    4451
    4552(define-syntax all-of
    4653  (syntax-rules ()
    47     ((_ ?expr) (amb-collect ?expr) ) ) )
     54    ((_ ?expr)
     55      (amb-collect ?expr) ) ) )
    4856
    4957(define-syntax required
    5058  (syntax-rules ()
    51     ((_ ?expr) (amb-assert ?expr) ) ) )
     59    ((_ ?expr)
     60      (amb-assert ?expr) ) ) )
    5261
    5362(define (distinct? xs #!optional (eql? equal?))
     
    5564  (check-procedure 'distinct? eql? 'equivalence)
    5665  (let loop ((xs xs))
    57     (or (null? xs)
    58         (and (not (member (car xs) (cdr xs) eql?))
    59              (loop (cdr xs)))) ) )
     66    (or
     67      (null? xs)
     68      (and
     69        (not (member (car xs) (cdr xs) eql?))
     70        (loop (cdr xs)))) ) )
    6071
    6172) ;module amb-extras
  • release/4/amb/tags/2.1.7/amb-pythagorean.scm

    r23312 r34107  
    1010  ; We're looking for dimensions of a legal right
    1111  ; triangle using the Pythagorean theorem:
     12  ;
    1213  (amb-assert (= (* c c) (+ (* a a) (* b b))))
    1314
    1415  ; And, we want the second side to be the shorter one:
     16  ;
    1517  (amb-assert (< b a))
    1618
    1719  ; Print out the answer:
     20  ;
    1821  (print " a = " a ", b = " b ", c = " c))
  • release/4/amb/tags/2.1.7/amb.scm

    r27621 r34107  
    55(module amb
    66
    7   (;export
    8     amb
    9     (amb/random shuffle)
    10     amb-find
    11     amb-collect
    12     amb-assert
    13     amb-failure-continuation
    14     amb-thunks
    15     amb-find-thunk
    16     amb-collect-thunk)
     7(;export
     8  amb
     9  (amb/random shuffle)
     10  amb-find
     11  amb-collect
     12  amb-assert
     13  amb-failure-continuation
     14  amb-thunks
     15  amb-find-thunk
     16  amb-collect-thunk
     17  amb-random-function)
    1718
    18   (import
    19     scheme
    20     chicken
    21     (only data-structures sort!)
    22     (only extras random)
    23     (only miscmacros let/cc define-parameter)
    24     (only type-errors warning-argument-type)
    25     (only condition-utils make-exn-condition+))
     19(import scheme chicken)
     20(import
     21  (only data-structures sort!)
     22  (only extras random) )
    2623
    27   (require-library
    28     data-structures extras
    29     miscmacros type-errors condition-utils)
     24(import
     25  (only miscmacros let/cc define-parameter)
     26  (only type-errors warning-argument-type)
     27  (only condition-utils make-exn-condition+))
     28(require-library
     29  miscmacros type-errors condition-utils)
    3030
    3131;;
     32
     33(define-parameter amb-random-function random
     34  (lambda (x)
     35    (if (procedure? x)
     36      x
     37      (begin
     38        (warning 'amb-random-function "not a procedure" x)
     39        (amb-random-function) ) ) ) )
    3240
    3341(define shuffle
     
    3543  (lambda (l random)
    3644    (let ((len (length l)))
    37       (map cdr
    38            (sort! (map (lambda (x) (cons (random len) x)) l)
    39                   (lambda (x y) (< (car x) (car y)))) ) ) ) )
     45      (map
     46        cdr
     47        (sort!
     48          (map (lambda (x) (cons (random len) x)) l)
     49          (lambda (x y) (< (car x) (car y)))) ) ) ) )
    4050
    4151(define-syntax amb
    4252  (syntax-rules ()
    43     ((_)            ((amb-failure-continuation)) )
    44     ((_ ?expr0 ...) (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
     53    ((_)
     54      ((amb-failure-continuation)) )
     55    ((_ ?expr0 ...)
     56      (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
    4557
    4658(define-syntax amb/random
    4759  (syntax-rules ()
    48     ((_)            ((amb-failure-continuation)) )
    49     ((_ ?expr0 ...) (amb-thunks (shuffle (list (lambda () ?expr0) ...) random)) ) ) )
     60    ((_)
     61      ((amb-failure-continuation)) )
     62    ((_ ?expr0 ...)
     63      (amb-thunks (shuffle (list (lambda () ?expr0) ...) (amb-random-function))) ) ) )
    5064
    5165(define-syntax amb-find
    5266  (syntax-rules ()
    53     ((_ ?expr)        (amb-find-thunk (lambda () ?expr)) )
    54     ((_ ?expr ?fail)  (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
     67    ((_ ?expr)
     68      (amb-find-thunk (lambda () ?expr)) )
     69    ((_ ?expr ?fail)
     70      (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
    5571
    5672(define-syntax amb-collect
    5773  (syntax-rules ()
    58     ((_ ?expr) (amb-collect-thunk (lambda () ?expr)) ) ) )
     74    ((_ ?expr)
     75      (amb-collect-thunk (lambda () ?expr)) ) ) )
    5976
    6077(define-syntax amb-assert
    6178  (syntax-rules ()
    62     ((_ ?expr) (unless ?expr ((amb-failure-continuation))) ) ) )
     79    ((_ ?expr)
     80      (unless ?expr ((amb-failure-continuation))) ) ) )
    6381
    6482;;
     
    7391(define-parameter amb-failure-continuation amb-exhausted
    7492  (lambda (x)
    75     (cond
    76       ((procedure? x) x)
    77       (else
     93    (if (procedure? x)
     94      x
     95      (begin
    7896        (warning-argument-type 'amb-failure-continuation x 'procedure)
    7997        (amb-failure-continuation) ) ) ) )
     
    101119  (let ((afc #f))
    102120    (dynamic-wind
    103       (lambda () (set! afc (amb-failure-continuation)) )
     121      (lambda ()
     122        (set! afc (amb-failure-continuation)) )
    104123      (lambda ()
    105124        (let/cc return
     
    110129            (set! head (cdr head))
    111130            ((amb-failure-continuation))) ) )
    112       (lambda () (amb-failure-continuation afc) ) ) ) )
     131      (lambda ()
     132        (amb-failure-continuation afc) ) ) ) )
    113133
    114134) ;module amb
  • release/4/amb/tags/2.1.7/amb.setup

    r27621 r34107  
    55(verify-extension-name "amb")
    66
    7 (setup-shared-extension-module 'amb (extension-version "2.1.6")
     7(setup-shared-extension-module 'amb (extension-version "2.1.7")
    88  #:inline? #t
    99  #:types? #t
     
    1111  #:install-options '((examples "amb-dwelling.scm" "amb-kalotan.scm" "amb-money.scm")))
    1212
    13 (setup-shared-extension-module 'amb-extras (extension-version "2.1.6")
     13(setup-shared-extension-module 'amb-extras (extension-version "2.1.7")
    1414  #:inline? #t
    1515  #:types? #t
  • release/4/amb/tags/2.1.7/tests/run.scm

    r13802 r34107  
    11;;;; amb test
     2(use test)
     3
     4(test-begin "amb")
    25
    36(include "../amb-kalotan")
    4 (assert (equal? '(female male female) (solve-kalotan-puzzle)))
     7(test "kalotan"
     8  '(female male female)
     9  (solve-kalotan-puzzle))
    510
    611(include "../amb-money")
    7 (assert (equal? '(9 5 6 7 + 1 0 8 5 = 1 0 6 5 2) (caddr (solve-money-puzzle))))
     12(test "amb-money"
     13  '(9 5 6 7 + 1 0 8 5 = 1 0 6 5 2)
     14  (caddr (solve-money-puzzle)))
    815
    916(include "../amb-dwelling")
    10 (assert (equal? '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)) (solve-dwelling-puzzle)))
     17(test "amb-dwelling"
     18  '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
     19  (solve-dwelling-puzzle))
     20
     21(test-end "amb")
  • release/4/amb/trunk/amb-extras.scm

    r27621 r34107  
    44(module amb-extras
    55
    6   (;export
    7     (choose shuffle)
    8     one-of
    9     all-of
    10     required
    11     distinct?)
     6(;export
     7  implies
     8  (choose shuffle)
     9  one-of
     10  all-of
     11  required
     12  distinct?)
    1213
    13   (import
    14     scheme
    15     chicken
    16     (only srfi-1 member)
    17     (only extras random)
    18     (only data-structures sort!)
    19     amb
    20     (only type-checks check-list check-procedure))
     14(import scheme chicken)
     15(import
     16  (only srfi-1 member)
     17  (only extras random)
     18  (only data-structures sort!))
    2119
    22   (require-library
    23     srfi-1 data-structures extras
    24     amb
    25     type-checks)
     20(import
     21  amb
     22  (only type-checks check-list check-procedure))
     23(require-library
     24  amb
     25  type-checks)
    2626
    2727;;
     28
     29(define (implies a b)
     30  (or (not a) b) )
    2831
    2932(define shuffle
     
    3134  (lambda (l random)
    3235    (let ((len (length l)))
    33       (map cdr
    34            (sort! (map (lambda (x) (cons (random len) x)) l)
    35                   (lambda (x y) (< (car x) (car y)))) ) ) ) )
     36      (map
     37        cdr
     38        (sort!
     39          (map (lambda (x) (cons (random len) x)) l)
     40          (lambda (x y) (< (car x) (car y)))) ) ) ) )
    3641
    3742(define-syntax choose
    3843  (syntax-rules ()
    39     ((_ ?ls) (amb-thunks (map (lambda (x) (lambda () x)) (shuffle ?ls random))) ) ) )
     44    ((_ ?ls)
     45      (amb-thunks (map (lambda (x) (lambda () x)) (shuffle ?ls random))) ) ) )
    4046
    4147(define-syntax one-of
    4248  (syntax-rules ()
    43     ((_ ?expr) (amb-find ?expr) ) ) )
     49    ((_ ?expr)
     50      (amb-find ?expr) ) ) )
    4451
    4552(define-syntax all-of
    4653  (syntax-rules ()
    47     ((_ ?expr) (amb-collect ?expr) ) ) )
     54    ((_ ?expr)
     55      (amb-collect ?expr) ) ) )
    4856
    4957(define-syntax required
    5058  (syntax-rules ()
    51     ((_ ?expr) (amb-assert ?expr) ) ) )
     59    ((_ ?expr)
     60      (amb-assert ?expr) ) ) )
    5261
    5362(define (distinct? xs #!optional (eql? equal?))
     
    5564  (check-procedure 'distinct? eql? 'equivalence)
    5665  (let loop ((xs xs))
    57     (or (null? xs)
    58         (and (not (member (car xs) (cdr xs) eql?))
    59              (loop (cdr xs)))) ) )
     66    (or
     67      (null? xs)
     68      (and
     69        (not (member (car xs) (cdr xs) eql?))
     70        (loop (cdr xs)))) ) )
    6071
    6172) ;module amb-extras
  • release/4/amb/trunk/amb-pythagorean.scm

    r23312 r34107  
    1010  ; We're looking for dimensions of a legal right
    1111  ; triangle using the Pythagorean theorem:
     12  ;
    1213  (amb-assert (= (* c c) (+ (* a a) (* b b))))
    1314
    1415  ; And, we want the second side to be the shorter one:
     16  ;
    1517  (amb-assert (< b a))
    1618
    1719  ; Print out the answer:
     20  ;
    1821  (print " a = " a ", b = " b ", c = " c))
  • release/4/amb/trunk/amb.scm

    r27621 r34107  
    55(module amb
    66
    7   (;export
    8     amb
    9     (amb/random shuffle)
    10     amb-find
    11     amb-collect
    12     amb-assert
    13     amb-failure-continuation
    14     amb-thunks
    15     amb-find-thunk
    16     amb-collect-thunk)
     7(;export
     8  amb
     9  (amb/random shuffle)
     10  amb-find
     11  amb-collect
     12  amb-assert
     13  amb-failure-continuation
     14  amb-thunks
     15  amb-find-thunk
     16  amb-collect-thunk
     17  amb-random-function)
    1718
    18   (import
    19     scheme
    20     chicken
    21     (only data-structures sort!)
    22     (only extras random)
    23     (only miscmacros let/cc define-parameter)
    24     (only type-errors warning-argument-type)
    25     (only condition-utils make-exn-condition+))
     19(import scheme chicken)
     20(import
     21  (only data-structures sort!)
     22  (only extras random) )
    2623
    27   (require-library
    28     data-structures extras
    29     miscmacros type-errors condition-utils)
     24(import
     25  (only miscmacros let/cc define-parameter)
     26  (only type-errors warning-argument-type)
     27  (only condition-utils make-exn-condition+))
     28(require-library
     29  miscmacros type-errors condition-utils)
    3030
    3131;;
     32
     33(define-parameter amb-random-function random
     34  (lambda (x)
     35    (if (procedure? x)
     36      x
     37      (begin
     38        (warning 'amb-random-function "not a procedure" x)
     39        (amb-random-function) ) ) ) )
    3240
    3341(define shuffle
     
    3543  (lambda (l random)
    3644    (let ((len (length l)))
    37       (map cdr
    38            (sort! (map (lambda (x) (cons (random len) x)) l)
    39                   (lambda (x y) (< (car x) (car y)))) ) ) ) )
     45      (map
     46        cdr
     47        (sort!
     48          (map (lambda (x) (cons (random len) x)) l)
     49          (lambda (x y) (< (car x) (car y)))) ) ) ) )
    4050
    4151(define-syntax amb
    4252  (syntax-rules ()
    43     ((_)            ((amb-failure-continuation)) )
    44     ((_ ?expr0 ...) (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
     53    ((_)
     54      ((amb-failure-continuation)) )
     55    ((_ ?expr0 ...)
     56      (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
    4557
    4658(define-syntax amb/random
    4759  (syntax-rules ()
    48     ((_)            ((amb-failure-continuation)) )
    49     ((_ ?expr0 ...) (amb-thunks (shuffle (list (lambda () ?expr0) ...) random)) ) ) )
     60    ((_)
     61      ((amb-failure-continuation)) )
     62    ((_ ?expr0 ...)
     63      (amb-thunks (shuffle (list (lambda () ?expr0) ...) (amb-random-function))) ) ) )
    5064
    5165(define-syntax amb-find
    5266  (syntax-rules ()
    53     ((_ ?expr)        (amb-find-thunk (lambda () ?expr)) )
    54     ((_ ?expr ?fail)  (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
     67    ((_ ?expr)
     68      (amb-find-thunk (lambda () ?expr)) )
     69    ((_ ?expr ?fail)
     70      (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
    5571
    5672(define-syntax amb-collect
    5773  (syntax-rules ()
    58     ((_ ?expr) (amb-collect-thunk (lambda () ?expr)) ) ) )
     74    ((_ ?expr)
     75      (amb-collect-thunk (lambda () ?expr)) ) ) )
    5976
    6077(define-syntax amb-assert
    6178  (syntax-rules ()
    62     ((_ ?expr) (unless ?expr ((amb-failure-continuation))) ) ) )
     79    ((_ ?expr)
     80      (unless ?expr ((amb-failure-continuation))) ) ) )
    6381
    6482;;
     
    7391(define-parameter amb-failure-continuation amb-exhausted
    7492  (lambda (x)
    75     (cond
    76       ((procedure? x) x)
    77       (else
     93    (if (procedure? x)
     94      x
     95      (begin
    7896        (warning-argument-type 'amb-failure-continuation x 'procedure)
    7997        (amb-failure-continuation) ) ) ) )
     
    101119  (let ((afc #f))
    102120    (dynamic-wind
    103       (lambda () (set! afc (amb-failure-continuation)) )
     121      (lambda ()
     122        (set! afc (amb-failure-continuation)) )
    104123      (lambda ()
    105124        (let/cc return
     
    110129            (set! head (cdr head))
    111130            ((amb-failure-continuation))) ) )
    112       (lambda () (amb-failure-continuation afc) ) ) ) )
     131      (lambda ()
     132        (amb-failure-continuation afc) ) ) ) )
    113133
    114134) ;module amb
  • release/4/amb/trunk/amb.setup

    r27621 r34107  
    55(verify-extension-name "amb")
    66
    7 (setup-shared-extension-module 'amb (extension-version "2.1.6")
     7(setup-shared-extension-module 'amb (extension-version "2.1.7")
    88  #:inline? #t
    99  #:types? #t
     
    1111  #:install-options '((examples "amb-dwelling.scm" "amb-kalotan.scm" "amb-money.scm")))
    1212
    13 (setup-shared-extension-module 'amb-extras (extension-version "2.1.6")
     13(setup-shared-extension-module 'amb-extras (extension-version "2.1.7")
    1414  #:inline? #t
    1515  #:types? #t
  • release/4/amb/trunk/tests/run.scm

    r13802 r34107  
    11;;;; amb test
     2(use test)
     3
     4(test-begin "amb")
    25
    36(include "../amb-kalotan")
    4 (assert (equal? '(female male female) (solve-kalotan-puzzle)))
     7(test "kalotan"
     8  '(female male female)
     9  (solve-kalotan-puzzle))
    510
    611(include "../amb-money")
    7 (assert (equal? '(9 5 6 7 + 1 0 8 5 = 1 0 6 5 2) (caddr (solve-money-puzzle))))
     12(test "amb-money"
     13  '(9 5 6 7 + 1 0 8 5 = 1 0 6 5 2)
     14  (caddr (solve-money-puzzle)))
    815
    916(include "../amb-dwelling")
    10 (assert (equal? '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)) (solve-dwelling-puzzle)))
     17(test "amb-dwelling"
     18  '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
     19  (solve-dwelling-puzzle))
     20
     21(test-end "amb")
Note: See TracChangeset for help on using the changeset viewer.