Browse Source

some more nondeterministic exercises

canon
Hazel Levine 3 months ago
parent
commit
fe50f130bd
Signed by: hazel <hazel@knightsofthelambdacalcul.us> GPG Key ID: 7578CDCDED2B28E9
6 changed files with 157 additions and 0 deletions
  1. +2
    -0
      ch4/amb-evaluator.scm
  2. +11
    -0
      ch4/amb-std.scm
  3. +30
    -0
      ch4/ex39.scm
  4. +41
    -0
      ch4/ex40.scm
  5. +47
    -0
      ch4/ex43.scm
  6. +26
    -0
      ch4/ex44.scm

+ 2
- 0
ch4/amb-evaluator.scm View File

@@ -482,8 +482,10 @@
(list 'cons cons)
(list 'list list)
(list 'null? null?)
(list 'eq? eq?)
(list 'memq memq)
(list 'member member)
(list 'assq assq)
(list 'not not)
(list 'abs abs)
(list '+ +)


+ 11
- 0
ch4/amb-std.scm View File

@@ -18,3 +18,14 @@
((null? (cdr items)) #t)
((member (car items) (cdr items)) #f)
(else (distinct? (cdr items)))))

(define (map fn list)
(if (null? list)
'()
(cons (fn (car list))
(map fn (cdr list)))))

(define (length list)
(if (null? list)
0
(+ 1 (length (cdr list)))))

+ 30
- 0
ch4/ex39.scm View File

@@ -0,0 +1,30 @@
;; Exercise 4.39: Does the order of the restrictions in the multiple-
;; dwelling procedure affect the answer? Does it affect the
;; time to find an answer? If you think it matters, demonstrate
;; a faster program obtained from the given one by reordering
;; the restrictions. If you think it does not matter, argue your
;; case.
;;
;; *DO NOT LOAD THIS FILE INTO SCHEME*
(load "amb-std.scm")

(define (multiple-dwelling)
(let ((baker (amb 1 2 3 4 5))
(cooper (amb 1 2 3 4 5))
(fletcher (amb 1 2 3 4 5))
(miller (amb 1 2 3 4 5))
(smith (amb 1 2 3 4 5)))
(require (not (= baker 5)))
(require (not (= cooper 1)))
(require (not (= fletcher 5)))
(require (not (= fletcher 1)))
(require (> miller cooper))
(require (not (= (abs (- smith fletcher)) 1)))
(require (not (= (abs (- fletcher cooper)) 1)))
;; distinct? runs in O(n), all other ops are O(1).
(require (distinct? (list baker cooper fletcher miller smith)))
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith))))

+ 41
- 0
ch4/ex40.scm View File

@@ -0,0 +1,41 @@
;; Exercise 4.40: In the multiple dwelling problem, how many
;; sets of assignments are there of people to floors, both be-
;; fore and alter the requirement that floor assignments be
;; distinct? It is very inefficient to generate all possible assign-
;; ments of people to floors and then leave it to backtracking
;; to eliminate them. For example, most of the restrictions de-
;; pend on only one or two of the person-floor variables, and
;; can thus be imposed before floors have been selected for
;; all the people. Write and demonstrate a much more effi-
;; cient nondeterministic procedure that solves this problem
;; based upon generating only those possibilities that are not
;; already ruled out by previous restrictions. (Hint: this will)
;; require a nest of let expressions.
;;
;; *DO NOT LOAD THIS FILE INTO SCHEME*
(load "amb-std.scm")

;; the idea here is that the lets aren't evaluated unless the conditions are
;; met, so we don't do needless checks.
;;
;; this could be further optimized by just checking equality rather than using
;; `distinct?', but weh.
(define (multiple-dwelling)
(let ((fletcher (amb 1 2 3 4 5)))
(require (not (= fletcher 5)))
(require (not (= fletcher 1)))
(let ((cooper (amb 1 2 3 4 5))
(baker (amb 1 2 3 4 5)))
(require (not (= baker 5)))
(require (not (= cooper 1)))
(let ((miller (amb 1 2 3 4 5)))
(require (> miller cooper))
(let ((smith (amb 1 2 3 4 5)))
(require (not (= (abs (- smith fletcher)) 1)))
(require (not (= (abs (- fletcher cooper)) 1)))
(require (distinct? (list fletcher cooper baker miller smith)))
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))))))

+ 47
- 0
ch4/ex43.scm View File

@@ -0,0 +1,47 @@
;; Exercise 4.43: Use the amb evaluator to solve the following
;; puzzle:
;; Mary Ann Moore’s father has a yacht and so has each of
;; his four friends: Colonel Downing, Mr. Hall, Sir Barnacle
;; Hood, and Dr. Parker. Each of the five also has one daugh-
;; ter and each has named his yacht after a daughter of one of
;; the others. Sir Barnacle’s yacht is the Gabrielle, Mr. Moore
;; owns the Lorna; Mr. Hall the Rosalind. The Melissa, owned
;; by Colonel Downing, is named after Sir Barnacle’s daugh-
;; ter. Gabrielle’s father owns the yacht that is named after
;; Dr. Parker’s daughter. Who is Lorna’s father?
;;
;; *DO NOT LOAD THIS FILE INTO SCHEME*
(load "amb-std.scm")

(define (yacht-puzzle)
(define (all-fathers) (amb 'moore 'downing 'hall 'hood 'parker))
(define (all-fathers-except exempt)
(let ((fathers (all-fathers)))
(require (not (eq? fathers exempt)))
fathers))
(define (name-of-yacht father)
(cond ((eq? father 'moore) 'lorna)
((eq? father 'downing) 'melissa)
((eq? father 'hall) 'rosalind)
((eq? father 'hood) 'gabrielle)
((eq? father 'parker) 'mary)))

(define lorna-father (all-fathers-except 'moore))
(define melissa-father 'hood)
(define rosalind-father (all-fathers-except 'hall))
(define gabrielle-father (all-fathers-except 'hood))
(define mary-father 'moore)
(define (her-father daughter)
(cond ((eq? daughter 'lorna) lorna-father)
((eq? daughter 'melissa) melissa-father)
((eq? daughter 'rosalind) rosalind-father)
((eq? daughter 'gabrielle) gabrielle-father)
((eq? daugther 'mary) mary-father)))

(require (distinct? (list lorna-father melissa-father rosalind-father gabrielle-father mary-father)))
(require (eq? (her-father (name-of-yacht gabrielle-father)) 'parker))
(list (list 'lorna lorna-father)
(list 'melissa melissa-father)
(list 'rosalind rosalind-father)
(list 'gabrielle gabrielle-father)
(list 'mary mary-father)))

+ 26
- 0
ch4/ex44.scm View File

@@ -0,0 +1,26 @@
;; Exercise 4.44: Exercise 2.42 described the “eight-queens
;; puzzle” of placing queens on a chessboard so that no two at-
;; tack each other. Write a nondeterministic program to solve
;; this puzzle.
;;
;; *DO NOT LOAD THIS FILE INTO SCHEME*
(load "amb-std.scm")

(define (new-queen col n)
(cons col (an-integer-between 1 (+ n 1))))

(define (queens n)
(define (iter queens)
;; places
(require (distinct? (map cdr queens)))
;; diagonals
(require (distinct? (map (lambda (q)
(- (car q) (cdr q)))
queens)))
(require (distinct? (map (lambda (q)
(+ (car q) (cdr q)))
queens)))
(if (= n (length queens))
queens
(iter (cons (new-queen (+ 1 (length queens)) n) queens))))
(iter '()))

Loading…
Cancel
Save