20-CS-4003-001 Organization of Programming Languages Fall 2017
Call-with-current-continuation examples

Lambda calculus, Type theory, Formal semantics, Program analysis

    Prev     Next     All lectures        Code

Logic Puzzle

(define call/cc call-with-current-continuation)

;; Implementation of amb
;;
(define amb-fail (lambda () (error 'no-solution)))

(define-syntax amb
  (syntax-rules ()
    ((amb x ...)
     (let ((prev-level amb-fail))
       (call/cc
         (lambda (sk)
           (call/cc
             (lambda (fk)
               (set! amb-fail (lambda () (fk 'fail)))
               (sk x)))
           ...
           (prev-level)))))))

;; (assert pred) - forces pred to be true
;;
(define assert (lambda (p) (if (not p) (amb))))

;; ---------------------------------------------------
;; All code above this line may be used in other
;; programs

;; (distinct? lst) - #t iff all objects in lst are different
;;
(define distinct?
  (lambda (l)
    (if (or (null? l) (null? (cdr l)))
        #t
        (letrec
          ((is-there?
             (lambda (l^ token)
               (if (null? l^)
                   '()
                   (if (eq? token (car l^))
                       #t
                       (is-there? (cdr l^) token))))))
          (if (is-there? (cdr l) (car l))
              '()
              (distinct? (cdr l)))))))

;; Solution to the puzzle using "amb"
;;
(define puzzle
 (lambda ()
  (let 
    ((house_red (amb 'swede 'dane 'german 'brit 'norge))
     (house_wht (amb 'swede 'dane 'german 'brit 'norge))
     (house_grn (amb 'swede 'dane 'german 'brit 'norge))
     (house_blu (amb 'swede 'dane 'german 'brit 'norge))
     (house_yel (amb 'swede 'dane 'german 'brit 'norge)))
   (assert (eq? house_red 'brit))
   (assert
     (distinct?
       (list
         house_red house_wht house_grn house_blu house_yel)))
   (let 
     ((posit_one (amb 'swede 'dane 'german 'brit 'norge))
      (posit_two (amb 'swede 'dane 'german 'brit 'norge))
      (posit_thr (amb 'swede 'dane 'german 'brit 'norge))
      (posit_fou (amb 'swede 'dane 'german 'brit 'norge))
      (posit_fve (amb 'swede 'dane 'german 'brit 'norge)))
     (assert (or (and (eq? posit_one house_blu)
                      (eq? posit_two 'norge))
                 (and (eq? posit_two house_blu)
                      (or (eq? posit_one 'norge)
                          (eq? posit_thr 'norge)))
                 (and (eq? posit_thr house_blu)
                      (or (eq? posit_two 'norge)
                          (eq? posit_fou 'norge)))
                 (and (eq? posit_fou house_blu)
                      (or (eq? posit_thr 'norge)
                          (eq? posit_fve 'norge)))
                 (and (eq? posit_fve house_blu)
                      (eq? posit_fou 'norge))))
     (assert (or (eq? posit_one 'norge)
                 (eq? posit_fve 'norge)))
     (assert (or (and (eq? posit_one house_grn)
                      (or (eq? posit_two house_wht)
                          (eq? posit_thr house_wht)
                          (eq? posit_fou house_wht)
                          (eq? posit_fve house_wht)))
                 (and (eq? posit_two house_grn)
                      (or (eq? posit_thr house_wht)
                          (eq? posit_fou house_wht)
                          (eq? posit_fve house_wht)))
                 (and (eq? posit_thr house_grn)
                      (or (eq? posit_fou house_wht)
                          (eq? posit_fve house_wht)))
                 (and (eq? posit_fou house_grn)
                      (eq? posit_fve house_wht))))
     (assert
       (distinct?
         (list
           posit_one posit_two posit_thr posit_fou posit_fve)))
     (let 
       ((pet_dog (amb 'swede 'dane 'german 'brit 'norge))
        (pet_cat (amb 'swede 'dane 'german 'brit 'norge))
        (pet_hrs (amb 'swede 'dane 'german 'brit 'norge))
        (pet_fsh (amb 'swede 'dane 'german 'brit 'norge))
        (pet_brd (amb 'swede 'dane 'german 'brit 'norge)))
       (assert (eq? pet_dog 'swede))
       (assert
         (distinct?
           (list pet_dog pet_cat pet_brd pet_fsh pet_hrs)))
       (let 
         ((smoke_pml (amb 'swede 'dane 'german 'brit 'norge))
          (smoke_dun (amb 'swede 'dane 'german 'brit 'norge))
          (smoke_blu (amb 'swede 'dane 'german 'brit 'norge))
          (smoke_bnd (amb 'swede 'dane 'german 'brit 'norge))
          (smoke_prn (amb 'swede 'dane 'german 'brit 'norge)))
         (assert (eq? smoke_prn 'german))
         (assert (eq? smoke_dun house_yel))
         (assert (eq? smoke_pml pet_brd))
         (assert
          (distinct?
           (list
            smoke_pml smoke_dun smoke_blu smoke_bnd smoke_prn)))
         (assert
           (let* 
             ((smoker 
                 (if (eq? smoke_bnd 'german) 'german
                     (if (eq? smoke_bnd 'norge) 'norge
                         (if (eq? smoke_bnd 'dane) 'dane
                             (if (eq? smoke_bnd 'brit) 'brit
                                 'swede)))))
              (petter
                 (if (eq? pet_cat 'german) 'german
                     (if (eq? pet_cat 'norge) 'norge
                         (if (eq? pet_cat 'dane) 'dane
                             (if (eq? pet_cat 'brit) 'brit
                                 'swede))))))
             (or (and (eq? posit_one smoker)
                      (eq? posit_two petter))
                 (and (eq? posit_two smoker)
                      (or (eq? posit_one petter)
                          (eq? posit_thr petter)))
                 (and (eq? posit_thr smoker)
                      (or (eq? posit_two petter)
                          (eq? posit_fou petter)))
                 (and (eq? posit_fou smoker)
                      (or (eq? posit_thr petter)
                          (eq? posit_fve petter)))
                 (and (eq? posit_fve smoker)
                      (eq? posit_fou petter)))))
             (let 
               ((drink_tea
                  (amb 'swede 'dane 'german 'brit 'norge))
                (drink_cof
                  (amb 'swede 'dane 'german 'brit 'norge))
                (drink_mlk
                  (amb 'swede 'dane 'german 'brit 'norge))
                (drink_ber
                  (amb 'swede 'dane 'german 'brit 'norge))
                (drink_wat
                  (amb 'swede 'dane 'german 'brit 'norge)))
               (assert (eq? posit_thr drink_mlk))
               (assert (eq? drink_tea 'dane))
               (assert (eq? smoke_blu drink_ber))
               (assert (eq? house_grn drink_cof))
               (assert
                (distinct?
                 (list
                  drink_tea drink_cof drink_mlk drink_ber drink_wat)))
               (assert
                 (let* 
                   ((smoker
                      (if (eq? smoke_bnd 'german) 'german
                          (if (eq? smoke_bnd 'norge) 'norge
                              (if (eq? smoke_bnd 'dane) 'dane
                                  (if (eq? smoke_bnd 'brit) 'brit
                                      'swede)))))
                    (drinker
                      (if (eq? drink_wat 'german) 'german
                          (if (eq? drink_wat 'norge) 'norge
                              (if (eq? drink_wat 'dane) 'dane
                                  (if (eq? drink_wat 'brit) 'brit
                                      'swede))))))
                   (or (and (eq? posit_one smoker)
                            (eq? posit_two drinker))
                       (and (eq? posit_two smoker)
                            (or (eq? posit_one drinker)
                                (eq? posit_thr drinker)))
                       (and (eq? posit_thr smoker)
                            (or (eq? posit_two drinker)
                                (eq? posit_fou drinker)))
                       (and (eq? posit_fou smoker)
                            (or (eq? posit_thr drinker)
                                (eq? posit_fve drinker)))
                       (and (eq? posit_fve smoker)
                            (eq? posit_fou drinker)))))

              (list
                (list 'Houses: 'red= house_red
                               'green= house_grn
                               'yellow= house_yel
                               'blue= house_blu
                               'white= house_wht)
                (list 'Smokes: 'dunhill= smoke_dun
                               'prince= smoke_prn
                               'blend= smoke_bnd
                               'pall-mall= smoke_pml
                               'blue= smoke_blu)
                (list 'Pets:   'fish= pet_fsh
                               'dog= pet_dog
                               'cat= pet_cat
                               'horse= pet_hrs
                               'birds= pet_brd)
                (list 'Drinks: 'water= drink_wat
                               'beer= drink_ber
                               'coffee= drink_cof
                               'tea= drink_tea
                               'milk= drink_mlk)
                (list 'Position: '1= posit_one
                                 '2= posit_two
                                 '3= posit_thr
                                 '4= posit_fou
                                 '5= posit_fve)))))))))
 -  No owners have the same pet, smoke the same brand of cigar or drink the same beverage. The question is: Who owns the fish?
Hints:
* the Brit lives in the red house
* the Swede keeps dogs as pets
* the Dane drinks tea
* the green house is on the left of the white house
* the green house's owner drinks coffee
* the person who smokes Pall Mall rears birds
* the owner of the yellow house smokes Dunhill
* the man living in the center house drinks milk
* the Norwegian lives in the first house
* the man who smokes blends lives next to the one who keeps cats
* the man who keeps horses lives next to the man who smokes Dunhill
* the owner who smokes BlueMaster drinks beer
* the German smokes Prince
* the Norwegian lives next to the blue house
* the man who smokes blend has a neighbor who drinks water