parallel-amb-callcc.scm

(use gauche.threads)

(define (amb . xs)
  (call/cc
    (lambda (k)
      (if (null? xs)
          ((thread-specific (current-thread)) #f)
          (begin
            (for-each
              (lambda (x)
                (let ((t (make-thread
                          (lambda ()
                            (guard (e (else #f))
                              (call/cc
                                (lambda (k2)
                                  (thread-specific-set! (current-thread) k2)
                                  (k x))))))))
                  (thread-start! t)))
              (cdr xs))
            (k (car xs)))))))

(define (run thunk)
  (let ((t
         (make-thread
          (lambda ()
            (guard (e (else #f))
              (call/cc
                (lambda (k)
                  (thread-specific-set! (current-thread) k)
                  (thunk)
                  ((thread-specific (current-thread)) #f))))))))
    (thread-start! t)
    (thread-join! t)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; N-Queens

(define (conflict? k qs)
  (if (memv k qs)
      #t
      (let loop ((a (+ k 1)) (b (- k 1)) (qs qs))
        (if (null? qs)
            #f
            (let ((q (car qs)))
              (if (or (eqv? a q)
                      (eqv? b q))
                  #t
                  (loop (+ a 1) (- b 1) (cdr qs))))))))

(define (an-element-of items)
  (apply amb items))

(define (q m n qs)
  (if (= n m)
      qs
      (let ((k (an-element-of (iota m))))
        (if (conflict? k qs)
            (amb)
            (q m (+ n 1) (cons k qs))))))

(run (lambda () (format #t "~S\n" (q 8 0 '()))))