Emacs Sokoban game

junk.xsb

###############
#   $       . #
# ###       . #
# #    #####  #
# # ####+$ #$ #
# #        #  #
# ##########  #
#             #
###############

level1.xsb

   ###
  ## # ####
 ##  ###  #
## $      #
#   @$ #  #
### $###  #
  #  #..  #
 ## ##.# ##
 #      ##
 #     ##
 #######

level2.xsb

   #############################
   ##  #################  ######
   ##  $ $ ####  #  #     $ $ ##
   ## #*.. ##   $*$   ## #*.. ##
   #  .   ### # .$. # #  .   ###
   # $$..$$ # #$...$# # $$..$$ #
   ###   .  # # .$. # ###   .  #
   ## ..*# ##   *$*   ## ..*# ##
   ## $ $     #  #  ###  $ $  ##
   ######  ############ ####  ##
   ####################  #######
   ###   ##    ##  ##### #######
   ### # #  ##  #  #####  #  ###
   ### $.*  ##$.#$.###   $*$   #
   ### .$ * # $.$ .  # # .$. # #
   ####*#$. #  .#$.$ # #$...$# #
   ##  .$.$ ##$.  .$## # .$. # #
   ## #$.$. ## $*.  ##   *$*   #
   ##    #  ###   ###  #  #  ###
   #######   ##       ##########
   ######### ###################
   #######   ############   ####
   ####  #  #######    ##   ####
   #### $$$ ##   #  ##  $$$$$ ##
   ####.....##  $*$ ##   . .  ##
   ##  #$.$##   .$. #####.#.####
   ##   $. ## ##.  ######*..  ##
   ## $  .    # . .  ####.#.# ##
   #####$.$  ## $*$  ##  . .   #
   #####  ####   #   ## $$$$$  #
   ########### ##########   ####
   ########@   ##########   ####
   #############################

sokoban.el

(require 'cl)
(require 'gamegrid)

(defvar sokoban-mode-map (make-sparse-keymap))
(suppress-keymap sokoban-mode-map)
(defvar sb/x 1)
(defvar sb/y 1)
(defvar sb/map nil)

(defun sokoban-mode ()
  (interactive)
  (setq sb/map (sb/read-map))
  (kill-all-local-variables)
  (buffer-disable-undo)
  (setq buffer-read-only t
        major-mode 'sokoban-mode
        mode-name "Sokoban"
        mode-line-process "")
  (use-local-map sokoban-mode-map)
  (setq gamegrid-use-glyphs nil)
  (gamegrid-init (make-vector 256 nil))
  (gamegrid-init-buffer 40 40 ? )
  (gamegrid-initialize-display)
  (sb/load-map sb/map)
  (sb/draw-player))

(defun sb/solid-p (x y dx dy &optional crate)
  (if (or (< x 0) (< y 0)) t
    (let ((c (gamegrid-get-cell x y)))
      (cond
       ((= ?. c) nil)
       ((= ?  c) nil)
       ((or (= ?$ c) (= ?* c))
        (or crate (sb/solid-p (+ x dx) (+ y dy) dx dy t)))
       (t t)))))

(defun sb/move-player (dx dy)
  (let ((new-x (+ dx sb/x))
        (new-y (+ dy sb/y)))
    (unless (sb/solid-p new-x new-y dx dy)
      (let ((c (gamegrid-get-cell new-x new-y)))
        (if (or (= ?$ c) (= ?* c))
            (sb/draw-crate (+ new-x dx) (+ new-y dy))))
      (sb/erase sb/x sb/y)
      (setq sb/x new-x) (setq sb/y new-y)
      (sb/draw-player))))

(defun sb/draw-crate (x y)
  (if (= ?. (gethash (cons x y) sb/map ?#))
      (gamegrid-set-cell x y ?*)
    (gamegrid-set-cell x y ?$)))

(defun sb/erase (x y)
  (let ((c (gethash (cons x y) sb/map ? )))
    (if (= c ?$)
        (setq c ? ))
    (gamegrid-set-cell x y c)))

(defun sb/draw-player ()
  (if (= ?. (gethash (cons sb/x sb/y) sb/map ? ))
      (gamegrid-set-cell sb/x sb/y ?+)
    (gamegrid-set-cell sb/x sb/y ?@)))

(define-key sokoban-mode-map [up]
  (lambda () (interactive) (sb/move-player  0 -1)))
(define-key sokoban-mode-map [down]
  (lambda () (interactive) (sb/move-player  0  1)))
(define-key sokoban-mode-map [left]
  (lambda () (interactive) (sb/move-player -1  0)))
(define-key sokoban-mode-map [right]
  (lambda () (interactive) (sb/move-player  1  0)))

(defun sb/read-map ()
  (let ((map (make-hash-table :test 'equal))
        (crates ())
        (x 0) (y 0))
    (puthash 'player (cons 0 0) map)
    (goto-char (point-min))
    (dotimes (i (1- (point-max)))
      (let ((c (char-after (point))))
        (cond
         ((eq c ?\n) (incf y) (setq x -1))
         ((eq c ?@)  (puthash 'player (cons x y) map))
         ((eq c ?+)  (puthash 'player (cons x y) map)
                     (puthash (cons x y) ?. map))
         ((eq c ?*)  (add-to-list 'crates (cons x y))
                     (puthash (cons x y) ?. map))
         ((eq c ?$)  (add-to-list 'crates (cons x y))
                     (puthash (cons x y) ?  map))
         (t          (puthash (cons x y) c map))))
      (incf x)
      (forward-char))
    (puthash 'crates crates map)
    map))

(defun sb/load-map (map)
  (maphash (lambda (p c)
             (if (consp p) (gamegrid-set-cell (car p) (cdr p) c))) map)
  (let ((player (gethash 'player map))
        (crates (gethash 'crates map)))
    (setq sb/x (car player))
    (setq sb/y (cdr player))
    (dolist (crate crates)
      (sb/draw-crate (car crate) (cdr crate)))))