frpong/src/cljs/frpong/core.cljs

(ns frpong.core
  (:require [frpong.signals :refer (signal keyboard ticks dom-events mult tap)]
            [domina :as dom :refer [log]]
            [domina.events :as ev])
  (:require-macros [frpong.core :refer (go go-loop rd wt)]))

;; * `signal` creates a new signal
;; * `keyboard`, `ticks` and `dom-events` create signals for keydown events, browser animation ticks and
;; JS DOM events repectively
;; * `mult` creates a mult(iple) of a signal which can then be tapped using `tap` to create a copy of the
;; original signal
;; * `rd` reads the current value of a signal
;; * `wt` sets the current value of a signal to the provided value
;; * `go` and `go-loop` start and run a component

;;                                       Signal Diagram
;;
;;                                                +-d-----------+--------------------------+
;;                                                v             |                          |
;;           keyboard +-e-> sampler +---k---> paddle-postnr +-d-+   +-> gravitation +--+   |
;;                            ^                                 |   p                  a   |
;;                            t                                 |   |                  |   |
;;                            |                                 |   |                  |   |
;;                            +-------+          +-p----------+-|---+                  |   d
;;                                    |          |  +-a-------|-|------+---------------+   |
;;                                    |          v  v         | |      |                   v
;;            browser +-b--> ticker +-+--t--> ball-postnr +-p-+-|------|------------p-> renderer
;;                              ^     |             ^         | |      |                  ^  ^
;;  Signals                     |     |       +-----|---------+ |      |                  |  |
;;  -------                     s     |       |     l     +--d--+      |                  s  t
;;  b: browser ticks            |     |       |   +-+-----|-------+    |                  |  |
;;  t: game ticks               |     |       p   l   +-a-|-------|----+                  |  |
;;  e: keyboard events          |     |       v   v   v   v  +-l--+                       |  |
;;  k: keydowns (at rate of t)  |     +---t-> collision-detr                              |  |
;;  p: ball position            |     |             ^        +-s--+-----------------------+  |
;;  l: ball velocity            |     |             s             |                          |
;;  a: ball acceleration        +-----|-------------+-------------+                          |
;;  d: paddle positions               |                                                      |
;;  s: game state                     +------------------------------------------------------+
;;
;;  All signals except the signal e are at the rate of the signal b. The signal e is at the rate
;;  at which the keyboard issues events. The signal b is at the rate at which the browser supplies
;;  animation frames.

(defn abs [x] (.abs js/Math x))
(defn sqrt [x] (.sqrt js/Math x))
(defn sq [x] (* x x))

(def PI 3.141592653589793)

(defn deg->rad [deg] (* (/ deg 180) PI))

(defn cos [x] (.cos js/Math x))
(defn sin [x] (.sin js/Math x))

;; Global settings
(def width            (- (.-scrollWidth (.-body js/document)) 20))
(def height           (- (.-scrollHeight (.-body js/document)) 130))
(def center           [(/ width 2 ) (/ height 2)])
(def padding          5)
(def paddle-size      100)

(def ball-radius      8)
(def ball-speed       0.6)
(def init-vel-deg-lim [35 55])
(def perturb-factor   0.05)

(def init-mass-radius 0)

(def paddle-width     10)
(def paddle-step      8)
(def max-paddle-y     (- height paddle-size))
(def ef-paddle-width  (+ paddle-width padding))
(def init-paddle-pos  (/ (- height paddle-size) 2))

(def gravity          (atom 0.005))
(def gravity-step     0.005)

(defn mass-radius []
  (+ init-mass-radius (* (deref gravity) 1000)))

