151.scm 5.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213
  1. ;; Paper sheets of standard size: an expected value problem
  2. ;; TODO: rewrite to make sense of batches. for instance, if we run out of paper before the last batch, then we should count the last paper as a hit.
  3. ;; TODO: how should this problem be written? I want to keep track of the cache outside of the functions so I can add it in later, but this leads to a lot of ugly code... (a lot of passing around the cache
  4. (use-modules (srfi srfi-1))
  5. (use-modules (ice-9 receive))
  6. (define (solve)
  7. (expected-value (sheet-problem 15 5)))
  8. (define (expected-value soln-set)
  9. (display soln-set)
  10. (if (not (zero? (cadr soln-set)))
  11. (exact->inexact (/ (car soln-set) (cadr soln-set)))
  12. 0))
  13. (define (sheet-problem total-batches number-of-cuts)
  14. (define cache '())
  15. (define (can-use-sheet? sheet)
  16. (= sheet number-of-cuts))
  17. (define (cut-sheet sheet)
  18. (cut-sheet-to-size sheet number-of-cuts))
  19. (define (last-batch? curr-batch)
  20. (= total-batches curr-batch))
  21. (define (batch-loop envelope curr-batch soltn-set)
  22. (cond
  23. ((or (last-batch? curr-batch)
  24. (empty? envelope))
  25. soltn-set)
  26. ;; Not sure if we need this condition now...
  27. ((only-one-sheet? envelope)
  28. (if (can-use-sheet? (get-sheet envelope))
  29. soltn-set
  30. (batch-loop (cut-sheet (get-sheet envelope))
  31. (1+ curr-batch)
  32. (add-hit soltn-set)))); not sure if we add a hit here...
  33. (else (pick-sheets-loop envelope curr-batch (add-miss soltn-set)))))
  34. ;; TODO: consider not having an inner loop?
  35. ;; Does cache get remembered?
  36. (define (pick-sheets-loop envelope curr-batch soltn-set)
  37. (define (get-sub-soltn-set sheet rest-of-envelope)
  38. (let* ((n-envelope
  39. (if (can-use-sheet? sheet) rest-of-envelope
  40. (append (cut-sheet sheet) rest-of-envelope)))
  41. (key (envelope->key n-envelope)))
  42. (if (assoc key cache) (assoc-ref cache key)
  43. (begin
  44. (set! cache
  45. (acons key
  46. (batch-loop n-envelope (1+ curr-batch) '(0 0))
  47. cache))
  48. (assoc-ref cache key)))))
  49. (let pick-sheet-loop ((i 0) (curr-soltn-set soltn-set))
  50. (if (= i (sheets-in-envelope envelope)) curr-soltn-set
  51. (receive (sheet rest-of-envelope)
  52. (pick-sheet i envelope)
  53. (pick-sheet-loop (1+ i)
  54. (combine-soltn-sets
  55. curr-soltn-set
  56. (get-sub-soltn-set sheet rest-of-envelope)))))))
  57. (batch-loop (init-envelope number-of-cuts) 1 '(0 0)))
  58. (define (pick-sheet i envelope)
  59. (values (list-ref envelope i) (append (take envelope i) (drop envelope (1+ i)))))
  60. (define (init-envelope smallest-sheet-size)
  61. (cut-sheet-to-size 1 smallest-sheet-size))
  62. ;; TODO: not convinced by this name
  63. ;; TODO: see if there is a better way to express this...
  64. (define (cut-sheet-to-size sheet final-size)
  65. (if (= sheet final-size)
  66. (list sheet)
  67. (receive (half1 half2)
  68. (cut-sheet-in-half sheet)
  69. (cons half1 (cut-sheet-to-size half2 final-size)))))
  70. (define (cut-sheet-in-half sheet)
  71. (values (1+ sheet) (1+ sheet)))
  72. ; (display (cut-sheet-to-size 1 5))
  73. (define (only-one-sheet? envelope)
  74. (= 1 (length envelope)))
  75. (define (sheets-in-envelope envelope)
  76. (length envelope))
  77. (define (empty? envelope)
  78. (null? envelope))
  79. (define (get-sheet envelope)
  80. (car envelope))
  81. (define (get-sheets envelope)
  82. envelope)
  83. (define (add-hit soltn-set)
  84. (map 1+ soltn-set))
  85. (define (add-miss soltn-set)
  86. (list (car soltn-set)
  87. (1+ (cadr soltn-set))))
  88. (define (envelope->key envelope)
  89. (fold string-append "" (map number->string (sort envelope <))))
  90. ;(display (envelope->key '(2 1 3)))
  91. (define (combine-soltn-sets set1 set2)
  92. (map + set1 set2))
  93. ;(display (combine-soltn-sets '(1 2) '(2 2)))
  94. (display (solve))
  95. ;; Thise examples show how we can't rely on passing the cache in as a parameter since it is always pass by value
  96. (define (cache-test1)
  97. (define (outer-loop cache)
  98. (set! cache (acons "hi" (inner-loop cache) cache))
  99. (display cache)
  100. 0)
  101. (define (inner-loop cache)
  102. (set! cache (acons "there" "answer2" cache))
  103. cache)
  104. (outer-loop '()))
  105. ;; (cache-test1)
  106. (define (cache-test2)
  107. (define (outer-loop cache)
  108. (begin
  109. (inner-loop cache)
  110. (display cache)
  111. 0))
  112. (define (inner-loop cache)
  113. (set! cache (acons "there" "answer2" cache))
  114. cache)
  115. (outer-loop '()))
  116. ;; (cache-test2)
  117. ;;Okay seriously wtffff
  118. (define (cache-test3)
  119. (define (outer-loop cache)
  120. (let ((n-value (inner-loop cache))) ; lets hope one of the side effect is that the cache has changeddddddddd
  121. (newline)
  122. (display "cache after n-value")
  123. (display cache)
  124. (newline)
  125. (set! cache (acons "hi" n-value cache))
  126. (newline)
  127. (display "cache after set")
  128. (display cache)
  129. (newline)0))
  130. (define (inner-loop cache)
  131. (set! cache (acons "there" "answer2" cache))
  132. cache)
  133. (outer-loop '()))
  134. ;; (cache-test3)
  135. (define (cache-test4)
  136. (letrec* ((cache '())
  137. (outer-loop
  138. (lambda ()
  139. (newline)
  140. (display "cache after n-value")
  141. (display cache)
  142. (newline)
  143. (set! cache (acons "hi" (inner-loop) cache))
  144. (newline)
  145. (display "cache after set")
  146. (display cache)
  147. (newline)0))
  148. (inner-loop
  149. (lambda ()
  150. (set! cache (acons "there" "answer2" cache))
  151. "answer1")))
  152. (outer-loop)))
  153. ;; (cache-test4)
  154. (define (cache-test5)
  155. (let ((cache '()))
  156. (define (outer-loop)
  157. (begin
  158. (set! cache (acons "hi" (inner-loop) cache))
  159. (display cache)
  160. 0))
  161. (define (inner-loop)
  162. (set! cache (acons "there" "answer2" cache))
  163. "answer1")
  164. (outer-loop)))
  165. ;;(newline)
  166. ;;(cache-test5)
  167. ;; HUH, this is really sutble stuff!!!