sokoban1.1.lisp

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

               (when (and (= (field nx ny) %object)
                          (= (field nnx nny) %goal))
                 (decf *n-objects*))
               (incf (field nx ny) 4)   ;remove object and add man
               (decf (field nnx nny) 2) ;add object
               (decf (field *man-x* *man-y*) 2) ;remove man
               (setf *man-x* nx *man-y* ny)
               (push (list dx dy 4 2 2) *undos*)
               (update-direction dx dy))))
          (t
           ;;Illegal. Should we make some annoying noise here?
           ;;But I hate programs, which make too much noise.
           ) )))

(defun undo ()
  (let ((ui (pop *undos*)))
    (cond ((eq ui :barrier)
           (do () ((eq (car *undos*) :barrier)) (undo))
           (pop *undos*))
          (t
           (when ui
             (when (cadddr ui);push-p?
               (when (and (= (field *man-x* *man-y*) %man)
                          (= (field (+ *man-x* (car ui)) (+ *man-y* (cadr ui))) %treasure))
                 (incf *n-objects*)) )
             (decf (field *man-x* *man-y*) (caddr ui))
             (when (cadddr ui)
               (incf (field (+ *man-x* (car ui)) (+ *man-y* (cadr ui))) (cadddr ui)))
             (incf (field (- *man-x* (car ui)) (- *man-y* (cadr ui))) (car (cddddr ui)))
             (decf *man-x* (car ui))
             (decf *man-y* (cadr ui))
             (update-direction (- (car ui)) (- (cadr ui))) )))))

(defun undo-til-push ()
  (let (ui)
    (loop
     (setq ui (car *undos*))
     (undo)
     (update)
     (xlib:display-finish-output *display*)
     (when (or (null *undos*) (cadddr ui))
       (return)))))

(defun restart-sokoban ()
  (do ()
      ((null *undos*))
      (undo)
      (update)
      (xlib:display-finish-output *display*)))

(defun stats ()
  (format T "~%; Statistics: You made ~R moves so far." (length *undos*) (length *undos*))
  (format T "~%;             This is ~:R level." *level*)
  (format T "~%;             There ~[are~;is~:;are~] ~:*~R ball~:*~P remaining to be goaled."
          *n-objects*))

(defun valid-p (x y) (<= 0 x 19) (<= 0 y 19))

(defun find-target (x y pathlen)
  (cond ((not (valid-p x y)))                   ;we escaped into space
        ((< (field x y) %floor))                ;we could not walk here
        ((<= (aref *findmap* x y) pathlen))     ;there is already some better way
        (t
         (setf (aref *findmap* x y) pathlen)
         (cond ((and (= x *man-x*) (= y *man-y*))) ;we reached our goal!
               (t
                (find-target (1- x) y (1+ pathlen))
                (find-target (1+ x) y (1+ pathlen))
                (find-target x (1- y) (1+ pathlen))
                (find-target x (1+ y) (1+ pathlen))))) ))

