code.delx.au - gnu-emacs-elpa/blob - packages/sokoban/sokoban.el

   1 ;;; sokoban.el --- Implementation of Sokoban for Emacs.
   2
   3 ;; Copyright (C) 1998, 2013 Free Software Foundation, Inc.
   4
   5 ;; Author: Glynn Clements <glynn.clements@xemacs.org>
   6 ;; Version: 1.4
   7 ;; Created: 1997-09-11
   8 ;; Keywords: games
   9 ;; Package-Type: multi
  10
  11 ;; This file is part of XEmacs.
  12
  13 ;; XEmacs is free software; you can redistribute it and/or modify it
  14 ;; under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; XEmacs is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  26 ;; 02111-1307, USA.
  27
  28 ;;; Synched up with: Not synched.
  29
  30 ;;; Commentary:
  31
  32 ;; Modified: 1998-01-09, conditionalised use of locate-data-directory
  33 ;; Modified: 1998-01-27, added mouse interface code
  34 ;;   (provided by Sean MacLennan <bn932@freenet.carleton.ca>
  35 ;; Modified: 1998-02-06, fixed bug, where sokoban-done wasn't reset to
  36 ;;   zero in sokoban-restart-level
  37 ;; Modified: 1998-02-27, patches from Hrvoje Niksic
  38 ;;   added bounds check to sokoban-goto-level
  39 ;;   added popup menu
  40 ;;   display level and score in modeline
  41 ;; Modified: 1998-06-04, added `undo' feature
  42 ;;   added number of blocks done/total to score and modeline
  43 ;; Modified: 2003-06-14, update email address, remove URL
  44
  45 ;; Tested with XEmacs 20.3/4/5 and Emacs 19.34
  46
  47 ;; The game is based upon XSokoban, by
  48 ;; Michael Bischoff <mbi@mo.math.nat.tu-bs.de>
  49
  50 ;; The levels and some of the pixmaps were
  51 ;; taken directly from XSokoban
  52
  53 ;;; Code:
  54
  55 (eval-when-compile
  56   (require 'cl))
  57
  58 (require 'gamegrid)
  59
  60 ;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61
  62 (defvar sokoban-use-glyphs t
  63   "Non-nil means use glyphs when available.")
  64
  65 (defvar sokoban-use-color t
  66   "Non-nil means use color when available.")
  67
  68 (defvar sokoban-font "-*-courier-medium-r-*-*-*-200-100-75-*-*-iso8859-*"
  69   "Name of the font used in X mode.")
  70
  71 (defvar sokoban-buffer-name "*Sokoban*")
  72
  73 (defvar sokoban-temp-buffer-name " Sokoban-tmp")
  74
  75 (defvar sokoban-level-file
  76   (if (fboundp 'locate-data-file)
  77       (locate-data-file "sokoban.levels")
  78     (or (locate-library "sokoban.levels")
  79             (let ((file (expand-file-name
  80                          "sokoban.levels"
  81                          (if load-file-name
  82                              (file-name-directory load-file-name)))))
  83               (and (file-exists-p file) file))
  84         (expand-file-name "sokoban.levels" data-directory))))
  85
  86 (defvar sokoban-width 20)
  87 (defvar sokoban-height 16)
  88
  89 (defvar sokoban-buffer-width 20)
  90 (defvar sokoban-buffer-height 20)
  91
  92 (defvar sokoban-score-x 0)
  93 (defvar sokoban-score-y 17)
  94
  95 (defvar sokoban-level-data nil)
  96
  97 ;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98
  99 (defconst sokoban-floor-xpm "\
 100 /* XPM */
 101 static char * floor_xpm[] = {
 102 \"32 32 1 1\",
 103 \"  c None\",
 104 \"                                \",
 105 \"                                \",
 106 \"                                \",
 107 \"                                \",
 108 \"                                \",
 109 \"                                \",
 110 \"                                \",
 111 \"                                \",
 112 \"                                \",
 113 \"                                \",
 114 \"                                \",
 115 \"                                \",
 116 \"                                \",
 117 \"                                \",
 118 \"                                \",
 119 \"                                \",
 120 \"                                \",
 121 \"                                \",
 122 \"                                \",
 123 \"                                \",
 124 \"                                \",
 125 \"                                \",
 126 \"                                \",
 127 \"                                \",
 128 \"                                \",
 129 \"                                \",
 130 \"                                \",
 131 \"                                \",
 132 \"                                \",
 133 \"                                \",
 134 \"                                \",
 135 \"                                \",
 136 };
 137 ")
 138
 139 (defconst sokoban-target-xpm "\
 140 /* XPM */
 141 static char * target_xpm[] = {
 142 \"32 32 3 1\",
 143 \"  c None\",
 144 \". c black\",
 145 \"X c yellow\",
 146 \"                                \",
 147 \"                                \",
 148 \"                                \",
 149 \"                                \",
 150 \"                                \",
 151 \"                                \",
 152 \"          ............          \",
 153 \"          .XXXXXXXXXX.          \",
 154 \"           .XXXXXXXX.           \",
 155 \"            .XXXXXX.            \",
 156 \"      ..     .XXXX.     ..      \",
 157 \"      .X.     .XX.     .X.      \",
 158 \"      .XX.     ..     .XX.      \",
 159 \"      .XXX.          .XXX.      \",
 160 \"      .XXXX.        .XXXX.      \",
 161 \"      .XXXXX.      .XXXXX.      \",
 162 \"      .XXXXX.      .XXXXX.      \",
 163 \"      .XXXX.        .XXXX.      \",
 164 \"      .XXX.          .XXX.      \",
 165 \"      .XX.     ..     .XX.      \",
 166 \"      .X.     .XX.     .X.      \",
 167 \"      ..     .XXXX.     ..      \",
 168 \"            .XXXXXX.            \",
 169 \"           .XXXXXXXX.           \",
 170 \"          .XXXXXXXXXX.          \",
 171 \"          ............          \",
 172 \"                                \",
 173 \"                                \",
 174 \"                                \",
 175 \"                                \",
 176 \"                                \",
 177 \"                                \",
 178 };
 179 ")
 180
 181 (defconst sokoban-wall-xpm "\
 182 /* XPM */
 183 static char * wall_xpm[] = {
 184 \"32 32 2 1\",
 185 \"  c white\",
 186 \". c SteelBlue\",
 187 \" .............................. \",
 188 \". ............................ .\",
 189 \".. .......................... . \",
 190 \"... ........................ . .\",
 191 \"....                        . . \",
 192 \".... ......................  . .\",
 193 \".... ...................... . . \",
 194 \".... ......................  . .\",
 195 \".... ...................... . . \",
 196 \".... ......................  . .\",
 197 \".... ...................... . . \",
 198 \".... ......................  . .\",
 199 \".... ...................... . . \",
 200 \".... ......................  . .\",
 201 \".... ...................... . . \",
 202 \".... ......................  . .\",
 203 \".... ...................... . . \",
 204 \".... ......................  . .\",
 205 \".... ...................... . . \",
 206 \".... ......................  . .\",
 207 \".... ...................... . . \",
 208 \".... ......................  . .\",
 209 \".... ...................... . . \",
 210 \".... ......................  . .\",
 211 \".... ...................... . . \",
 212 \".... ......................  . .\",
 213 \".... ...................... . . \",
 214 \"....                         . .\",
 215 \"... . . . . . . . . . . . .   . \",
 216 \".. . . . . . . . . . . . . .   .\",
 217 \". . . . . . . . . . . . . . .   \",
 218 \" . . . . . . . . . . . . . . .  \",
 219 };
 220 ")
 221
 222 (defconst sokoban-block-xpm "\
 223 /* XPM */
 224 static char * block_xpm[] = {
 225 \"32 32 3 1\",
 226 \"  c None\",
 227 \". c black\",
 228 \"X c yellow\",
 229 \".............................   \",
 230 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.   \",
 231 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX..  \",
 232 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX..  \",
 233 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.X. \",
 234 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.X. \",
 235 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 236 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 237 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 238 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 239 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 240 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 241 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 242 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 243 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 244 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 245 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 246 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 247 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 248 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 249 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 250 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 251 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 252 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 253 \".............................XX.\",
 254 \".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
 255 \" .XXXXXXXXXXXXXXXXXXXXXXXXXXX.X.\",
 256 \" .XXXXXXXXXXXXXXXXXXXXXXXXXXX.X.\",
 257 \"  .XXXXXXXXXXXXXXXXXXXXXXXXXXX..\",
 258 \"  .XXXXXXXXXXXXXXXXXXXXXXXXXXX..\",
 259 \"   .XXXXXXXXXXXXXXXXXXXXXXXXXXX.\",
 260 \"   .............................\",
 261 };
 262 ")
 263
 264 (defconst sokoban-player-xpm "\
 265 /* XPM */
 266 static char * player_xpm[] = {
 267 \"32 32 3 1\",
 268 \"  c None\",
 269 \"o c white\",
 270 \". c black\",
 271 \"                                \",
 272 \"                                \",
 273 \"                                \",
 274 \"            oooooooo            \",
 275 \"            o......o            \",
 276 \"           o.oooooo.o           \",
 277 \"           o.oooooo.o           \",
 278 \"          o.oooooooo.o          \",
 279 \"          o.o..oo..o.o          \",
 280 \"          o.oooooooo.o          \",
 281 \"          oo.o....o.oo          \",
 282 \"         oo..oo..oo..oo         \",
 283 \"         o....o..o....o         \",
 284 \"         o.o..o..o..o.o         \",
 285 \"         o.o...oo...o.o         \",
 286 \"        o.oo........oo.o        \",
 287 \"        o.oo........oo.o        \",
 288 \"       o.ooo........ooo.o       \",
 289 \"       o.ooo........ooo.o       \",
 290 \"       o.ooo........ooo.o       \",
 291 \"        o.oo........oo.o        \",
 292 \"        o.oo........oo.o        \",
 293 \"        o.o..........o.o        \",
 294 \"         o............o         \",
 295 \"          o..........o          \",
 296 \"           o........o           \",
 297 \"          o.o.oooo.o.o          \",
 298 \"         o.....oo.....o         \",
 299 \"        o......oo......o        \",
 300 \"       o.......oo.......o       \",
 301 \"      o..o..o..oo.oo..o..o      \",
 302 \"      oooooooooooooooooooo      \",
 303 };
 304 ")
 305
 306 (defconst sokoban-floor ?\+)
 307 ;; note - space character in level file is also allowed to indicate floor
 308 (defconst sokoban-target ?\.)
 309 (defconst sokoban-wall ?\#)
 310 (defconst sokoban-block ?\$)
 311 (defconst sokoban-player ?\@)
 312 (defconst sokoban-block-on-target ?\*)
 313
 314 ;; ;;;;;;;;;;;;; display options ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 315
 316 (defvar sokoban-floor-options
 317   `(((glyph
 318       [xpm :data ,sokoban-floor-xpm])
 319      (t ?\040))
 320     ((color-x color-x)
 321      (mono-x grid-x)
 322      (color-tty color-tty))
 323     (((glyph color-x) [0 0 0])
 324      (color-tty "black"))))
 325
 326 (defvar sokoban-target-options
 327   `(((glyph
 328       [xpm :data ,sokoban-target-xpm])
 329      ((mono-x mono-tty emacs-tty) ?\.)
 330      (t ?\040))
 331     ((color-x color-x)
 332      (mono-x grid-x)
 333      (color-tty color-tty))
 334     (((glyph color-x) [1 1 0.5])
 335      (color-tty "yellow"))))
 336
 337 (defvar sokoban-wall-options
 338   `(((glyph
 339       [xpm :data ,sokoban-wall-xpm])
 340      (emacs-tty ?\X)
 341      (t ?\040))
 342     ((color-x color-x)
 343      (mono-x mono-x)
 344      (color-tty color-tty)
 345      (mono-tty mono-tty))
 346     (((glyph color-x) [0 0 1])
 347      (color-tty "blue"))))
 348
 349 (defvar sokoban-block-options
 350   `(((glyph
 351       [xpm :data ,sokoban-block-xpm])
 352      ((mono-x mono-tty emacs-tty) ?\O)
 353      (t ?\040))
 354     ((color-x color-x)
 355      (mono-x grid-x)
 356      (color-tty color-tty))
 357     (((glyph color-x) [1 0 0])
 358      (color-tty "red"))))
 359
 360 (defvar sokoban-player-options
 361   `(((glyph
 362       [xpm :data ,sokoban-player-xpm])
 363      (t ?\*))
 364     ((color-x color-x)
 365      (mono-x grid-x)
 366      (color-tty color-tty))
 367     (((glyph color-x) [0 1 0])
 368      (color-tty "green"))))
 369
 370 ;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 371
 372 (defvar sokoban-level 0)
 373 (make-variable-buffer-local 'sokoban-level)
 374 (defvar sokoban-level-map nil)
 375 (make-variable-buffer-local 'sokoban-level-map)
 376 (defvar sokoban-targets 0)
 377 (make-variable-buffer-local 'sokoban-targets)
 378 (defvar sokoban-x 0)
 379 (make-variable-buffer-local 'sokoban-x)
 380 (defvar sokoban-y 0)
 381 (make-variable-buffer-local 'sokoban-y)
 382 (defvar sokoban-moves 0)
 383 (make-variable-buffer-local 'sokoban-moves)
 384 (defvar sokoban-pushes 0)
 385 (make-variable-buffer-local 'sokoban-pushes)
 386 (defvar sokoban-done 0)
 387 (make-variable-buffer-local 'sokoban-done)
 388 (defvar sokoban-mouse-x 0)
 389 (make-variable-buffer-local 'sokoban-mouse-x)
 390 (defvar sokoban-mouse-y 0)
 391 (make-variable-buffer-local 'sokoban-mouse-y)
 392 (defvar sokoban-undo-list nil)
 393 (make-variable-buffer-local 'sokoban-undo-list)
 394
 395 ;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 396
 397 (defvar sokoban-mode-map
 398   (let ((map (make-sparse-keymap
 399               (when (featurep 'xemacs) 'sokoban-mode-map))))
 400     (define-key map "n" 'sokoban-start-game)
 401     (define-key map "r" 'sokoban-restart-level)
 402     (define-key map "g" 'sokoban-goto-level)
 403
 404     (define-key map [left]      'sokoban-move-left)
 405     (define-key map [right]     'sokoban-move-right)
 406     (define-key map [up]        'sokoban-move-up)
 407     (define-key map [down]      'sokoban-move-down)
 408
 409     (when (featurep 'xemacs)
 410       (define-key map [button2]   'sokoban-mouse-event-start)
 411       (define-key map [button2up] 'sokoban-mouse-event-end))
 412
 413     (define-key map [down-mouse-2] 'sokoban-mouse-event-start)
 414     (define-key map [mouse-2]      'sokoban-mouse-event-end)
 415     ;; On some systems (OS X) middle mouse is difficult.
 416     ;; FIXME: Use follow-link?
 417     (define-key map [down-mouse-1] 'sokoban-mouse-event-start)
 418     (define-key map [mouse-1]      'sokoban-mouse-event-end)
 419
 420     (define-key map [(control ?/)]      'sokoban-undo)
 421     map))
 422
 423 ;; ;;;;;;;;;;;;;;;; level file parsing functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 424
 425 (defconst sokoban-level-regexp "^;LEVEL [0-9]+$")
 426
 427 (defconst sokoban-comment-regexp "^;")
 428
 429 (defun sokoban-init-level-data ()
 430   (setq sokoban-level-data nil)
 431   (with-current-buffer (find-file-noselect sokoban-level-file)
 432     (if (fboundp 'read-only-mode)
 433         (read-only-mode 1)
 434       (setq buffer-read-only t))
 435     (goto-char (point-min))
 436     (re-search-forward sokoban-level-regexp nil t)
 437     (forward-char)
 438     (while (not (eobp))
 439       (while (looking-at sokoban-comment-regexp)
 440         (forward-line))
 441       (let ((data (make-vector sokoban-height nil))
 442             (fmt (format "%%-%ds" sokoban-width)))
 443         (dotimes (y sokoban-height)
 444           (cond ((or (eobp)
 445                      (looking-at sokoban-comment-regexp))
 446                  (aset data y (format fmt "")))
 447                 (t
 448                  (let ((start (point))
 449                        (end (line-end-position)))
 450                    (aset data
 451                          y
 452                          (format fmt (buffer-substring start end)))
 453                    (goto-char (1+ end))))))
 454         (push data sokoban-level-data)))
 455     (kill-buffer (current-buffer))
 456     (setq sokoban-level-data (nreverse sokoban-level-data))))
 457
 458 ;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 459
 460 (defun sokoban-display-options ()
 461   (let ((options (make-vector 256 nil)))
 462     (dotimes (c 256)
 463       (aset options c
 464             (cond ((= c sokoban-floor)
 465                    sokoban-floor-options)
 466                   ((= c sokoban-target)
 467                    sokoban-target-options)
 468                   ((= c sokoban-wall)
 469                    sokoban-wall-options)
 470                   ((= c sokoban-block)
 471                    sokoban-block-options)
 472                   ((= c sokoban-player)
 473                    sokoban-player-options)
 474                   (t
 475                    '(nil nil nil)))))
 476     options))
 477
 478 (defun sokoban-get-level-data ()
 479   (setq sokoban-level-map (nth (1- sokoban-level) sokoban-level-data)
 480         sokoban-targets 0)
 481   (dotimes (y sokoban-height)
 482     (dotimes (x sokoban-width)
 483       (let ((c (aref (aref sokoban-level-map y) x)))
 484         (cond
 485          ((= c sokoban-target)
 486           (incf sokoban-targets))
 487          ((= c sokoban-block-on-target)
 488           (incf sokoban-targets)
 489           (incf sokoban-done))
 490          ((= c ?\040) ;; treat space characters in level file as floor
 491           (aset (aref sokoban-level-map y) x sokoban-floor)))))))
 492
 493 (defun sokoban-get-floor (x y)
 494   (let ((c (aref (aref sokoban-level-map y) x)))
 495     (if (or (= c sokoban-target)
 496             (= c sokoban-block-on-target))
 497         sokoban-target
 498       sokoban-floor)))
 499
 500 (defun sokoban-init-buffer ()
 501   (gamegrid-init-buffer sokoban-buffer-width
 502                         sokoban-buffer-height
 503                         ?\040)
 504   (dotimes (y sokoban-height)
 505     (dotimes (x sokoban-width)
 506       (let ((c (aref (aref sokoban-level-map y) x)))
 507         (if (= c sokoban-player)
 508             (setq sokoban-x x
 509                   sokoban-y y))
 510         (if (= c sokoban-block-on-target)
 511             (setq c sokoban-block))
 512         (gamegrid-set-cell x y c)))))
 513
 514 (defun sokoban-draw-score ()
 515   (let ((strings (vector (format "Moves:  %05d" sokoban-moves)
 516                          (format "Pushes: %05d" sokoban-pushes)
 517                          (format "Done:   %d/%d"
 518                                  sokoban-done
 519                                  sokoban-targets))))
 520     (dotimes (y 2)
 521       (let* ((string (aref strings y))
 522              (len (length string)))
 523         (dotimes (x len)
 524           (gamegrid-set-cell (+ sokoban-score-x x)
 525                              (+ sokoban-score-y y)
 526                              (aref string x))))))
 527   (setq mode-line-format
 528         (format "Sokoban:   Level: %3d   Moves: %05d   Pushes: %05d   Done: %d/%d"
 529                 sokoban-level sokoban-moves sokoban-pushes
 530                 sokoban-done sokoban-targets))
 531   (force-mode-line-update))
 532
 533 (defun sokoban-add-move (dx dy)
 534   (push (list 'move dx dy) sokoban-undo-list)
 535   (incf sokoban-moves)
 536   (sokoban-draw-score))
 537
 538 (defun sokoban-add-push (dx dy)
 539   (push (list 'push dx dy) sokoban-undo-list)
 540   (incf sokoban-moves)
 541   (incf sokoban-pushes)
 542   (sokoban-draw-score))
 543
 544 (defun sokoban-undo ()
 545   "Undo previous Sokoban change."
 546   (interactive)
 547   ;; FIXME: Use the normal undo (via `apply' undo entries).
 548   (if (null sokoban-undo-list)
 549       (message "Nothing to undo")
 550     (let* ((entry (pop sokoban-undo-list))
 551            (type (car entry))
 552            (dx (nth 1 entry))
 553            (dy (nth 2 entry)))
 554       (cond ((eq type 'push)
 555              (let* ((x (+ sokoban-x dx))
 556                     (y (+ sokoban-y dy))
 557                     (c (sokoban-get-floor x y)))
 558                (gamegrid-set-cell x y c)
 559                (if (eq c sokoban-target)
 560                    (decf sokoban-done))
 561                (gamegrid-set-cell sokoban-x sokoban-y sokoban-block)
 562                (setq c (sokoban-get-floor sokoban-x sokoban-y))
 563                (if (eq c sokoban-target)
 564                    (incf sokoban-done)))
 565              (setq sokoban-x (- sokoban-x dx))
 566              (setq sokoban-y (- sokoban-y dy))
 567              (gamegrid-set-cell sokoban-x sokoban-y sokoban-player)
 568              (decf sokoban-pushes)
 569              (decf sokoban-moves))
 570             ((eq type 'move)
 571              (let ((c (sokoban-get-floor sokoban-x sokoban-y)))
 572                (gamegrid-set-cell sokoban-x sokoban-y c))
 573              (setq sokoban-x (- sokoban-x dx))
 574              (setq sokoban-y (- sokoban-y dy))
 575              (gamegrid-set-cell sokoban-x sokoban-y sokoban-player)
 576              (decf sokoban-moves))
 577             (t
 578              (message "Invalid entry in sokoban-undo-list")))
 579       (sokoban-draw-score))))
 580
 581 (defun sokoban-move (dx dy)
 582   (let* ((x (+ sokoban-x dx))
 583          (y (+ sokoban-y dy))
 584          (c (gamegrid-get-cell x y)))
 585     (cond ((or (eq c sokoban-floor)
 586                (eq c sokoban-target))
 587            (gamegrid-set-cell sokoban-x
 588                               sokoban-y
 589                               (sokoban-get-floor sokoban-x
 590                                                  sokoban-y))
 591            (setq sokoban-x x
 592                  sokoban-y y)
 593            (gamegrid-set-cell sokoban-x
 594                               sokoban-y
 595                               sokoban-player)
 596            (sokoban-add-move dx dy))
 597           ((eq c sokoban-block)
 598            (let* ((xx (+ x dx))
 599                   (yy (+ y dy))
 600                   (cc (gamegrid-get-cell xx yy)))
 601              (cond ((or (eq cc sokoban-floor)
 602                         (eq cc sokoban-target))
 603                     (if (eq (sokoban-get-floor x y) sokoban-target)
 604                         (decf sokoban-done))
 605                     (gamegrid-set-cell xx yy sokoban-block)
 606                     (gamegrid-set-cell x y sokoban-player)
 607                     (gamegrid-set-cell sokoban-x
 608                                        sokoban-y
 609                                        (sokoban-get-floor sokoban-x
 610                                                           sokoban-y))
 611                     (setq sokoban-x x
 612                           sokoban-y y)
 613                     (if (eq (sokoban-get-floor xx yy) sokoban-target)
 614                         (incf sokoban-done))
 615                     (sokoban-add-push dx dy)
 616                     (cond ((= sokoban-done sokoban-targets)
 617                            (sit-for 3)
 618                            (sokoban-next-level))))))))))
 619
 620 (defun sokoban-event-x (event)
 621   (let ((x (gamegrid-event-x event)))
 622     (if (featurep 'xemacs)
 623         x
 624       ;; 32.0 is the pixel width of the xpm image
 625       (floor x (/ 32.0 (frame-char-width))))))
 626
 627 (defun sokoban-event-y (event)
 628   (let ((y (gamegrid-event-y event)))
 629     (if (featurep 'xemacs)
 630         y
 631       (floor y (/ 32.0 (frame-char-height))))))
 632
 633 (defun sokoban-mouse-event-start (event)
 634   "Record the beginning of a mouse click."
 635   (interactive "e")
 636   (setq sokoban-mouse-x (sokoban-event-x event))
 637   (setq sokoban-mouse-y (sokoban-event-y event)))
 638
 639 (defun sokoban-mouse-event-end (event)
 640   "Move according to the clicked position."
 641   (interactive "e")
 642   (let* ((x (sokoban-event-x event))
 643          (y (sokoban-event-y event))
 644          (dx (- x sokoban-x))
 645          (dy (- y sokoban-y)))
 646     (cond
 647      ;; Ensure that press and release are in the same square
 648      ;; (which allows you to abort a move)
 649      ((not (and (eq sokoban-mouse-x x) (eq sokoban-mouse-y y)))
 650       nil)
 651      ;; Check that the move isn't diagonal
 652      ((not (or (eq dx 0) (eq dy 0)))
 653       nil)
 654      ((< dx 0)  ;; Left
 655       (while (< dx 0)
 656         (sokoban-move -1 0)
 657         (setq dx (1+ dx))))
 658      ((> dx 0)  ;; Right
 659       (while (> dx 0)
 660         (sokoban-move 1 0)
 661         (setq dx (1- dx))))
 662      ((> dy 0)  ;; Up
 663       (while (> dy 0)
 664         (sokoban-move 0 1)
 665         (setq dy (1- dy))))
 666      ((< dy 0)  ;; Down
 667       (while (< dy 0)
 668         (sokoban-move 0 -1)
 669         (setq dy (1+ dy)))))))
 670
 671 (defun sokoban-move-left ()
 672   "Move one square left."
 673   (interactive)
 674   (sokoban-move -1 0))
 675
 676 (defun sokoban-move-right ()
 677   "Move one square right."
 678   (interactive)
 679   (sokoban-move 1 0))
 680
 681 (defun sokoban-move-up ()
 682   "Move one square up."
 683   (interactive)
 684   (sokoban-move 0 -1))
 685
 686 (defun sokoban-move-down ()
 687   "Move one square down."
 688   (interactive)
 689   (sokoban-move 0 1))
 690
 691 (defun sokoban-restart-level ()
 692   "Restart the current level."
 693   (interactive)
 694   (setq sokoban-moves 0
 695         sokoban-pushes 0
 696         sokoban-done 0
 697         sokoban-undo-list nil)
 698   (sokoban-get-level-data)
 699   (sokoban-init-buffer)
 700   (sokoban-draw-score))
 701
 702 (defun sokoban-next-level ()
 703   (incf sokoban-level)
 704   (sokoban-restart-level))
 705
 706 (defun sokoban-goto-level (level)
 707   "Jump to a specified LEVEL."
 708   (interactive "nLevel: ")
 709   (when (or (< level 1)
 710             (> level (length sokoban-level-data)))
 711     (signal 'args-out-of-range
 712             (list "No such level number"
 713                   level 1 (> level (length sokoban-level-data)))))
 714   (setq sokoban-level level)
 715   (sokoban-restart-level))
 716
 717 (defun sokoban-start-game ()
 718   "Start a new game of Sokoban."
 719   (interactive)
 720   (setq sokoban-level 0)
 721   (sokoban-next-level))
 722
 723 (put 'sokoban-mode 'mode-class 'special)
 724
 725 (unless (featurep 'xemacs)
 726   (easy-menu-define sokoban-popup-menu nil "Popup menu for Sokoban mode."
 727     '("Sokoban Commands"
 728       ["Restart this level" sokoban-restart-level]
 729       ["Start new game" sokoban-start-game]
 730       ["Go to specific level" sokoban-goto-level]))
 731   (define-key sokoban-mode-map [down-mouse-3] sokoban-popup-menu))
 732
 733 (define-derived-mode sokoban-mode special-mode "Sokoban"
 734   "A mode for playing Sokoban.
 735
 736 sokoban-mode keybindings:
 737    \\{sokoban-mode-map}"
 738
 739   (when (featurep 'xemacs)
 740     (setq mode-popup-menu
 741           '("Sokoban Commands"
 742             ["Restart this level" sokoban-restart-level]
 743             ["Start new game" sokoban-start-game]
 744             ["Go to specific level" sokoban-goto-level])))
 745
 746   (set (make-local-variable 'gamegrid-use-glyphs) sokoban-use-glyphs)
 747   (set (make-local-variable 'gamegrid-use-color) sokoban-use-color)
 748   (set (make-local-variable 'gamegrid-font) sokoban-font)
 749
 750   (gamegrid-init (sokoban-display-options))
 751
 752   (if (null sokoban-level-data)
 753       (sokoban-init-level-data)))
 754
 755 ;;;###autoload
 756 (defun sokoban ()
 757   "Sokoban.
 758
 759 Push the blocks onto the target squares.
 760
 761 sokoban-mode keybindings:
 762    \\<sokoban-mode-map>
 763 \\[sokoban-start-game]  Starts a new game of Sokoban
 764 \\[sokoban-restart-level]       Restarts the current level
 765 \\[sokoban-goto-level]  Jumps to a specified level
 766 \\[sokoban-move-left]   Move one square to the left
 767 \\[sokoban-move-right]  Move one square to the right
 768 \\[sokoban-move-up]     Move one square up
 769 \\[sokoban-move-down]   Move one square down"
 770   (interactive)
 771
 772   (switch-to-buffer sokoban-buffer-name)
 773   (gamegrid-kill-timer)
 774   (sokoban-mode)
 775   (sokoban-start-game))
 776
 777 ;;;###autoload
 778 (unless (featurep 'xemacs)
 779   (define-key-after                     ; install a menu entry
 780     (lookup-key global-map [menu-bar tools games])
 781     [sokoban]
 782     '(menu-item "Sokoban" sokoban)
 783     'snake))
 784
 785 (provide 'sokoban)
 786
 787 ;;; sokoban.el ends here
 788