Commit 8a164881 authored by John Croisant's avatar John Croisant

shmup: Entity bbox defines its position.

Instead of having a "pos" slot, an entity's bbox is now the
canonical definition of the entity's position. This simplifies
a lot of code.
parent d6a904f0
......@@ -79,13 +79,13 @@
(: rect-centerx ((struct sdl2:rect) -> number))
(: rect-centerx-fx ((struct sdl2:rect) -> fixnum))
(define (rect-centerx r) (+ (sdl2:rect-x r) (sdl2:rect-w/2 r)))
(define (rect-centerx-fx r) (fx+ (sdl2:rect-x r) (sdl2:rect-w/2-fx r)))
(define (rect-centerx r) (+ (sdl2:rect-x r) (rect-w/2 r)))
(define (rect-centerx-fx r) (fx+ (sdl2:rect-x r) (rect-w/2-fx r)))
(: rect-centery ((struct sdl2:rect) -> number))
(: rect-centery-fx ((struct sdl2:rect) -> fixnum))
(define (rect-centery r) (+ (sdl2:rect-y r) (sdl2:rect-h/2 r)))
(define (rect-centery-fx r) (fx+ (sdl2:rect-y r) (sdl2:rect-h/2-fx r)))
(define (rect-centery r) (+ (sdl2:rect-y r) (rect-h/2 r)))
(define (rect-centery-fx r) (fx+ (sdl2:rect-y r) (rect-h/2-fx r)))
(: rect-center ((struct sdl2:rect) -> (struct sdl2:point)))
(define (rect-center r)
......@@ -133,3 +133,25 @@
(fx- cx (fx/ w 2))
(fx- cy (fx/ h 2))
w h)))
;;; Returns the x and y amounts that r1 would need to move in order to
;;; be inside r2. Returns 0 0 if r1 is already inside r2.
(define (need-clamp-rect r1 r2)
;; pos is either x or y. dim is either w or h.
(define (change-needed pos1 dim1 pos2 dim2)
;; If r1 left/top is outside of r2...
(if (< pos1 pos2)
;; Then move so left/top edges are equal.
(- pos2 pos1)
;; Otherwise, if r1 right/bottom is outside of r2...
(if (> (+ pos1 dim1) (+ pos2 dim2))
;; Then move so right/bottom edges are equal.
(- (+ pos2 dim2) (+ pos1 dim1))
;; Otherwise, no change is needed.
0)))
(receive (x1 y1 w1 h1) (sdl2:rect->values r1)
(receive (x2 y2 w2 h2) (sdl2:rect->values r2)
(values (change-needed x1 w1 x2 w2)
(change-needed y1 h1 y2 h2)))))
......@@ -10,7 +10,7 @@
;;; or powerup item.
(define-record-type entity
(%make-entity id type texture pos vel scale bbox updater props)
(%make-entity id type texture bbox vel scale updater props)
entity?
;; symbol for finding entity, or #f if not needed
(id entity-id (setter entity-id))
......@@ -18,14 +18,12 @@
(type entity-type (setter entity-type))
;; sdl2:texture of entity's appearance
(texture entity-texture (setter entity-texture))
;; sdl2:point defining entity's position (center)
(pos entity-pos (setter entity-pos))
;; sdl2:rect defining the entity's bounding box
(bbox entity-bbox (setter entity-bbox))
;; sdl2:point defining entity's velocity
(vel entity-vel (setter entity-vel))
;; real number defining entity's size multiplier
(scale entity-scale (setter entity-scale))
;; sdl2:rect defining the entity's bounding box
(bbox entity-bbox (setter entity-bbox))
;; procedure called each game tick
(updater entity-updater (setter entity-updater))
;; alist of extra properties for gameplay logic
......@@ -34,6 +32,10 @@
(define-type entity (struct entity))
(define (entity-pos entity)
(rect-center (entity-bbox entity)))
(define (make-entity #!key
id type texture
(pos (sdl2:make-point))
......@@ -42,10 +44,12 @@
(updater entity-basic-updater)
(props '()))
(assert (sdl2:texture? texture))
(let ((bbox (R 0 0
(* scale (s->w (sdl2:texture-w texture)))
(* scale (s->w (sdl2:texture-h texture))))))
(%make-entity id type texture pos vel scale bbox updater props)))
(let ((bbox (centered-rect
(sdl2:point-x pos)
(sdl2:point-y pos)
(* scale (s->w (sdl2:texture-w texture)))
(* scale (s->w (sdl2:texture-h texture))))))
(%make-entity id type texture bbox vel scale updater props)))
(compose-accessors entity-pos-x (sdl2:point-x entity-pos))
......@@ -56,10 +60,9 @@
(define-record-printer (entity e out)
(fprintf out
"#<entity ~S pos: (~S ~S)>"
"#<entity ~S bbox: ~S>"
(entity-id e)
(entity-pos-x e)
(entity-pos-y e)))
(sdl2:rect->list (entity-bbox e))))
(define (destroy-entity! entity)
......@@ -103,16 +106,9 @@
;;; Update entity's position based on its current velocity.
(define (update-entity-pos! entity dt)
(sdl2:point-add!
(entity-pos entity)
(sdl2:point-scale (entity-vel entity) dt))
(update-entity-bbox! entity))
(define (update-entity-bbox! entity)
(recenter-rect! (entity-bbox entity)
(entity-pos-x entity)
(entity-pos-y entity)))
(sdl2:rect-add-point!
(entity-bbox entity)
(sdl2:point-scale (entity-vel entity) dt)))
;;; Returns #t if any of entity's bbox is touching scene's bounds.
......@@ -122,20 +118,18 @@
(scene-bounds scene)))
;;; Move the entity so its bbox is completely inside rect.
(define (entity-clamp-to-rect! entity rect)
(receive (dx dy) (need-clamp-rect (entity-bbox entity) rect)
(sdl2:rect-move! (entity-bbox entity) dx dy)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DRAW ENTITY
(define (draw-entity! entity ren #!optional (off-x 0) (off-y 0))
(let ((texture (entity-texture entity))
(scale (entity-scale entity)))
(let ((w (round (* scale (sdl2:texture-w texture))))
(h (round (* scale (sdl2:texture-h texture)))))
(sdl2:render-copy!
ren texture #f
(R (round (+ off-x (- (/ w 2)) (w->s (entity-pos-x entity))))
(round (+ off-y (- (/ h 2)) (w->s (entity-pos-y entity))))
w
h))
(when +draw-entity-bboxes+
(sdl2:render-draw-color-set! ren (C 0 255 0))
(sdl2:render-draw-rect! ren (w->s/r (entity-bbox entity)))))))
(define (draw-entity! entity ren)
(let ((bbox (w->s/r (entity-bbox entity))))
(sdl2:render-copy! ren (entity-texture entity) #f bbox)
(when +draw-entity-bboxes+
(sdl2:render-draw-color-set! ren (C 0 255 0))
(sdl2:render-draw-rect! ren bbox))))
......@@ -27,7 +27,7 @@
(make-laser
owner: owner
color: (entity-prop owner 'color)
pos: (sdl2:point-copy (entity-pos owner))
pos: (entity-pos owner)
vel: (P 0 (- +player-laser-speed+)))))
(scene-add-entity! scene laser)
laser))
......
......@@ -31,7 +31,7 @@
(when (player-shooting? player)
(player-try-shoot! player))
(update-entity-pos! player dt)
(player-clamp-to-rect! player (scene-bounds (*scene*))))
(entity-clamp-to-rect! player (scene-bounds (*scene*))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......@@ -66,20 +66,6 @@
(player-update-vel! player))
;;; Move the player so its bbox is completely inside rect.
(define (player-clamp-to-rect! player rect)
(let ((px (entity-pos-x player))
(py (entity-pos-y player))
(bbw/2 (/ (sdl2:rect-w (entity-bbox player)) 2))
(bbh/2 (/ (sdl2:rect-h (entity-bbox player)) 2)))
(receive (rx ry rw rh) (sdl2:rect->values rect)
(let ((new-px (clamp px (+ rx bbw/2) (- (+ rx rw) bbw/2)))
(new-py (clamp py (+ ry bbh/2) (- (+ ry rh) bbh/2))))
(unless (and (= px new-px) (= py new-py))
(set! (entity-pos-x player) new-px)
(set! (entity-pos-y player) new-py)
(update-entity-bbox! player))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SHOOTING
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment