;;;; amb-extras.scm  -*- Scheme -*
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Aug '17
;;;; Kon Lovett, May '17
;;;; Kon Lovett, Mar '09

(module amb-extras

(;export
  amb1
  choose
  one-of
  all-of
  required
  xor
  implies
  distinct?
  count-member
  only-member?
  list-constantly)

(import scheme)
(import (chicken base))
(import (chicken syntax))
(import (chicken type))
(import (only (chicken fixnum) fx+))
(import (only (chicken sort) sort!))
(import (only (srfi 1) count every))
(import amb)

;;

(: count-member (* (list-of *) #!rest (list procedure) --> fixnum))
(: only-member? (* (list-of *) #!rest (list procedure) --> boolean))
(: list-constantly (list --> (list-of procedure)))
(: distinct? ((list-of *) #!rest (list procedure) --> boolean))

;; Convenience

(define-syntax amb1
  (syntax-rules ()
    ;
    ((amb1)
     ((amb-failure-continuation)) )
    ;
    ((amb1 ?ls)
     (amb-thunks (list-constantly ?ls)) ) ) )

(define-syntax choose
  (syntax-rules ()
    ;
    ((choose)
     ((amb-failure-continuation)) )
    ;
    ((choose ?ls)
      (amb-thunks-shuffled (list-constantly ?ls) (amb-random-function)) ) ) )

;; Aliases

(define-syntax one-of
  (syntax-rules ()
    ((one-of ?expr)
      (amb-find ?expr) ) ) )

(define-syntax all-of
  (syntax-rules ()
    ((all-of ?expr)
      (amb-collect ?expr) ) ) )

(define-syntax required
  (syntax-rules ()
    ((required ?expr)
     (amb-assert ?expr) )
    ((required ?expr ...)
     (begin (amb-assert ?expr) ...) ) ) )

;; Logic Control

(define-syntax xor
  (syntax-rules ()
    ((xor ?a ?b)
      (let ((_a ?a) (_b ?b))
        (if (and _a _b) #f (or _a _b)) ) ) ) )

(define-syntax implies
  (syntax-rules ()
    ((mplies ?a ?b)
      (or (not ?a) ?b) ) ) )

;;;

;;

(define (count-member x xs . opts)
  (let ((eql? (optional opts equal?)))
    (count (cut eql? x <>) xs) ) )

(define (only-member? x xs . opts)
  (let ((eql? (optional opts equal?)))
    (= 1 (count-member x xs eql?)) ) )

;;

(define (list-constantly ls)
  (map constantly ls) )

;;

(define (distinct? xs . opts)
  (let ((eql? (optional opts equal?)))
    (every (cut only-member? <> xs eql?) xs) ) )

) ;module amb-extras