~octaspire/crates2

0829ad88b10f4d056a616f18f9e137d7c2517964 — octaspire 10 months ago 9a3eb7b
Continue implementing
7 files changed, 178 insertions(+), 56 deletions(-)

M crates2.asd
M doc/CodingConventions.org
M src/crates.lisp
M src/level.lisp
A src/levels.lisp
M src/main.lisp
M src/textual.lisp
M crates2.asd => crates2.asd +1 -0
@@ 21,6 21,7 @@
                 (:file "crates")
                 (:file "level")
                 (:file "textual")
                 (:file "levels")
                 (:file "main"))))
  :build-operation program-op
  :build-pathname "crates2"

M doc/CodingConventions.org => doc/CodingConventions.org +3 -0
@@ 29,3 29,6 @@ Example:
(defun head-on-collision-p (v1 v2))
(defun runningp ())
#+end_src
* Formatting
** Line length
Lines should not be longer that 90 characters.
\ No newline at end of file

M src/crates.lisp => src/crates.lisp +64 -25
@@ 19,12 19,12 @@
(defun find-at (x y z)
  "Get crate at (X,Y,Z) or NIL if location is empty."
  (find-if #'(lambda (crate)
               (if (and (= (x crate) x)
                        (= (y crate) y)
                        (= (z crate) z))
               (if (and (= (crate-x crate) x)
                        (= (crate-y crate) y)
                        (= (crate-z crate) z))
                   crate
                   nil))
           *level*))
           (get-current-level)))

(defun find-at-of-type (x y z type)
  "Get crate of TYPE at (X,Y,Z) or NIL if location is empty or crate is not of TYPE."


@@ 39,17 39,22 @@

(defclass crate ()
  ((x :initarg :x
      :accessor x)
      :accessor crate-x)
   (y :initarg :y
      :accessor y)
      :accessor crate-y)
   (z :initarg :z
      :accessor z)
      :accessor crate-z)
   (visible :initarg :visible
      :accessor visible)))
            :accessor crate-visible)))

(defclass wall (crate)
  ())

(defclass exit (crate)
  ((activated :initarg :activated
              :accessor exit-activated
              :initform nil)))

