From: christoph Date: Thu, 9 Apr 2009 21:45:19 +0000 (+0200) Subject: first commit X-Git-Url: http://uxul.de/gitweb/?p=uxul-world.git;a=commitdiff_plain;h=3520f2248cddebdc3c03a080047d76fdf1f6c382 first commit --- 3520f2248cddebdc3c03a080047d76fdf1f6c382 diff --git a/BUGS b/BUGS new file mode 100644 index 0000000..3e3a2a1 --- /dev/null +++ b/BUGS @@ -0,0 +1,3 @@ +2009/04/01 Background is too slow and "Jumps" + +2009/04/09 Setting the Animation of Jumping doesnt always work correct \ No newline at end of file diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..39452b4 --- /dev/null +++ b/Makefile @@ -0,0 +1,2 @@ +clean: + rm -rf ./*~ diff --git a/README b/README new file mode 100644 index 0000000..6e0eaf2 --- /dev/null +++ b/README @@ -0,0 +1,3 @@ +This Game is under development and may not be ready to use yet. + +It depends on Lispbuilder-SDL (SVN-Revision 759), LTK and lisp-magick. diff --git a/add-object.lisp b/add-object.lisp new file mode 100755 index 0000000..a68a2cb --- /dev/null +++ b/add-object.lisp @@ -0,0 +1,64 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(defun i-wanna-listen-to (object room &rest args) + "Brings all the Objects of the given classes in into the +listen-to-array of object. Any previous value will be deleted." + (dolist (arg args) + (setf (listen-to object) + (concatenate 'list + (listen-to object) + (get-objects room arg))))) + +(defun must-be-listened-by (object room &rest args) + "Adds itself to the listen-to-array of all the objects of the given +classes in " + (dolist (arg args) + (dolist (obj (get-objects room arg)) + (push object (listen-to obj))))) + +(defgeneric add-object (obj place) + (:documentation "Add an object to a place, i.e. a room or sth.")) + +(defmethod add-object ((obj t) (place t)) + "Just Warn - this shouldnt happen!" + (format t + "add-object was called with arguments it wasnt defined +for. Classes: ~A ~A" + (class-name (class-of obj)) + (class-name (class-of obj)))) + +(defmethod add-object ((object t) (room room)) + (add-object-of-class object (object-array room))) + +(defmethod add-object ((obj stone) (place room)) + "Add a stone to a room and all the objects it can collide with" + (must-be-listened-by obj place 'player 'moving-enemy 'moving-item) + (call-next-method)) + +(defmethod add-object ((obj moving-enemy) (place room)) + (i-wanna-listen-to obj place 'player 'stone) + (must-be-listened-by obj place 'player) + (call-next-method)) + +(defmethod add-object ((obj standing-enemy) (place room)) + (must-be-listened-by obj place 'player) + (call-next-method)) + +(defmethod add-object ((obj moving-item) (place room)) + (must-be-listened-by obj place 'player) + (i-wanna-listen-to obj place 'player 'stone) + (call-next-method)) + +(defmethod add-object ((obj standing-item) (place room)) + (must-be-listened-by obj place 'player) + (call-next-method)) + +(defmethod add-object ((obj player) (place room)) + (setf (key-listener place) obj) + (setf (graphic-centralizer place) obj) + (must-be-listened-by obj place 'moving-enemy 'moving-item) + (i-wanna-listen-to obj place 'moving-enemy 'moving-item 'standing-enemy + 'standing-item 'stone 'bottom) + (call-next-method)) \ No newline at end of file diff --git a/animation.lisp b/animation.lisp new file mode 100755 index 0000000..db6c7bf --- /dev/null +++ b/animation.lisp @@ -0,0 +1,121 @@ +;;; Copyright 2009 Christoph Senjak + +;; Basic definitions for animations. Needs lispbuilder-sdl. + +(in-package :uxul-world) + +(defparameter *graphics-table* nil) + +;; the functions may assume that the contents of a graphics-file - +;; once read - will not change at any time - so it wont reload +;; graphics with an equivalent path any time you load an image. + +(defclass animation (xy-coordinates) + ((images :initarg :images + :initform (make-array (list 0) :element-type 'sdl:surface) + :accessor images +; :type (simple-array 'sdl:surface (*)) + :documentation "Array with the images") + (sprite-image-number :initform 0 + :initarg :sprite-image-number + :accessor sprite-image-number +; :type xy-struct + :documentation "The Element-Number of the + current image. This slot should not be set + directly.") + (sprite-delay :initarg :sprite-delay + :initform 0 + :accessor sprite-delay +; :type integer + :documentation "How much frames to overjump on the +whole until changing to the next image of the animation.") + (already-jumped :initform 0 + :initarg :already-jumped + :accessor already-jumped +; :type integer + :documentation "How much frames have been already + drawn until the last jump? If this equals to , the + next image is selected. Dont set this variable yourself." ) + (visible :initarg :visible + :initform T + :accessor visible +; :type boolean + :documentation "Should this Animation be visible (i.e. be + drawn when the draw-method is called)? Anyway, the + draw-method will - even if set to false - \"animate\" the + animation, i.e. rotate the image currently drawn, if not + paused. It simply wont draw the graphics to the + screen.") + (reference-to-original :initarg :reference-to-original + :accessor reference-to-original + :initform nil + :documentation "DO NOT SET THIS MANUALLY! DO +NOT USE IT! This may not stay in later versions of this Program. It +will be used to minimize the number of file-accesses for loading +animations. For any animation created from a file by the api from +below, this will refer to an animation in the *graphics-table*." ))) + +(defmethod draw ((obj animation)) + (when (not (<= (sprite-delay obj) 0)) ;<=, because -a means "paused, + ;but a is the delay when + ;playing again", and 0 means + ;"no playing" + (incf (already-jumped obj)) + (when (= (sprite-delay obj) (already-jumped obj)) + (setf (already-jumped obj) 0) + (setf (sprite-image-number obj) (mod (+ 1 (sprite-image-number obj)) (length (images obj)))))) + (when (visible obj) + (sdl:draw-surface-at-* (elt (images obj) (sprite-image-number obj)) + (+ *current-translation-x* (round (x obj))) + (+ *current-translation-y* (round (y obj)))))) + +;additional methods to make life easier +(defmethod pause ((obj animation)) + "toggle the playing-flag (sgn sprite-delay), see documentation of draw-method." + (setf (sprite-delay obj) (- (sprite-delay obj)))) + +(defmethod is-paused ((obj animation)) + "is animation paused?" + (< (sprite-delay obj) 0)) + +(defmethod is-playing ((obj animation)) + "is animation playing?" + (< 0 (sprite-delay obj))) + +(defmethod ensure-pause ((obj animation)) + "ensures that the animation is paused if playing, otherwise, nothing is done." + (when (is-playing obj) (pause obj))) + +(defmethod ensure-playing ((obj animation)) + "ensures that the animation is playing if paused, otherwise, nothing is done." + (when (is-paused obj) (pause obj))) + +(defmethod rewind ((obj animation)) + "rewind the animation" + (setf (slot-value obj 'sprite-image-number) 0)) + +#|(defun load-png-image (filename) + (sdl-image:load-image (gethash filename *file-table*) :image-type :PNG :alpha 1 )) ;; :alpha t)) + +(defun hashed-load-image (filename) + "loads an image by its filename, if it wasnt loaded yet. returns a +reference, if the current filename already exists." + (let ((ret (gethash filename *graphics-table* nil))) + (cond + (ret ret) + (T + (setf ret (load-png-image filename)) + (setf (gethash filename *graphics-table*) ret) + ret))))|# + +(defun make-animation (frame-skip &rest image-list) + "Create an animation from the list of animation-names given in the +images-variable." + (make-instance 'animation + :images (mapcar + #'(lambda (x) + (sdl-image:load-image + x + :image-type :PNG :alpha 1 )) + image-list) + :sprite-delay frame-skip)) \ No newline at end of file diff --git a/blue_nasobem.png b/blue_nasobem.png new file mode 100644 index 0000000..2494abd Binary files /dev/null and b/blue_nasobem.png differ diff --git a/blue_nasobem2.png b/blue_nasobem2.png new file mode 100644 index 0000000..fa33376 Binary files /dev/null and b/blue_nasobem2.png differ diff --git a/blue_nasobem3.png b/blue_nasobem3.png new file mode 100644 index 0000000..f80ab37 Binary files /dev/null and b/blue_nasobem3.png differ diff --git a/boomerang1.png b/boomerang1.png new file mode 100644 index 0000000..97b9327 Binary files /dev/null and b/boomerang1.png differ diff --git a/boomerang2.png b/boomerang2.png new file mode 100644 index 0000000..c2a6bf7 Binary files /dev/null and b/boomerang2.png differ diff --git a/boomerang3.png b/boomerang3.png new file mode 100644 index 0000000..860b28e Binary files /dev/null and b/boomerang3.png differ diff --git a/boomerang4.png b/boomerang4.png new file mode 100644 index 0000000..fc7adaf Binary files /dev/null and b/boomerang4.png differ diff --git a/boomerang5.png b/boomerang5.png new file mode 100644 index 0000000..bcaf0ee Binary files /dev/null and b/boomerang5.png differ diff --git a/boomerang6.png b/boomerang6.png new file mode 100644 index 0000000..ff76854 Binary files /dev/null and b/boomerang6.png differ diff --git a/boomerang7.png b/boomerang7.png new file mode 100644 index 0000000..9bc8b2c Binary files /dev/null and b/boomerang7.png differ diff --git a/boomerang8.png b/boomerang8.png new file mode 100644 index 0000000..9bc8b2c Binary files /dev/null and b/boomerang8.png differ diff --git a/brown_stone.png b/brown_stone.png new file mode 100644 index 0000000..07354f9 Binary files /dev/null and b/brown_stone.png differ diff --git a/burning-marshmallow.lisp b/burning-marshmallow.lisp new file mode 100644 index 0000000..5d08382 --- /dev/null +++ b/burning-marshmallow.lisp @@ -0,0 +1,117 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(defclass burning-marshmallow (moving-enemy) + ((dont-ignore :accessor dont-ignore :initform t) + (width :initarg :width :initform 64 :accessor width) + (height :initarg :height :initform 64 :accessor height) + (active :initarg :active :initform t :accessor active) + (redraw :initarg :redraw :initform t :accessor redraw) + (activated :initarg :activated :initform nil :accessor activated) + ;; FIXME + (animation :initarg :animation :initform + (make-animation 2 + |burning_marshmallow_lu1| + |burning_marshmallow_lu2|) + :accessor animation) + + (lu-animation :initform (make-animation 2 + |burning_marshmallow_lu1| + |burning_marshmallow_lu2|)) + (ld-animation :initform (make-animation 2 + |burning_marshmallow_ld1| + |burning_marshmallow_ld2|)) + (ru-animation :initform (make-animation 2 + |burning_marshmallow_ru1| + |burning_marshmallow_ru2|)) + (rd-animation :initform (make-animation 2 + |burning_marshmallow_rd1| + |burning_marshmallow_rd2|)) + (inner-rectangle :initarg :inner-rectangle + :accessor inner-rectangle + :initform nil + :documentation +"An additional rectangle which the burning-marshmallow wont leave. Form: '(x1 y1 x2 y2). If nil, no bounds." + ) + (horizontal-speed :initarg :horizontal-speed + :accessor horizontal-speed + :initform 20) + (vertical-speed :initarg :vertical-speed + :accessor vertical-speed + :initform 20) + (horizontal-direction :initarg :horizontal-direction + :accessor horizontal-direction + :initform :left) + (vertical-direction :initarg :vertical-direction + :accessor vertical-direction + :initform :up))) + +(defmethod invoke ((obj burning-marshmallow)) + (cond + ((activated obj) + (when (inner-rectangle obj) + (cond + ((eql (horizontal-direction obj) :right) + (when (< (caddr (inner-rectangle obj)) + (+ (x obj) (horizontal-speed obj))) + (setf (horizontal-direction obj) :left) + (set-burning-marshmallow-animation obj))) + (T ;; (eql (horizontal-direction obj) :left) + (when (> (car (inner-rectangle obj)) + (- (x obj) (horizontal-speed obj))) + (setf (horizontal-direction obj) :right) + (set-burning-marshmallow-animation obj)))) + (cond + ((eql (vertical-direction obj) :down) + (when (< (cadddr (inner-rectangle obj)) + (+ (y obj) (vertical-speed obj))) + (setf (vertical-direction obj) :up) + (set-burning-marshmallow-animation obj))) + (T ;; (eql (vertical-direction obj) :up) + (when (> (cadr (inner-rectangle obj)) + (- (y obj) (vertical-speed obj))) + (setf (vertical-direction obj) :down) + (set-burning-marshmallow-animation obj))))) + (move-about obj (make-xy + (if (eql (horizontal-direction obj) :left) + (- (horizontal-speed obj)) (horizontal-speed obj)) + (if (eql (vertical-direction obj) :up) + (- (vertical-speed obj)) (vertical-speed obj))))) + (T + (dolist (player (get-objects *current-room* 'player)) + (if (and + (< (abs (- (x player) (x obj))) (+ +screen-width+ 300)) + (< (abs (- (y player) (y obj))) (+ +screen-height+ 300))) + (setf (activated obj) T)))))) + +(defun set-burning-marshmallow-animation (obj) + (cond + ((eql (horizontal-direction obj) :LEFT) + (cond + ((eql (vertical-direction obj) :UP) + (setf (animation obj) (slot-value obj 'lu-animation))) + (T ;; (eql (vertical-direction obj) :DOWN) + (setf (animation obj) (slot-value obj 'ld-animation))))) + (T ;;(eql (horizontal-direction obj) :RIGHT) + (cond + ((eql (vertical-direction obj) :UP) + (setf (animation obj) (slot-value obj 'ru-animation))) + (T ;; (eql (vertical-direction obj) :DOWN) + (setf (animation obj) (slot-value obj 'rd-animation))))))) + + + +(defun simple-enemy-and-player (player enemy) + (decf (power player)) + (setf (active enemy) nil) + (setf (visible enemy) nil) + (setf (colliding enemy) nil)) + +(defmethod player-hits-enemy ((player player) (enemy burning-marshmallow) &rest args) + (declare (ignore args)) + (decf (power player))) + +(defmethod enemy-hits-player ((enemy burning-marshmallow) (player player) &rest args) + (declare (ignore args)) + (decf (power player))) \ No newline at end of file diff --git a/burning_marshmallow_ld1.png b/burning_marshmallow_ld1.png new file mode 100644 index 0000000..90a9012 Binary files /dev/null and b/burning_marshmallow_ld1.png differ diff --git a/burning_marshmallow_ld2.png b/burning_marshmallow_ld2.png new file mode 100644 index 0000000..da03e11 Binary files /dev/null and b/burning_marshmallow_ld2.png differ diff --git a/burning_marshmallow_lu1.png b/burning_marshmallow_lu1.png new file mode 100644 index 0000000..97ffcba Binary files /dev/null and b/burning_marshmallow_lu1.png differ diff --git a/burning_marshmallow_lu2.png b/burning_marshmallow_lu2.png new file mode 100644 index 0000000..050ce44 Binary files /dev/null and b/burning_marshmallow_lu2.png differ diff --git a/burning_marshmallow_rd1.png b/burning_marshmallow_rd1.png new file mode 100644 index 0000000..ddd3dc7 Binary files /dev/null and b/burning_marshmallow_rd1.png differ diff --git a/burning_marshmallow_rd2.png b/burning_marshmallow_rd2.png new file mode 100644 index 0000000..5bb7f62 Binary files /dev/null and b/burning_marshmallow_rd2.png differ diff --git a/burning_marshmallow_ru1.png b/burning_marshmallow_ru1.png new file mode 100644 index 0000000..89a0bf7 Binary files /dev/null and b/burning_marshmallow_ru1.png differ diff --git a/burning_marshmallow_ru2.png b/burning_marshmallow_ru2.png new file mode 100644 index 0000000..dfeac67 Binary files /dev/null and b/burning_marshmallow_ru2.png differ diff --git a/collision.lisp b/collision.lisp new file mode 100755 index 0000000..9de4667 --- /dev/null +++ b/collision.lisp @@ -0,0 +1,38 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(defclass collision () + ((pos :initarg :pos + :accessor pos + :type xy-struct + :documentation "The position where the moving rectangle is at + the point of collision") + (direction :initarg :direction + :accessor direction + :documentation "On which side of the MOVING rectangle + does the collision occur?") + (collision-time :initarg :collision-time + :accessor collision-time + :type rational + :documentation "The quotient of the length of the + real movement and the length of the desired + movement.") + (desired-movement :initarg :desired-movement + :accessor desired-movement + :type xy-struct + :documentation "The full movement that was given + to move-about and could not be fulfilled."))) + +(defmethod has-horizontal-direction ((obj collision)) + "test, whether this has horizontal direction" + (or (eq (direction obj) :left) + (eq (direction obj) :right))) + +(defmethod has-vertical-direction ((obj collision)) + "test, whether this has vertical direction" + (or (eq (direction obj) :up) + (eq (direction obj) :down))) + +(defmethod colliding ((object null)) + nil) \ No newline at end of file diff --git a/compile.cl b/compile.cl new file mode 100755 index 0000000..ec06f57 --- /dev/null +++ b/compile.cl @@ -0,0 +1,15 @@ +#! /usr/bin/sbcl --script + +(clc:clc-require :uxul-world) + +(uxul-world:init-media) + +(sb-ext:save-lisp-and-die "coredump" + :executable + t + :toplevel + #'(lambda (x) + (unwind-protect + (uxul-world::start-game #'uxul-world::make-testing-room) + 0))) + diff --git a/constants.lisp b/constants.lisp new file mode 100755 index 0000000..c5527e1 --- /dev/null +++ b/constants.lisp @@ -0,0 +1,13 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(defconstant +screen-width+ 1024) +(defconstant +screen-height+ 768) + +(defconstant +class-indices+ '(t uxul-world::animation + uxul-world::collision uxul-world::game-object uxul-world::player + uxul-world::room uxul-world::stone uxul-world::xy-coordinates + uxul-world::bottom uxul-world::moving-enemy + uxul-world::standing-enemy uxul-world::moving-item + uxul-world::standing-item uxul-world::game-object-with-animation)) \ No newline at end of file diff --git a/draw.lisp b/draw.lisp new file mode 100755 index 0000000..c2a3154 --- /dev/null +++ b/draw.lisp @@ -0,0 +1,94 @@ +;;; Copyright 2009 Christoph Senjak + +;; various draw-methods + +(in-package :uxul-world) + +(defun draw-background (x-trans y-trans) + + + (flet ((modf (x y) + (if nil ;(< x 0) + (- y (mod x y)) + (mod x y)))) + + + #|(sdl:draw-rectangle-* (+ 100 (ceiling (/ (mod x-trans 800) 2))) (+ 100 (ceiling (/ (mod y-trans 800) 2))) 400 400 + :color (sdl:color :r 255 :g 255 :b 255))|# + ;; layer -1 + + ;; HAAAAAAAAAAAAACK + (incf x-trans (- 10000 300)) + (incf x-trans (- 10000 300)) + + (dolist (i '(8 9 10 11 12 13 14 15 16 17 18 19 20)) + (dolist (j '(8 9 10 11 12 13 14 15 16 17 18 19 20)) + (sdl:draw-box-* (+ (- +screen-width+) (* 100 i) (round (/ (modf x-trans (* 2 +screen-width+)) 16))) (+ (- +screen-width+) (* 100 j) (ceiling (/ (modf y-trans (* 2 +screen-height+)) 16))) 50 50 + :color (sdl:color :r (+ 128 64) :g (+ 128 64) :b (+ 128 64)))) :fill t) + + (dolist (i '(4 5 6 7 8 9)) + (dolist (j '(4 5 6 7 8 9)) + (sdl:draw-box-* (+ (- +screen-width+) (* 200 i) (round (/ (modf x-trans (* 2 +screen-width+)) 8))) (+ (- +screen-width+) (* 200 j) (ceiling (/ (modf y-trans (* 2 +screen-height+)) 8))) 100 100 + :color (sdl:color :r 128 :g 128 :b 128))) :fill t) + (dolist (i '(2 3 4 5)) + (dolist (j '(2 3 4 5)) + (sdl:draw-box-* (+ (- +screen-width+) (* 400 i) (round (/ (modf x-trans (* 2 +screen-width+)) 4))) (+ (- +screen-width+) (* 400 j) (ceiling (/ (modf y-trans (* 2 +screen-height+)) 4))) 200 200 + :color (sdl:color :r 64 :g 64 :b 64))) :fill t) + (dotimes (i 4) + (dotimes (j 4) + (sdl:draw-box-* (+ (- +screen-width+) (* 800 i) (round (/ (modf x-trans (* 2 +screen-width+)) 2))) (+ (- +screen-width+) (* 800 j) (ceiling (/ (modf y-trans (* 2 +screen-height+)) 2))) 400 400 + :color (sdl:color :r 0 :g 0 :b 0))) :fill t))) + + + + +(defmethod draw ((obj room)) + (let ((*current-translation-x* + #|(cond + ((< (- (x (graphic-centralizer obj)) 400) 0) 0) + ((> (+ (x (graphic-centralizer obj)) 400) (width obj)) + (- 800 (width obj))) + (T + (- 400 (x (graphic-centralizer obj)))))|# + (- 400 (x (graphic-centralizer obj))) + ) + (*current-translation-y* + #|(cond + ((< (- (y (graphic-centralizer obj)) 300) 0) 0) + ((> (+ (y (graphic-centralizer obj)) 300) (height obj)) + (- 600 (height obj))) + (T + (- 300 (y (graphic-centralizer obj)))))|# + (- 300 (y (graphic-centralizer obj))) + )) + ;;(draw-background *current-translation-x* *current-translation-y*) + (dolist (image (get-objects obj 'uxul-world::game-object)) + (if (and (redraw image) (visible image)) (draw image))))) + + +;; FIXME + +(defvar *player-bar-color* -255) + +(defmethod draw ((obj player)) + #+nil(if (rectangle-in-screen obj) + (old-draw-rectangle obj :r 255 :g 255 :b 255)) + + ;;; FIXME ************ + (sdl:draw-box-* + 10 10 (floor (* (power obj) (/ (- +screen-width+ 20) 10))) 10 + :color (sdl:color :r (abs *player-bar-color*) :g (abs *player-bar-color*) :b (abs *player-bar-color*))) + (incf *player-bar-color* 5) + (if (= *player-bar-color* 255) (setf *player-bar-color* -255)) + + (call-next-method)) + +(defmethod draw ((obj stone)) + (call-next-method) + #+nil(if (rectangle-in-screen obj) + (old-draw-rectangle obj :r 255 :g 255 :b 255))) + +(defmethod draw ((obj simple-enemy)) + (call-next-method) + #+nil(if (rectangle-in-screen obj) + (old-draw-rectangle obj :r 255 :g 255 :b 255))) \ No newline at end of file diff --git a/elementary-classes.lisp b/elementary-classes.lisp new file mode 100755 index 0000000..43cd9cf --- /dev/null +++ b/elementary-classes.lisp @@ -0,0 +1,74 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(defclass stone (game-object-with-animation) + ((animation :initarg :animation + :initform (make-animation 0 |gray_stone|) + :accessor animation) + (width :initarg :width + :accessor width + :initform 128) + (height :initarg :height + :accessor height + :initform 128) + (active :initarg :active + :accessor active + :initform NIL) + (redraw :accessor redraw + :initform t)) + (:documentation +"Defines an object that cannot be passed by enemies or the player or + items per default.")) + +(defclass bottom (stone) + ((animation :initarg :animation + :initform (make-animation 0 |block|) + :accessor animation) + (width :initarg :width + :accessor width + :initform 64) + (height :initarg :height + :accessor height + :initform 64) + (active :initarg :active + :accessor active + :initform NIL) + (redraw :accessor redraw + :initform t)) + (:documentation +"Defines an object that cannot be passed from the top side, but can be + passed from all other sides by the player, enemies and items per + default.")) + +(defclass moving-enemy (game-object-with-animation) + ((animation :initarg :animation + :initform (make-animation 0 |block|) + :accessor animation) + (width :initarg :width + :accessor width + :initform 64) + (height :initarg :height + :accessor height + :initform 64) + (active :initarg :active + :accessor active + :initform t) + (visible :initarg :visible + :accessor visible + :initform t) + (redraw :accessor redraw + :initform t) + ) + (:documentation +"The default class for moving enemies. This class cannot pass through +stones and bottoms, and listens to the player.")) + +(defclass standing-enemy (stone) () (:documentation +"The default class for standing enemies.")) + +(defclass standing-item (game-object-with-animation) () (:documentation +"The default class for standing items.")) + +(defclass moving-item () () (:documentation +"The default class for moving items.")) \ No newline at end of file diff --git a/empty.png b/empty.png new file mode 100644 index 0000000..2b5fcd8 Binary files /dev/null and b/empty.png differ diff --git a/files.lisp b/files.lisp new file mode 100755 index 0000000..e8e50db --- /dev/null +++ b/files.lisp @@ -0,0 +1,34 @@ +;;; Copyright 2009 Christoph Senjak + +;; This file declares the constants for loading different files and +;; file-formats. + +(in-package :uxul-world) + +(defun si (var val) + (setf (symbol-value (intern var)) val)) + +(defun init-file (file) + "Load a file into a Variable. Access with |filename| (without .png +and path)." + (si (pathname-name file) + (with-open-file (in file :element-type '(unsigned-byte 8)) + (let* ((length (file-length in)) + (content (make-array (list length) + :element-type '(unsigned-byte 8) + :adjustable nil))) + (read-sequence content in) + content)))) + +(defun file-relevant-p (file) + "Is the file relevant for initialization? So far only .png-files are +relevant." + (string= (pathname-type file) "png")) + +(defun init-files () + "Load the relevant files into variables" + (cl-fad:walk-directory + (asdf:component-pathname (asdf:find-system :uxul-world)) + #'init-file :test #'file-relevant-p)) + +(init-files) \ No newline at end of file diff --git a/flying-nasobem.lisp b/flying-nasobem.lisp new file mode 100644 index 0000000..7017ec6 --- /dev/null +++ b/flying-nasobem.lisp @@ -0,0 +1,60 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +;;; Desired behaviour: Fly around, and if uxul gets near, try to crash +;;; it. When Uxul jumps on top of it, then get broken. + + +(defclass flying-nasobem (simple-enemy) + ((animation :initarg :animation + :initform + (make-animation 3 |blue_nasobem| |blue_nasobem2|) + :accessor animation) + (animation-translation :accessor animation-translation + :initarg :animation-translation + :initform (make-xy -100 -50)) + + (flat-animation :initform (make-animation 0 |blue_nasobem3|) + :accessor flat-animation) + + (invoke-continuation :initform #'invoke-flying-nasobem) + (dont-ignore :accessor dont-ignore :initform t) + (width :initarg :width :initform 64 :accessor width) + (active :initarg :active :initform t :accessor active) + (height :initarg :height :initform 64 :accessor height) + (direction :initarg :direction :initform :left :accessor direction))) + +(defun invoke-flying-nasobem-wait (flying-nasobem frames) + (if (zerop frames) + #'invoke-flying-nasobem + #'(lambda (fn) (invoke-flying-nasobem-wait fn (1- frames))))) + +(defun invoke-flying-nasobem-playerhunt (flying-nasobem x y maxtime) + (move-about flying-nasobem + (make-xy + (if (< (x flying-nasobem) x) 20 -20) + (if (< (y flying-nasobem) y) 20 -20))) + (if (zerop maxtime) + #'(lambda (k) (invoke-flying-nasobem-wait k 16)) + #'(lambda (k) (invoke-flying-nasobem-playerhunt + k x y (1- maxtime))))) + + +(defun invoke-flying-nasobem (flying-nasobem) + (block return-here + (dolist (player (get-objects *current-room* 'player)) + (if (and + (< (abs (- (x player) (x flying-nasobem))) 700) + (< (abs (- (y player) (y flying-nasobem))) 700)) + (return-from return-here #'(lambda (fn) + (invoke-flying-nasobem-playerhunt + fn (x player) (y player) 25))) + (return-from return-here #'invoke-flying-nasobem))))) + + + + +(defmethod invoke ((obj flying-nasobem)) + (setf (slot-value obj 'invoke-continuation) + (funcall (slot-value obj 'invoke-continuation) obj))) diff --git a/functions.lisp b/functions.lisp new file mode 100755 index 0000000..2cbf8ca --- /dev/null +++ b/functions.lisp @@ -0,0 +1,577 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(declaim (optimize (speed 3)) + (inline rectangles-overlap is-horizontal is-vertical turn90 + turn270)) + +(defun rectangles-overlap (x1 y1 x2 y2 x3 y3 x4 y4) + "Does the rectangle with diagonal points (x1,y1) and (x2, y2) +overlap with (x3, y3),(x4,y4)? Assuming x1 x2 x3) + (> x4 x1) + (> y2 y3) + (> y4 y1))) + + +(defun symbol-prename (symbol &optional (charnum 1)) + "Returns just the first Characters of the name of that symbol" + (subseq (symbol-name symbol) 0 charnum)) + +(defun symbol-index (symbol &optional (charnum 1)) + "Removes the first (or charnum) character(s) of a Symbol and parses +the rest into an integer, i.e. makes 1 out of :R1" + (parse-integer (subseq (symbol-name symbol) charnum))) + +(defun is-horizontal (direction) + (or (eq direction :LEFT) (eq direction :RIGHT))) + +(defun is-vertical (direction) + (or (eq direction :UP) (eq direction :DOWN))) + +(defun turn90 (direction) + (cond + ((eq direction :LEFT) :UP) + ((eq direction :RIGHT) :DOWN) + ((eq direction :UP) :RIGHT) + ((eq direction :DOWN) :LEFT))) + +(defun turn270 (direction) + (cond + ((eq direction :LEFT) :DOWN) + ((eq direction :RIGHT) :UP) + ((eq direction :UP) :LEFT) + ((eq direction :DOWN) :RIGHT))) + +(defun string-ends-with (str1 str2) + (let ((length1 (length str1)) + (length2 (length str2))) + (and (>= length1 length2) + (string= (subseq str1 (- length1 length2)) str2)))) + +(defun lower-interval-bound (x1 x2 y1 y2) + "Find the lower interval-bound of [x1, x2] /\ [y1, y2] or - if +disjoint - return NIL." + (let ((xmin (min x1 x2)) + (xmax (max x1 x2)) + (ymin (min y1 y2)) + (ymax (max y1 y2))) + (if (<= xmin ymin xmax) ymin + (if (<= ymin xmin ymax) xmin NIL)))) + +(defmacro swapsort (a b) + `(if (> ,a ,b) + (rotatef ,a ,b))) + +(defun move-collision-rectangle-about-x (moving-object delta-x) + "this function is only a helper for a special case of the method +move-about for collision-objects, which is invoked iff there is no +movement in y-direction AND x is not zero" + (let ((current-time 1) + (current-collision NIL) + (current-standing-object NIL)) + (dolist (standing-object (listen-to moving-object)) + (when (and (colliding standing-object) (not (eq standing-object moving-object))) + (when (< (* 2 (abs (- (mid-y moving-object) (mid-y standing-object)))) + (+ (height moving-object) (height standing-object))) + ;are the y-coordinates near enough such that a collision *can* occur? + (let* ((x-minimal-distance (+ (half-width moving-object) (half-width standing-object))) + (x-distance (- (mid-x standing-object) (mid-x moving-object))) + (x-collide-time-1 + (/ (+ x-minimal-distance x-distance) delta-x)) + (x-collide-time-2 + (/ (- x-distance x-minimal-distance) delta-x)) + (x-minimal-collide-time (min x-collide-time-1 x-collide-time-2))) + (when (<= 0 x-minimal-collide-time current-time) + ;an earlier collision can only + ;occur between 0 and the + ;current-time which is <1 and + ;maybe was set before. + (setf current-time x-minimal-collide-time) + (setf current-collision + (make-instance + 'collision + :desired-movement (make-xy delta-x 0) + :pos (make-xy (+ (truncate (* current-time delta-x)) (x moving-object)) (y moving-object)) + :collision-time current-time + :direction (if (> delta-x 0) :right :left))) + (setf current-standing-object standing-object)))))) + (if current-collision ;if a collision occured, this must be the first now + (on-collision moving-object current-standing-object current-collision) + (incf (x moving-object) delta-x))) +;; (move-collision-rectangle-about-xy moving-object delta-x 0) +) + + +(defun move-collision-rectangle-about-y (moving-object delta-y) + "this function is only a helper for a special case of the method +move-about for collision-objects, which is invoked iff there is no +movement in y-direction AND x is not zero" + (let ((current-time 1) + (current-collision NIL) + (current-standing-object NIL)) + (dolist (standing-object (listen-to moving-object)) + (when (and (colliding standing-object) (not (eq standing-object moving-object))) + (when (< (abs (* 2 (- (mid-x moving-object) (mid-x standing-object)))) + (+ (width moving-object) (width standing-object))) + ;are the y-coordinates near enough such that a collision *can* occur? + (let* ((y-minimal-distance (+ (half-height moving-object) (half-height standing-object))) + (y-distance (- (mid-y standing-object) (mid-y moving-object))) + (y-collide-time-1 + (/ (+ y-minimal-distance y-distance) delta-y)) + (y-collide-time-2 + (/ (- y-distance y-minimal-distance) delta-y)) + (y-minimal-collide-time (min y-collide-time-1 y-collide-time-2))) + (when (<= 0 y-minimal-collide-time current-time) + ;an earlier collision can only occur between 0 and the current-time + ;which is <1 and maybe was set before. + (setf current-time y-minimal-collide-time) + (setf current-collision + (make-instance + 'collision + :desired-movement (make-xy 0 delta-y) + :pos (make-xy (x moving-object) (+ (truncate (* current-time delta-y)) (y moving-object))) + :collision-time current-time + :direction (if (> delta-y 0) :down :up))) + (setf current-standing-object standing-object)))))) + (if current-collision ;if a collision occured, this must be the first now + (on-collision moving-object current-standing-object current-collision) + (incf (mid-y moving-object) delta-y))) +;; (move-collision-rectangle-about-xy moving-object 0 delta-y) +) + + +;; Temporarily + +(defun rational-= (n1 d1 n2 d2) + (= (* n1 d2) (* n2 d1))) + +#|(defun rational-< (n1 d1 n2 d2 &rest args) + "Compare rationals even if the denominators are zero. Behaviour for +0/0 is not specified and may change." + (and (if (zerop d1) + (if (zerop d2) + (< (signum n1) (signum n2)) + (< n1 0)) + (< (* n1 (abs d2) (signum d1)) (* n2 (abs d1) (signum d2)))) + (or (not args) + (apply #'rational-< n2 d2 args))))|# + + +#|(defun rational-<= (n1 d1 n2 d2 &rest args) + "Compare rationals even if the denominators are zero. Behaviour for +0/0 is not specified and may change." + (and (if (zerop d1) + (if (zerop d2) + (<= (signum n1) (signum n2)) + (< n1 0)) + (<= (* n1 (abs d2) (signum d1)) (* n2 (abs d1) (signum d2)))) + (or (not args) + (apply #'rational-<= n2 d2 args))))|# + +(defun rational-<= (n1 d1 n2 d2 &rest args) + (and + (<= (* n1 (abs d2) (signum d1)) (* n2 (abs d1) (signum d2))) + (or + (not args) + (apply #'rational-<= n2 d2 args)))) + +(defun rational-< (n1 d1 n2 d2 &rest args) + (and + (< (* n1 (abs d2) (signum d1)) (* n2 (abs d1) (signum d2))) + (or + (not args) + (apply #'rational-< n2 d2 args)))) + +(defun rational-> (n1 d1 n2 d2 &rest args) + (and (rational-< n2 d2 n1 d1) + (or (not args) + (apply #'rational-> n2 d2 args)))) + +(defun rational->= (n1 d1 n2 d2 &rest args) + (and (rational-<= n2 d2 n1 d1) + (or (not args) + (apply #'rational->= n2 d2 args)))) + +#|FIIIIIIIIXMEEEEEEEEEEE!!!!!!!!!1111111!!!!!!!!!111 + +(defun move-collision-rectangle-about-xy (moving-object x y) + "GIANT ugly but faster implementation than before..." + (declare (type fixnum x y) + (type game-object moving-object)) + (let* ((current-time-num 1) + (current-time-denom 1) + (collision-with-x nil) + (collision-with-y nil) + (current-standing-object nil) + (wm (width moving-object)) + (hm (height moving-object)) + (x1 (x moving-object)) + (y1 (y moving-object)) + (x2 (+ x1 wm)) + (y2 (+ y1 hm))) + (declare (type fixnum current-time-num current-time-denom wm x1 + y1 x2 y2) + (type boolean collision-with-x collision-with-y)) + (dolist (standing-object (listen-to moving-object)) + (let* ((ws (width standing-object)) + (hs (height standing-object)) + (x3 (x standing-object)) + (y3 (y standing-object)) + (x4 (+ x3 ws)) + (y4 (+ y3 hs)) + (y-enter (- (sgn y))) ;; gain negative infty for y-enter/0 + (y-leave y) + (x-enter (- (sgn x))) ;; gain negative infty for x-enter/0 + (x-leave x)) + (declare (type fixnum ws hs x3 y3 x4 y4 y-enter y-leave + x-enter x-leave)) + (and + ;; is the object colliding? does the standing object overlap a (huge enough) + ;; rectangle around the moving object? + + (colliding standing-object) +#| (rectangles-overlap (- x1 absx) + (- y1 absy) + (+ x2 absx 1) + (+ y2 absy 1) + x3 y3 (1+ x4) (1+ y4))|# + (cond + ((> x2 x3) + (cond + ((> x4 x1) + ;;x-enter = -1 +;; (format t "x-inside") + (macrolet ((calc-x () + `(progn + (if (> x 0) + (setf x-leave (- x4 x1)) + (setf x-leave (- x3 x2)))))) + (cond + ((> y2 y3) + (cond + ((> y4 y1) + ;; rectangles do overlap before movement ... do + ;; nothing. + nil) + (T ; y4 <= y1 + ;; standing-object is over moving-object + (cond + ((>= y 0) + ;; no collision - wrong direction, or no + ;; movement at all. + nil) + (T + ;; collision may occur + (setf y-enter (- y1 y4)) + (setf y-leave (- y3 y2)) + (calc-x) + T))))) + (T ; y2 <= y3 + ;; standing-object is below moving-object + (cond + ((<= y 0) + ;; no collision - wrong direction, or no movement + ;; at all. + nil) + (T + ;; collision may occur + (setf y-enter (- y3 y2)) + (setf y-leave (- y4 y1)) + (calc-x) + T)))))) + (T ; x4 <= x1 + ;; standing-rectangle left of moving-rectangle + (macrolet ((calc-x () + ;; x will be <= 0 + `(progn (setf x-enter (- x3 x2)) + (setf x-leave (- x4 x1))))) + (cond + ((> x 0) + ;; no collision - wrong direction, or no movement at + ;; all. + nil) + (T + ;; collision may occur - check y + (cond + ((> y2 y3) + (cond + ((> y4 y1) + ;; y-enter = 0 + (setf y-leave (if (> y 0) (- y2 y3) (- y1 y4))) + (calc-x) + T) + (T ; y4 <= y1 + ;; standing-object is over moving-object + (cond + ((>= y 0) + ;; no collision - wrong direction, or no + ;; movement at all. + nil) + (T + ;; collision may occur + (setf y-enter (- y4 y1)) + (setf y-leave (- y3 y2)) + (calc-x) + T))))) + (T ; y2 < y3 + ;; standing-object is below moving-object + (cond + ((<= y 0) + ;; no collision - wrong direction, or no movement + ;; at all. + nil) + (T + ;; collision may occur + (setf y-enter (- y3 y2)) + (setf y-leave (- y4 y1)) + (calc-x) + T)))))))))) + (T ; x2 <= x3 + ;; standing-rectangle right of moving-rectangle + (macrolet ((calc-x () + ;; will be x > 0 + '(progn + (setf x-leave (- x2 x3)) + (setf x-enter (- x1 x4))))) + (cond + ((<= x 0) + ;; no collision - wrong direction, or no movement at + ;; all. + nil) + (T + ;; collision may occur - check y + (cond + ((> y2 y3) + (cond + ((> y4 y1) + ;; y-bounds of standing-object lie completely + ;; inside y-bounds of moving-object. + (setf y-leave (if (> y 0) (- y1 y4) (- y2 y3))) + (calc-x) + T) + (T ; y4 < y1 + ;; standing-object is over moving-object + (cond + ((>= y 0) + ;; no collision - wrong direction, or no + ;; movement at all. + nil) + (T + ;; collision may occur + (setf y-enter (- y1 y4)) + (setf y-leave (- y3 y2)) + (calc-x) + T))))) + (T ; y2 < y3 + ;; standing-object is below moving-object + (cond + ((<= y 0) + ;; no collision - wrong direction, or no movement + ;; at all. + nil) + (T + ;; collision may occur + (setf y-enter (- y3 y2)) + (setf y-leave (- y1 y4)) + (calc-x) + T))))))))) + + ;; collision could occure - find the smallest collision-time + + (progn (format t "---~%could occure.~%current ~d/~d~%x-enter ~d/~d~%x-leave ~d/~d~%y-enter ~d/~d~%y-leave ~d/~d~%---~%" + current-time-num current-time-denom + x-enter x x-leave x y-enter y y-leave y) t) + + (cond + ((rational-<= x-enter x y-enter y x-leave x) + ;; first collision-time is y-enter/y - check if this is + ;; smaller (earlier) than current-time-num/current-time-denom + ;; and later than 0 + (when (rational-< y-enter y current-time-num current-time-denom) + (setf current-standing-object standing-object) + (setf current-time-denom y) + (setf current-time-num y-enter) + (setf collision-with-y t) + (setf collision-with-x (rational-<= y-enter y y-enter x y-leave y)))) + ((rational-<= y-enter y x-enter x y-leave y) ;; first collision-time is x-enter/y + (when (rational-< x-enter x current-time-num current-time-denom) + (setf current-standing-object standing-object) + (setf current-time-denom x) + (setf current-time-num x-enter) + (setf collision-with-x t) + (setf collision-with-y nil))) + (T nil))))) + (cond + (current-standing-object + (format t "occured~d~%" current-time-num) +; (write (cons current-time-num current-time-denom)) + ;; a collision occured + (on-collision moving-object current-standing-object + (make-instance 'collision + :desired-movement (make-xy x y) + :collision-time + (the rational (/ current-time-num + current-time-denom)) + :pos (make-xy + (+ (truncate (* current-time-num x) current-time-denom) x1) + (+ (truncate (* current-time-num y) current-time-denom) y1)) + :direction (if collision-with-x + (if collision-with-y + :diagonal + (if (> y 0) :down :up)) + (if (> x 0) :right :left))))) + (T + (setf (x moving-object) (+ x1 x)) + (setf (y moving-object) (+ y1 y))))))|# + + + + +(defun move-collision-rectangle-about-xy (moving-object x y) + "this function is only a helper for a special case of the method +move-about for collision-objects, which is invoked iff both x and y +are not zero" + (declare (optimize (debug 0) (safety 0) (space 0) (compilation-speed 0) (speed 3)) + (type fixnum x y) + (type game-object moving-object)) + (let ((absx (abs x)) + (absy (abs y)) + (xm (x moving-object)) + (ym (y moving-object)) + (wm (width moving-object)) + (hm (height moving-object)) + (2*current-time-num 2) + (current-time-denom 1) + (current-standing-object NIL) + (current-direction nil)) + (declare (type fixnum xm ym wm hm 2*current-time-num + current-time-denom absx absy) + (type symbol current-direction) + ) + (let ((2*mid-x-moving (the fixnum (+ xm xm wm))) + (2*mid-y-moving (the fixnum (+ ym ym hm)))) + (declare (type fixnum 2*mid-x-moving 2*mid-y-moving)) + (dolist (standing-object (listen-to moving-object)) + (when (and + + ;;;;;;;;;;;;; BEEEEEEEEEEETTTTTTTTTTEEEEEEEEEEEEEEEEEERRRRRRRRRRRRRRRR!!!!!!!!!!!!!!!!!! + + (colliding standing-object) + +#| (rectangles-overlap (- xm absx) (- ym absy) (+ xm wm absy) (+ ym hm absx) + (- xs absx) (- ys absy) (+ xs ws absx) (+ ys hs absy)) + + (not + (rectangles-overlap xm ym (+ xm wm) (+ ym hm) + xs ys (+ xs hs) (+ ys hs)))|# + + (not (eq moving-object standing-object)) + + ) + (let* ((xs (x standing-object)) + (ys (y standing-object)) + (ws (width standing-object)) + (hs (height standing-object)) + (temporary-direction nil) + (2*x-minimal-distance (the fixnum (+ wm ws))) + (2*y-minimal-distance (the fixnum (+ hm hs))) + (2*x-distance (the fixnum (- (+ xs xs ws) 2*mid-x-moving))) + (2*y-distance (the fixnum (- (+ ys ys hs) 2*mid-y-moving))) + (2*x-collide-time-1 (the fixnum (+ 2*x-minimal-distance 2*x-distance))) + (2*x-collide-time-2 (the fixnum (- 2*x-distance 2*x-minimal-distance))) + (2*y-collide-time-1 (the fixnum (+ 2*y-minimal-distance 2*y-distance))) + (2*y-collide-time-2 (the fixnum (- 2*y-distance 2*y-minimal-distance))) + (minimal-collide-time-denom 0) + (2*minimal-collide-time-num + (progn + (if (> x 0) + (if (> 2*x-collide-time-1 2*x-collide-time-2) + (rotatef 2*x-collide-time-1 2*x-collide-time-2)) + (if (< 2*x-collide-time-1 2*x-collide-time-2) + (rotatef 2*x-collide-time-1 2*x-collide-time-2))) + (if (> y 0) + (if (> 2*y-collide-time-1 2*y-collide-time-2) + (rotatef 2*y-collide-time-1 2*y-collide-time-2)) + (if (< 2*y-collide-time-1 2*y-collide-time-2) + (rotatef 2*y-collide-time-1 2*y-collide-time-2))) + (cond + ((rational-<= 2*x-collide-time-1 x 2*y-collide-time-1 y 2*x-collide-time-2 x) + (setf minimal-collide-time-denom y) + (setf temporary-direction (if (> y 0) :down :up)) + 2*y-collide-time-1) + ((rational-<= 2*y-collide-time-1 y 2*x-collide-time-1 x 2*y-collide-time-2 y) + (setf minimal-collide-time-denom x) + (setf temporary-direction (if (> x 0) :right :left)) + 2*x-collide-time-1) + (T 0))))) + (declare (type fixnum xs ys ws hs 2*x-minimal-distance + 2*y-minimal-distance 2*x-distance + 2*y-distance 2*x-collide-time-1 + 2*x-collide-time-2 2*y-collide-time-1 + 2*y-collide-time-2 + 2*minimal-collide-time-num + minimal-collide-time-denom) + (type symbol temporary-direction)) + (when (and (not (zerop minimal-collide-time-denom)) + (rational-<= 0 1 + 2*minimal-collide-time-num minimal-collide-time-denom + 2*current-time-num current-time-denom)) + (setf 2*current-time-num 2*minimal-collide-time-num) + (setf current-time-denom minimal-collide-time-denom) + (setf current-direction + (cond + ((or (eq temporary-direction :right) + (eq temporary-direction :left)) + (if (or (rational-= 2*minimal-collide-time-num + minimal-collide-time-denom + 2*y-collide-time-1 + y) + (rational-= 2*minimal-collide-time-num + minimal-collide-time-denom + 2*y-collide-time-2 + y)) + :diagonal + temporary-direction)) + ((or (eq temporary-direction :up) + (eq temporary-direction :down)) + (if (or (rational-= 2*minimal-collide-time-num + minimal-collide-time-denom + 2*x-collide-time-1 + x) + (rational-= 2*minimal-collide-time-num + minimal-collide-time-denom + 2*x-collide-time-2 + x)) + :diagonal + temporary-direction)))) + (setf current-standing-object standing-object))))) + (if current-direction + (on-collision moving-object current-standing-object + (make-instance 'collision + :desired-movement (make-xy x y) + :collision-time (the rational (/ 2*current-time-num (* 2 current-time-denom))) + :pos (make-xy + (+ + (truncate (the fixnum (* 2*current-time-num x)) + (the fixnum (* 2 current-time-denom))) + (x moving-object)) + (+ (truncate (the fixnum (* 2*current-time-num y)) + (the fixnum (* 2 current-time-denom))) + (y moving-object))) + :direction current-direction)) + (progn + (setf (x moving-object) (the fixnum (+ (x moving-object) x))) + (setf (y moving-object) (the fixnum (+ (y moving-object) y))) + ))))) + + +(defun old-draw-rectangle (obj &key (r 0) (g 0) (b 0)) + (sdl:draw-rectangle-* (+ *current-translation-x* (x obj)) + (+ *current-translation-y* (y obj)) + (width obj) + (height obj) + :color (sdl:color :r r :g g :b b))) diff --git a/game-object-with-animation.lisp b/game-object-with-animation.lisp new file mode 100755 index 0000000..6b6aa13 --- /dev/null +++ b/game-object-with-animation.lisp @@ -0,0 +1,68 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +;; as many game-objects do have an animation related to them, instead +;; of just having a draw-method which will manually draw anything, we +;; declare a standard-class for that, with some useful methods. + +(defclass game-object-with-animation (game-object) + ((animation-translation :initarg :animation-translation + :accessor animation-translation + :initform (make-xy 0 0) + :documentation "The translation of the animation") + (animation :initarg :animation + :accessor animation + :documentation "The animation of this object"))) + +(defmethod (setf animation) ((newval animation) (obj game-object-with-animation)) + "Sets the animation and x and y-coordinates. Wont rewind the animation." + (setf (slot-value obj 'animation) newval) + (setf (x obj) (x obj)) + (setf (y obj) (y obj)) + (setf (visible obj) (visible obj))) + +(defmethod (setf x) (newval (obj game-object-with-animation)) + (call-next-method) + (setf (x (animation obj)) (+ (x obj) (x (animation-translation obj))))) + +(defmethod (setf y) (newval (obj game-object-with-animation)) + (call-next-method) + (setf (y (animation obj)) (+ (y obj) (y (animation-translation obj))))) + +(defmethod (setf visible) (newval (obj game-object-with-animation)) + (call-next-method) + (setf (visible (animation obj)) newval)) + +(defun rectangle-in-screen (obj) + (rectangles-overlap + ;; HAAAAAAAAAAAAAAACK + (- (x obj) 50) + (- (y obj) 50) + (+ (x obj) (width obj) 50) + (+ (y obj) (height obj) 50) + *current-translation-x* + *current-translation-y* + (- +screen-width+ *current-translation-x*) + (- +screen-height+ *current-translation-y*))) + + + +(defmethod draw ((obj game-object-with-animation)) + ;(if (rectangle-in-screen obj) + (draw (animation obj)) +;) +) + +(defmethod shared-initialize :after ((instance game-object-with-animation) spam &rest + initargs &key &allow-other-keys) + (declare (ignore initargs)) + (declare (ignore spam)) + "Set the x and y-Coordinates in the drawable and the rectangle (this +had to be done by hand before)" +; (write (x instance)) +; (write (y instance)) + (setf (x instance) (x instance)) + (setf (y instance) (y instance)) + (setf (visible instance) (visible instance))) + diff --git a/game-object.lisp b/game-object.lisp new file mode 100755 index 0000000..df28f33 --- /dev/null +++ b/game-object.lisp @@ -0,0 +1,169 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +;; Define a class for the Standard Game-Object which has a draw-Method +;; which will be called at every frame, and a Collision-Box, and has a +;; unique (x, y)-Coordinate with translations for both the Drawable +;; Object and the collision-box + +;; We changed the api, and added stuff from Collision-Rectangle (which +;; explains some documentation about it) + +(defclass game-object (xy-coordinates) + ((width :initarg :width + :initform 0 + :accessor width + :type fixnum + :documentation "The width of that rectangle") + (height :initarg :height + :initform 0 + :accessor height + :type fixnum + :documentation "The height of that rectangle") + (listen-to :initarg :listen-to + :initform NIL + :accessor listen-to + :documentation "List of rectangles and game-objects to + check for collisions at movement") + (colliding :initarg :colliding + :initform T + :accessor colliding +; :type boolean + :documentation "Throw Collisions with this + Collision-Rectangle to other Collision-Rectangles? (this + makes it a bit easier to \"turn off\" Objects, i.e. you + dont always have to remove them from the + listen-to-lists") + (visible :initarg :visible + :initform T + :accessor visible +; :type boolean + :documentation "Should this Object be drawn?") + (redraw :initarg :redraw + :initform T + :accessor redraw + :documentation "If set to nil, this object will be painted + once onto the Background of the Level and then never be + painted again (except when needed), i.e. the engine first + paints it onto its background-surface, and then it keeps + using its background-surface for all further images. This + makes drawing faster. It should be set to NIL whenever + possible, however, if the Object will change its place or + look different in the future, or should be painted over + some other object that can move or change its look, then it + must be set to T, because it must be redrawn. NOTICE: It is + not specified, what happens, if this Value changes during + runtime. It should not be set manually after it is used by + the engine. + +**********************FIXME: DOESNT WORK ATM********************** + +") + (active :initarg :active + :initform NIL + :accessor active +; :type boolean + :documentation "Will the Invoke-Function be called?") + (object-id :initarg :object-id + :initform NIL + :accessor object-id + :documentation "To identify an object, a room may give it an id.")) + (:documentation "Define a Class for all Game-Objects. This class + has an invoke-, a draw- and an on-collide Function, which do + nothing per default." )) + +(defmethod draw ((obj game-object)) + "To be called when drawing the object - does nothing per default, except throwing a warning." + (format t "waring: draw-method not overridden. Object: ") + (write obj) + (sdl:push-quit-event)) + +(defmethod invoke ((obj game-object)) + "To be called when invoking the object - does nothing per default, except throwing a warning." + (format t "warning: invoke-method not overridden. Object: ") + (write obj) + (sdl:push-quit-event)) + +(defmethod on-collision ((moving-object game-object) (standing-object game-object) (collision collision)) + "To be called if a Collision occurs. May have more than one overriding declaration, to use the dispatcher." + (declare (ignore standing-object moving-object collision)) + (format t "warning: on-collision-method not overridden.")) + +(defmethod half-width ((obj game-object)) + (/ (width obj) 2)) +(defmethod (setf half-width) (x (obj game-object)) + (setf (width obj) (* x 2))) +(defmethod half-height ((obj game-object)) + (/ (height obj) 2)) +(defmethod (setf half-height) (x (obj game-object)) + (setf (height obj) (* x 2))) + +(defmethod mid-x ((obj game-object)) + (+ (x obj) (half-width obj))) + +(defmethod mid-y ((obj game-object)) + (+ (y obj) (half-height obj))) + +(defmethod (setf mid-x) (x (obj game-object)) + (setf (x obj) (- x (half-width obj)))) + +(defmethod (setf mid-y) (y (obj game-object)) + (setf (y obj) (- y (half-height obj)))) + +(defmethod move-about ((moving-rectangle game-object) (translation xy-struct)) + (if (= (x translation) 0) + (when (not (= (y translation) 0)) + (move-collision-rectangle-about-y moving-rectangle (y translation))) + (if (= (y translation) 0) + (move-collision-rectangle-about-x moving-rectangle (x translation)) + (move-collision-rectangle-about-xy moving-rectangle (x translation) (y translation))))) + + +(defmethod move-to ((moving-rectangle game-object) (translation xy-struct)) + "This is highly inefficient and should be replaced" + (move-about moving-rectangle + (make-xy (- (x translation) (x moving-rectangle)) (- (y translation) (y moving-rectangle))))) + + +(defmethod draw-bounds ((obj game-object)) + "This function draws a rectangle with the Object's Bounds. May be useful for some debug-spam" + (sdl:draw-rectangle-* (+ (x obj) *current-translation-x*) + (+ (y obj) *current-translation-y*) + (width obj) (height obj) + :color sdl:*BLACK*)) + +(defun collide-blocks (moving-rectangle standing-rectangle collision) + "as MANY collision-methods need to move the moving-object around the +standing-object, we will write a function for doing that. IMPORTANT: +moving-rectangle MUST have a dont-ignore-property" + (declare (ignore standing-rectangle)) + (directly-with-all-accessors collision collision + (setf (x moving-rectangle) (x pos)) + (setf (y moving-rectangle) (y pos)) + (cond + ((or (eq direction :left) (eq direction :right)) + (move-about moving-rectangle (make-xy 0 (truncate (* (- 1 collision-time) (y desired-movement)))))) + ((or (eq direction :up) (eq direction :down)) + (move-about moving-rectangle (make-xy (truncate (* (- 1 collision-time) (x desired-movement))) 0))) + (T ;; diagonal - argh! lets try to move up/down. if this fails, + ;; lets try to move left/right. we're setting our + ;; dont-ignore-flag to nil for that + (let ((current-y (y moving-rectangle)) + (current-x (x moving-rectangle))) + (setf (dont-ignore moving-rectangle) nil) + (move-about moving-rectangle (make-xy (truncate (* (- 1 collision-time) (x desired-movement))) 0)) + (if (not (= current-x (x moving-rectangle))) + (progn + (setf (x moving-rectangle) current-x) + (setf (dont-ignore moving-rectangle) T) + ;; now really move it! + (move-about moving-rectangle (make-xy (truncate (* (- 1 collision-time) (x desired-movement))) 0))) + ;else - it cannot move in x-direction... + (progn + (move-about moving-rectangle (make-xy 0 (truncate (* (- 1 collision-time) (y desired-movement))))) + (when (not (= current-y (y moving-rectangle))) + (setf (y moving-rectangle) current-y) + (setf (dont-ignore moving-rectangle) T) + ;; now really move it! + (move-about moving-rectangle (make-xy 0 (truncate (* (- 1 collision-time) (y desired-movement))))))))))))) diff --git a/game.lisp b/game.lisp new file mode 100755 index 0000000..49e4e96 --- /dev/null +++ b/game.lisp @@ -0,0 +1,99 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(defparameter *cfont* nil) + +(defun start-game (&key (music nil) room-function (15-fps nil)) + "Start the Game: Call room-function for getting the room-object to +run. Music is ignored so far. 15-fps makes only every second frame be +drawn (for very slow computers)" + (sdl:with-init (sdl:sdl-init-video sdl:sdl-init-audio) + (sdl:window +screen-width+ +screen-height+ + :title-caption "Uxul World" + :icon-caption "Uxul World" + :flags (logior sdl:sdl-hw-accel sdl:sdl-hw-surface) + ;:flags (logior sdl:sdl-hw-surface) #| sdl:sdl-fullscreen )|# +) + ;;(if music (sdl-mixer:OPEN-AUDIO :frequency 44100)) + (let ((*graphics-table* + #-ecl (trivial-garbage:make-weak-hash-table + :weakness :value + :test #'equal) + #+ecl (make-hash-table :test #'equal) + )) + (if 15-fps + (setf (sdl:frame-rate) 15) + (setf (sdl:frame-rate) 30)) + + (setf *current-room* (funcall room-function)) + + (sdl:clear-display (sdl:color :r 0 :g 0 :b 0));; :update-p nil) + + ;;(if music (sdl-mixer:play-sample levelmusic)) + + (sdl:with-events () + (:quit-event () + #|(if music + (progn (sdl-mixer:halt-music) + (sdl-mixer:halt-sample :channel t) + (sdl-mixer:free levelmusic) + (sdl-mixer:close-audio)) + t + )|# t) + (:key-down-event (:key key) + (cond + ((sdl:key= key :SDL-KEY-ESCAPE) + (sdl:push-quit-event)) + (T + (on-key-down *current-room* key)))) + (:key-up-event (:key key) + (on-key-up *current-room* key)) + (:idle + (progn + (invoke *current-room*) + (when 15-fps + (invoke *current-room*)) + (sdl:clear-display (sdl:color :r 128 :g 128 :b 128)); :update-p nil) + (draw *current-room*) + (sdl:update-display) + )))))) + + +;; For Debugging + +(defun preview-animation (frameskip &rest images) + + (sdl:with-init (sdl:sdl-init-video sdl:sdl-init-audio) + (sdl:window +screen-width+ +screen-height+ + :title-caption "Uxul World" + :icon-caption "Uxul World" + :flags (logior sdl:sdl-hw-accel) + #| :flags (logior sdl:sdl-hw-surface sdl:sdl-fullscreen )|# ) + (let ((*graphics-table* + #-ecl (trivial-garbage:make-weak-hash-table + :weakness :value + :test #'equal) + #+ecl (make-hash-table :test #'equal) + ) + (my-anim (apply #'make-animation frameskip images)) + ) + + (setf (sdl:frame-rate) 30) + (sdl:clear-display (sdl:color :r 64 :g 64 :b 46));; :update-p nil) + + (sdl:with-events () + (:quit-event () t) + (:key-down-event (:key key) + (cond + ((sdl:key= key :SDL-KEY-ESCAPE) + (sdl:push-quit-event)))) + (:idle + (progn + (sdl:clear-display (sdl:color :r 64 :g 64 :b 46));; :update-p nil) + + + (draw my-anim) + + (sdl:update-display) + )))))) \ No newline at end of file diff --git a/gray_stone.png b/gray_stone.png new file mode 100644 index 0000000..d3c8a36 Binary files /dev/null and b/gray_stone.png differ diff --git a/leaf.png b/leaf.png new file mode 100644 index 0000000..14e8328 Binary files /dev/null and b/leaf.png differ diff --git a/leveleditor.lisp b/leveleditor.lisp new file mode 100644 index 0000000..5a7808c --- /dev/null +++ b/leveleditor.lisp @@ -0,0 +1,351 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(defparameter *leveleditor-images* nil) + +(defun stretched-base64-image (img) + "Call ImageMagick to resize that file to 32x32." + (lisp-magick:with-magick-wand (mywand) + (lisp-magick::magick-read-image-blob mywand img) + (lisp-magick::magick-resize-image mywand 32 32 #x00000000 1d0) + (lisp-magick::magick-set-format mywand "gif") + (base64-encode-byteseq (lisp-magick::magick-get-image-blob mywand)))) + +(defun prepare-base64-images (&optional (care-about-initialization *leveleditor-images*)) + (when (not care-about-initialization) + (setf *leveleditor-images* (make-hash-table)) + (setf (gethash 'uxul *leveleditor-images*) (stretched-base64-image |uxul_small1|)) + (setf (gethash 'leaf *leveleditor-images*) (stretched-base64-image |leaf|)) + (setf (gethash 'nasobem *leveleditor-images*) (stretched-base64-image |nasobem|)) + (setf (gethash 'blue-nasobem *leveleditor-images*) (stretched-base64-image |blue_nasobem|)) + (setf (gethash 'burning-marshmallow *leveleditor-images*) (stretched-base64-image |burning_marshmallow_ld1|)) + (setf (gethash 'gray-stone *leveleditor-images*) (stretched-base64-image |gray_stone|)) + (setf (gethash 'brown-stone *leveleditor-images*) (stretched-base64-image |brown_stone|)) + (setf (gethash 'empty *leveleditor-images*) (stretched-base64-image |empty|)) + (setf (gethash 'tulip *leveleditor-images*) (stretched-base64-image |tulip|)))) + +(defun load-image-into-tk (png-base64) + "return a tkobject with this image" + (let ((name (ltk::create-name))) + (ltk:format-wish "set ~A [ image create photo -data \"~A\" ]" + name png-base64) + (make-instance 'ltk:tkobject :name name))) + +(defun config-button-image (button tkobject) + (ltk:format-wish "~A configure -image $~A" (ltk::widget-path button) (ltk::name tkobject))) + +(defun item-table-to-list (item-table) + "Special Function vor level-editor. Returns a list of lists of the +form (x y object)." + (let ((ret nil)) + (maphash #'(lambda (key val) + (when val + (push (list (car key) (cdr key) val) ret))) + item-table) + ret)) + +(defun create-room-from-item-list (item-list) + (let* + ((player (make-instance 'player + :active t + :visible t + :redraw t)) + (room (make-instance 'room :width 0 :height 0 + :graphic-centralizer player + :key-listener player + :key-up-function #'(lambda (key) (on-key-up player key)) + :key-down-function #'(lambda (key) (on-key-down player key))))) + (dolist (item item-list) + (let ((y (car item)) + (x (cadr item)) + (type (caddr item))) + (cond + ((eq type 'uxul) + (setf (x player) (* 128 x)) + (setf (y player) (* 128 y)) + (add-object player room)) + ((eq type 'tulip) + (add-object (make-instance 'tulip + :x (* 128 x) + :y (* 128 y)) room)) + ((eq type 'brown-stone) + (add-object (make-instance 'stone + :animation (make-animation 0 |brown_stone|) + :x (* 128 x) + :y (* 128 y)) room)) + ((eq type 'gray-stone) + (add-object (make-instance 'stone + :animation (make-animation 0 |gray_stone|) + :x (* 128 x) + :y (* 128 y)) room)) + ((eq type 'nasobem) + (add-object (make-instance 'simple-enemy + :x (* 128 x) + :y (* 128 y)) room)) + ((eq type 'blue-nasobem) + (add-object (make-instance 'flying-nasobem + :x (* 128 x) + :y (* 128 y)) room)) + (T + (add-object (make-instance type + :x (* 128 x) + :y (* 128 y)) room))))) + room)) + +(defun level-editor (&optional (level nil)) + (prepare-base64-images) + (let ((item-table (make-hash-table :test 'equal))) + ;;initialize given level + (dolist (item level) + (setf (gethash (cons (car item) (cadr item)) item-table) (caddr item))) + + (ltk:with-ltk () + (let* + ((uxul (load-image-into-tk (gethash 'uxul *leveleditor-images*))) + (leaf (load-image-into-tk (gethash 'leaf *leveleditor-images*))) + (nasobem (load-image-into-tk (gethash 'nasobem *leveleditor-images*))) + (blue-nasobem (load-image-into-tk (gethash 'blue-nasobem *leveleditor-images*))) + (burning-marshmallow (load-image-into-tk (gethash 'burning-marshmallow *leveleditor-images*))) + (gray-stone (load-image-into-tk (gethash 'gray-stone *leveleditor-images*))) + (brown-stone (load-image-into-tk (gethash 'brown-stone *leveleditor-images*))) + (empty (load-image-into-tk (gethash 'empty *leveleditor-images*))) + (tulip (load-image-into-tk (gethash 'tulip *leveleditor-images*))) + (current-upper-left (cons 0 0)) + (current-chosen-object 'uxul) + (objects-and-arrows (make-instance 'ltk:frame)) + (object-frame (make-instance 'ltk:frame :master objects-and-arrows)) + (arrow-frame (make-instance 'ltk:frame :master objects-and-arrows)) + (grid-frame (make-instance 'ltk:frame)) + (right-button (make-instance 'ltk:button :text ">" + :master arrow-frame)) + (left-button (make-instance 'ltk:button :text "<" + :master arrow-frame)) + (up-button (make-instance 'ltk:button :text "/\\" + :master arrow-frame)) + (down-button (make-instance 'ltk:button :text "\\/" + :master arrow-frame)) + (rright-button (make-instance 'ltk:button :text ">>" + :master arrow-frame)) + (lleft-button (make-instance 'ltk:button :text "<<" + :master arrow-frame)) + (uup-button (make-instance 'ltk:button :text "//\\\\" + :master arrow-frame)) + (ddown-button (make-instance 'ltk:button :text "\\\\//" + :master arrow-frame)) + (uxul-button (make-instance 'ltk:button :text "" + :master object-frame)) + (nasobem-button (make-instance 'ltk:button :text "" + :master object-frame)) + (blue-nasobem-button (make-instance 'ltk:button :text "" + :master object-frame)) + (burning-marshmallow-button (make-instance 'ltk:button :text "" + :master object-frame)) + (gray-stone-button (make-instance 'ltk:button :text "" + :master object-frame)) + (brown-stone-button (make-instance 'ltk:button :text "" + :master object-frame)) + (empty-button (make-instance 'ltk:button :text "" + :master object-frame)) + (tulip-button (make-instance 'ltk:button :text "" + :master object-frame)) + (leaf-button (make-instance 'ltk:button :text "" + :master object-frame)) + (btns (make-array '(16 16) :adjustable nil :element-type 'ltk:button))) + (labels ((redraw-button (i j) + "Redraw Button (i, j)" + (let* ((current-upper-x (car current-upper-left)) + (current-upper-y (cdr current-upper-left)) + (cval (gethash (cons (+ i current-upper-x) + (+ j current-upper-y)) + item-table nil)) + (cbtn (aref btns i j))) + (if (listp cval) + (setf cval (car cval))) + (cond + ((eq cval 'leaf) + (config-button-image cbtn leaf)) + ((eq cval 'nasobem) + (config-button-image cbtn nasobem)) + ((eq cval 'blue-nasobem) + (config-button-image cbtn blue-nasobem)) + ((eq cval 'burning-marshmallow) + (config-button-image cbtn burning-marshmallow)) + ((eq cval 'gray-stone) + (config-button-image cbtn gray-stone)) + ((eq cval 'brown-stone) + (config-button-image cbtn brown-stone)) + ((eq cval nil) + (config-button-image cbtn empty)) + ((eq cval 'tulip) + (config-button-image cbtn tulip)) + ((eq cval 'uxul) + (config-button-image cbtn uxul))))) + (redraw-buttons () + "Redraw all Buttons" + (dotimes (i 16) + (dotimes (j 16) + (redraw-button i j)))) + (react (i j) + (let ((current-upper-x (car current-upper-left)) + (current-upper-y (cdr current-upper-left))) + (cond + ((eq current-chosen-object 'burning-marshmallow) + (setf (gethash (cons (+ i current-upper-x) + (+ j current-upper-y)) + item-table) 'burning-marshmallow)) + (t + (setf (gethash (cons (+ i current-upper-x) + (+ j current-upper-y)) + item-table) current-chosen-object))) + (redraw-button i j))) + (move-field-about (i j) + (let ((current-upper-y (car current-upper-left)) + (current-upper-x (cdr current-upper-left))) + (setf current-upper-left (cons (+ i current-upper-y) (+ j current-upper-x)))) + (redraw-buttons))) + (ltk:pack grid-frame) + (ltk:grid arrow-frame 0 1) + (ltk:grid left-button 1 0) + (setf (ltk:command left-button) #'(lambda () (move-field-about 0 1))) + (ltk:grid lleft-button 2 0) + (setf (ltk:command lleft-button) #'(lambda () (move-field-about 0 15))) + (ltk:grid right-button 1 2) + (setf (ltk:command right-button) #'(lambda () (move-field-about 0 -1))) + (ltk:grid rright-button 0 2) + (setf (ltk:command rright-button) #'(lambda () (move-field-about 0 -15))) + (ltk:grid up-button 0 1) + (setf (ltk:command up-button) #'(lambda () (move-field-about 1 0))) + (ltk:grid uup-button 0 0) + (setf (ltk:command uup-button) #'(lambda () (move-field-about 15 0))) + (ltk:grid down-button 2 1) + (setf (ltk:command down-button) #'(lambda () (move-field-about -1 0))) + (ltk:grid ddown-button 2 2) + (setf (ltk:command ddown-button) #'(lambda () (move-field-about -15 0))) + + (ltk:grid empty-button 0 0) + (config-button-image empty-button empty) + (setf (ltk:command empty-button) + #'(lambda () + (setf current-chosen-object nil))) + (ltk:grid uxul-button 0 1) + (config-button-image uxul-button uxul) + (setf (ltk:command uxul-button) + #'(lambda () + (setf current-chosen-object 'uxul))) + (ltk:grid nasobem-button 0 2) + (config-button-image nasobem-button nasobem) + (setf (ltk:command nasobem-button) + #'(lambda () + (setf current-chosen-object 'nasobem))) + (ltk:grid blue-nasobem-button 0 3) + (config-button-image blue-nasobem-button blue-nasobem) + (setf (ltk:command blue-nasobem-button) + #'(lambda () + (setf current-chosen-object 'blue-nasobem))) + (ltk:grid burning-marshmallow-button 0 4) + (config-button-image burning-marshmallow-button burning-marshmallow) + (setf (ltk:command burning-marshmallow-button) + #'(lambda () + (setf current-chosen-object 'burning-marshmallow))) + (ltk:grid gray-stone-button 0 5) + (config-button-image gray-stone-button gray-stone) + (setf (ltk:command gray-stone-button) + #'(lambda () + (setf current-chosen-object 'gray-stone))) + (ltk:grid brown-stone-button 0 6) + (config-button-image brown-stone-button brown-stone) + (setf (ltk:command brown-stone-button) + #'(lambda () + (setf current-chosen-object 'brown-stone))) + (ltk:grid leaf-button 0 7) + (config-button-image leaf-button leaf) + (setf (ltk:command leaf-button) + #'(lambda () + (setf current-chosen-object 'leaf))) + + (ltk:grid tulip-button 0 8) + (config-button-image tulip-button tulip) + (setf (ltk:command tulip-button) + #'(lambda () + (setf current-chosen-object 'tulip))) + + (ltk:grid object-frame 0 0) + (ltk:pack objects-and-arrows) + + (dotimes (i 16) + (dotimes (j 16) + (let ((cbtn + (make-instance 'ltk:button + :master grid-frame + :text ""))) + (setf (ltk:command cbtn) (let ((i i) (j j)) #'(lambda () (react i j)))) + (config-button-image cbtn empty) + (setf (aref btns i j) cbtn) + (ltk:grid cbtn i j)))) + (redraw-buttons)))) + (item-table-to-list item-table))) + + +(defun get-base64-char-for-number (i) + (declare (type (integer 0 63) i)) + (elt "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" i)) + +(defun base64-encode-threebytes (byte1 byte2 byte3) + (declare (type (unsigned-byte 8) byte1 byte2 byte3)) + (coerce + (list + (get-base64-char-for-number (logand #b111111 (ash byte1 -2))) + (get-base64-char-for-number (logand #b111111 (+ (ash (ash byte1 6) -2) (ash byte2 -4)))) + (get-base64-char-for-number (logand #b111111 (+ (ash (ash byte2 4) -2) (ash byte3 -6)))) + (get-base64-char-for-number (logand #b111111 (ash (ash byte3 2) -2)))) 'string)) + + +(defun base64-encode-bytelist (bytelist &optional (ret "")) + (if bytelist + (if (cdr bytelist) + (if (cddr bytelist) + (base64-encode-bytelist + (cdddr bytelist) + (concatenate 'string + ret + (base64-encode-threebytes + (car bytelist) + (cadr bytelist) + (caddr bytelist)))) + ;;else (genau zwei elemente) + (concatenate 'string ret + (base64-encode-threebytes + (car bytelist) + (cadr bytelist) + 0) + "=")) + ;;else (genau ein element) + (concatenate 'string ret + (base64-encode-threebytes + (car bytelist) 0 0) + "==")) + ;;else (kein element) + ret)) + + +(defun base64-encode-byteseq (byteseq &optional (ret "")) + (case (length byteseq) + (0 ret) + (1 (concatenate 'string ret + (base64-encode-threebytes + (elt byteseq 0) 0 0) "==")) + (2 (concatenate 'string ret + (base64-encode-threebytes + (elt byteseq 0) + (elt byteseq 1) + 0) + "=")) + (t (base64-encode-byteseq + (subseq byteseq 3) + (concatenate 'string + ret + (base64-encode-threebytes + (elt byteseq 0) + (elt byteseq 1) + (elt byteseq 2))))))) \ No newline at end of file diff --git a/macros.lisp b/macros.lisp new file mode 100755 index 0000000..5ce181f --- /dev/null +++ b/macros.lisp @@ -0,0 +1,63 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(defvar *current-translation-x* 0) +(defvar *current-translation-y* 0) +(defmacro with-translation-* ((x y) &body body) + `(let ((*current-translation-x* (+ ,x *current-translation-x*)) + (*current-translation-y* (+ ,y *current-translation-y*))) + ,@body)) + +(defmacro with-translation ((translation) &body body) + `(with-translation-* ((x ,translation) (y ,translation)) ,@body)) + +(defmacro with-negative-translation-* ((x y) &body body) + `(with-translation-* ((- ,x) (- ,y)) ,@body)) + +(defmacro with-negative-translation ((translation) &body body) + `(with-negative-translation-* ((x ,translation) (y ,translation)) ,@body)) + +(defmacro directly-with-accessors (accessors objname &body body) + `(with-accessors ( + ,@(let ((args nil)) + (dolist (arg accessors args) + (push (list arg arg) args)))) + ,objname ,@body)) + +(defun class-all-readers (class) + (nconc (loop for superclass in + (closer-mop:class-direct-superclasses class) + nconc (class-all-readers superclass)) + (loop for direct-slot in + (closer-mop:class-direct-slots class) + append + (closer-mop:slot-definition-readers direct-slot)))) + +(defmacro directly-with-all-accessors (classname objname &body body) + `(directly-with-accessors (,@(class-all-readers (find-class classname))) + ,objname ,@body)) + +(defmacro defvars (&rest vars) + `(progn + ,@(let ((ret nil)) + (dolist (var vars ret) + (push `(defvar ,var) ret))))) + + +(defmacro let-accessor (((accessor object) value) &body body) + "Temporarily set an Accessor to another value." + (let ((symbol (gensym))) + `(let ((,symbol (,accessor ,object))) + (unwind-protect + (progn (setf (,accessor ,object) ,value) ,@body) + (setf (,accessor ,object) ,symbol))))) + +(defmacro let-accessors ((&rest bindings) &body body) + "Temporarily set Accessors to other values." + (let ((cbind (car bindings))) + (if cbind + `(let-accessor + ((,(first (first cbind)) ,(second (first cbind))) ,(second cbind)) + (let-accessors (,@(cdr bindings)) ,@body)) + `(progn ,@body)))) \ No newline at end of file diff --git a/marchmallow1.png b/marchmallow1.png new file mode 100755 index 0000000..9889718 Binary files /dev/null and b/marchmallow1.png differ diff --git a/nasobem.png b/nasobem.png new file mode 100755 index 0000000..f243f7d Binary files /dev/null and b/nasobem.png differ diff --git a/nasobem2.png b/nasobem2.png new file mode 100644 index 0000000..c43ec10 Binary files /dev/null and b/nasobem2.png differ diff --git a/nasobem3.png b/nasobem3.png new file mode 100644 index 0000000..c55d4a1 Binary files /dev/null and b/nasobem3.png differ diff --git a/objectarray.lisp b/objectarray.lisp new file mode 100755 index 0000000..9f63900 --- /dev/null +++ b/objectarray.lisp @@ -0,0 +1,44 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(declaim (inline get-by-index)) + +(defun get-by-index (index array) + (svref array index)) + +(defun create-object-array () + (make-array (list (length +class-indices+)) + :element-type 'list + :initial-element nil + :adjustable nil)) + +(defun add-object-of-class (object array) + (dolist (class (c2mop:class-precedence-list (class-of object))) + (let ((index (position (class-name class) +class-indices+))) + (if index + (pushnew object (svref array index)))))) + +(defun get-objects-of-class (class-name array) + (get-by-index (position class-name +class-indices+) array)) + + +(define-compiler-macro get-objects-of-class (&whole form class-name array) + (if (constantp class-name) + `(get-by-index ,(position (eval class-name) +class-indices+) ,array) + form)) + +;; for rooms + +(defmethod add-object ((room room) (object t)) + (add-object-of-class object (object-array room))) + +(defun get-objects (room class) + (get-objects-of-class class (object-array room))) + +(define-compiler-macro get-objects (&whole form room class-name) + (format t "Compiler Macro for get-objects...") + (print (if (constantp class-name) + `(get-by-index ,(position (eval class-name) +class-indices+) (object-array ,room)) + form + ))) diff --git a/objects b/objects new file mode 100755 index 0000000..600e411 --- /dev/null +++ b/objects @@ -0,0 +1,30 @@ +listen-to relation +a + b +bedeutet: a listens to b + +player + stone + bottom + moving-item + standing-item + moving-enemy + standing-enemy + +standing-stone + +standing-item + +moving-item + player + +moving-enemy + player + stone + +standing-enemy + +subclasses: +moving-enemy => nasobem, flying-nasobem, jumping-marchmallow +standing-enemy => needle, fire +item => bulb, slobber, tulip diff --git a/on-collision.lisp b/on-collision.lisp new file mode 100755 index 0000000..d9e47f7 --- /dev/null +++ b/on-collision.lisp @@ -0,0 +1,209 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(defmethod on-collision ((obj T) (obj2 T) collision) + "Per default do not react on objects at all. Warn only." + (format t "Warning: On-Collision is not overridden for some object + it is called for. Classes of Arguments: ~A ~A~%" + (class-name (class-of obj)) + (class-name (class-of obj)))) + +;; Player colliding with other objects + +(defmethod on-collision + ((moving-rectangle player) + (standing-rectangle stone) + (collision collision)) + (if (eql (direction collision) :DOWN) + ;; "bottom" - allow jumping again + (setf (mayjump moving-rectangle) T) + ;; "ceiling" - dont allow continuing jump + (if (eql (direction collision) :UP) + (setf (maycontjump moving-rectangle) nil)) + ) + (collide-blocks moving-rectangle standing-rectangle collision)) + +(defmethod on-collision + ((moving-rectangle player) + (standing-rectangle tulip) + (collision collision)) + (setf (visible standing-rectangle) nil) + (setf (active standing-rectangle) nil) + (setf (colliding standing-rectangle) nil) + (if (< (power moving-rectangle) 10) + (incf (power moving-rectangle))) + (incf (tulips moving-rectangle))) + +(defmethod on-collision + ((moving-rectangle player) + (standing-rectangle bottom) + (collision collision)) + (if (eql (direction collision) :DOWN) + (call-next-method) + ;; else + (progn + (setf (colliding standing-rectangle) nil) + (move-about moving-rectangle (desired-movement collision)) + (setf (colliding standing-rectangle) t)))) + +(defmethod on-collision + ((moving-rectangle player) + (standing-rectangle moving-enemy) + (collision collision)) + (collide-blocks moving-rectangle + standing-rectangle + collision) + (setf (mayjump moving-rectangle) T) + (setf (autojump moving-rectangle) 5) + (player-hits-enemy moving-rectangle + standing-rectangle + collision)) + +(defmethod on-collision + ((moving-rectangle player) + (standing-rectangle standing-enemy) + (collision collision)) + (collide-blocks moving-rectangle + standing-rectangle + collision) + (player-hits-enemy moving-rectangle + standing-rectangle + collision)) + +(defmethod on-collision + ((moving-rectangle player) + (standing-rectangle standing-item) + (collision collision)) + (collide-blocks moving-rectangle + standing-rectangle + collision) + (item-catch standing-rectangle moving-rectangle)) + +(defmethod on-collision + ((moving-rectangle player) + (standing-rectangle moving-item) + (collision collision)) + (collide-blocks moving-rectangle + standing-rectangle + collision) + (item-catch standing-rectangle moving-rectangle)) + + +;; moving-item colliding with other objects + +(defmethod on-collision + ((moving-rectangle moving-item) + (standing-rectangle player) + (collision collision)) + (collide-blocks moving-rectangle + standing-rectangle + collision) + (item-catch moving-rectangle standing-rectangle)) + +(defmethod on-collision + ((moving-rectangle moving-item) + (standing-rectangle bottom) + (collision collision)) + (if (eql (direction collision) :DOWN) + (call-next-method) + ;; else + (progn + (setf (colliding standing-rectangle) nil) + (move-about moving-rectangle (desired-movement collision)) + (setf (colliding standing-rectangle) t)))) + +(defmethod on-collision + ((moving-rectangle moving-item) + (standing-rectangle stone) + (collision collision)) + (collide-blocks moving-rectangle standing-rectangle collision)) + +;; simple-enemy special methods + +(defmethod on-collision ((m simple-enemy) (s stone) (c collision)) + (cond ((eql (direction c) :left) + (setf (direction m) :right)) + ((eql (direction c) :right) + (setf (direction m) :left))) + (collide-blocks m s c)) + +;; burning-marshmallow special methods + +(defmethod on-collision ((m burning-marshmallow) (s stone) (c collision)) + (cond + ((eql (direction c) :LEFT) + (setf (horizontal-direction m) :RIGHT)) + ((eql (direction c) :RIGHT) + (setf (horizontal-direction m) :LEFT)) + ((eql (direction c) :UP) + (setf (vertical-direction m) :DOWN)) + ((eql (direction c) :DOWN) + (setf (vertical-direction m) :UP)) + (T ;; diagonal + (setf (horizontal-direction m) + (if (eql (horizontal-direction m) :LEFT) :RIGHT :LEFT)) + (setf (vertical-direction m) + (if (eql (vertical-direction m) :UP) :DOWN :UP)))) + (set-burning-marshmallow-animation m)) + +(defmethod on-collision + ((moving-rectangle burning-marshmallow) + (standing-rectangle bottom) + (collision collision)) + (if (eql (direction collision) :DOWN) + (call-next-method) + ;; else + (progn + (setf (colliding standing-rectangle) nil) + (move-about moving-rectangle (desired-movement collision)) + (setf (colliding standing-rectangle) t)))) + +(defmethod on-collision + ((moving-rectangle burning-marshmallow) + (standing-rectangle player) + (collision collision)) + (enemy-hits-player moving-rectangle + standing-rectangle + collision) + (setf (colliding standing-rectangle) nil) + (move-about moving-rectangle (desired-movement collision)) + (setf (colliding standing-rectangle) t)) + +(defmethod on-collision + ((moving-rectangle player) + (standing-rectangle burning-marshmallow) + (collision collision)) + (enemy-hits-player standing-rectangle + moving-rectangle + collision) + (setf (colliding standing-rectangle) nil) + (move-about moving-rectangle (desired-movement collision)) + (setf (colliding standing-rectangle) t)) +;; moving-enemy colliding with other objects + +(defmethod on-collision ((m moving-enemy) (s stone) (c collision)) + (collide-blocks m s c)) + +(defmethod on-collision + ((moving-rectangle moving-enemy) + (standing-rectangle bottom) + (collision collision)) + (if (eql (direction collision) :DOWN) + (call-next-method) + ;; else + (progn + (setf (colliding standing-rectangle) nil) + (move-about moving-rectangle (desired-movement collision)) + (setf (colliding standing-rectangle) t)))) + +(defmethod on-collision + ((moving-rectangle moving-enemy) + (standing-rectangle player) + (collision collision)) + (collide-blocks moving-rectangle + standing-rectangle + collision) + (enemy-hits-player moving-rectangle + standing-rectangle + collision)) diff --git a/package.lisp b/package.lisp new file mode 100755 index 0000000..34a44bb --- /dev/null +++ b/package.lisp @@ -0,0 +1,11 @@ +;;; Copyright 2009 Christoph Senjak + +(defpackage #:uxul-world + (:use + #:cl) + (:shadow #:room) + (:export + #:init-media + #:level-editor + #:create-room-from-item-list + #:start-game)) diff --git a/player.lisp b/player.lisp new file mode 100755 index 0000000..a111e43 --- /dev/null +++ b/player.lisp @@ -0,0 +1,184 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +;; define the standard-class player, which will represent the +;; player. + + +(defclass player (game-object-with-animation) + ((dont-ignore :initarg :dont-ignore + :initform T + :accessor dont-ignore + :documentation "When we're testing whether we can go + on or not without colliding, we will set this flag to + nil, which means, that all collision-methods should + ONLY set the player to the position when it collides, + but NOT have any other effect (since its only a test)") + (animation-left :accessor animation-left + :initform (make-animation 7 + |uxul_small1| + |uxul_small2|)) + (animation-right :accessor animation-right + :initform (make-animation 7 + |uxul_small3| + |uxul_small4|)) + (animation :initarg :animation + :accessor animation + :initform (make-animation 7 + |uxul_small1| + |uxul_small2|)) + (jump-accel :accessor jump-accel + :initform -50) + (mayjump :accessor mayjump + :initform t) + (maycontjump :accessor maycontjump + :initform t) + (autojump :accessor autojump + :initform 0 + :documentation "push jump-events even though no key is + pressed for n invocations.") + (overjump :initarg :overjump + :accessor overjump + :initform 0 + :documentation "How many Frames to overjump until movement. Default 0.") + (overjumped :accessor overjumped + :initform 0 + :documentation "DO NOT SET MANUALLY - counter for overjumped frames") + (width :initarg :width + :accessor width + :initform 60) + (height :initarg :height + :accessor height + :initform 75) + (animation-translation :initarg :animation-translation + :accessor animation-translation + :initform (make-xy -40 -20)) + (key-pressed-up :initform nil :accessor key-pressed-up :initarg :key-pressed-up) + (key-pressed-down :initform nil :accessor key-pressed-down :initarg :key-pressed-down) + (key-pressed-left :initform nil :accessor key-pressed-left :initarg :key-pressed-left) + (key-pressed-right :initform nil :accessor key-pressed-right :initarg :key-pressed-right) + (go-down :initform 0 :accessor go-down :initarg :go-down) + (go-right :initform 0 :accessor go-right :initarg :go-right) + (power :initform 10 :accessor + power :initarg :power :documentation "power - will be decreased if + enemy touches.") + (tulips :initform 0 :accessor tulips :initarg :tulips) + (immortable :initform 0 + :accessor immortable + :documentation "after hit by an enemy you wont be + wounded by another enemy for that ammount of + frames.") + (keys :initform 0 + :accessor keys + :documentation "Number of keys for doors") + )) + + +;; Interaction with enemies +(defgeneric player-hits-enemy (player enemy &rest args) + (:documentation +"To be called when a player collides with an enemy.")) + +(defmethod player-hits-enemy ((player t) (enemy t) &rest args) + (declare (ignore args)) + "Shouldnt be called - warn only" + (format t + "player-hits-enemy called with non-fitting classes: ~A ~A~%" + (class-name (class-of player)) + (class-name (class-of enemy)))) + +(defgeneric enemy-hits-player (enemy player &rest args) + (:documentation +"To be called when an enemy collides with a player.")) + +(defmethod enemy-hits-player ((enemy t) (player t) &rest args) + (declare (ignore args)) + "Shouldnt be called - warn only" + (format t + "player-hits-enemy called with non-fitting classes: ~A ~A~%" + (class-name (class-of enemy)) + (class-name (class-of player)))) + +;; interaction with items + +(defgeneric item-catch (item player &rest args) + (:documentation "Obvious")) + +(defmethod item-catch ((item t) (player t) &rest args) + (declare (ignore args)) + "Do nothing, just warn." + (format t "item-catch called with non-fitting classes: ~A ~A~%" + (class-name (class-of item)) + (class-name (class-of player)))) + +(defmethod (setf animation) ((new-value animation) (object player)) + (setf (x new-value) (+ (x object) (x(animation-translation object)))) + (setf (y new-value) (+ (y object) (y(animation-translation object)))) + (call-next-method)) + +(defmethod on-key-down ((obj player) key) + (cond + ((sdl:key= key :SDL-KEY-UP) + (setf (key-pressed-up obj) T)) + ((sdl:key= key :SDL-KEY-DOWN) + (setf (key-pressed-down obj) T)) + ((sdl:key= key :SDL-KEY-LEFT) + (setf (key-pressed-left obj) T) + (setf (animation obj) (animation-left obj)) + (setf (animation-translation obj) (make-xy -40 -20)) + (ensure-playing (animation obj)) + ) + ((sdl:key= key :SDL-KEY-RIGHT) + (setf (key-pressed-right obj) T) + (setf (animation obj) (animation-right obj)) + (ensure-playing (animation obj)) + (setf (animation-translation obj) (make-xy -20 -20)) + ) + )) + +(defmethod on-key-up ((obj player) key) + (cond + ((sdl:key= key :SDL-KEY-UP ) + (setf (key-pressed-up obj) NIL)) + ((sdl:key= key :SDL-KEY-DOWN) + (setf (key-pressed-down obj) NIL)) + ((sdl:key= key :SDL-KEY-LEFT) + (setf (key-pressed-left obj) NIL) + (ensure-pause (animation obj))) + ((sdl:key= key :SDL-KEY-RIGHT) + (setf (key-pressed-right obj) NIL) + (ensure-pause (animation obj))))) + +(defmethod invoke ((obj player)) + "Do whatever a player does ^^" + + ;; SIMPLE GRAVITY HACK + (setf (key-pressed-down obj) (not (key-pressed-up obj))) + + (if (not (zerop (immortable obj))) (decf (immortable obj))) + + (let ((go-left (if (key-pressed-left obj) 10 0)) + (go-right (if (key-pressed-right obj) 10 0)) + (go-up 30)) + (labels ((jump () + (cond ((mayjump obj) + (setf (mayjump obj) nil) + (setf (maycontjump obj) t) + (setf go-up (jump-accel obj)) + (setf (jump-accel obj) -49)) + ((maycontjump obj) + (setf go-up (jump-accel obj)) + (incf (jump-accel obj) 3) + (when (zerop (jump-accel obj)) + (setf (maycontjump obj) nil) + (setf (jump-accel obj) -50)))))) + (cond + ((key-pressed-up obj) + (jump)) + ((> (autojump obj) 0) + (jump) + (decf (autojump obj))) + (T (setf (maycontjump obj) nil))) + + (move-about obj (make-xy (- go-right go-left) go-up))))) \ No newline at end of file diff --git a/room.lisp b/room.lisp new file mode 100755 index 0000000..37292d0 --- /dev/null +++ b/room.lisp @@ -0,0 +1,95 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(defvar *current-room*) + +(declaim (inline get-by-index)) + +(defun get-by-index (index array) + (svref array index)) + +(defun create-object-array () + (make-array (list (length +class-indices+)) + :element-type 'list + :initial-element nil + :adjustable nil)) + +(defun add-object-of-class (object array) + (dolist (class (c2mop:class-precedence-list (class-of object))) + (let ((index (position (class-name class) +class-indices+))) + (if index + (pushnew object (svref array index)))))) + +(defun get-objects-of-class (class-name array) + (get-by-index (position class-name +class-indices+) array)) + + +(define-compiler-macro get-objects-of-class (&whole form class-name array) + (if (constantp class-name) + `(get-by-index ,(position (eval class-name) +class-indices+) ,array) + form)) + +(defun get-objects (room class) + (get-objects-of-class class (object-array room))) + +(define-compiler-macro get-objects (&whole form room class-name) + (format t "Compiler Macro for get-objects...") + (print (if (constantp class-name) + `(get-by-index ,(position (eval class-name) +class-indices+) (object-array ,room)) + form + ))) + +(defclass room () + ((key-down-function :initform + #'(lambda (key) (declare (ignore key))) + :accessor key-down-function + :initarg :key-down-function + :documentation "Function to call in case of a + key-down event.") + (key-up-function :initform + #'(lambda (key) (declare (ignore key))) + :accessor key-up-function + :initarg :key-up-function + :documentation "Function to call in case of a + key-up event.") + (object-array :initform (create-object-array) + :accessor object-array + :initarg :object-array + :documentation "Array of Objects indexed by class.") + (key-listener :initarg :key-listener + :accessor key-listener + :documentation "An Object with Methods on-key-up and + on-key-down, to which key-events are passed.") + (graphic-centralizer :initarg :graphic-centralizer + :accessor graphic-centralizer) + (background-surface :initarg :background-surface + :accessor background-surface) + (background-surface-drawn :initarg :background-surface-drawn + :accessor background-surface-drawn + :initform nil) + (invocation-function :initform nil + :accessor invocation-function + :documentation "Will be called, if not nil, by + invoke, so 'overriding' the invoke-method for room (implemented for + Pausings, etc.). Set to nil, the normal invoke-method will be + called again.") + (width :initarg :width :accessor width) + (height :initarg :height :accessor height) + (position-table :initarg :position-table :accessor position-table + :initform (make-hash-table :test 'eql) + :documentation ":tblabla-Symbols in + make-tiled-room are pushed as keys with the associated + positions to this table."))) + +(defmethod on-key-down ((obj room) key) + (on-key-down (key-listener obj) key)) + +(defmethod on-key-up ((obj room) key) + (on-key-up (key-listener obj) key)) + +(defmethod invoke ((obj room)) + (if (invocation-function obj) + (funcall (invocation-function obj) obj) + (dolist (invoker (get-objects obj 'uxul-world::game-object)) + (if (active invoker) (invoke invoker))))) \ No newline at end of file diff --git a/simple-enemy.lisp b/simple-enemy.lisp new file mode 100755 index 0000000..ae8d3b7 --- /dev/null +++ b/simple-enemy.lisp @@ -0,0 +1,53 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(defclass simple-enemy (moving-enemy) + ((animation :initarg :animation + :initform + (make-animation 3 |nasobem| |nasobem2|) + :accessor animation) + (animation-translation :accessor animation-translation + :initarg :animation-translation + :initform (make-xy -100 -50)) + (flat-animation :accessor flat-animation + :initform (make-animation 0 |nasobem3|)) + (dont-ignore :accessor dont-ignore :initform t) + (activated :accessor activated :initform nil) + (width :initarg :width :initform 64 :accessor width) + (active :initarg :active :initform t :accessor active) + (height :initarg :height :initform 64 :accessor height) + (direction :initarg :direction :initform :left :accessor direction))) + +(defmethod invoke ((obj simple-enemy)) + "Move the object down-left if direction is :left" + (cond + ((activated obj) (move-about obj (make-xy + (if (eql (direction obj) :left) + -10 + 10) 10))) + (T + (dolist (player (get-objects *current-room* 'player)) + (if (and + (< (abs (- (x player) (x obj))) (+ +screen-width+ 300)) + (< (abs (- (y player) (y obj))) (+ +screen-height+ 300))) + (setf (activated obj) T)))))) + +(defun simple-enemy-and-player (player enemy) + (decf (power player)) + (setf (active enemy) nil) + (setf (visible enemy) nil) + (setf (colliding enemy) nil)) + +(defmethod player-hits-enemy ((player player) (enemy simple-enemy) &rest args) + (cond + ((eql (direction (car args)) :DOWN) + (setf (animation enemy) (flat-animation enemy)) + (setf (active enemy) nil) + (setf (colliding enemy) nil)) + (T + (simple-enemy-and-player player enemy)))) + +(defmethod enemy-hits-player ((enemy simple-enemy) (player player) &rest args) + (declare (ignore args)) + (simple-enemy-and-player player enemy)) \ No newline at end of file diff --git a/small-classes.lisp b/small-classes.lisp new file mode 100755 index 0000000..a78c607 --- /dev/null +++ b/small-classes.lisp @@ -0,0 +1,29 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(defclass leaf (bottom) + ((animation :initarg :animation + :accessor animation + :initform (make-animation 0 |leaf|)) + (width :initarg :width + :accessor :width + :initform 128) + (height :initarg :height + :accessor :height + :initform 3) + (animation-translation :initarg :animation-translation + :accessor animation-translation + :initform (make-xy -7 -30)) + )) + +(defclass tulip (standing-item) + ((animation :initarg :animation + :accessor animation + :initform (make-animation 10 |tulip| |tulip2| |tulip| |tulip3|)) + (width :initarg :width + :accessor :width + :initform 128) + (height :initarg :height + :accessor :height + :initform 128))) \ No newline at end of file diff --git a/testing-room.lisp b/testing-room.lisp new file mode 100755 index 0000000..b9e4649 --- /dev/null +++ b/testing-room.lisp @@ -0,0 +1,288 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + + +#| +(defmethod (setf x) (new-value (obj T))) +(defmethod (setf y) (new-value (obj T))) +(defmethod (setf visible) (new-value (obj T))) +|# + +(defun make-testing-room () + "Create a simple room for testing. Shouldnt be used anymore. Use the +level-editor instead!" + (let* ((player (make-instance 'player + :active t + :visible t + :redraw t + :x 100 + :y 0)) + (ret (make-instance 'room + :width 0;(* 155 128) + :height 0;(* 9 128) + :key-listener player + :graphic-centralizer player + :key-up-function + #'(lambda (key) (on-key-up player key)) + :key-down-function + #'(lambda (key) (on-key-down player key)) + ))) + (add-object player ret) + + (add-object (make-instance 'burning-marshmallow + :x (* 128 55) + :y (* 128 8) + :inner-rectangle (list (* 40 128) (* 5 128) (* 65 128) (* 9 128)) + :active t + :visible t + :redraw t) ret) + + + (add-object (make-instance 'burning-marshmallow + :x (* 128 60) + :y (* 128 8) + :inner-rectangle (list (* 40 128) (* 5 128) (* 65 128) (* 9 128)) + :active t + :visible t + :redraw t) ret) + + (add-object (make-instance 'burning-marshmallow + :x (* 128 45) + :y (* 128 8) + :inner-rectangle (list (* 40 128) (* 5 128) (* 65 128) (* 9 128)) + :active t + :visible t + :redraw t) ret) + + (add-object (make-instance 'burning-marshmallow + :x (* 128 34) + :y (* 128 4) + :inner-rectangle (list (* 30 128) (* 5 128) (* 41 128) (* 9 128)) + :active t + :visible t + :redraw t) ret) + + (add-object (make-instance 'simple-enemy + :y (* 128 8) + :x (* 128 4) + :redraw t + :active t + :visible t) ret) + (add-object (make-instance 'simple-enemy + :y (* 128 8) + :x (* 128 9) + :redraw t + :active t + :visible t) ret) + (add-object (make-instance 'simple-enemy + :y (* 128 8) + :x (* 128 15) + :redraw t + :active t + :visible t) ret) + (add-object (make-instance 'simple-enemy + :y (* 128 3) + :x (* 128 16) + :redraw t + :active t + :visible t) ret) + (add-object (make-instance 'simple-enemy + :y (* 128 7) + :x (* 128 20) + :redraw t + :active t + :visible t) ret) + (add-object (make-instance 'simple-enemy + :y (* 128 6) + :x (* 128 21) + :redraw t + :active t + :visible t) ret) + (add-object (make-instance 'simple-enemy + :y (* 128 8) + :x (* 128 34) + :redraw t + :active t + :visible t) ret) + + (dotimes (i 155) + (add-object + (make-instance 'stone + :y (* 128 9) + :x (* 128 i) + :active nil + :visible t + :redraw t) ret)) + + (add-object + (make-instance 'stone + :y (* 128 4) + :x (* 128 14) + :active nil + :visible t + :redraw t +) ret) + (add-object + (make-instance 'stone + :y (* 128 4) + :x (* 128 15) + :active nil + :visible t + :redraw t +) ret) + + (dotimes (i 7) + (add-object (make-instance 'stone + :x (* 17 128) + :y (* i 128) + :active nil + :visible t + :redraw t +) ret)) + (dotimes (i 4) + (add-object (make-instance 'leaf + :x (* (+ 18 i) 128) + :y (* 7 128)) ret)) + (dotimes (i 4) + (add-object (make-instance 'leaf + :x (* (+ 19 i) 128) + :y (* 6 128)) ret)) + + (add-object (make-instance 'leaf + :x (* 21 128) + :y (* 4 128)) ret) + + (dotimes (i 4) + (dotimes (j 6) + (add-object (make-instance 'stone + :x (* (+ 23 i) 128) + :y (* (+ 3 j) 128) + :active nil + :visible t + :redraw t) ret))) + + (add-object (make-instance 'stone + :x (* 37 128) + :y (* 8 128) + :active nil + :visible t + :redraw t) ret) + (add-object (make-instance 'stone + :x (* 39 128) + :y (* 8 128) + :active nil + :visible t + :redraw t) ret) + (add-object (make-instance 'stone + :x (* 39 128) + :y (* 7 128) + :active nil + :visible t + :redraw t) ret) + (add-object (make-instance 'stone + :x (* 40 128) + :y (* 8 128) + :active nil + :visible t + :redraw t) ret) + (add-object (make-instance 'stone + :x (* 41 128) + :y (* 8 128) + :active nil + :visible t + :redraw t) ret) + (add-object (make-instance 'stone + :x (* 41 128) + :y (* 7 128) + :active nil + :visible t + :redraw t) ret) + (add-object (make-instance 'stone + :x (* 41 128) + :y (* 6 128) + :active nil + :visible t + :redraw t) ret) + + (dotimes (i 16) + (add-object (make-instance 'stone + :x (* (+ i 44) 128) + :y (* 4 128) + :active nil + :visible t + :redraw t +) ret)) + + (dotimes (i 5) + (dotimes (j (1+ i)) + (add-object (make-instance 'stone + :x (* (+ i 65) 128) + :y (* (+ (- 4 i) j 4) 128) + :active nil + :visible t + :redraw t +) ret))) + + (dotimes (i 3) + (dotimes (j 3) + (add-object (make-instance 'stone + :x (* (+ i 70) 128) + :y (* (+ j 3) 128) + :active nil + :visible t + :redraw t +) ret))) + + (dotimes (j 2) + (dotimes (i 8) + (add-object (make-instance 'stone + :x (* (+ i j 72) 128) + :y (* (- 8 i) 128) + :active nil + :visible t + :redraw t +) ret))) + (dotimes (j 7) + (dolist (i (cond + ((member j '(0 1 2)) '(83)) + ((member j '(3 4 5)) '(83 84 85 86)) + (T '(79 80 81 82 83 84 85 86)))) + (add-object (make-instance 'stone + :x (* i 128) + :y (* j 128) + :active nil + :visible t + :redraw t +) ret))) + + (let ((y (* 128 4))) + (dolist (j '((0 0 0 0 0 1 1 1 2) + (0 0 0 1 1 1 0 0 2) + (0 0 0 0 1 1 1 1 2) + (1 1 1 1 1 0 0 0 2) + (0 0 0 1 1 1 1 1 2))) + (let ((x (* 128 87))) + (dolist (i j) + (cond ((eql i 2) + (add-object (make-instance 'stone + :x x + :y y + :active nil + :visible t + :redraw t +) ret)) + ((eql i 1) + (add-object (make-instance 'leaf + :x x + :y y) ret)) + (T)) + (incf x 128))) + (incf y 128))) + (add-object (make-instance 'flying-nasobem + :x (* 128 87) + :y (* 128 2)) ret) + (add-object (make-instance 'flying-nasobem + :x (* 128 110) + :y (* 128 4)) ret) + ret)) diff --git a/tulip.png b/tulip.png new file mode 100755 index 0000000..fff8763 Binary files /dev/null and b/tulip.png differ diff --git a/tulip2.png b/tulip2.png new file mode 100644 index 0000000..b1b67ef Binary files /dev/null and b/tulip2.png differ diff --git a/tulip3.png b/tulip3.png new file mode 100644 index 0000000..a0fc4a7 Binary files /dev/null and b/tulip3.png differ diff --git a/uxul-world.asd b/uxul-world.asd new file mode 100755 index 0000000..9f2e2d1 --- /dev/null +++ b/uxul-world.asd @@ -0,0 +1,42 @@ +;;; -*- lisp -*- + +;;; Copyright 2009 Christoph Senjak + +(defsystem "uxul-world" + :description "Uxul World - A simple Jump'N'Run" + :version "No Release Yet" + :author "Christoph Senjak " + :license "Copyright 2009 Christoph Senjak." + :depends-on (#:lispbuilder-sdl #:closer-mop + #:cl-fad + ;#:asdf + #:ltk + #:lisp-magick + #:lispbuilder-sdl-image + #:trivial-garbage) + :components ((:file "package") + (:file "macros") + (:file "constants") + (:file "xy-coordinates") + (:file "collision") + (:file "files") + (:file "leveleditor") + (:file "animation") + (:file "functions") + (:file "game-object") + (:file "game-object-with-animation") + (:file "elementary-classes") + (:file "small-classes") + (:file "player") + (:file "simple-enemy") + (:file "flying-nasobem") + (:file "burning-marshmallow") + (:file "on-collision") + (:file "room") + (:file "objectarray") + (:file "add-object") + (:file "draw") + (:file "game") + (:file "testing-room") + ) + :serial t) diff --git a/uxul1.png b/uxul1.png new file mode 100755 index 0000000..11926b8 Binary files /dev/null and b/uxul1.png differ diff --git a/uxul1shoot_small.png b/uxul1shoot_small.png new file mode 100644 index 0000000..c940ee5 Binary files /dev/null and b/uxul1shoot_small.png differ diff --git a/uxul2.png b/uxul2.png new file mode 100755 index 0000000..e7f6613 Binary files /dev/null and b/uxul2.png differ diff --git a/uxul2shoot_small.png b/uxul2shoot_small.png new file mode 100644 index 0000000..5d06edb Binary files /dev/null and b/uxul2shoot_small.png differ diff --git a/uxul_small1.png b/uxul_small1.png new file mode 100755 index 0000000..425af58 Binary files /dev/null and b/uxul_small1.png differ diff --git a/uxul_small2.png b/uxul_small2.png new file mode 100755 index 0000000..1f405bc Binary files /dev/null and b/uxul_small2.png differ diff --git a/uxul_small3.png b/uxul_small3.png new file mode 100755 index 0000000..aca6762 Binary files /dev/null and b/uxul_small3.png differ diff --git a/uxul_small4.png b/uxul_small4.png new file mode 100755 index 0000000..3070408 Binary files /dev/null and b/uxul_small4.png differ diff --git a/xy-coordinates.lisp b/xy-coordinates.lisp new file mode 100755 index 0000000..83f8d3e --- /dev/null +++ b/xy-coordinates.lisp @@ -0,0 +1,28 @@ +;;; Copyright 2009 Christoph Senjak + +(in-package :uxul-world) + +(declaim (inline make-xy coordinate-distance)) + +(defstruct xy-struct (x 0 :type fixnum) (y 0 :type fixnum)) + +(defmethod x ((obj xy-struct)) (slot-value obj 'x)) +(defmethod (setf x) (new-value (obj xy-struct)) + (setf (slot-value obj 'x) (the number new-value))) +(defmethod y ((obj xy-struct)) (slot-value obj 'y)) +(defmethod (setf y) (new-value (obj xy-struct)) + (setf (slot-value obj 'y) (the number new-value))) + +(defclass xy-coordinates () + ((x :accessor x :initarg :x :initform 0 :type fixnum) + (y :accessor y :initarg :y :initform 0 :type fixnum))) + +(defun coordinate-distance (a b) + "Calculate the euklidian distance of two points. They must have x- +and y-accessors." + (sqrt (+ (expt (- (x a) (x b)) 2) (expt (- (y a) (y b)) 2)))) + +(defun make-xy (x y) + (declare (type fixnum x y)) + "Guess what this function does..." + (make-xy-struct :x x :y y)) \ No newline at end of file