Changeset 38990 in project


Ignore:
Timestamp:
09/01/20 03:02:06 (4 weeks ago)
Author:
Kon Lovett
Message:

fix amb-collect-thunks type assumption, reflow, type is interface, update test runner

Location:
release/5/amb/trunk
Files:
8 edited

Legend:

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

    r38500 r38990  
    1818(define (solve-dwelling-puzzle)
    1919  ;
    20   (let (
    21     (baker    (amb 1 2 3 4 5))
    22     (cooper   (amb 1 2 3 4 5))
    23     (fletcher (amb 1 2 3 4 5))
    24     (miller   (amb 1 2 3 4 5))
    25     (smith    (amb 1 2 3 4 5)) )
     20  (let ((baker    (amb 1 2 3 4 5))
     21        (cooper   (amb 1 2 3 4 5))
     22        (fletcher (amb 1 2 3 4 5))
     23        (miller   (amb 1 2 3 4 5))
     24        (smith    (amb 1 2 3 4 5)) )
    2625    ;
    2726    ;; They live on different floors.
  • release/5/amb/trunk/amb-extras.scm

    r38500 r38990  
    2828(import amb)
    2929
    30 ;;;
     30;;
     31
     32(: count-member (* (list-of *) #!rest (list procedure) --> fixnum))
     33(: only-member? (* (list-of *) #!rest (list procedure) --> boolean))
     34(: list-constantly (list --> (list-of procedure)))
     35(: distinct? ((list-of *) #!rest (list procedure) --> boolean))
    3136
    3237;; Convenience
     
    8489;;
    8590
    86 (: count-member (* (list-of *) #!rest (list procedure) --> fixnum))
    87 ;
    8891(define (count-member x xs . opts)
    8992  (let ((eql? (optional opts equal?)))
    9093    (count (cut eql? x <>) xs) ) )
    9194
    92 (: only-member? (* (list-of *) #!rest (list procedure) --> boolean))
    93 ;
    9495(define (only-member? x xs . opts)
    9596  (let ((eql? (optional opts equal?)))
     
    9899;;
    99100
    100 (: list-constantly (list --> (list-of procedure)))
    101 ;
    102101(define (list-constantly ls)
    103102  (map constantly ls) )
     
    105104;;
    106105
    107 (: distinct? ((list-of *) #!rest (list procedure) --> boolean))
    108 ;
    109106(define (distinct? xs . opts)
    110107  (let ((eql? (optional opts equal?)))
  • release/5/amb/trunk/amb-kalotan.scm

    r38500 r38990  
    2626(define (solve-kalotan-puzzle)
    2727  ;
    28   (let (
    29     (parent1          (amb 'male 'female))
    30     (parent2          (amb 'male 'female))
    31     (kibi             (amb 'male 'female))
    32     (kibi-self-desc   (amb 'male 'female))
    33     (kibi-lied?       (amb #t #f)) )
     28  (let ((parent1          (amb 'male 'female))
     29        (parent2          (amb 'male 'female))
     30        (kibi             (amb 'male 'female))
     31        (kibi-self-desc   (amb 'male 'female))
     32        (kibi-lied?       (amb #t #f)) )
    3433    ;
    3534    (amb-assert (not (eq? parent1 parent2)))
  • release/5/amb/trunk/amb-money.scm

    r38500 r38990  
    3232(define (solve-money-puzzle)
    3333  ;
    34   (let (
    35     (digits '(0 1 2 3 4 5 6 7 8 9))
    36     (trial 0)
    37     (m 1) )
     34  (let ((digits '(0 1 2 3 4 5 6 7 8 9))
     35        (trial 0)
     36        (m 1) )
    3837    ;
    39     (let (
    40       (p1 (amb 0 1))
    41       (p2 (amb 0 1))
    42       (p3 (amb 0 1))
    43       (d (choose digits) ) )
     38    (let ((p1 (amb 0 1))
     39          (p2 (amb 0 1))
     40          (p3 (amb 0 1))
     41          (d (choose digits) ) )
    4442      ;
    45       (let* (
    46         (e (choose (lset-difference equal? digits (list d))))
    47         (y (modulo (+ d e (* -10 p1)) 10))
    48         (n (choose (lset-difference equal? digits (list d e y))))
    49         (r (modulo (+ (* 10 p2) e (- p1) (- n)) 10))
    50         (o (modulo (+ (* 10 p3) n (- p2) (- e)) 10))
    51         (s (modulo (+ (* 9 m) o (- p3)) 10) ) )
     43      (let* ((e (choose (lset-difference equal? digits (list d))))
     44             (y (modulo (+ d e (* -10 p1)) 10))
     45             (n (choose (lset-difference equal? digits (list d e y))))
     46             (r (modulo (+ (* 10 p2) e (- p1) (- n)) 10))
     47             (o (modulo (+ (* 10 p3) n (- p2) (- e)) 10))
     48             (s (modulo (+ (* 9 m) o (- p3)) 10)) )
    5249        ;
    5350        (set! trial (add1 trial))
  • release/5/amb/trunk/amb-pl-solver.scm

    r38500 r38990  
    1818  (syntax-rules (and or xor implies not)
    1919    ;
    20     ((_ ?form ?body)
     20    ((solve ?form ?body)
    2121      (solve ?form ?body ?form) )
    2222    ;
  • release/5/amb/trunk/amb-pythagorean.scm

    r38500 r38990  
    99(define (pythagorean)
    1010  ;
    11   (let (
    12     (a (amb 1 2 3 4 5 6 7))
    13     (b (amb 1 2 3 4 5 6 7))
    14     (c (amb 1 2 3 4 5 6 7)) )
     11  (let ((a (amb 1 2 3 4 5 6 7))
     12        (b (amb 1 2 3 4 5 6 7))
     13        (c (amb 1 2 3 4 5 6 7)) )
    1514    ;
    1615    ; We're looking for dimensions of a legal right
  • release/5/amb/trunk/amb.scm

    r38500 r38990  
    3838(import (only exn-condition make-exn-condition+))
    3939
    40 ;;; data-structures
    41 
    42 (define platform-random pseudo-random-integer)
    43 
    44 (: vector-shuffle! ((vector-of *) #!optional (procedure (fixnum) fixnum) -> void))
    45 ;
    46 (define (vector-shuffle! vec #!optional (rnd platform-random))
    47   (let (
    48     (len (vector-length vec)) )
    49     (define (swap-adj! i)
    50       (let (
    51         (i+1 (modulo (+ i 1) len))
    52         (tmp (vector-ref vec i)) )
    53         (vector-set! vec i (vector-ref vec i+1))
    54         (vector-set! vec i+1 tmp) ) )
    55     (do ((n (integer-length len) (- n 1)))
    56         ((= n 0))
    57       (swap-adj! (rnd len)) ) ) )
    58 
    59 (: shuffle ((list-of *) #!optional (procedure (fixnum) fixnum) -> (list-of *)))
    60 ;
    61 (define (shuffle ls #!optional (rnd platform-random))
    62   (let (
    63     (vec (list->vector ls)) )
    64     (vector-shuffle! vec rnd)
    65     (vector->list vec) ) )
    66 
    67 ;;; miscmacros
     40;;(from miscmacros.scm)
    6841
    6942(define-syntax let/cc
     
    8255     (define name (make-parameter (void))))))
    8356
    84 ;;;
     57;;
     58
     59(: vector-shuffle! ((vector-of *) #!optional (procedure (fixnum) fixnum) -> void))
     60(: shuffle ((list-of *) #!optional (procedure (fixnum) fixnum) -> (list-of *)))
     61(: amb-thunks ((list-of procedure) -> *))
     62(: amb-thunks-shuffled ((list-of procedure) #!rest (list procedure) -> *))
     63(: amb-find-thunk (procedure #!rest (list procedure) -> *))
     64(: amb-collect-thunk (procedure -> *))
     65
     66;;
     67
     68(define platform-random pseudo-random-integer)
     69
     70(define (vector-shuffle! vec #!optional (rnd platform-random))
     71  (let ((len (vector-length vec)))
     72    (define (swap-adj! i)
     73      (let ((i+1 (modulo (add1 i) len))
     74            (tmp (vector-ref vec i)) )
     75            (vector-set! vec i (vector-ref vec i+1))
     76            (vector-set! vec i+1 tmp) ) )
     77    (do ((n (integer-length len) (sub1 n)))
     78        ((= n 0))
     79      (swap-adj! (rnd len)) ) ) )
     80
     81(define (shuffle ls #!optional (rnd platform-random))
     82  (let ((vec (list->vector ls)))
     83    (vector-shuffle! vec rnd)
     84    (vector->list vec) ) )
    8585
    8686;;
     
    9090
    9191(define make-amb-exhausted-condition
    92   (let (
    93     (+cached-amb-exhausted-condition+
    94       (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb)) )
     92  (let ((+cached-amb-exhausted-condition+
     93          (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb)) )
    9594    (lambda () +cached-amb-exhausted-condition+) ) )
    9695
     
    118117  (syntax-rules ()
    119118    ;
    120     ((_)
     119    ((amb)
    121120     ((amb-failure-continuation)) )
    122121    ;
    123     ((_ ?expr0 ...)
     122    ((amb ?expr0 ...)
    124123     (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
    125124
     
    127126  (syntax-rules ()
    128127    ;
    129     ((_)
     128    ((amb/random)
    130129     ((amb-failure-continuation)) )
    131130    ;
    132     ((_ ?expr0 ...)
     131    ((amb/random ?expr0 ...)
    133132     (amb-thunks-shuffled (list (lambda () ?expr0) ...)) ) ) )
    134133
     
    136135  (syntax-rules ()
    137136    ;
    138     ((_ ?expr)
     137    ((amb-find ?expr)
    139138     (amb-find-thunk (lambda () ?expr)) )
    140139    ;
    141     ((_ ?expr ?fail)
     140    ((amb-find ?expr ?fail)
    142141     (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
    143142
    144143(define-syntax amb-collect
    145144  (syntax-rules ()
    146     ((_ ?expr)
     145    ((amb-collect ?expr)
    147146     (amb-collect-thunk (lambda () ?expr)) ) ) )
    148147
    149148(define-syntax amb-assert
    150149  (syntax-rules ()
    151     ((_ ?expr)
     150    ((amb-assert ?expr)
    152151     (unless ?expr ((amb-failure-continuation))) ) ) )
    153152
    154153;;
    155154
    156 (: amb-thunks ((list-of procedure) -> *))
    157 ;
    158155(define (amb-thunks thunks)
    159156  (let ((afc (amb-failure-continuation)))
     
    168165            (return ((car tt))) ) ) ) ) ) )
    169166
    170 (: amb-thunks-shuffled ((list-of procedure) #!rest (list procedure) -> *))
    171 ;
    172167(define (amb-thunks-shuffled thunks . opts)
    173168  (let ((rand (optional opts (amb-random-function))))
    174169    (amb-thunks (shuffle thunks rand)) ) )
    175170
    176 (: amb-find-thunk (procedure #!rest (list procedure) -> *))
    177 ;
    178171(define (amb-find-thunk thunk . opts)
    179172  (let ((failure (optional opts amb-exhausted)))
     
    183176          (thunk) ) ) ) ) )
    184177
    185 (: amb-collect-thunk (procedure -> *))
    186 ;
    187178(define (amb-collect-thunk thunk)
    188   (let ((afc #f))
     179  (let ((afc (amb-failure-continuation)))
    189180    (dynamic-wind
    190181      ;
    191       (lambda ()
    192         (set! afc (amb-failure-continuation)) )
     182      void
    193183      ;
    194184      (lambda ()
    195185        (let/cc return
    196           (let* (
    197             (root (list #f))
    198             (head root) )
    199             ;
     186          (let* ((root (the list (list #f))) ;ovverride strict-types assumption
     187                 (head root) )
    200188            (amb-failure-continuation (lambda () (return (cdr root))))
    201189            (set-cdr! head (list (thunk)))
  • release/5/amb/trunk/tests/amb-test.scm

    r38414 r38990  
    1010(import scheme)
    1111(import (chicken base))
     12
     13(import amb amb-extras)
     14
     15(test '(1 2 3 4) (all-of (amb 1 2 3 4)))
    1216
    1317(include "../amb-kalotan")
     
    2731
    2832(include "../amb-sat-solve")
    29 (test "amb-sat-solve"
    30   '(#f #f #t)
    31   (sat-solve))
     33(test "amb-sat-solve" '(#f #f #t) (sat-solve))
    3234
    3335(include "../amb-pythagorean")
    34 (test "amb-pythagorean"
    35   '(4 3 5)
    36   (pythagorean))
     36(test "amb-pythagorean" '(4 3 5) (pythagorean))
    3737
    3838;;;
Note: See TracChangeset for help on using the changeset viewer.