blob: 5439e6bb9e876438ee51be6ef1534046f6c22f6b (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
;;; Lisparuga
;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu>
;;;
;;; Lisparuga is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; Lisparuga is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Lisparuga. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; A class representing a scripted or player-controller object in the
;; game world. Actors can emit bullets and have many hitboxes.
;;
;;; Code:
(define-module (lisparuga actor)
#:use-module (chickadee math vector)
#:use-module (chickadee math rect)
#:use-module (lisparuga node)
#:use-module (lisparuga node-2d)
#:use-module (oop goops)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:export (make-hitbox
hitbox?
hitbox-name
hitbox-rect
world-hitbox?
world-hitbox-collision?
world-hitbox-parent
<actor>
polarity
velocity
hitboxes
world-hitboxes
collide
on-collision
bullet-field))
;;;
;;; Hitboxes
;;;
(define-record-type <hitbox>
(make-hitbox name rect)
hitbox?
(name hitbox-name)
(rect hitbox-rect))
(define-record-type <world-hitbox>
(%make-world-hitbox parent rect)
world-hitbox?
(parent world-hitbox-parent)
(rect world-hitbox-rect))
(define (make-world-hitbox parent)
(let ((r (hitbox-rect parent)))
(%make-world-hitbox parent
(make-rect 0.0 0.0 (rect-width r) (rect-height r)))))
(define (sync-world-hitbox world-hitbox position)
(let ((r (hitbox-rect (world-hitbox-parent world-hitbox)))
(wr (world-hitbox-rect world-hitbox)))
(set-rect-x! wr (+ (vec2-x position) (rect-x r)))
(set-rect-y! wr (+ (vec2-y position) (rect-y r)))))
(define (world-hitbox-collision? a b)
(if (world-hitbox? b)
(rect-intersects? (world-hitbox-rect a) (world-hitbox-rect b))
(rect-intersects? (world-hitbox-rect a) b)))
;;;
;;; Actors
;;;
(define-class <actor> (<node-2d>)
(polarity #:accessor polarity #:init-form 'none #:init-keyword #:polarity)
(velocity #:getter velocity #:init-form (vec2 0.0 0.0))
(hitboxes #:accessor hitboxes #:init-form '() #:init-keyword #:hitboxes)
(world-hitboxes #:accessor world-hitboxes #:init-form '())
(bullet-field #:accessor bullet-field #:init-keyword #:bullet-field))
(define (sync-hitboxes actor)
;; Sync hitboxes to world coordinates.
(let ((pos (position actor)))
(for-each (lambda (world-hitbox)
(sync-world-hitbox world-hitbox pos))
(world-hitboxes actor))))
(define-method (initialize (actor <actor>) initargs)
(next-method)
(set! (world-hitboxes actor)
(map make-world-hitbox (hitboxes actor)))
(sync-hitboxes actor))
(define-method (update (actor <actor>) dt)
(let ((v (velocity actor)))
(unless (and (= (vec2-x v) 0.0)
(= (vec2-y v) 0.0))
;; Move by current velocity.
(vec2-add! (position actor) v)
(sync-hitboxes actor)
;; Mark for matrix updates.
(dirty! actor))))
(define-method (collide (actor <actor>) (other-actor <actor>))
(any (lambda (wh)
(any (lambda (other-wh)
(and (world-hitbox-collision? wh other-wh)
(on-collision actor other-actor
(world-hitbox-parent wh)
(world-hitbox-parent other-wh))))
(world-hitboxes other-actor)))
(world-hitboxes actor)))
;; Actor-actor collision event.
(define-method (on-collision (actor <actor>) (other-actor <actor>)
hitbox other-hitbox)
#f)
|
