sokoban1.1.lisp

Title: A sample sokoban implementation using CLX Created: Tue Feb 27 15:43:28 1996

;;;;
;;;;     Title: A sample sokoban implementation using CLX
;;;;   Created: Tue Feb 27 15:43:28 1996
;;;;    Author: Gilbert Baumann <[e-mail]>
;;;; Copyright: (c) copyright 1996 by Gilbert Baumann, distributed under GPL.

;;;; History
;;;;
;;;; This is inspirited by some Sokoban implementation for UNIX. (Which I do not
;;;; any longer have, and from which I do not know the originator anymore,
;;;; sorry.) As I was working on a Windows NT system [No,No!  Not for fun, to
;;;; earn money; I consider it important to mention that!]  I implemented a
;;;; Windows version of sokoban using the orginal screens and pixmaps from the
;;;; UNIX version. However now I wanted to reimplemenet this version in LISP,
;;;; just to show, that it *is* possible to implement rather fast reacting X11
;;;; applications in LISP and to bypass the long recompilation times of CLISP
;;;; (30-45 mins on my system).
;;;;
;;;; The pixmaps and screens are from the original X11 sokoban. But I found the
;;;; same screens on many other implementations. Also some ancient PC implementation,
;;;; which uses CGA graphics (The first one -- perhaps not, the idea of sokoban
;;;; is too good to be invented on an PC) The pixmaps seem to be unique to the
;;;; X11 sokoban I talked about. Could anybody please help me out to find the
;;;; source to be able to acknowledge the author of the pixmaps? Also if anybody
;;;; has some information on the history of this game please tell me.
;;;;
;;;; BTW -- The numerical notation of field values is indeed just copied from
;;;; the Windows version, as far as I could recall the original sokoban
;;;; implemention uses these too, but I am not sure. This makes this code look
;;;; like MacLISP, doesn't it?

;;;; Todos
;;;;  - mouse actions
;;;;  - high score

;;;; Bugs
;;;;  - does only run on colour screens. Not realy but is unusable on b/w unless
;;;;    there a b/w pixmaps.
;;;;  - maximum field size is hard wired to 20x20. (This is not in the LISP spirit!)
;;;;  - sometimes the programm could not count correctly ...

(in-package :clx-demos)

;;;; First a lot of global variables ...
(defvar *pixmaps* nil)                  ;array of pixmaps according to below indices
(defvar *field* nil)                    ;the field
(defvar *changes* nil)                  ;A map of T/NIL saying, which field changed
(defvar *display* nil)                  ;The connection to the X server
(defvar *window* nil)                   ;The window sokoban is living in
(defvar *gcontext* nil)                 ;Graphics context used by sokoban
(defvar *man-x* nil)                    ;X position of the man
(defvar *man-y* nil)                    ;Y position of the man (actually a nose)
(defvar *undos* nil)                    ;undo information
(defvar *level* 0)                      ;current level
(defvar *n-objects* 0)                  ;number of balls to be saved
(defvar *said-congrat-p* nil)
(defvar *said-proceed-p* nil)
(defvar *findmap* nil)

(defvar *sokoban-state-file* '#"~/.sokoban-state.lsp") ;Change if you want
(defvar *state-vars*
  '(*man-x* *man-y* *undos* *field* *level* *n-objects*))

(defvar *pixmap-names*
  '("lonewall" "southwall" "westwall" "llcorner"
    "northwall" "vertiwall" "ulcorner" "west_twall"
    "eastwall" "lrcorner" "horizwall" "south_twall"
    "urcorner" "east_twall" "north_twall" "centerwall"
    "object" "treasure"
    "floor" "goal"
    "man_down" "save_man_down"))

(defvar *man-pixmap-names*
  '("man_left"  "save_man_left"
    "man_right" "save_man_right"
    "man_up"    "save_man_up"
    "man_down"  "save_man_down"))

(defvar *man-pixmaps* nil)
(defvar *man-direction* 0)

