Don't like ads? PRO users don't see any ads ;-)
Public Pastes
Guest

Untitled

By: a guest on Apr 17th, 2012  |  syntax: None  |  size: 7.32 KB  |  hits: 15  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. ;; ben piche
  2. ;; cs 287
  3. ;; homework 5
  4. ;;
  5. ;; question 1:
  6. ;; do exercise 3.22 on p. 266. make sure your dispatch procedure covers the following local procedures: front-ptr, rear-ptr, set-front-ptr!,
  7. ;; set-rear-ptr, empty-queue?, front-queue, insert-queue!, and delete-queue! as described on pp. 262-5.
  8.  
  9. (define (make-queue)
  10.   (let ((fptr '())
  11.         (rptr '()))
  12.  
  13.     (define (front-ptr) fptr)
  14.     (define (rear-ptr) rptr)
  15.     (define (set-front-ptr! item) (set! fptr item))
  16.     (define (set-rear-ptr! item) (set! rptr item))
  17.     (define (empty-queue?) (null? (front-ptr)))
  18.  
  19.     (define (front-queue)
  20.       (if (empty-queue?)
  21.           (error "FRONT called with an empty queue" fptr)
  22.           (car (front-ptr))))
  23.  
  24.     (define (insert-queue! item)
  25.       (let ((new-pair (cons item '())))
  26.         (cond ((empty-queue?)
  27.                (set-front-ptr! new-pair)
  28.                (set-rear-ptr! new-pair))
  29.               (else
  30.                (set-cdr! (rear-ptr) new-pair)
  31.                (set-rear-ptr! new-pair)))))
  32.  
  33.     (define (delete-queue!)
  34.       (cond ((empty-queue?)
  35.              (error "DELETE! called with an empty queue" fptr))
  36.             (else
  37.              (set-front-ptr! (cdr (front-ptr))))))
  38.  
  39.     (define (dispatch m)
  40.       (cond ((eq? m 'front-ptr) front-ptr)
  41.             ((eq? m 'rear-ptr) rear-ptr)
  42.             ((eq? m 'set-front-ptr!) set-front-ptr!)
  43.             ((eq? m 'set-rear-ptr!) set-rear-ptr!)
  44.             ((eq? m 'empty-queue?) empty-queue?)
  45.             ((eq? m 'front-queue) front-queue)
  46.             ((eq? m 'insert-queue!) insert-queue!)
  47.             ((eq? m 'delete-queue!) delete-queue!)
  48.             (else (error "ERROR" m))))
  49.  
  50.     dispatch))
  51.  
  52. ;; question 2:
  53. ;; use make-queue from #1 above to generate all the binary strings of length n. we'll use lists of 1's and 0's to represent binary strings,
  54. ;; and we'll grow al the possible strings on the queue. define a procedure (allStrings n queue solutions) and call it with the following
  55. ;; parameters to generate all the strings of length 3:
  56. ;;
  57. ;; (define qu (make-queue))
  58. ;; ((qu 'insert-queue!) '())
  59. ;; (allStrings 3 qu '())
  60.  
  61. (define (allStrings n q solutions)
  62.   (if ((q 'empty-queue?))
  63.       solutions
  64.       (begin
  65.         (if (= (length ((q 'front-queue))) n)
  66.             (set! solutions (cons ((q 'front-queue)) solutions))
  67.             (begin
  68.               ((q 'insert-queue!) (cons 0 ((q 'front-queue))))
  69.               ((q 'insert-queue!) (cons 1 ((q 'front-queue))))))
  70.         ((q 'delete-queue!))
  71.         (allStrings n q solutions))))
  72.  
  73. ;;  question 3: we will now use the queue-based strategy that worked for #2 above to solve the "missionaries and cannibals" problem.
  74. ;; the problem: three missionaries and three cannibals are on the left bank of a river and they want to cross the river to the right bank.
  75. ;; they have a boat but it can carry only two people at a time. all the missionaries and cannibals are able to row the boat. getting
  76. ;; everyone from one side to the other would be trivial except for one complication. if at any time the cannibals outnumber the missionaries
  77. ;; on a river bank the cannibals will eat the missionaries. although reducing the number of missionaries does simplify the problem, we will
  78. ;; not condone solutions that rely on anthropophagous activities. find all the possible solutions to this problem (there is more than one).
  79. ;;
  80. ;; represent your problem states with a procedure:
  81. ;;
  82. ;; (make-MC-state left right previous-state)
  83. ;;
  84. ;; where 'make-MC-state' returns a dispatch procedure. this dispatch procedure should be defined to return the following procedures defined
  85. ;; locally inside 'make-MC-state':
  86. ;;
  87. ;; ((s 'show))
  88. ;; ((s 'goal?))
  89. ;; ((s 'get-previous-state))
  90. ;; ((s 'find-totally-new-states) s)
  91. ;;
  92. ;; the queue processing for missionaries & cannibals works just like the queue in 'allStrings' in #2. each string in 'allStrings' was either
  93. ;; a solution string or a string that generated two new strings for the queue. in 'solveMC', each state is either the solution state, or a
  94. ;; state that might generate new states that could folow the current state in a move sequence. you will end up in an infinite loop if you
  95. ;; allow the same state to appear more than once in one move sequence. make sure you never add a state to a move sequence if that same state
  96. ;; can be found earlier (anywhere) in the chain of previous states. note that you can always examine all the states in a move sequence by
  97. ;; chaining back through all of the previous tates from the most recent 'MC-state'.
  98.  
  99. (define (make-MC-state left right prev)
  100.  
  101.   (define (show) (list left right))
  102.   (define (goal?) (equal? left '(#f 0 0)))
  103.   (define (get-previous-state) prev)
  104.   (define (num-miss lst) (caddr lst))
  105.   (define (num-cann lst) (cadr lst))
  106.  
  107.   (define (isPrevSame? lst prev)
  108.     (cond ((null? prev) #f)
  109.           ((let ((Ls ((lst 'show)))(Ps ((prev 'show))))
  110.              (and (equal? (caar Ls) (caar Ps)) (= (cadar Ls) (cadar Ps)) (= (caddar Ls) (caddar Ps))
  111.                   (equal? (caadr Ls) (caadr Ps)) (= (cadadr Ls) (cadadr Ps)) (= (car (cddadr Ls)) (car (cddadr Ps)))))
  112.            #t)
  113.           (else (isPrevSame? lst ((prev 'get-previous-state))))))
  114.  
  115.   (define (find-totally-new-states s)
  116.     (define fromside (if (equal? (car left) #t) left right))
  117.     (define toside (if (equal? (car left) #t) right left))
  118.  
  119.     (define (makenew nM nC)
  120.       (if (equal? (car left) #t)
  121.           (make-MC-state (list #f (- (cadr left) nC) (- (caddr left) nM)) (list #t (+ (cadr right) nC) (+ (caddr right) nM)) s)
  122.           (make-MC-state (list #t (+ (cadr left) nC) (+ (caddr left) nM)) (list #f (- (cadr right) nC) (- (caddr right) nM)) s)))
  123.  
  124.     (let ((poss '()))
  125.  
  126.       (define (addifok lst)
  127.         (if (and (equal? (isPrevSame? lst ((lst 'get-previous-state))) #f)
  128.                  (or (= (num-miss (car ((lst 'show)))) 0) (>= (num-miss (car ((lst 'show)))) (num-cann (car ((lst 'show))))))
  129.                  (or (= (num-miss (cadr ((lst 'show)))) 0) (>= (num-miss (cadr ((lst 'show)))) (num-cann (cadr ((lst 'show)))))))
  130.             (set! poss (cons lst poss))))
  131.  
  132.       (begin
  133.         (if (> (num-miss fromside) 1) (addifok (makenew 2 0)))
  134.         (if (> (num-cann fromside) 1) (addifok (makenew 0 2)))
  135.         (if (> (num-miss fromside) 0) (addifok (makenew 1 0)))
  136.         (if (> (num-cann fromside) 0) (addifok (makenew 0 1)))
  137.         (if (and (> (num-miss fromside) 0) (> (num-cann fromside) 0)) (addifok (makenew 1 1)))
  138.         poss)))
  139.  
  140.   (define (dispatch m)
  141.     (cond ((eq? m 'show) show)
  142.           ((eq? m 'goal?) goal?)
  143.           ((eq? m 'get-previous-state) get-previous-state)
  144.           ((eq? m 'find-totally-new-states) find-totally-new-states)
  145.           (else (error "ERROR" m))))
  146.  
  147.   dispatch)
  148.  
  149. (define (solveMC q solutions)
  150.   (if ((q 'empty-queue?))
  151.       solutions
  152.       (begin
  153.         (if ((((q 'front-queue)) 'goal?))
  154.             (set! solutions (cons ((q 'front-queue)) solutions))
  155.             (map (lambda (x) ((q 'insert-queue!) x)) ((((q 'front-queue)) 'find-totally-new-states) ((q 'front-queue)))))
  156.         ((q 'delete-queue!))
  157.         (solveMC q solutions))))
  158.  
  159. (define (seeSolutions lst)
  160.   (define (recurse L ret)
  161.     (if (equal? ((L 'get-previous-state)) '()) ret
  162.         (begin (set! ret (cons ((L 'show)) ret)) (recurse ((L 'get-previous-state)) ret))))
  163.   (map (lambda (x) (recurse x '())) lst))
create a new version of this paste RAW Paste Data