Changeset 34138 in project


Ignore:
Timestamp:
05/30/17 22:55:26 (7 months ago)
Author:
kon
Message:

add amb-thunks-shuffled, count-member

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

Legend:

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

    r34107 r34138  
    11;;;; amb-extras.scm
    22;;;; Kon Lovett, Mar '09
     3;;;; Kon Lovett, Mar '17
    34
    45(module amb-extras
    56
    67(;export
    7   implies
    8   (choose shuffle)
     8  (amb1 list-thunkify)
     9  (choose random list-thunkify)
    910  one-of
    1011  all-of
    1112  required
    12   distinct?)
     13  implies
     14  distinct?
     15  ;
     16  count-member)
    1317
    14 (import scheme chicken)
     18(import scheme)
     19
     20(import chicken)
    1521(import
    16   (only srfi-1 member)
    1722  (only extras random)
    1823  (only data-structures sort!))
    1924
    20 (import
    21   amb
    22   (only type-checks check-list check-procedure))
    23 (require-library
    24   amb
    25   type-checks)
     25(import (only (srfi 1) count))
     26(require-library (srfi 1))
     27
     28(import (only type-checks check-list check-procedure))
     29(require-library type-checks)
     30
     31(require-extension amb)
     32
     33;;;
    2634
    2735;;
    2836
    29 (define (implies a b)
    30   (or (not a) b) )
    31 
    32 (define shuffle
    33   ;; this should really shadow SORT! and RANDOM...
    34   (lambda (l random)
    35     (let ((len (length l)))
    36       (map
    37         cdr
    38         (sort!
    39           (map (lambda (x) (cons (random len) x)) l)
    40           (lambda (x y) (< (car x) (car y)))) ) ) ) )
     37(define-syntax amb1
     38  (syntax-rules ()
     39    ((_)
     40     ((amb-failure-continuation)) )
     41    ((_ ?ls)
     42     (amb-thunks (list-thunkify ?ls)) ) ) )
    4143
    4244(define-syntax choose
    4345  (syntax-rules ()
    44     ((_ ?ls)
    45       (amb-thunks (map (lambda (x) (lambda () x)) (shuffle ?ls random))) ) ) )
     46     ((_)
     47     ((amb-failure-continuation)) )
     48   ((_ ?ls)
     49      (amb-thunks-shuffled (list-thunkify ?ls) random) ) ) )
    4650
    4751(define-syntax one-of
     
    5862  (syntax-rules ()
    5963    ((_ ?expr)
    60       (amb-assert ?expr) ) ) )
     64     (amb-assert ?expr) ) ) )
     65
     66;;
     67
     68(define (implies a b)
     69  (or (not a) b) )
    6170
    6271(define (distinct? xs #!optional (eql? equal?))
    6372  (check-list 'distinct? xs 'list)
    64   (check-procedure 'distinct? eql? 'equivalence)
    65   (let loop ((xs xs))
     73  (check-procedure 'distinct? eql? '=?)
     74  (let loop ((txs xs))
    6675    (or
    67       (null? xs)
     76      (null? txs)
    6877      (and
    69         (not (member (car xs) (cdr xs) eql?))
    70         (loop (cdr xs)))) ) )
     78        (= 1 (count-member (car txs) xs eql?))
     79        (loop (cdr txs)))) ) )
     80
     81;;;
     82
     83;;
     84
     85(define (count-member x xs #!optional (eql? equal?))
     86  (count (cut eql? x <>) xs) )
     87
     88(define (list-thunkify ls)
     89  (map (lambda (x) (lambda () x)) ls) )
    7190
    7291) ;module amb-extras
  • release/4/amb/tags/2.2.0/amb.meta

    r26835 r34138  
    1313        (condition-utils "1.0.0"))
    1414 (test-depends test)
    15  (files "amb.setup" "amb.scm" "amb-dwelling.scm" "amb.release-info" "amb-pythagorean.scm" "amb-extras.scm" "amb-money.scm" "amb-kalotan.scm" "amb-sat-solve.scm" "amb.meta" "tests/run.scm") )
     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 
  • release/4/amb/tags/2.2.0/amb.scm

    r34107 r34138  
    11;;;; amb.scm
    22;;;; The fundamental non-deterministic backtracking operator
     3
    34;;;; Chicken 4 Port: Kon Lovett, Mar '09
     5;;;; Kon Lovett, May '17
    46
    57(module amb
     
    79(;export
    810  amb
    9   (amb/random shuffle)
     11  amb/random
    1012  amb-find
    1113  amb-collect
    1214  amb-assert
    1315  amb-failure-continuation
    14   amb-thunks
     16  amb-thunks amb-thunks-shuffled
    1517  amb-find-thunk
    1618  amb-collect-thunk
    1719  amb-random-function)
    1820
    19 (import scheme chicken)
     21(import scheme)
     22
     23(import chicken)
    2024(import
    2125  (only data-structures sort!)
    2226  (only extras random) )
     27
     28(import (only (srfi 1) map!))
     29(require-library (srfi 1))
    2330
    2431(import
     
    2936  miscmacros type-errors condition-utils)
    3037
     38;;;
     39
     40;;
     41
     42(define (amb-exhausted)
     43  (signal (make-amb-exhausted-condition)) )
     44
     45(define make-amb-exhausted-condition
     46  (let ((+cached-amb-exhausted-condition+
     47         (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb)))
     48    (lambda ()
     49      +cached-amb-exhausted-condition+ ) ) )
     50
    3151;;
    3252
     
    3656      x
    3757      (begin
    38         (warning 'amb-random-function "not a procedure" x)
     58        (warning 'amb-random-function "not a procedure" x)
    3959        (amb-random-function) ) ) ) )
    40 
    41 (define shuffle
    42   ;; this should really shadow SORT! and RANDOM...
    43   (lambda (l random)
    44     (let ((len (length l)))
    45       (map
    46         cdr
    47         (sort!
    48           (map (lambda (x) (cons (random len) x)) l)
    49           (lambda (x y) (< (car x) (car y)))) ) ) ) )
    50 
    51 (define-syntax amb
    52   (syntax-rules ()
    53     ((_)
    54       ((amb-failure-continuation)) )
    55     ((_ ?expr0 ...)
    56       (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
    57 
    58 (define-syntax amb/random
    59   (syntax-rules ()
    60     ((_)
    61       ((amb-failure-continuation)) )
    62     ((_ ?expr0 ...)
    63       (amb-thunks (shuffle (list (lambda () ?expr0) ...) (amb-random-function))) ) ) )
    64 
    65 (define-syntax amb-find
    66   (syntax-rules ()
    67     ((_ ?expr)
    68       (amb-find-thunk (lambda () ?expr)) )
    69     ((_ ?expr ?fail)
    70       (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
    71 
    72 (define-syntax amb-collect
    73   (syntax-rules ()
    74     ((_ ?expr)
    75       (amb-collect-thunk (lambda () ?expr)) ) ) )
    76 
    77 (define-syntax amb-assert
    78   (syntax-rules ()
    79     ((_ ?expr)
    80       (unless ?expr ((amb-failure-continuation))) ) ) )
    81 
    82 ;;
    83 
    84 (define (make-amb-exhausted-condition)
    85   (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb) )
    86 
    87 (define (amb-exhausted) (signal (make-amb-exhausted-condition)))
    88 
    89 ;;
    9060
    9161(define-parameter amb-failure-continuation amb-exhausted
     
    9666        (warning-argument-type 'amb-failure-continuation x 'procedure)
    9767        (amb-failure-continuation) ) ) ) )
     68
     69;;
     70
     71(define-syntax amb
     72  (syntax-rules ()
     73    ((_)
     74     ((amb-failure-continuation)) )
     75    ((_ ?expr0 ...)
     76     (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
     77
     78(define-syntax amb/random
     79  (syntax-rules ()
     80    ((_)
     81     ((amb-failure-continuation)) )
     82    ((_ ?expr0 ...)
     83     (amb-thunks-shuffled (list (lambda () ?expr0) ...)) ) ) )
     84
     85(define-syntax amb-find
     86  (syntax-rules ()
     87    ((_ ?expr)
     88     (amb-find-thunk (lambda () ?expr)) )
     89    ((_ ?expr ?fail)
     90     (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
     91
     92(define-syntax amb-collect
     93  (syntax-rules ()
     94    ((_ ?expr)
     95     (amb-collect-thunk (lambda () ?expr)) ) ) )
     96
     97(define-syntax amb-assert
     98  (syntax-rules ()
     99    ((_ ?expr)
     100     (unless ?expr ((amb-failure-continuation))) ) ) )
    98101
    99102;;
     
    111114            (return ((car tt))) ) ) ) ) ) )
    112115
     116(define (amb-thunks-shuffled thunks #!optional (rand (amb-random-function)))
     117  (amb-thunks (shuffle thunks rand)) )
     118
    113119(define (amb-find-thunk thunk #!optional (failure amb-exhausted))
    114120  (let/cc return
     
    124130        (let/cc return
    125131          (let* ((root (list #f))
    126                  (head root))
     132                 (head root) )
    127133            (amb-failure-continuation (lambda () (return (cdr root))))
    128134            (set-cdr! head (list (thunk)))
     
    132138        (amb-failure-continuation afc) ) ) ) )
    133139
     140;;;
     141
     142(define (shuffle ls random)
     143  (let ((len (length ls)))
     144    (map!
     145      cdr
     146      (sort!
     147        (map (lambda (x) (cons (random len) x)) ls)
     148        (lambda (x y) (< (car x) (car y)))) ) ) )
     149
    134150) ;module amb
  • release/4/amb/tags/2.2.0/amb.setup

    r34107 r34138  
    55(verify-extension-name "amb")
    66
    7 (setup-shared-extension-module 'amb (extension-version "2.1.7")
     7(setup-shared-extension-module 'amb (extension-version "2.2.0")
    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.7")
     13(setup-shared-extension-module 'amb-extras (extension-version "2.2.0")
    1414  #:inline? #t
    1515  #:types? #t
  • release/4/amb/trunk/amb-extras.scm

    r34107 r34138  
    11;;;; amb-extras.scm
    22;;;; Kon Lovett, Mar '09
     3;;;; Kon Lovett, Mar '17
    34
    45(module amb-extras
    56
    67(;export
    7   implies
    8   (choose shuffle)
     8  (amb1 list-thunkify)
     9  (choose random list-thunkify)
    910  one-of
    1011  all-of
    1112  required
    12   distinct?)
     13  implies
     14  distinct?
     15  ;
     16  count-member)
    1317
    14 (import scheme chicken)
     18(import scheme)
     19
     20(import chicken)
    1521(import
    16   (only srfi-1 member)
    1722  (only extras random)
    1823  (only data-structures sort!))
    1924
    20 (import
    21   amb
    22   (only type-checks check-list check-procedure))
    23 (require-library
    24   amb
    25   type-checks)
     25(import (only (srfi 1) count))
     26(require-library (srfi 1))
     27
     28(import (only type-checks check-list check-procedure))
     29(require-library type-checks)
     30
     31(require-extension amb)
     32
     33;;;
    2634
    2735;;
    2836
    29 (define (implies a b)
    30   (or (not a) b) )
    31 
    32 (define shuffle
    33   ;; this should really shadow SORT! and RANDOM...
    34   (lambda (l random)
    35     (let ((len (length l)))
    36       (map
    37         cdr
    38         (sort!
    39           (map (lambda (x) (cons (random len) x)) l)
    40           (lambda (x y) (< (car x) (car y)))) ) ) ) )
     37(define-syntax amb1
     38  (syntax-rules ()
     39    ((_)
     40     ((amb-failure-continuation)) )
     41    ((_ ?ls)
     42     (amb-thunks (list-thunkify ?ls)) ) ) )
    4143
    4244(define-syntax choose
    4345  (syntax-rules ()
    44     ((_ ?ls)
    45       (amb-thunks (map (lambda (x) (lambda () x)) (shuffle ?ls random))) ) ) )
     46     ((_)
     47     ((amb-failure-continuation)) )
     48   ((_ ?ls)
     49      (amb-thunks-shuffled (list-thunkify ?ls) random) ) ) )
    4650
    4751(define-syntax one-of
     
    5862  (syntax-rules ()
    5963    ((_ ?expr)
    60       (amb-assert ?expr) ) ) )
     64     (amb-assert ?expr) ) ) )
     65
     66;;
     67
     68(define (implies a b)
     69  (or (not a) b) )
    6170
    6271(define (distinct? xs #!optional (eql? equal?))
    6372  (check-list 'distinct? xs 'list)
    64   (check-procedure 'distinct? eql? 'equivalence)
    65   (let loop ((xs xs))
     73  (check-procedure 'distinct? eql? '=?)
     74  (let loop ((txs xs))
    6675    (or
    67       (null? xs)
     76      (null? txs)
    6877      (and
    69         (not (member (car xs) (cdr xs) eql?))
    70         (loop (cdr xs)))) ) )
     78        (= 1 (count-member (car txs) xs eql?))
     79        (loop (cdr txs)))) ) )
     80
     81;;;
     82
     83;;
     84
     85(define (count-member x xs #!optional (eql? equal?))
     86  (count (cut eql? x <>) xs) )
     87
     88(define (list-thunkify ls)
     89  (map (lambda (x) (lambda () x)) ls) )
    7190
    7291) ;module amb-extras
  • release/4/amb/trunk/amb.meta

    r26835 r34138  
    1313        (condition-utils "1.0.0"))
    1414 (test-depends test)
    15  (files "amb.setup" "amb.scm" "amb-dwelling.scm" "amb.release-info" "amb-pythagorean.scm" "amb-extras.scm" "amb-money.scm" "amb-kalotan.scm" "amb-sat-solve.scm" "amb.meta" "tests/run.scm") )
     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 
  • release/4/amb/trunk/amb.scm

    r34107 r34138  
    11;;;; amb.scm
    22;;;; The fundamental non-deterministic backtracking operator
     3
    34;;;; Chicken 4 Port: Kon Lovett, Mar '09
     5;;;; Kon Lovett, May '17
    46
    57(module amb
     
    79(;export
    810  amb
    9   (amb/random shuffle)
     11  amb/random
    1012  amb-find
    1113  amb-collect
    1214  amb-assert
    1315  amb-failure-continuation
    14   amb-thunks
     16  amb-thunks amb-thunks-shuffled
    1517  amb-find-thunk
    1618  amb-collect-thunk
    1719  amb-random-function)
    1820
    19 (import scheme chicken)
     21(import scheme)
     22
     23(import chicken)
    2024(import
    2125  (only data-structures sort!)
    2226  (only extras random) )
     27
     28(import (only (srfi 1) map!))
     29(require-library (srfi 1))
    2330
    2431(import
     
    2936  miscmacros type-errors condition-utils)
    3037
     38;;;
     39
     40;;
     41
     42(define (amb-exhausted)
     43  (signal (make-amb-exhausted-condition)) )
     44
     45(define make-amb-exhausted-condition
     46  (let ((+cached-amb-exhausted-condition+
     47         (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb)))
     48    (lambda ()
     49      +cached-amb-exhausted-condition+ ) ) )
     50
    3151;;
    3252
     
    3656      x
    3757      (begin
    38         (warning 'amb-random-function "not a procedure" x)
     58        (warning 'amb-random-function "not a procedure" x)
    3959        (amb-random-function) ) ) ) )
    40 
    41 (define shuffle
    42   ;; this should really shadow SORT! and RANDOM...
    43   (lambda (l random)
    44     (let ((len (length l)))
    45       (map
    46         cdr
    47         (sort!
    48           (map (lambda (x) (cons (random len) x)) l)
    49           (lambda (x y) (< (car x) (car y)))) ) ) ) )
    50 
    51 (define-syntax amb
    52   (syntax-rules ()
    53     ((_)
    54       ((amb-failure-continuation)) )
    55     ((_ ?expr0 ...)
    56       (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
    57 
    58 (define-syntax amb/random
    59   (syntax-rules ()
    60     ((_)
    61       ((amb-failure-continuation)) )
    62     ((_ ?expr0 ...)
    63       (amb-thunks (shuffle (list (lambda () ?expr0) ...) (amb-random-function))) ) ) )
    64 
    65 (define-syntax amb-find
    66   (syntax-rules ()
    67     ((_ ?expr)
    68       (amb-find-thunk (lambda () ?expr)) )
    69     ((_ ?expr ?fail)
    70       (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
    71 
    72 (define-syntax amb-collect
    73   (syntax-rules ()
    74     ((_ ?expr)
    75       (amb-collect-thunk (lambda () ?expr)) ) ) )
    76 
    77 (define-syntax amb-assert
    78   (syntax-rules ()
    79     ((_ ?expr)
    80       (unless ?expr ((amb-failure-continuation))) ) ) )
    81 
    82 ;;
    83 
    84 (define (make-amb-exhausted-condition)
    85   (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb) )
    86 
    87 (define (amb-exhausted) (signal (make-amb-exhausted-condition)))
    88 
    89 ;;
    9060
    9161(define-parameter amb-failure-continuation amb-exhausted
     
    9666        (warning-argument-type 'amb-failure-continuation x 'procedure)
    9767        (amb-failure-continuation) ) ) ) )
     68
     69;;
     70
     71(define-syntax amb
     72  (syntax-rules ()
     73    ((_)
     74     ((amb-failure-continuation)) )
     75    ((_ ?expr0 ...)
     76     (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
     77
     78(define-syntax amb/random
     79  (syntax-rules ()
     80    ((_)
     81     ((amb-failure-continuation)) )
     82    ((_ ?expr0 ...)
     83     (amb-thunks-shuffled (list (lambda () ?expr0) ...)) ) ) )
     84
     85(define-syntax amb-find
     86  (syntax-rules ()
     87    ((_ ?expr)
     88     (amb-find-thunk (lambda () ?expr)) )
     89    ((_ ?expr ?fail)
     90     (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
     91
     92(define-syntax amb-collect
     93  (syntax-rules ()
     94    ((_ ?expr)
     95     (amb-collect-thunk (lambda () ?expr)) ) ) )
     96
     97(define-syntax amb-assert
     98  (syntax-rules ()
     99    ((_ ?expr)
     100     (unless ?expr ((amb-failure-continuation))) ) ) )
    98101
    99102;;
     
    111114            (return ((car tt))) ) ) ) ) ) )
    112115
     116(define (amb-thunks-shuffled thunks #!optional (rand (amb-random-function)))
     117  (amb-thunks (shuffle thunks rand)) )
     118
    113119(define (amb-find-thunk thunk #!optional (failure amb-exhausted))
    114120  (let/cc return
     
    124130        (let/cc return
    125131          (let* ((root (list #f))
    126                  (head root))
     132                 (head root) )
    127133            (amb-failure-continuation (lambda () (return (cdr root))))
    128134            (set-cdr! head (list (thunk)))
     
    132138        (amb-failure-continuation afc) ) ) ) )
    133139
     140;;;
     141
     142(define (shuffle ls random)
     143  (let ((len (length ls)))
     144    (map!
     145      cdr
     146      (sort!
     147        (map (lambda (x) (cons (random len) x)) ls)
     148        (lambda (x y) (< (car x) (car y)))) ) ) )
     149
    134150) ;module amb
  • release/4/amb/trunk/amb.setup

    r34107 r34138  
    55(verify-extension-name "amb")
    66
    7 (setup-shared-extension-module 'amb (extension-version "2.1.7")
     7(setup-shared-extension-module 'amb (extension-version "2.2.0")
    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.7")
     13(setup-shared-extension-module 'amb-extras (extension-version "2.2.0")
    1414  #:inline? #t
    1515  #:types? #t
Note: See TracChangeset for help on using the changeset viewer.