#|  amb.scm: McCarthy's ambiguous operator.
    Copyright (C) 2007 Will M. Farr <[email protected]>

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
|#

(module amb mzscheme
  (provide with-amb amb-thunks amb amb-collect)
  
  (require (lib "list.ss" "srfi" "1"))
  
  (define (default-base-amb-fail)
    (error 'amb "no more choices"))
  
  (define base-amb-fail
    (make-parameter default-base-amb-fail))
  
  (define amb-running?
    (make-parameter #f))
  
  (define queue? (lambda (obj) (or (null? obj) (pair? obj))))
  (define empty? null?)
  (define head car)
  (define pop cdr)
  (define push cons)
  (define (make-empty) '())
  
  (define queue
    (make-parameter (make-empty)))
  
  (define-struct choice
    (continuation thunk) #f)
  
  (define (amb-fail)
    (if (empty? (queue))
        ((base-amb-fail))
        (let ((next-choice (head (queue))))
          (queue (pop (queue)))
          ((choice-continuation next-choice)
           ((choice-thunk next-choice))))))
  
  (define-syntax amb
    (syntax-rules ()
      ((amb) (amb-fail))
      ((amb x) x)
      ((amb x y ...)
       (call/cc
        (lambda (k)
          (amb-thunks k (lambda () x) (lambda () y) ...))))))
  
  (define (amb-thunks k . thunks)
    (if (amb-running?)
        (begin (add-to-queue! k (cdr thunks))
               (k ((car thunks))))
        (error 'amb-thunks "no running amb instance")))
  
  (define (add-to-queue! k thunks)
    (let ((choices (map (lambda (thunk) (make-choice k thunk)) thunks)))
      (queue (fold-right push (queue) choices))))
  
  (define-syntax amb-collect
    (syntax-rules ()
      ((amb-collect expr ...)
       (let ((results '()))
         (call/cc
          (lambda (return)
            (parameterize ((queue (make-empty))
                           (base-amb-fail (lambda () (return (reverse results))))
                           (amb-running? #t))
              (let ((result (begin expr ...)))
                (set! results (cons result results))
                (amb)))))))))
  
  (define-syntax with-amb
    (syntax-rules ()
      ((with-amb expr ...)
       (parameterize ((queue (make-empty))
                      (base-amb-fail default-base-amb-fail)
                      (amb-running? #t))
         expr ...)))))