(defclass vacuum (crate)
  ((full :initarg :full
         :accessor full


@@ 97,6 102,15 @@
(defgeneric collide (moving target)
  (:documentation "Handle MOVING crate colliding into TARGET"))

(defgeneric movingp (self)
  (:documentation "Predicate telling whether moving SELF is in motion"))

(defgeneric stationaryp (self)
  (:documentation "Predicate telling whether moving SELF is not moving"))

(defgeneric handle-input (self input)
  (:documentation "React to input"))

;; Methods

(defmethod update ((self crate)))


@@ 105,9 119,9 @@
  (call-next-method))

(defmethod update ((self vacuum))
  (let ((crate (find-at-of-type (x self) (y self) 0 'moving)))
  (let ((crate (find-at-of-type (crate-x self) (crate-y self) 0 'moving)))
    (when crate
      (setf (active crate) nil)
      (crate-active! crate nil)
      (when (typep crate 'player)
        (setf (lamented crate) t)
        (setf (full self) t))))


@@ 125,15 139,23 @@
  (call-next-method))

(defmethod update ((self player))
  (let ((input (car *input*)))
    (when (and input (stationaryp self))
      (handle-input self input)))
  (call-next-method))

(defmethod visual ((self crate))
  (when (visible self)
  (when (crate-visible self)
    (call-next-method)))

(defmethod visual ((self wall))
  #\x)

(defmethod visual ((self exit))
  (if (exit-activated self)
      #\E
      #\e))

(defmethod visual ((self player))
  (if (active self)
      #\o


@@ 148,40 170,40 @@
  #\p)

(defmethod west ((self moving))
  (let* ((x (- (x self) 1))
         (crate (find-at x (y self) (z self))))
  (let* ((x (- (crate-x self) 1))
         (crate (find-at x (crate-y self) (crate-z self))))
    (if (< x 0)
        (escape self)
        (if crate
            (collide self crate)
            (setf (x self) x)))))
            (setf (crate-x self) x)))))

(defmethod east ((self moving))
  (let* ((x (+ (x self) 1))
         (crate (find-at x (y self) (z self))))
  (let* ((x (+ (crate-x self) 1))
         (crate (find-at x (crate-y self) (crate-z self))))
    (if (>= x *level-width*)
        (escape self)
        (if crate
            (collide self crate)
            (setf (x self) x)))))
            (setf (crate-x self) x)))))

(defmethod north ((self moving))
  (let* ((y (+ (y self) 1))
         (crate (find-at (x self) y (z self))))
    (if (>= y *level-height*)
  (let* ((y (- (crate-y self) 1))
         (crate (find-at (crate-x self) y (crate-z self))))
    (if (< y 0)
        (escape self)
        (if crate
            (collide self crate)
            (setf (y self) y)))))
            (setf (crate-y self) y)))))

(defmethod south ((self moving))
  (let* ((y (- (y self) 1))
         (crate (find-at (x self) y (z self))))
    (if (< y 0)
  (let* ((y (+ (crate-y self) 1))
         (crate (find-at (crate-x self) y (crate-z self))))
    (if (>= y *level-height*)
        (escape self)
        (if crate
            (collide self crate)
            (setf (y self) y)))))
            (setf  (crate-y self) y)))))

(defmethod escape ((self moving))
  (setf (active self) nil)


@@ 194,6 216,23 @@
(defmethod collide ((self player) (target crate))
  (call-next-method))

(defmethod collide ((self player) (target exit))
  (request-next-level)
  (call-next-method))

(defmethod movingp ((self moving))
  (not (stationaryp self)))

(defmethod stationaryp ((self moving))
  (eq (velocity self) :zero))

(defmethod handle-input ((self player) input)
  (ecase input
    (:east  (setf (velocity self) input))
    (:west  (setf (velocity self) input))
    (:north (setf (velocity self) input))
    (:south (setf (velocity self) input))))

(defun head-on-collision-p (v1 v2)
  "Predicate telling whether velocities V1 and V2 can cause
head on collision - i.e. if the velocities are in opposite

M src/level.lisp => src/level.lisp +10 -14
@@ 14,22 14,18 @@
;; limitations under the License.
(in-package :crates2)

(defparameter *running* t)
(defparameter *level* (list))
(defparameter *level-width* 8)
(defparameter *level-height* 4)

;; Methods

(defmethod update ((self list))
  (when *running* (loop for crate in *level*
                        do (update crate)
                           (when (and (typep crate 'player)
                                      (lamented crate))
                             (setf *running* nil))))
  *running*)
  (let ((level (get-current-level)))
    (when (runningp) (loop for crate in level
                           do (update crate)
                              (when (and (typep crate 'player)
                                         (lamented crate))
                                (request-restart-level))))))

(defmethod render ((self list))
  (when *running*
    (loop for crate in *level*
          do (render crate))))
  (when (runningp)
    (let ((level (get-current-level)))
      (loop for crate in level
            do (render crate)))))

A src/levels.lisp => src/levels.lisp +31 -0
@@ 0,0 1,31 @@
;; Octaspire Crates 2 - Puzzle Game
;; Copyright 2020 octaspire.com
;;
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;;
;; http://www.apache.org/licenses/LICENSE-2.0
;;
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
(in-package :crates2)

(defparameter *num-levels* 2)

(defun load-level (index)
  (ecase index
    (0 (load-level-0))
    (1 (load-level-1))))

(defun load-level-0 ()
  (list (make-instance 'exit     :x 1 :y 3 :z 0)
        (make-instance 'player   :x 5 :y 3 :z 0)))

(defun load-level-1 ()
  (list (make-instance 'exit     :x 1 :y 2 :z 0)
        (make-instance 'vacuum   :x 3 :y 2 :z 0)
        (make-instance 'player   :x 5 :y 2 :z 0)))

M src/main.lisp => src/main.lisp +46 -11
@@ 19,10 19,28 @@
(defparameter *version-minor* 1)
(defparameter *version-patch* 0)
(defparameter *errors* nil)
(defparameter *input* nil)
(defparameter *level-number* -1)
(defparameter *running* t)
(defparameter *level* nil)
(defparameter *next-level* nil)
(defparameter *level-width* 20)
(defparameter *level-height* 10)

(defun verbose-parser (x)
  (setf *verbose* (parse-integer x)))

(defun get-current-level()
  (unless *level*
    (load-next-level))
  *level*)

(defun runningp ()
  *running*)

(defun running (value)
  (setf *running* value))

(opts:define-opts
  (:name :help
   :description "Show this usage information and quit"


@@ 44,12 62,18 @@
  (when (> *verbose* 0)
    (format t fmt args)))

(defun run (level)
(defun run ()
  (unless *errors*
    (loop while *running*
          do (ui-render level)
             (update level)
             (sleep 2))))
    (request-next-level)
    (loop while (runningp)
            do (ui-render *level*)
               (let ((input (ui-input)))
                 (when input
                   (setf *input* (cons input *input*))))
               (update *level*)
               (when *next-level*
                 (load-next-level))
               (sleep 2))))

(defun usage ()
  (opts:describe


@@ 76,11 100,22 @@
       (loop for (,option ,value) on ,opts-not-empty by #'cddr
             do (case ,option ,@clauses)))))

(setf *level* (cons (make-instance 'wall   :x 1 :y 1 :z 0) *level*))
;; (setf *level* (cons (make-instance 'vacuum :x 2 :y 1 :z -1) *level*))
(setf *level* (cons (make-instance 'pushed :x 3 :y 1 :z 0) *level*))
(setf *level* (cons (make-instance 'player :x 5 :y 1 :z 0) *level*))
(setf (velocity (car *level*)) :west)
(defun load-next-level ()
  (let ((level-number (mod *next-level* *num-levels*)))
    (setf *next-level* nil)
    (setf *level-number* level-number)
    (format t "LEVEL ~A~%" *level-number*)
    (setf *level* nil)
    (setf *level* (load-level *level-number*))))

(defun request-next-level ()
  (setf *next-level* (+ *level-number* 1)))

(defun request-restart-level ()
  (setf *next-level* *level-number*))

(defun request-previous-level ()
  (setf *next-level* (- *level-number* 1)))

(defun main ()
  (let ((options (handler-case


@@ 90,4 125,4 @@
    (cond-option options
                 (:help (usage))
                 (:version (version))
                 (otherwise (run *level*)))))
                 (otherwise (run)))))

M src/textual.lisp => src/textual.lisp +23 -6
@@ 29,19 29,36 @@
          do (setf (aref a i) (empty-line)))
    a))

(defparameter *fake-input* (list :west :west))

(defun ui-input ()
  (let ((input (car *fake-input*)))
    (setf *fake-input* (cdr *fake-input*))
    input))

(defun x-axis (length)
  (let ((result ""))
    (loop for i from 0 to (- length 1)
          do (let ((num (mod i 10)))
               (setf result (concatenate 'string result (write-to-string num)))))
    result))

(defun ui-render (level)
  (let ((lines (empty-level))
        (x-axis (x-axis *level-width*))
        (bar (format nil "~v@{~A~:*~}" *level-width* #\-)))
    (loop for crate in level
          do (progn
               (let* ((x (x crate))
                      (y (y crate))
                      (z (z crate))
               (let* ((x (crate-x crate))
                      (y (crate-y crate))
                      (z (crate-z crate))
                      (v (visual crate))
                      (line (aref lines y)))
                 (when v
                   (setf (aref line x) v)))))
    (format t "~%+~A+~%" bar)
    (format t "~%  ~A~%" x-axis)
    (format t " +~A+ Level ~A~%" bar *level-number*)
    (loop for line across lines
          do (format t "|~A|~%" line))
    (format t "+~A+~%" bar)))
\ No newline at end of file
          for y from 0
          do (format t "~A|~A|~%" (mod y 10) line))
    (format t " +~A+~%" bar)))
\ No newline at end of file