(defun walk-to (sx sy)
  (let ((x (floor sx 40))
        (y (floor sy 40)))
    (setq *findmap* (make-array '(20 20) :initial-element %badmove))
    ;;Flood fill search to find a shortest path to the push point.
    (find-target x y 0)
    (cond ((= (aref *findmap* *man-x* *man-y*) %badmove)
           ;; if we didn't make it back to the players position, there is no valid path
           ;; to that place.
           nil)
          (t
           ;; We made it back, so let's walk the path we just built up
           (push :barrier *undos*)
           (let ((cx *man-x*) (cy *man-y*))
             (do ()
                 ((zerop (aref *findmap* cx cy))
                  (push :barrier *undos*)
                  t)
                 (cond ((= (aref *findmap* (1- cx) cy) (1- (aref *findmap* cx cy)))
                        (decf cx)
                        (move -1 0))
                       ((= (aref *findmap* (1+ cx) cy) (1- (aref *findmap* cx cy)))
                        (incf cx)
                        (move 1 0))
                       ((= (aref *findmap* cx (1- cy)) (1- (aref *findmap* cx cy)))
                        (decf cy)
                        (move 0 -1))
                       ((= (aref *findmap* cx (1+ cy)) (1- (aref *findmap* cx cy)))
                        (incf cy)
                        (move 0 1))
                       (t
                        ;;If we get here, something is SERIOUSLY wrong, so we should abort
                        (error "Ups!")) )
                 (update)
                 (xlib:display-finish-output *display*) ) )) )))

(defun usage ()
  "Print a short description on how to play sokoban."
  (format T "

Object of the game is to move all balls into the striped area. Use the cursor
keys to move the man (err the nose). You could push the balls around, but only
one ball at a time. (The nose is not strong enaugh to move more balls).

Recover from mistakes:
  u -- undo one move
       [u wie \"Ungeschehen\" wie meine Schwester, die kleinere, immer sagt.]
  v -- undo til the last push made. (push = moving a ball)
  r -- restart the current level

Proceeding:
  n -- proceed to next level, you must have saved all balls to do this
  f -- cheat! goto next level unconditionally

Other keys:
  q -- quit sokoban; the current state will be saved
  k -- kill sokoban state will *not* be saved
  a -- print current statistics
  h -- show this brief guide again.

If you quit sokoban using 'q' the current state will be saved in
~A and recovered next time you play sokoban."
       *sokoban-state-file*))

(defun sokoban ()
  (unless *display*
    (init-sokoban)
    (usage))
  (block event-loop
         (xlib:event-case (*display*)
                          (:button-press (code window x y)
                                         window
                                         (case code
                                           (1 (walk-to x y) nil)
                                           (3 (undo) (update) nil)
                                           (otherwise nil)))
                          (:key-press (code window)
                                      (case (xlib:keycode->keysym *display* code 0)
                                        (65361 #|LEFT|#  (move -1 0))
                                        (65362 #|UP|#    (move 0 -1))
                                        (65363 #|RIGHT|# (move 1 0))
                                        (65364 #|DOWN|#  (move 0 1))
                                        (#o165 #|u|#  (undo))
                                        (#o166 #|v|# (undo-til-push))
                                        (#o162 #|r|# (restart-sokoban))
                                        (#o163 #|s|# (save-state))
                                        (#o161 #|q|# (return-from event-loop t))
                                        (#o153 #|k|# (return-from sokoban 'killed))
                                        (#o141 #|a|# (stats))
                                        (#o150 #|h|# (usage))
                                        (#o156 #|n|#
                                               (cond ((ready-p)
                                                      (incf *level*)
                                                      (init-field))
                                                     (T
                                                      (format T "~%;You are not yet ready! (consider restart with `r'.)"))))
                                        (#o146 #|f|# ;force
                                               (incf *level*)
                                               (init-field) )
                                        (otherwise #|(print (xlib:keycode->keysym *display* code 0))|#))
                                      (update)
                                      (when (ready-p)
                                        (unless *said-congrat-p*
                                          (format T "~%; Congratulations! -- you are ready.~A" (code-char 7))
                                          (format T "~%; Statistics: You needed ~R moves." (length *undos*))
                                          (setq *said-congrat-p* t))
                                        (unless *said-proceed-p*
                                          (format T "~%; Proceed to next move with 'n'.")
                                          (setq *said-proceed-p* t)) )
                                      nil)
                          (:exposure (x y width height count)
                                     x y width height count ;This is for the compiler.
                                     (when (= count 0) (update t))
                                     nil) ))
  (save-state))

(defun update (&optional all-p)
  (dotimes (x 20)
    (dotimes (y 20)
      (let ((changed-p (aref *changes* x y))
            (value (aref *field* x y)))
        (when (and (or all-p changed-p)
                   (or (/= value %floor) changed-p))
          (setf (aref *changes* x y) nil)
          (xlib:copy-area (aref *pixmaps* value)
                          *gcontext* 0 0 40 40 *window* (* x 40) (* y 40)))))))

(defun save-state ()
  (with-open-file (o *sokoban-state-file* :direction :output)
    (let ((*package* (find-package :sokoban)))
      (dolist (k *state-vars*)
        (print `(setq ,k ',(symbol-value k)) o))))
  (format T "~%;Saved state"))

(defun load-state ()
  (cond ((probe-file *sokoban-state-file*)
         (format T "~%;Retrieving old state")
         (let ((*package* (find-package :sokoban)))
           (load *sokoban-state-file*))
         (format T "~%;This is the ~:R level, you have made already ~R move~P."
                 *level* (length *undos*) (length *undos*))
         (setf (xlib:wm-name *window*) (format nil "Sokoban - ~:(~:R~) Level" *level*)))
        (t
         (format T "~%;You are beginning fresh.")
         (setq *level* 1)
         (init-field))) )

;; These functions should realy been compiled:
'(mapcar #'compile '(init-field ready-p update find-outers field find-target walk-to))

(format t "~& Call (clx-demos:sokoban).~%")