Windows fixes
[commonqt.git] / tutorial / t14.lisp
1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
2
3 ;;; http://doc.trolltech.com/4.3/tutorial-t14.html
4
5 (defpackage :qt-tutorial-14
6   (:use :cl :qt)
7   (:export #:main))
8
9 (in-package :qt-tutorial-14)
10 (named-readtables:in-readtable :qt)
11
12 (defclass cannon-field ()
13     ((current-angle :initform 45
14                     :accessor current-angle)
15      (current-force :initform 0
16                     :accessor current-force)
17      (timer-count :initform 0
18                   :accessor timer-count)
19      (auto-shoot-timer :accessor auto-shoot-timer)
20      (shoot-angle :initform 0
21                   :accessor shoot-angle)
22      (shoot-force :initform 0
23                   :accessor shoot-force)
24      (target :initform nil
25              :accessor target)
26      (game-ended-p :initform nil
27                    :accessor game-ended-p)
28      (barrel-pressed-p :initform nil
29                        :accessor barrel-pressed-p))
30   (:metaclass qt-class)
31   (:qt-superclass "QWidget")
32   (:slots ("setAngle(int)" (lambda (this newval)
33                              (setf (current-angle this)
34                                    (min (max 5 newval) 70))))
35           ("setForce(int)" (lambda (this newval)
36                              (setf (current-force this)
37                                    (max 0 newval))))
38           ("void moveShot()" move-shot)
39           ("void shoot()" shoot)
40           ("void setGameOver()" set-game-over)
41           ("void restartGame()" restart-game))
42   (:signals ("angleChanged(int)")
43             ("forceChanged(int)")
44             ("void hit()")
45             ("void missed()")
46             ("void canShoot(bool)"))
47   (:override ("paintEvent" paint-event)
48              ("mousePressEvent" mouse-press-event)
49              ("mouseMoveEvent" mouse-move-event)
50              ("mouseReleaseEvent" mouse-release-event)))
51
52 (defmethod (setf current-angle) :around (newval (instance cannon-field))
53   (let ((oldval (current-angle instance)))
54     (prog1
55         (call-next-method)
56       (unless (eql oldval newval)
57         (with-objects ((rect (cannon-rect instance)))
58           (#_update instance rect))
59         (emit-signal instance "angleChanged(int)" newval)))))
60
61 (defmethod (setf current-force) :around (newval (instance cannon-field))
62   (let ((oldval (current-force instance)))
63     (prog1
64         (call-next-method)
65       (unless (eql oldval newval)
66         (with-objects ((rect (cannon-rect instance)))
67           (#_update instance rect))
68         (emit-signal instance "forceChanged(int)" newval)))))
69
70 (defun cannon-rect (instance)
71   (let ((result (#_new QRect 0 0 50 50)))
72     (#_moveBottomLeft result (#_bottomLeft (#_rect instance)))
73     result))
74
75 (defun barrier-rect (instance)
76   (#_new QRect 145 (- (#_height instance) 100) 15 99))
77
78 (defun barrel-hit-p (instance pos)
79   (with-objects ((matrix (#_new QMatrix)))
80     (#_translate matrix 0 (#_height instance))
81     (#_rotate matrix (- (current-angle instance)))
82     (with-objects ((br (barrel-rect))
83                    (mapped-pos (#_map (#_inverted matrix) pos)))
84       (#_contains br mapped-pos))))
85
86 (defun target-rect (instance)
87   (let ((result (#_new QRect 0 0 20 10)))
88     (with-objects ((to (#_new QPoint
89                               (#_x (target instance))
90                               (- (#_height instance)
91                                  1
92                                  (#_y (target instance))))))
93       (#_moveCenter result to))
94     result))
95
96 (defun barrel-rect ()
97   (#_new QRect 30 -5 20 10))
98
99 (defun shot-rect (instance)
100   (with-objects ((barrel-rect (barrel-rect)))
101     (let* ((gravity 4.0d0)
102            (time (/ (timer-count instance) 20.0d0))
103            (velocity (shoot-force instance))
104            (radians (* (shoot-angle instance) (/ pi 180.0d0)))
105            (velx (* velocity (cos radians)))
106            (vely (* velocity (sin radians)))
107            (x0 (* (+ (#_right barrel-rect) 5.0d0) (cos radians)))
108            (y0 (* (+ (#_right barrel-rect) 5.0d0) (sin radians)))
109            (x (+ x0 (* velx time)))
110            (y (+ y0 (* vely time) (- (* 0.5d0 gravity time time))))
111            (result (#_new QRect 0 0 6 6)))
112       (with-objects ((to (#_new QPoint
113                                 (round x)
114                                 (- (#_height instance) 1 (round y)))))
115         (#_moveCenter result to))
116       result)))
117
118 (defun is-shooting-p (instance)
119   (#_isActive (auto-shoot-timer instance)))
120
121 (defun shoot (instance)
122   (unless (is-shooting-p instance)
123     (setf (timer-count instance) 0)
124     (setf (shoot-angle instance) (current-angle instance))
125     (setf (shoot-force instance) (current-force instance))
126     (#_start (auto-shoot-timer instance) 5)
127     (emit-signal instance "canShoot(bool)" nil)))
128
129 (defun set-game-over (instance)
130   (unless (game-ended-p instance)
131     (when (is-shooting-p instance)
132       (#_stop (auto-shoot-timer instance)))
133     (setf (game-ended-p instance) t)
134     (#_update instance)))
135
136 (defun restart-game (instance)
137   (when (is-shooting-p instance)
138     (#_stop (auto-shoot-timer instance)))
139   (setf (game-ended-p instance) nil)
140   (#_update instance)
141   (emit-signal instance "canShoot(bool)" t))
142
143 (defun move-shot (instance)
144   (with-objects ((old (shot-rect instance)))
145     (incf (timer-count instance))
146     (with-objects ((new (shot-rect instance))
147                    (tr (target-rect instance)))
148       (cond
149         ((#_intersects new tr)
150          (#_stop (auto-shoot-timer instance))
151          (emit-signal instance "hit()")
152          (emit-signal instance "canShoot(bool)" t))
153         ((or (> (#_x new) (#_width instance))
154              (> (#_y new) (#_height instance))
155              (with-objects ((br (barrier-rect instance)))
156                (#_intersects new br)))
157          (#_stop (auto-shoot-timer instance))
158          (emit-signal instance "missed()")
159          (emit-signal instance "canShoot(bool)" t))
160         (t
161          (let ((new (#_unite old new)))
162            (delete-object old)
163            (setf old new)))))
164     (#_update instance old)))
165
166 (defmethod initialize-instance :after ((instance cannon-field) &key parent)
167   (if parent
168       (new instance parent)
169       (new instance))
170   (setf (auto-shoot-timer instance) (#_new QTimer instance))
171   (#_connect "QObject"
172              (auto-shoot-timer instance)
173              (QSIGNAL "timeout()")
174              instance
175              (QSLOT "moveShot()"))
176   (with-objects ((col (#_new QColor 250 250 200))
177                  (pal (#_new QPalette col)))
178     (#_setPalette instance pal))
179   (#_setAutoFillBackground instance (bool 1))
180   (new-target instance))
181
182 (defun new-target (instance)
183   (when (target instance)
184     (delete-object (target instance)))
185   (setf (target instance)
186         (#_new QPoint
187                (+ 200 (random 190))
188                (+ 10 (random 255))))
189   (#_update instance))
190
191 (defun paint-shot (instance painter)
192   (#_setPen painter (#_NoPen "Qt"))
193   (with-objects ((brush (#_new QBrush (#_black "Qt") (#_SolidPattern "Qt"))))
194     (#_setBrush painter brush))
195   (with-objects ((rect (shot-rect instance)))
196     (#_drawRect painter rect)))
197
198 (defun paint-cannon (instance painter)
199   (#_setPen painter (#_NoPen "Qt"))
200   (with-objects ((brush (#_new QBrush (#_blue "Qt") (#_SolidPattern "Qt"))))
201     (#_setBrush painter brush))
202
203   (#_save painter)
204   (#_translate painter 0 (#_height (#_rect instance)))
205   (with-objects ((rect (#_new QRect -35 -35 70 70)))
206     (#_drawPie painter rect 0 (* 90 16)))
207   (#_rotate painter (- (current-angle instance)))
208   (with-objects ((rect (#_new QRect 30 -5 20 10)))
209     (#_drawRect painter rect))
210   (#_restore painter))
211
212 (defun paint-target (instance painter)
213   (#_setPen painter (#_NoPen "Qt"))
214   (with-objects ((brush (#_new QBrush (#_red "Qt") (#_SolidPattern "Qt"))))
215     (#_setBrush painter brush))
216   (with-objects ((rect (target-rect instance)))
217     (#_drawRect painter rect)))
218
219 (defun paint-barrier (instance painter)
220   (with-objects ((pen (#_new QPen (#_black "Qt"))))
221     (#_setPen painter pen))
222   (with-objects ((brush (#_new QBrush (#_blue "Qt") (#_SolidPattern "Qt"))))
223     (#_setBrush painter brush))
224   (with-objects ((rect (barrier-rect instance)))
225     (#_drawRect painter rect)))
226
227 (defmethod paint-event ((instance cannon-field) paint-event)
228   (with-objects ((painter (#_new QPainter instance)))
229     (when (game-ended-p instance)
230       (#_setPen painter (#_black "Qt"))
231       (with-objects ((font (#_new QFont "Courier" 48 (#_Bold "QFont"))))
232         (#_setFont painter font))
233       (#_drawText painter (#_rect instance) (#_AlignCenter "Qt") "Game Over"))
234     (paint-cannon instance painter)
235     (when (is-shooting-p instance)
236       (paint-shot instance painter))
237     (unless (game-ended-p instance)
238       (paint-target instance painter))
239     (paint-barrier instance painter)
240     (#_end painter)))
241
242 (defmethod mouse-press-event ((instance cannon-field) event)
243   (setf (barrel-pressed-p instance)
244         (and (enum= (#_button event) (#_LeftButton "Qt"))
245              (barrel-hit-p instance (#_pos event)))))
246
247 (defmethod mouse-move-event ((instance cannon-field) event)
248   (when (barrel-pressed-p instance)
249     (let ((pos (#_pos event)))
250       (unless (plusp (#_x pos))
251         (#_setX pos 1))
252       (unless (< (#_x pos) (#_height instance))
253         (#_setX pos (1- (#_height instance))))
254       (let ((radians (atan (- (float (#_bottom (#_rect instance)) 1.0d0)
255                               (#_y pos))
256                            (#_x pos))))
257         (setf (current-angle instance)
258               (round (* radians (/ 180 pi))))))))
259
260 (defmethod mouse-release-event ((instance cannon-field) event)
261   (when (enum= (#_button event) (#_LeftButton "Qt"))
262     (setf (barrel-pressed-p instance) nil)))
263
264 (defclass lcd-range ()
265     ((slider :accessor slider)
266      (label :accessor label))
267   (:metaclass qt-class)
268   (:qt-superclass "QWidget")
269   (:slots ("setValue(int)" (lambda (this int) (setf (value this) int)))
270           ("setRange(int,int)" set-range))
271   (:signals ("valueChanged(int)")))
272
273 (defmethod value ((instance lcd-range))
274   (#_value (slider instance)))
275
276 (defmethod (setf value) (newval (instance lcd-range))
277   (#_setValue (slider instance) newval))
278
279 (defmethod text ((instance lcd-range))
280   (#_text (label instance)))
281
282 (defmethod (setf text) (newval (instance lcd-range))
283   (#_setText (label instance) newval))
284
285 (defun set-range (instance min max)
286   (when (or (minusp min) (> max 99) (> min max))
287     (warn "invalid SET-RANGE(~D, ~D)" min max))
288   (#_setRange (slider instance) min max))
289
290 (defmethod initialize-instance
291     :after
292     ((instance lcd-range) &key parent text)
293   (if parent
294       (new instance parent)
295       (new instance))
296   (let ((lcd (#_new QLCDNumber 2)))
297     (#_setSegmentStyle lcd (#_Filled "QLCDNumber"))
298     (let ((slider (#_new QSlider (#_Horizontal "Qt"))))
299       (setf (slider instance) slider)
300       (#_setRange slider 0 99)
301       (#_setValue slider 0)
302       (#_connect "QObject"
303                   slider
304                   (QSIGNAL "valueChanged(int)")
305                   lcd
306                   (QSLOT "display(int)"))
307       (#_connect "QObject"
308                   slider
309                   (QSIGNAL "valueChanged(int)")
310                   instance
311                   (QSIGNAL "valueChanged(int)"))
312       (let ((label (#_new QLabel)))
313         (#_setSizePolicy label
314                          (#_Preferred "QSizePolicy")
315                          (#_Fixed "QSizePolicy"))
316         (setf (label instance) label)
317         (#_setAlignment label (logior (primitive-value
318                                        (#_AlignHCenter "Qt"))
319                                       (primitive-value
320                                        (#_AlignTop "Qt"))))
321         (let ((layout (#_new QVBoxLayout)))
322           (#_addWidget layout lcd)
323           (#_addWidget layout slider)
324           (#_addWidget layout label)
325           (#_setLayout instance layout)))
326       (#_setFocusProxy instance slider)))
327   (when text
328     (setf (text instance) text)))
329
330 (defclass game-board ()
331     ((hits :accessor hits)
332      (shots-left :accessor shots-left)
333      (cannon-field :accessor cannon-field))
334   (:metaclass qt-class)
335   (:qt-superclass "QWidget")
336   (:slots ("fire()" fire)
337           ("hit()" hit)
338           ("missed()" missed)
339           ("newGame()" new-game)))
340
341 (defmethod initialize-instance :after ((instance game-board) &key parent)
342   (if parent
343       (new instance parent)
344       (new instance))
345   (with-objects ((font (#_new QFont (qstring "Times") 18 (#_Bold "QFont"))))
346     (let ((quit (#_new QPushButton "&Quit"))
347           (shoot (#_new QPushButton "&Shoot"))
348           (new-game (#_new QPushButton "&New Game")))
349       (#_setFont quit font)
350       (#_setFont shoot font)
351       (#_setFont new-game font)
352       (#_connect "QObject"
353                  new-game
354                  (QSIGNAL "clicked()")
355                  instance
356                  (QSLOT "newGame()"))
357       (#_connect "QObject"
358                  quit
359                  (QSIGNAL "clicked()")
360                  (#_QCoreApplication::instance)
361                  (QSLOT "quit()"))
362       (let ((angle (make-instance 'lcd-range :text "ANGLE"))
363             (force (make-instance 'lcd-range :text "FORCE"))
364             (hits (#_new QLCDNumber 2))
365             (shots-left (#_new QLCDNumber 2))
366             (hits-label (#_new QLabel "HITS"))
367             (shots-left-label (#_new QLabel "SHOTS LEFT"))
368             (cf (make-instance 'cannon-field))
369             (cannon-box (#_new QFrame)))
370         (#_setFrameStyle cannon-box
371                          (logior (primitive-value (#_WinPanel "QFrame"))
372                                  (primitive-value (#_Sunken "QFrame"))))
373         (with-objects ((key (#_new QKeySequence (#_Key_Enter "Qt"))))
374           (#_new QShortcut key instance (QSLOT "fire()")))
375         (with-objects ((key (#_new QKeySequence (#_Key_Return "Qt"))))
376           (#_new QShortcut key instance (QSLOT "fire()")))
377         (with-objects ((key (#_new QKeySequence (#_CTRL "Qt") (#_Key_Q "Qt"))))
378           (#_new QShortcut key instance (QSLOT "close()")))
379         (setf (cannon-field instance) cf)
380         (setf (hits instance) hits)
381         (setf (shots-left instance) shots-left)
382         (#_setSegmentStyle hits (#_Filled "QLCDNumber"))
383         (#_setSegmentStyle shots-left (#_Filled "QLCDNumber"))
384         (#_connect "QObject"
385                    shoot
386                    (QSIGNAL "clicked()")
387                    instance
388                    (QSLOT "fire()"))
389         (#_connect "QObject"
390                    cf
391                    (QSIGNAL "hit()")
392                    instance
393                    (QSLOT "hit()"))
394         (#_connect "QObject"
395                    cf
396                    (QSIGNAL "missed()")
397                    instance
398                    (QSLOT "missed()"))
399         (#_connect "QObject"
400                    cf
401                    (QSIGNAL "canShoot(bool)")
402                    shoot
403                    (QSLOT "setEnabled(bool)"))
404         (set-range angle 5 70)
405         (set-range force 10 50)
406         (#_connect "QObject"
407                    angle
408                    (QSIGNAL "valueChanged(int)")
409                    cf
410                    (QSLOT "setAngle(int)"))
411         (#_connect "QObject"
412                    cf
413                    (QSIGNAL "angleChanged(int)")
414                    angle
415                    (QSLOT "setValue(int)"))
416         (#_connect "QObject"
417                    force
418                    (QSIGNAL "valueChanged(int)")
419                    cf
420                    (QSLOT "setForce(int)"))
421         (#_connect "QObject"
422                    cf
423                    (QSIGNAL "forceChanged(int)")
424                    force
425                    (QSLOT "setValue(int)"))
426         (let ((left-layout (#_new QVBoxLayout))
427               (top-layout (#_new QHBoxLayout))
428               (grid (#_new QGridLayout)))
429           (#_addWidget left-layout angle)
430           (#_addWidget left-layout force)
431           
432           (#_addWidget top-layout shoot)
433           (#_addWidget top-layout hits)
434           (#_addWidget top-layout hits-label)
435           (#_addWidget top-layout shots-left)
436           (#_addWidget top-layout shots-left-label)
437           (#_addStretch top-layout 1)
438           (#_addWidget top-layout new-game)
439           
440           (#_addWidget grid quit 0 0)
441           (#_addLayout grid top-layout 0 1)
442           (#_addLayout grid left-layout 1 0)
443           (#_addWidget grid cannon-box 1 1 2 1)
444           (#_addWidget grid cf 1 1 2 1)
445           (#_setColumnStretch grid 1 10)
446           (#_setLayout instance grid))
447         (setf (value angle) 60)
448         (setf (value force) 25)
449         (#_setFocus angle)
450         (new-game instance)))))
451
452 (defmethod fire ((game game-board))
453   (with-slots (cannon-field shots-left) game
454     (unless (or (game-ended-p cannon-field)
455                 (is-shooting-p cannon-field))
456       (#_display shots-left (1- (#_intValue shots-left)))
457       (shoot cannon-field))))
458
459 (defmethod hit ((game game-board))
460   (with-slots (cannon-field hits shots-left) game
461     (#_display hits (1+ (#_intValue hits)))
462     (if (zerop (#_intValue shots-left))
463         (set-game-over cannon-field)
464         (new-target cannon-field))))
465
466 (defmethod missed ((game game-board))
467   (with-slots (cannon-field shots-left) game
468     (when (zerop (#_intValue shots-left))
469       (set-game-over cannon-field))))
470
471 (defmethod new-game ((game game-board))
472   (with-slots (cannon-field hits shots-left) game
473     (#_display shots-left 15)
474     (#_display hits 0)
475     (restart-game cannon-field)
476     (new-target cannon-field)))
477
478 (defun test ()
479   (let ((window (make-instance 'game-board)))
480     (#_setGeometry window 100 100 500 355)
481     (#_show window)
482     window))
483
484 (defun main ()
485   (make-qapplication)
486   (let ((window (test)))
487     (unwind-protect
488          (#_exec (#_new QEventLoop))
489       (#_hide window))))