diff --git a/min-steps.scm b/min-steps.scm index a0b03c6..9a7d148 100755 --- a/min-steps.scm +++ b/min-steps.scm @@ -2,21 +2,21 @@ !# (use-modules (srfi srfi-1) + (srfi srfi-9 gnu) (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 (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-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-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)) @@ -24,7 +24,7 @@ (hash-set! visited start (cons #f 0)) (define (push! x cost) - (set! frontier (pq-insert frontier x cost))) + (set! frontier (pq-insert! frontier x cost))) (define (pop!) (let-values ([(pq node) (pq-pop frontier)]) @@ -48,38 +48,40 @@ (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)) +;; use set-field[s] instead of a setter fun +(define-immutable-record-type + (make-square box? goal? wall?) + square? + (box? square-box?) + (goal? square-goal?) + (wall? square-wall?)) - (vector-for-each - (lambda (y line) - (string-for-each-index - (lambda (x) - (array-set! squares (string-ref line x) x y)) - line)) - lines) +(define (square-solid? s) (or (square-box? s) (square-wall? s))) +(define (square-passable? s) (not (square-solid? s))) - squares) +;; 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->stuff c) +(define (char->square+player? c) (case c - [(#\.) '(goal)] - [(#\@) '(player)] - [(#\+) '(goal player)] - [(#\$) '(box)] - [(#\*) '(goal box)] - [(#\#) '(wall)] - [else '()])) + [(#\.) (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 (stuff->char stuff) - (define goal? (memq 'goal stuff)) - (define player? (memq 'player stuff)) - (define box? (memq 'box stuff)) - (define wall? (memq 'wall stuff)) +(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?) #\+] @@ -90,27 +92,68 @@ [wall? #\#] [else #\space])) -(define (board-width b) (first (array-dimensions b))) -(define (board-height b) (second (array-dimensions b))) +;; 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 + (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-both instead of filter (compose not string-null?) keeps internal + ;; blanks while removing (almost always) useless leading and trailing blanks + (define lines (list->vector (string-split (string-trim-both 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 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 (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)) + (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)) @@ -120,38 +163,48 @@ [(= y height)] (f (board-ref b x y) x y))) +(set-record-type-printer! + (lambda (b p) + (format p "#< (~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 ">"))) -(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)))) +;; 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 (memq 'goal c) (not (memq 'box c))) - (return #f))) + (lambda (c x y) + (when (and (square-goal? c) (not (square-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))) + (values (board-player-x b) (board-player-y b))) -(define (copy-board b) (array-copy b)) - -(define (board-move b dx dy) +;; 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))) @@ -160,21 +213,17 @@ (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) + [(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) (equal? newb b)) + (lambda (newb) (eq? newb b)) (map - (lambda (dx dy) (board-move b dx dy)) + (lambda (dx dy) (board-step b dx dy)) '( 0 0 -1 1) '(-1 1 0 0)))) @@ -182,6 +231,7 @@ (define-values (final-board steps) (ucs b board-succ board-won?)) steps) +;; by David Buchweitz (define steaming-hot (string->board " # # @@ -201,9 +251,9 @@ #$$$$$$$ # # # #### ########## -\"Steaming Hot\" by David Buchweitz ")) + (define microban-1 (string->board " #### @@ -226,6 +276,10 @@ ###### ")) + (define (main . args) (format #t "~a\n" (min-steps (string->board (get-string-all (current-input-port)))))) + +;; TODO: lol i have immutable board movement, so just make this actually playable +;; with super easy undo lol