part-02.scm 7.1 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235
  1. (import
  2. (except (rnrs base)
  3. let-values
  4. map
  5. error
  6. vector-map)
  7. (only (guile)
  8. lambda* λ
  9. simple-format
  10. current-output-port)
  11. (fileio)
  12. (array-helpers)
  13. ;; (ice-9 pretty-print)
  14. (ice-9 format)
  15. (parallelism)
  16. ;; purely functional data structures
  17. (pfds sets)
  18. (srfi srfi-1))
  19. (define debug-peek
  20. (lambda* (sth #:optional (message ""))
  21. (let ([as-string
  22. (call-with-output-string
  23. (λ (port)
  24. (simple-format port "~a" sth)))])
  25. (simple-format (current-output-port)
  26. "~a~a\n"
  27. message
  28. as-string)
  29. sth)))
  30. (define-syntax ->
  31. (syntax-rules ()
  32. ;; first expression is left unchanged
  33. [(-> expr) expr]
  34. ;; take from the back, wrap other calls
  35. [(-> expr* ... (op args* ...))
  36. (op args* ... (-> expr* ...))]
  37. ;; make parens unnecessary in trivial case of no further arguments
  38. [(-> expr* ... op)
  39. (op (-> expr* ...))]))
  40. (define input-filename "input")
  41. (define lines (get-lines-from-file input-filename))
  42. (define rows (length lines))
  43. (define cols (string-length (car lines)))
  44. (define empty-landscape (make-array 0 rows cols))
  45. (define a-z->01-26
  46. (λ (char)
  47. (let ([offset (char->integer (car (string->list "a")))])
  48. (- (char->integer char)
  49. offset))))
  50. (define string->char
  51. (λ (str)
  52. (car (string->list str))))
  53. (define landscape
  54. (let ([char-array
  55. (parallel-map (λ (line _index) (string->list line))
  56. lines)])
  57. (array-map (λ (elem) (a-z->01-26 elem))
  58. (list->array 2 char-array))))
  59. (define start-pos
  60. (let ([as-vec
  61. (array-index-of landscape
  62. (λ (num)
  63. (= num (a-z->01-26 (string->char "S")))))])
  64. (cons (vector-ref as-vec 0)
  65. (vector-ref as-vec 1))))
  66. (define end-pos
  67. (let ([as-vec
  68. (array-index-of landscape
  69. (λ (num)
  70. (= num (a-z->01-26 (string->char "E")))))])
  71. (cons (vector-ref as-vec 0)
  72. (vector-ref as-vec 1))))
  73. (define landscape-replaced
  74. (array-map (λ (elem)
  75. (cond
  76. [(= elem (a-z->01-26 (string->char "S")))
  77. (a-z->01-26 (string->char "a"))]
  78. [(= elem (a-z->01-26 (string->char "E")))
  79. (a-z->01-26 (string->char "z"))]
  80. [else elem]))
  81. landscape))
  82. (define neighbors
  83. (λ (arr row-ind col-ind)
  84. (define up
  85. (λ (row-ind col-ind)
  86. (cons (- row-ind 1) col-ind)))
  87. (define down
  88. (λ (row-ind col-ind)
  89. (cons (+ row-ind 1) col-ind)))
  90. (define left
  91. (λ (row-ind col-ind)
  92. (cons row-ind (- col-ind 1))))
  93. (define right
  94. (λ (row-ind col-ind)
  95. (cons row-ind (+ col-ind 1))))
  96. (define neighbors?
  97. (λ (elem step-elem)
  98. (or
  99. ;; Height can be lower than height of current
  100. ;; position/platform.
  101. (<= step-elem elem)
  102. ;; Or at max 1 heigher than height of current
  103. ;; position.
  104. (= (+ elem 1) step-elem))))
  105. (let ([directions (list right up down left)])
  106. (filter (λ (elem) elem)
  107. (map (λ (step)
  108. (let* ([elem (array-ref landscape-replaced row-ind col-ind)]
  109. [next-pos (step row-ind col-ind)])
  110. (and
  111. (array-in-bounds? arr (car next-pos) (cdr next-pos))
  112. (let ([step-elem (array-ref landscape-replaced (car next-pos) (cdr next-pos))])
  113. (and (neighbors? elem step-elem) next-pos)))))
  114. directions)))))
  115. (define neighborhood
  116. (let ([rows (array-len-in-dim landscape-replaced 0)]
  117. [cols (array-len-in-dim landscape-replaced 1)])
  118. (let ([neighborhood (make-array '() rows cols)])
  119. (let iter-rows ([row° 0])
  120. (let iter-cols ([col° 0])
  121. (cond
  122. [(>= col° cols) (iter-rows (+ row° 1))]
  123. [(>= row° rows) neighborhood]
  124. [else (array-set! neighborhood
  125. (neighbors landscape-replaced row° col°)
  126. row° col°)
  127. (iter-cols (+ col° 1))]))))))
  128. (define make-empty-set
  129. (λ ()
  130. (make-set
  131. (λ (p1 p2)
  132. (or (< (car p1) (car p2))
  133. (and (= (car p1) (car p2))
  134. (< (cdr p1) (cdr p2))))))))
  135. (define set-insert-multiple
  136. (λ (myset items)
  137. (cond
  138. [(null? items) myset]
  139. [else
  140. (set-insert-multiple (set-insert myset (car items))
  141. (cdr items))])))
  142. (define update-finge
  143. (λ (landscape fringe visited)
  144. (let iter ([fringe-set° (make-empty-set)]
  145. [fringe° fringe])
  146. (cond
  147. [(null? fringe°) (set->list fringe-set°)]
  148. [else
  149. (let ([pos (car fringe°)])
  150. (iter (-> (array-ref neighborhood (car pos) (cdr pos))
  151. (filter (λ (pos) (not (set-member? visited pos))) #|arg|#)
  152. (set-insert-multiple fringe-set° #|arg|#))
  153. (cdr fringe°)))]))))
  154. (define made-progress?
  155. (λ (visited-before visited-after)
  156. (> (set-size visited-after)
  157. (set-size visited-before))))
  158. (define find-shortest-path
  159. (λ (landscape neighborhood start-pos end-pos)
  160. (let iter ([fringe° (list start-pos)]
  161. [visited° (make-empty-set)]
  162. [step-count° 0])
  163. (let ([end-reached
  164. (reduce (λ (elem acc) (or acc elem))
  165. #f
  166. (parallel-map (λ (pos ind) (equal? pos end-pos))
  167. fringe°))])
  168. (cond
  169. [end-reached
  170. (simple-format #t "result for start position ~a: ~a\n" start-pos step-count°)
  171. step-count°]
  172. [else
  173. (let ([updated-visited° (set-insert-multiple visited° fringe°)])
  174. ;; (simple-format #t "visited before: ~a\n" (set-size visited°))
  175. ;; (simple-format #t "visited after : ~a\n" (set-size updated-visited°))
  176. (cond
  177. [(made-progress? visited° updated-visited°)
  178. (iter (update-finge landscape fringe° updated-visited°)
  179. updated-visited°
  180. (+ step-count° 1))]
  181. [else
  182. ;; (simple-format #t "no more progress possible from starting pos: ~a\n" start-pos)
  183. +inf.0]))])))))
  184. (define a-indices
  185. (array-indices-of landscape-replaced (λ (elem) (= elem 0))))
  186. (let ([result
  187. (inexact->exact
  188. (run-in-parallel a-indices
  189. (λ (indices-vec _ind)
  190. ;; (simple-format #t "checking for start position: ~a\n" indices-vec)
  191. (find-shortest-path landscape-replaced
  192. neighborhood
  193. (cons (vector-ref indices-vec 0)
  194. (vector-ref indices-vec 1))
  195. end-pos))
  196. (λ (elem acc) (min elem acc))
  197. +inf.0))])
  198. (simple-format #t "result: ~a\n" result))