;;;; examples/08-pong.lisp

(defpackage #:ww.examples/8
  (:use #:cl)
  (:export #:start)
  (:import-from #:defclass-std #:defclass/std))

(in-package #:ww.examples/8)

;;; CLASSES

(defclass/std solo-pong (ww::application)
  ((paddle ball game-over intro-text)))

(defclass/std mobile ()
  ((dx dy dr :std 0)))

(defclass/std paddle (ww::bitmap mobile) ())
(defclass/std ball (ww::bitmap mobile) ())

;;; UTILITY FUNCTIONS

(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)
  "THING is expected to have the affine protocol implemented on it,
and to be an instance of MOBILE.

In this game, this will only ever be called on the ball."
  (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)
    (setf dr (decay dr)))) ;; rotation diminishes every round, just aesthetic.

(defun decay (val &optional (amount 0.01))
  "Returns a value that is VAL reduced in magnitude by AMOUNT, or zero
of VAL is already zero."
  (cond
    ((zerop val)
     val)
    ((plusp val)
     (- val amount))
    ((minusp val)
     (+ val amount))))

(defun avg (&rest args)
  "Just averages values"
  (loop for x in args
        sum x into total
        sum 1 into count
        finally (return (/ total count))))

(defun sqrt+ (val)
  "Returns a value with the same sign as VAL, but whose magnitude is
the sqrt of the magintude of VAL."
  (if (plusp val) (sqrt val)
      (* -1 (sqrt (abs val)))))

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

(ww::defhandler pong-perframe
    (ww::on-perframe (app)
      "Called on the app once per frame. Responsible for checking
       collisions and adjusting the ball's properties. And for
       checking for and handling gameover conditions."
      (with-slots (paddle ball game-over) app
        (when (ww::units-intersect-p paddle ball)
          (setf
           ;; dy just reverses direction
           (dy ball) (* -1 (dy ball)) 
           ;; average dx of the two
           (dx ball) (avg (dx ball) (dx paddle)) 
           ;; no logic to it dr change, just aesthetic
           (dr ball) (avg (sqrt+ (sqrt+ (dx paddle))) (dr ball))) 

          ;; its a good idea to advance the ball position after every collision
          ;; this prevents the ball from "getting stuck" contstantly colliding
          ;; with an object / wall.
          (advance-pos ball))

        ;; since the dx of the paddle only changes when the paddle
        ;; moves we should have it decay if its just been sitting
        ;; still. Mostly for aesthetics. It looks funny if a
        ;; stationary paddle speeds up the ball.
        (setf (dx paddle) (decay (dx paddle) 1))

        ;; here we just check the bounds, bounce when the ball hits the top left or right
        ;; and signal game over if it hits the bottom.
        (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)
                   by (- 600 h))
             (advance-pos ball))

            ((<= 800 (+ bx w))
             (setf dx (* -1 dx))
             (advance-pos ball))

            ((<= bx 0)
             (setf dx (* -1 dx)))

            ;; game over
            ((<= by 0)
             (setf (ww::unit-visiblep game-over) t)))

          ;; just to be safe, dx can get pretty fast
          (setf bx (clamp 0.0 bx (- 800 w)))

          ;; and whatever else happens, advance the ball position.
          (advance-pos ball)))))

(ww::defhandler pong-mousemove
    (ww::on-mousemotion (app)
      "Just sets the position of the paddle, and updates the paddles dx"
      (setf (ww::x  (paddle app))
            (- x (* 0.5 (ww::width (paddle app))))
            ;; using dx to store some motion informaton
            ;; used to chagne dx and dr in the ball
            (dx (paddle app)) xrel)))   ; xrel is supplied by default by on-mousemotion

(ww::defhandler press-to-start
    (ww::on-keydown (app)
      "Sets up the ball, paddle, and game over text."
      ;; first remove the intro text and keydown handler.
      (ww::drop-unit (intro-text app))
      (ww::remove-handler app #'press-to-start)
      (let* ((ball
               (make-instance
                'ball
                :texture (ww::get-asset "Fezghoul.png")
                :x 400 :y 300
                :dr (random-velocity)
                :dx (random-velocity 10)
                :dy 8))
             (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))))


(defmethod ww::boot ((app solo-pong))
  "Adds the intro text and sets up the start button handler."
  (sdl2:hide-cursor)
  (ww::add-unit
   app
   (setf (intro-text app)
         (make-instance
          'ww::text
          :content "Press any key to start"
          :font (ww::get-asset "Ticketing.ttf")
          :x 160
          :y 300
          :scale-x 3.0
          :scale-y 3.0)))

  (ww::add-handler app #'press-to-start))

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