bitboards v1

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 <square>
+  (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 <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-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! <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 ">")))
 
-(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