scheme-sokoban/sokoban.scm

(define MAX-MENU-HEIGHT 4)
(define MAX-MENU-WIDTH 36)

(define (new-menu callback undo-callback item-list)
  (make-menu
   (list->vector item-list)
   0
   0
   callback
   undo-callback))

(define (menu-select! menu)
  (define menu-item (vector-ref (menu-items menu) (menu-cursor menu)))
  (when (menu-callback menu)
    ((menu-callback menu) (cdr menu-item))))

(define (menu-close! menu)
  (when (menu-undo-callback menu)
    ((menu-undo-callback menu))))

(define (menu-length menu)
  (vector-length (menu-items menu)))

(define (menu-bottom-item menu)
  (+ MAX-MENU-HEIGHT (menu-top-item menu) -1))

(define (menu-bottom-item-set! menu new-val)
  (menu-top-item-set! menu (- new-val MAX-MENU-HEIGHT -1)))

(define (menu-scroll! menu direction)
  (unless (memq direction '(up down))
    (error "menu-scroll!" "Direction not recognized" direction))
  (let ((new-cursor-val (+ (if (eq? direction 'up) -1 1)
                           (menu-cursor menu))))
    (unless (or (< new-cursor-val 0)
                (>= new-cursor-val (menu-length menu)))
      (menu-cursor-set! menu new-cursor-val)
      (cond
       ((< new-cursor-val (menu-top-item menu))
        (menu-top-item-set! menu new-cursor-val))
       ((> new-cursor-val (menu-bottom-item menu))
        (menu-bottom-item-set! menu new-cursor-val))))))

(define (render-menu menu)
  (let loop ((result '())
             (i (menu-top-item menu)))
    (if (and (< i (menu-length menu))
             (<= i (menu-bottom-item menu)))
        (loop (cons (string-append (if (= i (menu-cursor menu))
                                       "> "
                                       "  ")
                                       (string-take
                                        (string-pad-right (car (vector-ref (menu-items menu) i))
                                                          MAX-MENU-WIDTH)
                                        MAX-MENU-WIDTH))
                    result)
              (+ i 1))
        (string-join (reverse result) "\n"))))

(define (kill-game! global-state)
  ((global-event-handler global-state) 'kill))

(define (play-victory-sound! global-state)
  ((global-event-handler global-state) 'victory-sound))

(define (play-level-music! global-state)
  ((global-event-handler global-state) 'level-music))

(define (open-level! global-state game-selected level-number)
  (play-level-music! global-state)
  (global-level-set! global-state (game-file-ref game-selected level-number))
  (global-menu-set! global-state #f))

(define (restart-level! global-state)
  (define g (level-game-file (global-level global-state)))
  (define n (level-number (global-level global-state)))
  (open-level! global-state g n))

(define (level-up! global-state)
  (define g (level-game-file (global-level global-state)))
  (define n (level-number (global-level global-state)))
  (open-level! global-state g (+ n 1)))

(define (open-pause-menu! global-state)
  (define parent-menu (global-menu global-state))
  (define (on-enter command)
    (case command
      ((restart)
       (restart-level! global-state))
      (else
       (open-main-menu! global-state))))
  (define (on-exit)
    (global-menu-set! global-state parent-menu))
  (global-menu-set! global-state
    (new-menu on-enter on-exit '(("Restart level" . restart)
                                 ("Exit to main menu" . main)))))

(define (open-victory-menu! global-state)
  (define (on-enter command)
    (level-up! global-state))
  (global-menu-set! global-state
    (new-menu on-enter #f '(("Next level" . next)))))

(define (open-main-menu! global-state)
  (define (on-enter command)
    (case command
     ((new)
      (open-pick-game-menu! global-state))
     (else
      (kill-game! global-state))))
  (global-level-set! global-state #f)
  (global-menu-set! global-state
    (new-menu on-enter #f '(("Pick game" . new)
                            ("Exit program" . exit)))))

(define (open-pick-game-menu! global-state)
  (define parent-menu (global-menu global-state))
  (define (on-enter command)
    (open-pick-level-menu! global-state command this-menu))
  (define (on-exit)
    (global-menu-set! global-state parent-menu))
  (define this-menu (new-menu on-enter on-exit xsb-level-menu-list))
  (global-menu-set! global-state this-menu))

(define (open-pick-level-menu! global-state game-selection parent-menu)
  (define (make-menu-list-from-progress p)
    (define a (assoc game-selection p))
    (if a
        (let loop ((i 1)
                   (out '()))
          (if (<= i (+ 1 (cdr a)))
              (loop (+ i 1)
                    (cons (cons (string-append "Level " (number->string i))
                                i)
                          out))
              (reverse out)))
        '(("Level 1" . 1))))
  (define (on-enter command)
    (let ((levels (file-id->game-file game-selection)))
      (open-level! global-state levels (- command 1))))
  (define (on-exit)
    (global-menu-set! global-state parent-menu))
  (define menu-list (make-menu-list-from-progress (global-progress global-state)))
  (global-menu-set! global-state (new-menu on-enter on-exit menu-list)))

(define (increment-progress! global-state)
  (define file-id (level-game-file (global-level global-state)))
  (define level (level-number (global-level global-state)))
  (define (assoc-set l k v)
    (let loop ((in l)
               (out '()))
      (if (null? in)
          (cons (cons k v) l)
          (if (equal? (car (car in)) k)
              (append (reverse out)
                      (list (cons k v))
                      (cdr in))
              (loop (cdr in)
                    (cons (car in) out))))))
  (define p (assoc file-id (global-progress global-state)))
  (when (or (not p)
            (> level (cdr p)))
    (let ((new-progress (assoc-set (global-progress global-state)
                         file-id 
                         level)))
      (global-progress-set! global-state new-progress))))

(define (move-player-and-check-complete! global-state direction)
  (define current-level-state (global-level global-state))
  (move-player! current-level-state direction)
  (when (level-complete? current-level-state)
    (play-victory-sound! global-state)
    (increment-progress! global-state)
    (open-victory-menu! global-state)))

(define (try-undo-last-move! global-state)
  (define current-level-state (global-level global-state))
  (when (level-last-move current-level-state)
    (undo-move-player! current-level-state)))

(define (string->level-data s)
  (vector-map string->vector (list->vector (string-split s "\n"))))

(define (level->string l)
  (string-join (vector->list (vector-map vector->string (level-data l))) "\n"))

(define (char->tile-type c)
  (cond
   ((char=? c #\space) 'floor)
   ((char=? c #\.) 'goal-square)
   ((char=? c #\*) 'box-on-goal-square)
   ((char=? c #\$) 'box)
   ((char=? c #\+) 'player-on-goal-square)
   ((char=? c #\@) 'player)
   ((char=? c #\#) 'wall)
   (else (error "tile char not recognized" c))))

(define (level-last-move level)
  (define result (level-move-history level))
  (if (null? result) #f (car result)))

(define (render-level-status level)
  (define game-name (game-name-lookup (game-file-id (level-game-file level))))
  (define level-no (number->string (level-number level)))
  (define move-ct (number->string (length (level-move-history level))))
  (string-append
   (string-pad-left game-name 16)
   "-"
   (string-pad-left level-no 3 #\0)
   "\n"
   (string-pad-left move-ct 4 #\0)))

(define (level-ref l i j)
  (define data (level-data l))
  (make-tile
   i
   j
   (char->tile-type
    (if (and (>= i 0)
             (< i (vector-length data)))
        (let ((v (vector-ref data i)))
          (if (and (>= j 0)
                   (< j (vector-length v)))
              (vector-ref v j)
              #\space))
        #\space))))

(define (level-set! l i j tile-type)
  (define v (cdr (assq tile-type '((floor . #\space)
                                   (goal-square . #\.)
                                   (box-on-goal-square . #\*)
                                   (box . #\$)
                                   (player-on-goal-square . #\+)
                                   (player . #\@)
                                   (wall . #\#)))))
  (vector-set! (vector-ref (level-data l) i) j v))

(define (level-add-history! l history-item)
  (level-move-history-set! l (cons history-item (level-move-history l))))

(define (level-remove-history! l)
  (level-move-history-set! l (cdr (level-move-history l))))

(define (tile-player? t)
  (let ((tt (tile-type t)))
    (or (eq? tt 'player)
        (eq? tt 'player-on-goal-square))))

(define (find-next-tile level tile direction)
  (define i (tile-row tile))
  (define j (tile-col tile))
  (cond
   ((eq? direction 'left)
    (level-ref level i (- j 1)))
   ((eq? direction 'right)
    (level-ref level i (+ j 1)))
   ((eq? direction 'up)
    (level-ref level (- i 1) j))
   ((eq? direction 'down)
    (level-ref level (+ i 1) j))
   (else
    (error "find-next-tile" "Direction not recognized" direction))))

(define (player-position l)
  (define rows (level-rows l))
  (define cols (level-cols l))
  (let loop ((i 0)
             (j 0))
    (when (>= i rows)
      (error "player-position" "Player position not found"))
    (if (< j cols)
        (if (tile-player? (level-ref l i j))
            (list i j)
            (loop i (+ j 1)))
        (loop (+ i 1) 0))))

(define (level-complete? l)
  (define rows (level-rows l))
  (define cols (level-cols l))
  (let loop ((i 0)
             (j 0))
    (or (>= i rows)
        (if (< j cols)
            (and (not (memq (tile-type (level-ref l i j))
                                       '(goal-square player-on-goal-square)))
                 (loop i (+ j 1)))
            (loop (+ i 1) 0)))))

(define (find-player l)
  (define results (player-position l))
  (define i (list-ref results 0))
  (define j (list-ref results 1))
  (level-ref l i j))

(define (tile->list-repr t)
  (list (tile-row t) (tile-col t) (tile-type t)))

(define (opposite-direction sym)
  (cond
   ((eq? sym 'up) 'down)
   ((eq? sym 'down) 'up)
   ((eq? sym 'left) 'right)
   (else 'left)))

(define (undo-move-player! level)
  (define player (find-player level))
  (define last-move (level-last-move level))
  (define previous-direction
    (cond
     ((memv last-move '(#\u #\U)) 'up)
     ((memv last-move '(#\d #\D)) 'down)
     ((memv last-move '(#\l #\L)) 'left)
     ((memv last-move '(#\r #\R)) 'right)))
  (define direction (opposite-direction previous-direction))
  (define did-push? (memv last-move '(#\U #\D #\L #\R)))
  (define next (find-next-tile level player direction))
  (define previous (find-next-tile level player previous-direction))
  (define player-type (tile-type player))
  (define next-type (tile-type next))
  (define previous-type (tile-type previous))
  (level-remove-history! level)
  (cond
   (did-push?
      (level-set! level (tile-row previous)
                        (tile-col previous)
                        (if (eq? previous-type 'box)
                            'floor
                            'goal-square))
      (level-set! level (tile-row player)
                        (tile-col player)
                        (if (eq? player-type 'player)
                            'box
                            'box-on-goal-square))
      (level-set! level (tile-row next)
                        (tile-col next)
                        (if (eq? next-type 'floor)
                            'player
                            'player-on-goal-square)))
    (else
      (level-set! level (tile-row next)
                        (tile-col next)
                        (if (eq? next-type 'floor)
                            'player
                            'player-on-goal-square))
      (level-set! level (tile-row player)
                        (tile-col player)
                        (if (eq? player-type 'player)
                            'floor
                            'goal-square)))))

(define (move-player! level direction)
  (define player (find-player level))
  (define next (find-next-tile level player direction))
  (define next-next (find-next-tile level next direction))
  (let ((player-type (tile-type player))
        (next-type (tile-type next))
        (next-next-type (tile-type next-next)))
    (cond
     ((memq next-type '(floor goal-square))
      (level-add-history! level
       (cond 
        ((eq? direction 'up) #\u)
        ((eq? direction 'down) #\d)
        ((eq? direction 'left) #\l)
        ((eq? direction 'right) #\r)))
      (level-set! level (tile-row next)
                        (tile-col next)
                        (if (eq? next-type 'floor)
                            'player
                            'player-on-goal-square))
      (level-set! level (tile-row player)
                        (tile-col player)
                        (if (eq? player-type 'player)
                            'floor
                            'goal-square)))
     ((and (memq next-type '(box box-on-goal-square))
           (memq next-next-type '(floor goal-square)))
      (level-add-history! level
       (cond 
        ((eq? direction 'up) #\U)
        ((eq? direction 'down) #\D)
        ((eq? direction 'left) #\L)
        ((eq? direction 'right) #\R)))
      (level-set! level (tile-row next-next)
                        (tile-col next-next)
                        (if (eq? next-next-type 'floor)
                            'box
                            'box-on-goal-square))
      (level-set! level (tile-row next)
                        (tile-col next)
                        (if (eq? next-type 'box)
                            'player
                            'player-on-goal-square))
      (level-set! level (tile-row player)
                        (tile-col player)
                        (if (eq? player-type 'player)
                            'floor
                            'goal-square))))))

(define (read-level-list-data port)
  (let loop ((in-tiles? #f)
             (in-comment? #f)
             (current-level '())
             (level-list '()))
    (define c (read-char port))
    (cond
     ((eof-object? c)
      ;; eof
      (reverse (map (lambda (l) 
                      (string->level-data
                       (string-join
                        (reverse
                         (map list->string (map reverse l)))
                       "\n")))
                      level-list)))
     ((char=? c #\newline)
      ;; new line
      (if in-tiles?
          (loop #f
                #f
                (cons '() current-level)
                level-list)
          (loop #f
                #f
                '()
                (if (null? current-level)
                    level-list
                    (cons current-level level-list)))))
     ((memv c '(#\space #\. #\* #\$ #\+ #\@ #\#))
      ;; tile
      (if in-comment?
          (loop in-tiles?
                #t
                current-level
                level-list)
          (loop #t
                #f
                (if (null? current-level)
                    (list (list c))
                    (cons (cons c (car current-level))
                          (cdr current-level)))
                level-list)))
     ((char=? c #\return)
      ;; ignore returns
      (loop in-tiles?
            in-comment?
            current-level
            level-list))
     (else
      ;; comment
      (loop in-tiles?
            #t
            current-level
            level-list)))))

(define (game-file-ref game-selected level-number)
  (define data (list-ref (game-file-level-list game-selected) level-number))
  (define rows (vector-length data))
  (define cols (apply max (map vector-length (vector->list data))))
  (make-level
   rows
   cols
   (vector-map vector-copy data)
   '()
   game-selected
   level-number))

(define (game-file-length game-selected)
  (length (game-file-level-list game-selected)))

(define (file-id->game-file file-id)
  (define f (fake-open-input-file file-id))
  (let ((result (read-level-list-data f)))
    (close-input-port f)
    (make-game-file result file-id)))