blob: cf18e3135156c843b43a32430bd7e5b6e1aee4f7 (
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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
;;;; examples/09-ghoulspree.lisp
(defpackage #:ww.examples/9
(:use #:cl)
(:export #:start)
(:import-from #:defclass-std #:defclass/std))
(in-package #:ww.examples/9)
;;; CLASSES
(defclass/std ghoulspree (ww::application)
((ghouls-per-click :std 20)
(collision-on-p :std t)
(gravity-on-p :std nil)))
(defclass/std ghoul (ww:image)
((dx dy dr :std)))
;;; UTILITY FUNCTIONS
(defun make-ghoul (x y)
(make-instance 'ghoul :texture (ww:get-asset "Fezghoul.png")
:x x :y y
:dr (random-velocity 0.2)
:dx (random-velocity 4)
:dy (random-velocity 4)))
(defun out-of-bounds-p (ghoul)
(not
(and
(< -50 (ww:x ghoul) 850)
(< -50 (ww:y ghoul) 650))))
(defun random-velocity (&optional (size 1.0))
(* size (if (zerop (random 2))
(random 1.0)
(* -1 (random 1.0)))))
(defun advance-pos (thing)
(with-accessors ((dr dr) (dx dx) (dy dy) (x ww::x) (y ww::y) (r ww::rotation)) thing
(incf x dx)
(incf y dy)
(incf r dr)))
(defun clamp (lo val hi)
"Returns VAL if (< LO VAL HI), otherwise returns LO or HI depending
on which boundary VAL is outside of."
(max lo (min val hi)))
(defun sign (x)
(if (zerop x) 0
(/ x (abs x))))
(defmacro with-pairs ((a b) ls &rest body)
"run body with a and b bound to unique 2-sets of LS"
(let ((more-a (gensym)))
`(loop for (,a . ,more-a) on ,ls do
(loop for ,b in ,more-a do (progn ,@body)) )))
(defun handle-collision (g1 g2 &optional (friction 0.99))
(with-slots ((dx1 dx) (dy1 dy) (dr1 dr)) g1
(with-slots ((dx2 dx) (dy2 dy) (dr2 dr)) g2
(let ((tdx (* friction dx1))
(tdy (* friction dy1))
(tdr (* friction dr1)))
(setf dx1 (* friction dx2)
dy1 (* friction dy2)
dr1 (* friction dr2)
dx2 tdx
dy2 tdy
dr2 tdr)))))
(defun apply-gravity-to (thing acc)
(with-slots (dx dy) thing
(decf dy acc)))
(ww:defhandler moveghouls
(ww:on-perframe (app)
;; first handle collisions
(when (collision-on-p app)
(with-pairs
(g1 g2) (ww:container-units app)
(when (ww:units-intersect-p g1 g2)
(handle-collision g1 g2 1.0)
;; need a "bounce"
(advance-pos g1)
(advance-pos g1)
(advance-pos g2)
(advance-pos g2))))
;; then update positions and remove the out of bounds
(let ((gravity
(gravity-on-p app))
(accelleration
(/ 9.8 (ww:fps app))))
(loop for ghoul in (ww:container-units app)
do (advance-pos ghoul)
when gravity
do (apply-gravity-to ghoul accelleration)
when (out-of-bounds-p ghoul)
do (ww:drop-unit ghoul)))))
(defun random-sign ()
(if (zerop (random 2)) -1 1))
(defun random-between (lo hi)
(+ lo (random (- hi lo))))
(ww:defhandler add-ghouls
(ww:on-mousedown (app x y)
(loop repeat (ghouls-per-click app)
for rx = (random 800); (+ x (* (random-sign) (random-between 30 60)))
for ry = (random 600); (+ y (* (random-sign) (random-between 30 60)))
do (ww:add-unit app (make-ghoul rx ry)))
(format t "~a ghouls on screen~%"
(length (ww:container-units app )))))
(ww:defhandler toggle-collision
(ww:on-keydown (app scancode)
(case scancode
(:scancode-c
(format t "collision: ~a~%"
(setf (collision-on-p app)
(not (collision-on-p app)))))
(:scancode-g
(format t "gravity: ~a~%"
(setf (gravity-on-p app)
(not (gravity-on-p app))))))))
(defmethod ww::boot ((app ghoulspree))
"Adds the intro text and sets up the start button handler."
(format t "Click to add ~a ghouls to the screen.~%" (ghouls-per-click app))
(format t "Press c to toggle collision handling.~%")
(format t "Press g to toggle gravity.~%")
(ww:add-handler app #'add-ghouls)
(ww:add-handler app #'moveghouls)
(ww:add-handler app #'toggle-collision))
(defun start (&optional (scale 1.0))
(ww::start
(make-instance
'ghoulspree
:fps 60
:width (round (* 800 scale))
:height (round (* 600 scale))
:scale scale
:refocus-on-mousedown-p nil
:title "Click to add ghouls"
:asset-root
(merge-pathnames
"examples/"
(asdf:system-source-directory :wheelwork)))))
|
