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