;; ATNs: Augmented Transition Networks (OnLisp, chp 23)
;; see also: SICP 4.3
(define first car)
(define rest cdr)
;; prerequisite:
;; section 22.3: Scheme implementation of choose and fail
(define paths ())
(define failsym '@)
;; NOTE this version of choose will run into trouble when fed cyclic
;; graphs. A truely non-deterministic version `true-choose' is on
;; pp 304, fig 22.14.
(define (choose choices)
(if (null? choices)
(fail)
(call-with-current-continuation
(lambda (cc)
(set! paths
(cons (lambda ()
(cc (choose (rest choices))))
paths))
(first choices)))))
(define fail ())
(call-with-current-continuation
(lambda (cc)
(set! fail
(lambda ()
(if (null? paths)
(cc failsym)
(let ((p1 (first paths)))
(set! paths (rest paths))
(p1)))))))
;; on-lisp example, fig 22.3, pp 291
(define (two-numbers)
(list (choose '(0 1 2 3 4 5))
(choose '(0 1 2 3 4 5))))
(define (parlor-trick sum)
(let ((nums (two-numbers)))
(if (= (apply + nums) sum)
`(the sum of ,@nums)
(fail))))
(print "(parlor-trick 7): " (parlor-trick 7))
;; ----------------------------------------------------------------------
;; SICP 4.3.2
;; The following puzzle (taken from Dinesman 1968) is typical of a
;; large class of simple logic puzzles:
;;
;; Baker, Cooper, Fletcher, Miller, and Smith live on different floors
;; of an apartment house that contains only five floors. Baker does
;; not live on the top floor. Cooper does not live on the bottom
;; floor. Fletcher does not live on either the top or the bottom
;; floor. Miller lives on a higher floor than does Cooper. Smith does
;; not live on a floor adjacent to Fletcher's. Fletcher does not live
;; on a floor adjacent to Cooper's. Where does everyone live?
(define (trace string)
(and #f
(print string)))
(define (require. p)
(unless p (fail)))
(define (distinct? seq)
(cond ((null? seq) #t)
((memq (first seq) (rest seq)) #f)
(else (distinct? (rest seq)))))
(define (multiple-dwelling)
(let ((baker (choose '(1 2 3 4 5)))
(cooper (choose '(1 2 3 4 5)))
(fletcher (choose '(1 2 3 4 5)))
(miller (choose '(1 2 3 4 5)))
(smith (choose '(1 2 3 4 5))))
(trace (list baker cooper fletcher miller smith))
(require. (distinct? (list baker cooper fletcher miller smith)))
(trace "distinct")
(require. (not (= baker 5)))
(trace "baker not 5")
(require. (not (= cooper 1)))
(trace "cooper not 1")
(require. (not (= fletcher 5)))
(trace "fletcher not 5")
(require. (not (= fletcher 1)))
(trace "fletcher not 1")
(require. (> miller cooper))
(trace "miller > cooper")
(require. (not (= (abs (- smith fletcher)) 1)))
(trace "smith not adjacent to fletcher")
(require. (not (= (abs (- fletcher cooper)) 1)))
(trace "fletcher not adjacent to cooper")
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith))))
(print "(multiple-dwelling): " (multiple-dwelling))
;; -----------------------------------------------------------------
;; Teach Yourself Scheme in fixnum days
;;
;; 14.4.1 The Kalotan puzzle
;;
;; 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.
;;
;; --
;;
;; The solution consists in introducing a bunch of variables, allowing
;; them to take a choice of values, and enumerating the conditions on
;; them as a sequence of assert expressions.
;;
;; The variables: parent1, parent2, and kibi are the sexes of the
;; parents (in order of appearance) and Kibi; kibi-self-desc is the
;; sex Kibi claimed to be (in Kalotan); kibi-lied? is the boolean on
;; whether Kibi's claim was a lie.
(define assert require.)
(define (xor p q)
(if (eq? p q)
#f
#t))
(define (xor a b)
(if a (not b) b))
(define solve-kalotan-puzzle
(lambda ()
(let ((parent1 (choose '(m f)))
(parent2 (choose '(m f)))
(kibi (choose '(m f)))
(kibi-self-desc (choose '(m f)))
(kibi-lied? (choose '(#t #f))))
(assert
(distinct? (list parent1 parent2)))
(assert
(if (eqv? kibi 'm)
(not kibi-lied?)))
(assert
(if kibi-lied?
(xor
(and (eqv? kibi-self-desc 'm)
(eqv? kibi 'f))
(and (eqv? kibi-self-desc 'f)
(eqv? kibi 'm)))))
(assert
(if (not kibi-lied?)
(xor
(and (eqv? kibi-self-desc 'm)
(eqv? kibi 'm))
(and (eqv? kibi-self-desc 'f)
(eqv? kibi 'f)))))
(assert
(if (eqv? parent1 'm)
(and
(eqv? kibi-self-desc 'm)
(xor
(and (eqv? kibi 'f)
(eqv? kibi-lied? #f))
(and (eqv? kibi 'm)
(eqv? kibi-lied? #t))))))
(assert
(if (eqv? parent1 'f)
(and
(eqv? kibi 'f)
(eqv? kibi-lied? #t))))
(list parent1 parent2 kibi))))
;; A note on the helper procedures: The procedure distinct? returns
;; true if all the elements in its argument list are distinct, and
;; false otherwise. The procedure xor returns true if only one of its
;; two arguments is true, and false otherwise.
(print "(kalotan): (parent1 parent2 kibi): " (solve-kalotan-puzzle))