;; 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)))