;; I am afraid that I am better at compiler hacking than at pathname hacking ...
(defvar *xpm-directory* (merge-pathnames '#"xpms/" *load-pathname*))
(defvar *screen-directory* (merge-pathnames '#"screens/" *load-pathname*))

;; BTW - This is my personal style to write enum constants with %-prefix notation.
(defvar %object 16)
(defvar %treasure 17)
(defvar %floor 18)
(defvar %goal 19)
(defvar %man 20)
(defvar %saveman 21)
(defvar %badmove (* 20 21))

(defun field (x y)
  "Retrieves the field x/y"
  (cond ((and (<= 0 x 19) (<= y 19)) (aref *field* x y))
        (t %floor)))                    ;fake entry

(defun (setf field) (value x y)
  (setf (aref *field* x y) value)
  (setf (aref *changes* x y) T)
  value)

(defun load-screen (level)
  "Loads the screen belonging to level 'level'."
  (with-open-file (in (merge-pathnames (format nil "screen.~D" level) *screen-directory*))
    (do ((l (read-line in nil nil) (read-line in nil nil))
         (r nil (cons l r)))
        ((null l) (nreverse r))) ))

(defun find-outers ()
  "Goes thru' the board and finds all fields which are outside and sets the shape mask accordingly"
  (let ((map (make-array '(20 20)))
        (maxx 0)
        (maxy 0))
    (labels ((ff (x y)
                 (unless (or (aref map x y) (< (field x y) %object))
                   (setf (aref map x y) T)
                   (ff (1+ x) y) (ff (1- x) y) (ff x (1- y)) (ff x (1+ y)))))
      (ff *man-x* *man-y*)
      (let ((*rects* nil))
        (dotimes (x 20)
          (dotimes (y 20)
            (unless (and (= (field x y) %floor) (not (aref map x y)))
              (setq maxx (max x maxx)
                    maxy (max y maxy))
              (push (list (* x 40) (* y 40) 40 40) *rects*))))
        (setf (xlib:drawable-width *window*)  (* 40 (1+ maxx))
              (xlib:drawable-height *window*) (* 40 (1+ maxy)))
        (xlib:shape-combine *window* *rects*)) )))

(defun init-field (&optional (level *level*))
  "Does all initialisation work needed when going to a different level."
  (let ((screen (load-screen level)))
    (format T "~%;This is the ~:R level." level)
    (setf (xlib:wm-name *window*) (format nil "Sokoban - ~:(~:R~) Level" *level*))
    (labels ((screen-field (x y)
                           (if (<= 0 y (1- (length screen)))
                               (if (<= 0 x (1- (length (nth y screen))))
                                   (aref (nth y screen) x)
                                 #\Space)
                             #\Space))
             (is-wall (ch) (char= ch #\#)))
      (setq *field* (make-array '(20 20))
            *undos* nil
            *n-objects* 0
            *said-congrat-p* nil)
      (dotimes (x 20)
        (dotimes (y 20)
          (setf (field x y)
                (ecase (screen-field x y)
                       (#\Space %floor)
                       (#\$ (incf *n-objects* 1) %object)
                       (#\@ (setf *man-x* x *man-y* y) %man)
                       (#\. %goal)
                       (#\* %treasure)
                       (#\#
                        (let ((val 0))
                          (when (is-wall (screen-field x (1- y))) (incf val 1))
                          (when (is-wall (screen-field (1+ x) y)) (incf val 2))
                          (when (is-wall (screen-field x (1+ y))) (incf val 4))
                          (when (is-wall (screen-field (1- x) y)) (incf val 8))
                          val)) )))) )
    (find-outers)))

(defun init-sokoban ()
  "Initialized the whole beast, opens display, creates window ..."
  (let (root-window)
    (setq *display*     (x-open-display)
          root-window   (xlib:screen-root (car (xlib:display-roots *display*)))
          *changes*     (make-array '(20 20))
          *pixmaps*     (map 'vector
                             #'(lambda (name)
                                 (xpm::read-file-to-pixmap root-window (merge-pathnames (make-pathname :name name :type "xpm")
                                                                                        *xpm-directory*)))
                             *pixmap-names*)
          *man-pixmaps* (map 'vector
                             #'(lambda (name)
                                 (xpm::read-file-to-pixmap root-window (merge-pathnames (make-pathname :name name :type "xpm")
                                                                                        *xpm-directory*)))
                             *man-pixmap-names*)
          *window*      (xlib:create-window :parent root-window :x 0 :y 0 :width 400 :height 400
                                            :background (aref *pixmaps* %floor)
                                            :event-mask '(:exposure
                                                          :button-press :button-release
                                                          :key-press :key-release))
          *gcontext*    (xlib:create-gcontext :drawable *window*))
    (setf (xlib:wm-icon-name *window*) "Sokoban")
    (xlib:map-window *window*)
    (load-state)
    (find-outers)))

(defun direction-index (dx dy)
  (cond ((minusp dx) 0)                 ;left
        ((plusp dx)  1)                 ;right
        ((minusp dy) 2)                 ;up
        ((plusp dy)  3)                 ;down
        (t 0)))                         ;safety

(defun update-direction (dx dy)
  (let ((di (direction-index dx dy)))
    (setf (aref *pixmaps* %man) (aref *man-pixmaps* (* di 2))
          (aref *pixmaps* %saveman) (aref *man-pixmaps* (1+ (* di 2))))))

(defun ready-p ()
  (zerop *n-objects*))

(defun move (dx dy)
  (let ((nx (+ *man-x* dx))
        (ny (+ *man-y* dy)))
    (cond ((>= (field nx ny) %floor)
           (decf (field *man-x* *man-y*) 2)
           (incf *man-x* dx)
           (incf *man-y* dy)
           (incf (field *man-x* *man-y*) 2)
           (push (list dx dy 2 nil 2) *undos*)
           (update-direction dx dy))
          ((>= (field nx ny) %object)
           (let ((nnx (+ nx dx))
                 (nny (+ ny dy)))
             (when (>= (field nnx nny) %floor)
               ;;Ok its legal ...