(defn setup-gravity-controls
  "Sets up keyboard controls for changing gravity."
  []
  (let [keydowns   (first (dom-events :keydown))
        actions    { 37 #(- % gravity-step) 39 #(+ % gravity-step) }
        mass-el    (dom/by-id "mass")]
    (go-loop
      (let [k (:keyCode (rd keydowns))]
        (when (contains? actions k)
          (do (swap! gravity #(max 0 (min 0.1 ((actions k) %))))
            (dom/set-attr! mass-el "r" (mass-radius))))))))

(defn layout-game
  "Lays out the game screen."
  []
  (doto (dom/by-id "canvas")
      (dom/set-style! "width" (str width "px"))
      (dom/set-style! "height" (str height "px")))
  (doto (dom/by-id "ball")
    (dom/set-attr! "r" ball-radius)
    (dom/set-attr! "cx" (first center))
    (dom/set-attr! "cy" (second center)))
  (doto (dom/by-id "mass")
    (dom/set-attr! "r" (mass-radius))
    (dom/set-attr! "cx" (first center))
    (dom/set-attr! "cy" (second center)))
  (doto (dom/by-id "score")
    (dom/set-attr! "x" (first center))
    (dom/set-attr! "y" (- height 50)))
  (doseq [id ["lpaddle" "rpaddle"]]
    (doto (dom/by-id id)
      (dom/set-attr! "width" paddle-width)
      (dom/set-attr! "height" paddle-size)
      (dom/set-attr! "y" (/ (- height paddle-size) 2))))
  (dom/set-attr! (dom/by-id "lpaddle") "x" 0)
  (dom/set-attr! (dom/by-id "rpaddle") "x" (- width paddle-width)))

(defn initial-velocity
  "Calculates a random initial ball velocity, randomly in any four quadrants, between
   the limits of degrees specified by init-vel-deg-lim."
  []
  (let [[l h] init-vel-deg-lim
        sgn   #(if (< % 0.5) -1 1)
        deg   (+ l (* (- h l) (rand)))
        rad   (deg->rad deg)]
    (map #(* ball-speed %)
      [(* (sgn (rand)) (sin rad)) (* (sgn (rand)) (cos rad))])))

(defn start-game
  "Sets up the game by creating the signals and setting up the components and starts the game."
  []
  (let [br-ticks   (ticks)               ;; ticks signal from the browser
        pos        (signal)              ;; ball position signal
        vel        (signal)              ;; ball velocity signal
        acc        (signal)              ;; ball acceleration signal
        pd-pos     (signal)              ;; paddles position signal
        game-state (signal)              ;; game state signal, the state of the game and the current score
        init-vel   (initial-velocity)]
    (setup-components br-ticks game-state pos vel acc pd-pos)

    ;; start the game by setting the initial values of the signals
    (go
      (wt pos center)
      (wt vel init-vel)
      (wt pd-pos [init-paddle-pos init-paddle-pos])
      (wt game-state [:moving 0]))))

(defn start-on-space []
  (ev/listen-once! :keypress #(if (= (:keyCode %) 32) (start-game) (start-on-space))))

(defn setup-components
  "Creates mult(iple)s of the signals and sets up the components by connecting them using
   the signals tapped from the mults.
   The signals and their stop functions are taken as parameters."
  [[br-ticks stop-ticks] game-state pos vel acc pd-pos]
  (let [ticks                    (signal)           ;; game ticks signal
        ticks-m                  (mult ticks)       ;; mult(iple)s for all signals
        pos-m                    (mult pos)
        vel-m                    (mult vel)
        acc-m                    (mult acc)
        pd-pos-m                 (mult pd-pos)
        game-state-m             (mult game-state)

        ;; keyboard signal for w, s, up and down keys
        [keyboard stop-keyboard] (keyboard (tap ticks-m) {83 :s 87 :w 38 :up 40 :down})

        ;; calling this will stop the ticks and the keyboard signals and hence stop the game
        stop-game                 #(do (stop-ticks) (stop-keyboard))]
    ;; set up the components by tapping into mults
    (ticker br-ticks stop-game (tap game-state-m) ticks)

    (gravitation (tap pos-m) acc)
    (ball-positioner (tap ticks-m) (tap pos-m) (tap vel-m) (tap acc-m) pos)
    (paddle-positioner keyboard (tap pd-pos-m) pd-pos)

    (collision-detector (tap ticks-m) (tap pos-m) (tap vel-m) (tap acc-m)
      (tap pd-pos-m) (tap game-state-m) game-state vel)

    (renderer (tap ticks-m) (tap game-state-m) (tap pos-m) (tap pd-pos-m))))

(defn ticker
  "Ticker component.
   Reads ticks generated by the browser from the `br-ticks` signal and outputs them to the
   `game-ticks` signal as long as the `game-state` signal is not :gameover.
   Once the `game-state` signal is :gameover, stops the game by calling the `stop-game` function.
   Each tick is the number of milliseconds since the last tick was generated."
  [br-ticks stop-game game-state game-ticks]
  (go (loop []
        (let [[state _] (rd game-state)]
          (do (wt game-ticks (rd br-ticks))
            (if-not (= :gameover state)
              (recur)
              (stop-game)))))))

(defn gravity-acc
  "Calculates acceleration due to gravitation for the ball caused by the mass placed at the
   center of the board."
  [[x y]]
  (let [grav     (deref gravity)
        [cx cy]  center
        x-dist   (- cx x)
        y-dist   (- cy y)
        distance (sqrt (+ (sq x-dist) (sq y-dist)))
        bearing  [(/ x-dist distance) (/ y-dist distance)]]
    (if-not (= distance 0)
      (map #(* grav % (/ 1 distance)) bearing)
      [0 0])))

(defn gravitation
  "Gravitation component.
   Calculates acceleration due to gravitation using the pos from the `pos-in` signal and outputs
   it to the `acc` signal."
  [pos-in acc]
  (go-loop
    (wt acc (gravity-acc (rd pos-in)))))

(defn next-pos [[x y] [vel-x vel-y] [acc-x acc-y] tick]
  [(+ x (* vel-x tick) (* acc-x (sq tick))) (+ y (* vel-y tick) (* acc-y (sq tick)))])

(defn ball-positioner
  "Ball Positioner component.
   Calculates the next ball position using the current ball position, velocity and acceleration
   (from the `pos-in`, `vel` and `acc` signals respectively) and the current tick (from the
   `ticks` signal) and outputs it to the `pos-out` signal."
  [ticks pos-in vel acc pos-out]
  (go-loop
    (let [tick     (rd ticks)
          pos-next (next-pos (rd pos-in) (rd vel) (rd acc) tick)]
      (wt pos-out pos-next))))

(defn paddle-positioner
  "Paddle Positioner component.
   Captures the keys signal for the provides keycodes and calculates the next paddle
   positions using the current paddle positions (from the `pos-in` signal) and keys signal
   and outputs it to the `pos-out` signal."
  [keys pos-in pos-out]
  (go-loop
    (let [[lpos rpos] (rd pos-in)
          ks          (rd keys)
          move        (fn [pos up down]
                        (cond
                          (contains? ks up)   (max (- pos paddle-step) 0)
                          (contains? ks down) (min (+ pos paddle-step) max-paddle-y)
                          :else                pos))]
      (wt pos-out [(move lpos :w :s) (move rpos :up :down)]))))

(defn in-y-range? [y paddle-y]
    (and (> y (- paddle-y padding)) (< y (+ paddle-y paddle-size padding))))

(defn detect-x-collision [x y lpaddle-y rpaddle-y]
  (cond
    (< x ef-paddle-width)
      (if (in-y-range? y lpaddle-y) :collision-left  :gameover)
    (> x (- width ef-paddle-width))
      (if (in-y-range? y rpaddle-y) :collision-right :gameover)
    :else :moving))

(defn detect-y-collision [y]
  (cond
    (< y padding)            :collision-left
    (> y (- height padding)) :collision-right
    :else                    :moving))

(defn collision? [state]
  (or (= state :collision-left) (= state :collision-right)))

(defn adjust-vel [state vel]
  (condp = state
    :collision-left  (abs vel)
    :collision-right (- (abs vel))
    :moving          vel
    :gameover        0))

(defn perturb [v] (* v (+ 1 (* (rand) perturb-factor))))

(defn collision-detector [ticks pos vel-in acc pd-pos game-state-in game-state vel-out]
  "Collision Detector component.
   Detects the collision of the ball with the walls and the paddles and accordingly calculates
   and outputs the next ball velocity and next game state to the `vel-out` and `game-state`
   signals respectively.
   Reads the current tick, ball position, ball velocity, ball acceleration, left and right paddle
   positions and game state from the `ticks`, `pos`, `vel-in`, `acc`, `pd-pos` and `game-state`
   signals respectively."

  (go-loop
    (let [;; read all current values
          tick                  (rd ticks)
          [vel-x vel-y]         (rd vel-in)
          [x y]                 (rd pos)
          [gx gy]               (rd acc)
          [lpaddle-y rpaddle-y] (rd pd-pos)
          [_ score]             (rd game-state-in)

          ;; calculate next position and detect collision
          [xn yn]               (next-pos [x y] [vel-x vel-y] [gx gy] tick)
          x-state               (detect-x-collision xn yn lpaddle-y rpaddle-y)
          y-state               (detect-y-collision yn)
          x-collision           (collision? x-state)
          y-collision           (collision? y-state)

          ;; calculate next velocity and game state
          vel-xn                (min ball-speed (+ (adjust-vel x-state vel-x) (* gx tick)))
          vel-yn                (min ball-speed (+ (adjust-vel y-state vel-y) (* gy tick)))
          state-n               (cond
                                  (= x-state :gameover)        :gameover
                                  (or x-collision y-collision) :collision
                                  :else                        :moving)
          score-n               (if x-collision (inc score) score)

          ;; add a small random perturbation to the ball velocity on collision with paddles
          [vel-xn vel-yn]       (if x-collision
                                  (map perturb [vel-xn vel-yn])
                                  [vel-xn vel-yn])]
      (wt vel-out [vel-xn vel-yn])
      (wt game-state [state-n score-n]))))

(defn renderer
  "Renderer component.
   Renders the ball and paddle positions on the browser. Also shows the game state and stats.
   Reads the current values from the signals supplied as parameters."
  [ticks game-state pos pd-pos]
  (let [ball-el    (dom/by-id "ball")
        score-el   (dom/by-id "score")
        lpaddle-el (dom/by-id "lpaddle")
        rpaddle-el (dom/by-id "rpaddle")
        fps-el     (dom/by-id "fps")
        msg-el     (dom/by-id "msg")]
    (dom/set-style! ball-el "fill" "orange")
    (dom/set-text! msg-el "")
    (go (loop [fps-p nil score-p nil]
          (let [fps                   (int (/ 1000 (rd ticks)))
                [x y]                 (rd pos)
                [lpaddle-y rpaddle-y] (rd pd-pos)
                [state score]         (rd game-state)]
            (doto ball-el
              (dom/set-attr! "cx" x)
              (dom/set-attr! "cy" y))
            (dom/set-attr! lpaddle-el "y" lpaddle-y)
            (dom/set-attr! rpaddle-el "y" rpaddle-y)
            (when-not (= fps fps-p)
              (dom/set-text! fps-el fps))
            (when-not (= score score-p)
              (dom/set-text! score-el score))
            (when (= state :gameover)
              (do (dom/set-style! ball-el "fill" "red")
                (dom/set-html! msg-el "<span class='imp'>GAME OVER</span><br>press &lt;space&gt; to restart")
                (start-on-space)))
            (recur fps score))))))

;; Everything is ready now. Layout the game and start it on pressing <space>!
(defn ^:export frpong []
  (setup-gravity-controls)
  (layout-game)
  (start-on-space))