298 lines
7.7 KiB
Scheme
Executable file
298 lines
7.7 KiB
Scheme
Executable file
#! /usr/bin/env guile -e main -s
|
|
!#
|
|
|
|
;; TODO: make this a module
|
|
|
|
(use-modules (srfi srfi-1)
|
|
(srfi srfi-9 gnu)
|
|
(srfi srfi-11)
|
|
(srfi srfi-43)
|
|
(ice-9 control)
|
|
(rnrs io ports)
|
|
(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? null?)
|
|
(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 (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 cost node))
|
|
|
|
(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)))
|
|
|
|
;; use set-field[s] instead of a setter fun
|
|
(define-immutable-record-type <square>
|
|
(make-square box? goal? wall?)
|
|
square?
|
|
(box? square-box?)
|
|
(goal? square-goal?)
|
|
(wall? square-wall?))
|
|
|
|
(define (square-solid? s) (or (square-box? s) (square-wall? s)))
|
|
(define (square-passable? s) (not (square-solid? s)))
|
|
|
|
;; there are actually only seven valid squares.
|
|
;; what the heck, let's save *some* allocations
|
|
;; used for . and + (player on goal)
|
|
(define square-goal (make-square #f #t #f))
|
|
(define square-box (make-square #t #f #f))
|
|
(define square-done (make-square #t #t #f))
|
|
(define square-wall (make-square #f #f #t))
|
|
(define square-empty (make-square #f #f #f))
|
|
|
|
(define (char->square+player? c)
|
|
(case c
|
|
[(#\.) (values square-goal #f)]
|
|
[(#\@) (values square-empty #t)]
|
|
[(#\+) (values square-goal #t)]
|
|
[(#\$) (values square-box #f)]
|
|
[(#\*) (values square-done #f)]
|
|
[(#\#) (values square-wall #f)]
|
|
[else (values square-empty #f)]))
|
|
|
|
(define (square+player?->char s player?)
|
|
(define box? (square-box? s))
|
|
(define goal? (square-goal? s))
|
|
(define wall? (square-wall? s))
|
|
|
|
(cond
|
|
[(and goal? player?) #\+]
|
|
[(and goal? box?) #\*]
|
|
[player? #\@]
|
|
[goal? #\.]
|
|
[box? #\$]
|
|
[wall? #\#]
|
|
[else #\space]))
|
|
|
|
|
|
;; SWEET: we can use (make-typed-array 'b _ _) for a 2d bitarray (PLEASE be efficient)
|
|
;; what's really great about this is that there is way more sharing
|
|
;; goals and walls stay constant, so that saves even more time and memory
|
|
(define-immutable-record-type <board>
|
|
(make-board player-x player-y boxes goals walls)
|
|
board?
|
|
(player-x board-player-x)
|
|
(player-y board-player-y)
|
|
(boxes board-boxes)
|
|
(goals board-goals)
|
|
(walls board-walls))
|
|
|
|
;; board = (player-pos (wall goal box)-bitsets)
|
|
(define (string->board s)
|
|
;; string-trim alone doesn't work because e.g.
|
|
;; ###
|
|
;; ###.#
|
|
;; #@ $#
|
|
;; # #
|
|
;; #####
|
|
;; becomes
|
|
;; ###
|
|
;; ###.#
|
|
;; #@ $#
|
|
;; # #
|
|
;; #####
|
|
;; which is just no good
|
|
|
|
(define lines (list->vector
|
|
(string-split (string-trim-both s (lambda (c) (eqv? c #\newline)))
|
|
#\newline)))
|
|
(define widths (vector-map (lambda (_ line) (string-length line)) lines))
|
|
(define width (apply max (vector->list widths)))
|
|
(define height (vector-length lines))
|
|
|
|
(define player-x #f)
|
|
(define player-y #f)
|
|
|
|
(define boxes (make-typed-array 'b #f width height))
|
|
(define goals (make-typed-array 'b #f width height))
|
|
(define walls (make-typed-array 'b #f width height))
|
|
|
|
(vector-for-each
|
|
(lambda (y line)
|
|
(string-for-each-index
|
|
(lambda (x)
|
|
(define char (string-ref line x))
|
|
(define-values (square player?) (char->square+player? char))
|
|
(when player?
|
|
(when player-x
|
|
(error "more than one player"))
|
|
(set! player-x x)
|
|
(set! player-y y))
|
|
(when (square-box? square) (array-set! boxes #t x y))
|
|
(when (square-goal? square) (array-set! goals #t x y))
|
|
(when (square-wall? square) (array-set! walls #t x y)))
|
|
line))
|
|
lines)
|
|
|
|
(unless (and player-x player-y)
|
|
(error "no player found"))
|
|
|
|
(make-board player-x player-y boxes goals walls))
|
|
|
|
(define (board-width b) (first (array-dimensions (board-boxes b))))
|
|
(define (board-height b) (second (array-dimensions (board-boxes b))))
|
|
|
|
;; TODO: maybe use existing squares
|
|
(define (board-ref b x y)
|
|
(if (array-in-bounds? (board-boxes b) x y)
|
|
(let ([box? (array-ref (board-boxes b) x y)]
|
|
[goal? (array-ref (board-goals b) x y)]
|
|
[wall? (array-ref (board-walls b) x y)])
|
|
(make-square box? goal? wall?))
|
|
square-wall))
|
|
|
|
(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)))
|
|
|
|
(set-record-type-printer! <board>
|
|
(lambda (b p)
|
|
(format p "#<<board> (~a, ~a)\n " (board-player-x b) (board-player-y b))
|
|
(board-for-each
|
|
(lambda (s x y)
|
|
(put-char p (square+player?->char s (and (= x (board-player-x b))
|
|
(= y (board-player-y b)))))
|
|
(when (= (1+ x) (board-width b))
|
|
(newline p)
|
|
(unless (= (1+ y) (board-height b))
|
|
(display " " p))))
|
|
b)
|
|
(format p ">")))
|
|
|
|
;; functional version of array-set!
|
|
;; copies, of course
|
|
(define (board-move-box b x0 y0 x y)
|
|
(define new-boxes (array-copy (board-boxes b)))
|
|
(array-set! new-boxes #f x0 y0)
|
|
(array-set! new-boxes #t x y)
|
|
(set-field b (board-boxes) new-boxes))
|
|
|
|
;; EASY MONEY
|
|
(define (board-move-player b x y)
|
|
(set-fields b [(board-player-x) x] [(board-player-y) y]))
|
|
|
|
(define (board-won? b)
|
|
(when (zero? (random 10000))
|
|
(format #t "~a\n" b))
|
|
(let/ec return
|
|
(board-for-each
|
|
(lambda (c x y)
|
|
(when (and (square-goal? c) (not (square-box? c)))
|
|
(return #f)))
|
|
b)
|
|
#t))
|
|
|
|
(define (board-player-pos b)
|
|
(values (board-player-x b) (board-player-y b)))
|
|
|
|
;; returns the *exact same board* when move is blocked
|
|
(define (board-step 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))
|
|
|
|
(cond
|
|
[(square-passable? s1) (board-move-player b x1 y1)]
|
|
[(and (square-box? s1) (square-passable? s2))
|
|
(board-move-player (board-move-box b x1 y1 x2 y2) x1 y1)]
|
|
[else b]))
|
|
|
|
(define (board-succ b)
|
|
(remove
|
|
(lambda (newb) (eq? newb b))
|
|
(map
|
|
(lambda (dx dy) (board-step b dx dy))
|
|
'( 0 0 -1 1)
|
|
'(-1 1 0 0))))
|
|
|
|
(define (min-steps b)
|
|
(ucs b board-succ board-won?))
|
|
|
|
;; by David Buchweitz
|
|
(define steaming-hot
|
|
(string->board "
|
|
# #
|
|
# # #
|
|
# # #
|
|
# # #
|
|
# # #
|
|
# # #
|
|
# # #
|
|
|
|
##########
|
|
#........####
|
|
# $$$$$$$# #
|
|
#.$......# #
|
|
# $$$$$$ # #
|
|
#......$+# #
|
|
#$$$$$$$ # #
|
|
# ####
|
|
##########
|
|
"))
|
|
|
|
|
|
(define microban-1
|
|
(string->board "
|
|
####
|
|
# .#
|
|
# ###
|
|
#*@ #
|
|
# $ #
|
|
# ###
|
|
####
|
|
"))
|
|
|
|
(define microban-2
|
|
(string->board "
|
|
######
|
|
# #
|
|
# #@ #
|
|
# $* #
|
|
# .* #
|
|
# #
|
|
######
|
|
"))
|
|
|
|
|
|
(define (main args)
|
|
(define-values (cost node) (min-steps (string->board (get-string-all (current-input-port)))))
|
|
(format #t "~a\n~a\n" cost node))
|