[add] [example] pong

1 files changed, 110 insertions, 0 deletions

diff --git a/examples/08-pong.lisp b/examples/08-pong.lisp
new file mode 100644
index 0000000..1eed260
--- /dev/null
+++ b/examples/08-pong.lisp
@@ -0,0 +1,110 @@
+;;;; examples/08-pong.lisp
+
+(defpackage #:ww.examples/8
+  (:use #:cl)
+  (:export #:start)
+  (:import-from #:defclass-std #:defclass/std))
+
+(in-package #:ww.examples/8)
+
+(defclass/std solo-pong (ww::application)
+  ((paddle ball game-over)))
+
+(defclass/std mobile ()
+  ((dx dy dr :std 0)))
+
+(defclass/std paddle (ww::bitmap mobile) ())
+(defclass/std ball (ww::bitmap mobile) ())
+
+(defun random-velocity (&optional (size 1.0))
+  (* size (if (< 0.5 (random 1.0))
+              (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)))
+
+
+(ww::defhandler pong-perframe
+    (ww::on-perframe (app)
+      (with-slots (paddle ball game-over) app
+
+        (when (ww::units-intersect-p paddle ball)
+          (setf (dy ball) (* -1 (dy ball))
+                (dr ball) (* -1 (dr ball)))
+          (incf (ww::x ball) (dx ball))
+          (incf (ww::y ball) (dy ball)))
+
+        (with-accessors ((dx dx) (dy dy) (bx ww::x) (by ww::y) (w ww::width) (h ww::height)) ball
+          (cond
+            ((<= 600 (+ by h))
+             (setf dy (* -1 dy))
+             (advance-pos ball))
+
+            ((or (<= 800 (+ bx w)) (<= bx 0))
+             (setf dx (* -1 dx))
+             (advance-pos ball))
+
+            ((<= by 0)
+             (setf (ww::unit-visiblep game-over) t)))
+
+          (advance-pos ball)))))
+
+(ww::defhandler pong-mousemove
+    (ww::on-mousemotion (app x)
+      (setf (ww::x (paddle app))
+            (- x (* 0.5 (ww::width (paddle app)))))))
+
+(defmethod ww::boot ((app solo-pong))
+  (let* ((ball
+           (make-instance
+            'ball
+            :texture (ww::get-asset "Fezghoul.png")
+            :x 400 :y 300
+            :dr (random-velocity)
+            :dx (random-velocity 10)
+            :dy (random-velocity 10)))
+         (paddle
+           (make-instance
+            'paddle
+            :texture (ww::get-asset "GelatinousCube.png")
+            :x 400
+            :y 0))
+         (game-over
+           (make-instance
+            'ww::text
+            :font (ww::get-asset "Ticketing.ttf")
+            :content "Game Over"
+            :visiblep nil
+            :x 300
+            :y 300
+            :scale-x 3.0
+            :scale-y 3.0)))
+    (setf (ww::width paddle) 120
+          (ww::height paddle) 20
+          (paddle app) paddle
+          (ball app) ball
+          (game-over app) game-over)
+
+    (ww::add-unit app ball)
+    (ww::add-unit app paddle)
+    (ww::add-unit app game-over)
+    (ww::add-handler app #'pong-mousemove)
+    (ww::add-handler app #'pong-perframe )))
+
+(defun start ()
+  (ww::start
+   (make-instance
+    'solo-pong
+    :fps 60
+    :width 800
+    :height 600
+    :refocus-on-mousedown-p nil
+    :title "Now the lonely can enjoy pong."
+    :asset-root
+    (merge-pathnames
+     "examples/"
+     (asdf:system-source-directory :wheelwork)))))