initial

min-steps.scm

@@ -0,0 +1,231 @@
+#! /usr/bin/env guile -e main -s
+!#
+
+(use-modules (srfi srfi-1)
+             (srfi srfi-11)
+             (srfi srfi-43)
+             (rnrs io ports)
+             (ice-9 control)
+             (ice-9 arrays))
+
+(define (insert-sorted x xs <)
+  (merge (list x) xs <))
+
+(define (make-pq . elems) (map (lambda (x) (cons x 0)) elems))
+(define (pq-empty? pq) (null? pq))
+(define (pq< a b) (< (cdr a) (cdr b)))
+(define (pq-insert pq x prio) (insert-sorted (cons x prio) pq pq<))
+(define (pq-pop pq) (values (cdr pq) (car pq)))
+(define (pq-contains? pq x) (any (lambda (a) (equal? (car a) x)) x))
+
+(define (ucs start succ win?)
+  (define frontier (make-pq start))
+  (define visited (make-hash-table))
+  (hash-set! visited start (cons #f 0))
+
+  (define (push! x cost)
+    (set! frontier (pq-insert frontier x cost)))
+
+  (define (pop!)
+    (let-values ([(pq node) (pq-pop frontier)])
+      (set! frontier pq)
+      (values (car node) (cdr node))))
+
+  (let/ec return
+    (while (not (pq-empty? frontier))
+      (let-values ([(node cost) (pop!)])
+        (when (win? node)
+          (return node cost))
+
+        (for-each
+         (lambda (neighbor)
+           (define total-cost (1+ cost))
+           (when (or
+                  (not (hash-ref visited neighbor))
+                  (< total-cost (cdr (hash-ref visited neighbor))))
+               (hash-set! visited neighbor (cons node total-cost))
+               (push! neighbor total-cost)))
+         (succ node))))
+    (values #f #f)))
+
+(define (string->board s)
+  (define lines (list->vector (filter (compose not string-null?) (string-split s #\newline))))
+  (define widths (vector-map (lambda (_ line) (string-length line)) lines))
+  (define width (apply max (vector->list widths)))
+  (define height (vector-length lines))
+  (define squares (make-array #\space width height))
+
+  (vector-for-each
+   (lambda (y line)
+     (string-for-each-index
+      (lambda (x)
+        (array-set! squares (string-ref line x) x y))
+      line))
+   lines)
+
+  squares)
+
+(define (char->stuff c)
+  (case c
+    [(#\.) '(goal)]
+    [(#\@) '(player)]
+    [(#\+) '(goal player)]
+    [(#\$) '(box)]
+    [(#\*) '(goal box)]
+    [(#\#) '(wall)]
+    [else '()]))
+
+(define (stuff->char stuff)
+  (define goal? (memq 'goal stuff))
+  (define player? (memq 'player stuff))
+  (define box? (memq 'box stuff))
+  (define wall? (memq 'wall stuff))
+
+  (cond
+   [(and goal? player?) #\+]
+   [(and goal? box?)    #\*]
+   [player?             #\@]
+   [goal?               #\.]
+   [box?                #\$]
+   [wall?               #\#]
+   [else #\space]))
+
+(define (board-width b) (first (array-dimensions b)))
+(define (board-height b) (second (array-dimensions b)))
+
+(define (board-ref b x y)
+  (if (and (< -1 x (board-width b))
+           (< -1 y (board-height b)))
+      (char->stuff (array-ref b x y))
+      '(wall)))
+
+(define (board-set! b x y stuff)
+  (array-set! b (stuff->char stuff) x y))
+
+(define (board-remove! b x y thing)
+  (board-set! b x y (lset-difference eq? (board-ref b x y) (list thing))))
+
+(define (board-add! b x y thing)
+  (board-set! b x y (lset-union eq? (board-ref b x y) (list thing))))
+
+(define (board-move! b x0 y0 x y thing)
+  (board-remove! b x0 y0 thing)
+  (board-add! b x y thing))
+
+(define (board-for-each f b)
+  (define width (board-width b))
+  (define height (board-height b))
+  (do ([x 0 (modulo (1+ x) width)]
+       [y 0 (if (= (1+ x) width) (1+ y) y)])
+      [(= y height)]
+    (f (board-ref b x y) x y)))
+
+
+(define (board->string b)
+  (with-output-to-string
+    (lambda ()
+      (board-for-each
+       (lambda (c x y)
+         (write-char (stuff->char c))
+         (when (= (1+ x) (board-width b))
+           (newline)))
+       b))))
+
+(define (board-won? b)
+  (let/ec return
+    (board-for-each
+     (lambda (c x y) (when (and (memq 'goal c) (not (memq 'box c)))
+                       (return #f)))
+     b)
+    #t))
+
+(define (solid? stuff)
+  (pair? (lset-intersection eq? stuff '(wall box player))))
+
+(define (board-player-pos b)
+  (let/ec return
+    (board-for-each
+     (lambda (c x y) (when (memq 'player c) (return x y)))
+     b)
+    (values #f #f)))
+
+(define (copy-board b) (array-copy b))
+
+(define (board-move b dx dy)
+  (define-values (x0 y0) (board-player-pos b))
+  (define-values (x1 y1) (values (+ x0 dx) (+ y0 dy)))
+  (define-values (x2 y2) (values (+ x1 dx) (+ y1 dy)))
+
+  (define s0 (board-ref b x0 y0))
+  (define s1 (board-ref b x1 y1))
+  (define s2 (board-ref b x2 y2))
+
+  (define newb (copy-board b))
+
+  (cond
+   [(not (solid? s1)) (board-move! newb x0 y0 x1 y1 'player)]
+   [(and (memq 'box s1) (not (solid? s2)))
+    (board-move! newb x1 y1 x2 y2 'box)
+    (board-move! newb x0 y0 x1 y1 'player)])
+
+  newb)
+
+(define (board-succ b)
+  (remove
+   (lambda (newb) (equal? newb b))
+   (map
+    (lambda (dx dy) (board-move b dx dy))
+    '( 0 0 -1 1)
+    '(-1 1  0 0))))
+
+(define (min-steps b)
+  (define-values (final-board steps) (ucs b board-succ board-won?))
+  steps)
+
+(define steaming-hot
+  (string->board "
+  #      #
+ #   #  #
+  # #  #
+   # #  #
+  #   #  #
+ #   #  #
+  # #  #
+
+##########
+#........####
+# $$$$$$$#  #
+#.$......#  #
+# $$$$$$ #  #
+#......$+#  #
+#$$$$$$$ #  #
+#        ####
+##########
+\"Steaming Hot\" by David Buchweitz
+"))
+
+(define microban-1
+  (string->board "
+####
+# .#
+#  ###
+#*@  #
+#  $ #
+#  ###
+####
+"))
+
+(define microban-2
+  (string->board "
+######
+#    #
+# #@ #
+# $* #
+# .* #
+#    #
+######
+"))
+
+(define (main . args)
+  (format #t "~a\n"
+          (min-steps (string->board (get-string-all (current-input-port))))))