source: project/release/4/amb/trunk/amb-kalotan.scm @ 13801

Last change on this file since 13801 was 13801, checked in by Kon Lovett, 12 years ago

Save.

File size: 2.3 KB
Line 
1;;;; amb-kalotan.scm
2
3(require-extension amb)
4
5;; The following code is a rewrite of an example from the book "Teach Yourself
6;; Scheme in Fixnum Days" by Dorai Sitaram. The book gives the following problem
7;; setting:
8;;
9;; The Kalotans are a tribe with a peculiar quirk. Their males always tell the
10;; truth. Their females never make two consecutive true statements, or two
11;; consecutive untrue statements.
12;;
13;; An anthropologist (let's call him Worf) has begun to study them. Worf does not
14;; yet know the Kalotan language. One day, he meets a Kalotan (heterosexual)
15;; couple and their child Kibi. Worf asks Kibi: "Are you a boy?" Kibi answers in
16;; Kalotan, which of course Worf doesn't understand.
17;;
18;; Worf turns to the parents (who know English) for explanation. One of them says:
19;; "Kibi said: 'I am a boy.'" The other adds: "Kibi is a girl. Kibi lied.
20;;
21;; Solve for the sex of the parents and Kibi.
22
23(define (solve-kalotan-puzzle)
24
25  (define (xor a? b?) (if (and a? b?) #f (or a? b?)))
26
27  (let ((parent1 (amb 'male 'female))
28        (parent2 (amb 'male 'female))
29        (kibi (amb 'male 'female))
30        (kibi-self-desc (amb 'male 'female))
31        (kibi-lied? (amb #t #f)) )
32
33    (amb-assert (not (eq? parent1 parent2)))
34
35    (when kibi-lied?
36      (amb-assert (xor (and (eq? kibi-self-desc 'male)
37                            (eq? kibi 'female))
38                       (and (eq? kibi-self-desc 'female)
39                            (eq? kibi 'male)))) )
40
41    (unless kibi-lied?
42      (amb-assert (xor (and (eq? kibi-self-desc 'male)
43                            (eq? kibi 'male))
44                       (and (eq? kibi-self-desc 'female)
45                            (eq? kibi 'female)))) )
46
47    (when (eq? parent1 'male)
48      (amb-assert (and (eq? kibi-self-desc 'male)
49                       (xor (and (eq? kibi 'female)
50                                 (not kibi-lied?))
51                            (and (eq? kibi 'male)
52                                 kibi-lied?)))) )
53
54    (when (eq? parent1 'female)
55      (amb-assert (and (eq? kibi 'female)
56                       kibi-lied?)) )
57
58    (list parent1 parent2 kibi) ) )
59
60(let* ((res (amb-collect (solve-kalotan-puzzle)))
61       (ls (car res))
62       (p1 (car ls))
63       (p2 (cadr ls))
64       (kibi (caddr ls)) )
65  (print "Gender Parent 1 " p1 " Parent 2 " p2 " Kibi " kibi)
66  (newline) )
Note: See TracBrowser for help on using the repository browser.