;; The following definition for *amb* and the Kalotan Puzzle
example are from Teach
Yourself Scheme in Fixnum Days by Dorai Sitaram.
(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)))