;; The following definition for <i>amb</i> and the Kalotan Puzzle
example are from <a
href="http://www.ccs.neu.edu/home/dorai/t-y-scheme/t-y-scheme.html"><cite>Teach
Yourself Scheme in Fixnum Days</cite></a> by Dorai Sitaram.  <xmp>
(define amb-fail '())

(define initialize-amb-fail
  (lambda ()
    (set! amb-fail
      (lambda ()
        (error "amb tree exhausted")))))

(initialize-amb-fail)

(define-macro amb
  (lambda alts
    `(let ((+prev-amb-fail amb-fail))
       (call/cc
        (lambda (+sk)
          ,@(map (lambda (alt)
                   `(call/cc
                     (lambda (+fk)
                       (set! amb-fail
                         (lambda ()
                           (set! amb-fail +prev-amb-fail)
                           (+fk 'fail)))
                       (+sk ,alt))))
                 alts)
          (+prev-amb-fail))))))

(define assert
  (lambda (pred)
    (if (not pred) (amb))))

;; The Kalotans are a tribe with a peculiar quirk. Their males always
;; tell the truth. Their females never make two consecutive true
;; statements, or two consecutive untrue statements. An anthropologist
;; (let's call him Worf) has begun to study them. Worf does not yet know
;; the Kalotan language. One day, he meets a Kalotan (heterosexual)
;; couple and their child Kibi. Worf asks Kibi: ``Are you a boy?'' Kibi
;; answers in Kalotan, which of course Worf doesn't understand.  Worf
;; turns to the parents (who know English) for explanation. One of them
;; says: ``Kibi said: `I am a boy.' '' The other adds: ``Kibi is a
;; girl. Kibi lied.'' Solve for the sex of the parents and Kibi.

(define solve-kalotan-puzzle
  (lambda ()
    (let ((parent1 (amb 'm 'f))
          (parent2 (amb 'm 'f))
          (kibi (amb 'm 'f))
          (kibi-self-desc (amb 'm 'f))
          (kibi-lied? (amb #t #f)))
      (assert
       (distinct? (list parent1 parent2)))
      (assert
       (if (eq? kibi 'm)
           (not kibi-lied?)
	   #t))
      (assert
       (if kibi-lied?
           (xor
            (and (eq? kibi-self-desc 'm)
                 (eq? kibi 'f))
            (and (eq? kibi-self-desc 'f)
                 (eq? kibi 'm)))
	   #t))
      (assert
       (if (not kibi-lied?)
           (xor
            (and (eq? kibi-self-desc 'm)
                 (eq? kibi 'm))
            (and (eq? kibi-self-desc 'f)
                 (eq? kibi 'f)))
	   #t))
      (assert
       (if (eq? parent1 'm)
           (and
            (eq? kibi-self-desc 'm)
            (xor
             (and (eq? kibi 'f)
                  (not kibi-lied?))
             (and (eq? kibi 'm)
                  kibi-lied?)))
	   #t))
      (assert
       (if (eq? parent1 'f)
           (and
            (eq? kibi 'f)
            kibi-lied?)
	   #t))
      (list parent1 parent2 kibi))))

(define distinct?
  (lambda (ls)
    (if (null? ls)
	#t
	(and (not (member (car ls) (cdr ls)))
	     (distinct? (cdr ls))))))

(define xor
  (lambda (x y)
    (if x (not y) y)))

</xmp>