--- /dev/null
+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
--- /dev/null
+clean:
+ rm -rf ./*~
--- /dev/null
+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.
--- /dev/null
+;;; 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 <args> 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 <args>"
+ (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
--- /dev/null
+;;; 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 <sprite-delay>, 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+#! /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)))
+
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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)))
--- /dev/null
+;;; 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, y same. We dont
+add the limits to the rectangle, we only see the interior points."
+ (and
+ (> x2 x3)
+ (> x4 x1)
+ (> y2 y3)
+ (> y4 y1)))
+
+
+(defun symbol-prename (symbol &optional (charnum 1))
+ "Returns just the first <charnum> 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)))
--- /dev/null
+;;; 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)))
+
--- /dev/null
+;;; 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)))))))))))))
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
+ )))
--- /dev/null
+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
--- /dev/null
+;;; 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))
--- /dev/null
+;;; Copyright 2009 Christoph Senjak
+
+(defpackage #:uxul-world
+ (:use
+ #:cl)
+ (:shadow #:room)
+ (:export
+ #:init-media
+ #:level-editor
+ #:create-room-from-item-list
+ #:start-game))
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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))
--- /dev/null
+;;; -*- lisp -*-
+
+;;; Copyright 2009 Christoph Senjak
+
+(defsystem "uxul-world"
+ :description "Uxul World - A simple Jump'N'Run"
+ :version "No Release Yet"
+ :author "Christoph Senjak <firstName.secondName at googlemail.com>"
+ :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)
--- /dev/null
+;;; 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
projects / uxul-world.git / commitdiff
