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))))