cgit.sxemacs.org Git - packages/blob - xemacs-packages/games/sokoban.el

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