(ns glimmer-gfx.tests
  "Every check here runs headless: the backend measures, places, paints and
   dispatches into a plain framebuffer, so none of it needs a window or a
   display. `jolt test`."
  (:require [glimmer.ratom :as ra]
            [glimmer.core :as gui]
            [glimmer.backend :as backend]
            [glimmer-gfx.core :as gfx]
            [glimmer-gfx.tictactoe :as ttt]
            [glimmer-gfx.maze :as maze]
            [glimmer-gfx.asteroids :as ast]
            [glimmer-gfx.raster :as r]
            [clojure.string :as str]))

;; --- the rasterizer ----------------------------------------------------------

(defn- check-raster! []
  (let [b  (r/buf 200 120)
        at (fn [x y] (aget ^ints (:px b) (+ (* y (:w b)) x)))]
    (r/clear b 0)
    (r/rect! b 10 10 5 5 0xff0000)
    (assert (= 0xff0000 (at 12 12)))
    (assert (= 0 (at 9 9)) "a rect must not bleed past its edge")
    (r/rect! b -5 -5 3 3 0x00ff00)                    ; offscreen, must not throw
    (r/line! b 0 0 199 119 0x0000ff)
    (assert (= 0x0000ff (at 0 0)))
    (r/clear b 0)
    (r/text! b 0 0 "A" 0xffffff 1)
    (assert (some #(= 0xffffff (at % 0)) (range 3)) "the glyph drew nothing")))

;; --- a component, through the real reconciler --------------------------------

(def ^:private clicks (ra/atom 0))

(defn- counter []
  [:card {}
   [:title {:label "Counter"}]
   [:label {:label (str "Count: " (ra/deref clicks))}]
   [:hbox {:spacing 8}
    [:button {:label "-1" :on-click #(ra/swap! clicks dec)}]
    [:button {:label "+1" :kind :primary :on-click #(ra/swap! clicks inc)}]]])

(defn- walk [n] (cons n (mapcat walk (:children @n))))
(defn- tagged [root tag] (first (filter #(= tag (:tag @%)) (walk root))))
(defn- buttons [root] (filter #(= :button (:tag @%)) (walk root)))
(defn- labelled? [root prefix]
  (some #(and (= :label (:tag @%))
              (str/starts-with? (str (:label (:props @%))) prefix))
        (walk root)))
(defn- centre [n]
  (let [[x y w h] (:rect @n)] [(+ x (quot w 2)) (+ y (quot h 2))]))

(defn- check-tree! [root]
  (assert (tagged root :card) "no card in the tree")
  (assert (= 2 (count (buttons root))) "expected two buttons")
  (assert (labelled? root "Count: 0") "the label did not render the ratom"))

(defn- check-layout! [root]
  (let [[cx cy]       (:rect @(tagged root :card))
        [tx ty]       (:rect @(tagged root :title))
        [_ by bw bh]  (:rect @(first (buttons root)))]
    (assert (= [0 0] [cx cy]) "the card should sit at the origin")
    (assert (= [10 10] [tx ty]) "a card must inset its child by PAD")
    (assert (and (pos? bw) (= 26 bh)) "button box is the wrong size")
    (assert (> by ty) "the title must be placed above the buttons"))
  ;; an hbox lays its children left to right, with the gap it was given
  (let [[b1 b2] (map #(:rect @%) (buttons root))]
    (assert (= (second b1) (second b2)) "hbox children must share a baseline")
    (assert (= (+ (first b1) (nth b1 2) 8) (first b2)) "hbox gap not honoured")))

(defn- check-clicks! [root buf]
  (let [plus  (second (buttons root))
        p     (centre plus)
        state (atom {})
        before (ra/deref clicks)]
    (gfx/render-once root buf 400 {:mouse p :down? true :released? false} state)
    (assert (= before (ra/deref clicks)) "a press alone must not fire the handler")
    (gfx/render-once root buf 400 {:mouse p :down? false :released? true} state)
    (assert (= (inc before) (ra/deref clicks)) "the click did not fire")
    (gfx/render-once root buf 400)
    (assert (labelled? root (str "Count: " (inc before)))
            "the reactive re-render never reached the tree")

    ;; press, then release somewhere else: not a click
    (gfx/render-once root buf 400 {:mouse p :down? true :released? false} state)
    (gfx/render-once root buf 400 {:mouse [399 239] :down? false :released? true} state)
    (assert (= (inc before) (ra/deref clicks)) "releasing off the button must not fire")))

(defn- check-painted! [root buf]
  (gfx/render-once root buf 400)
  (let [at (fn [x y] (aget ^ints (:px buf) (+ (* y (:w buf)) x)))
        [x y] (:rect @(tagged root :card))
        row   (+ 4 (second (:rect @(second (buttons root)))))]
    (assert (= (:card gfx/theme) (at (+ x 2) (+ y 2))) "card background not painted")
    (assert (some #(= (:accent gfx/theme) (at % row)) (range 400))
            "the primary button is not painted in the accent colour")))

(defn- check-scheduled! [root buf]
  ;; With a loop running, glimmer refuses to re-render inline and posts the work
  ;; through :schedule instead. That is the path a real window takes, and a
  ;; different one from every check above.
  (reset! backend/loop-running? true)
  (try
    (let [before (ra/deref clicks)
          p      (centre (second (buttons root)))
          state  (atom {})]
      (gfx/render-once root buf 400 {:mouse p :down? true :released? false} state)
      (gfx/render-once root buf 400 {:mouse p :down? false :released? true} state)
      (assert (= (inc before) (ra/deref clicks)) "the handler did not fire under a loop")
      (gfx/render-once root buf 400)              ; the next frame drains the queue
      (assert (labelled? root (str "Count: " (inc before)))
              "the scheduled re-render never reached the tree"))
    (finally (reset! backend/loop-running? false))))

;; --- asteroids ----------------------------------------------------------------

(defn- check-asteroids! []
  (assert (= [5.0 5.0] (ast/wrap [645.0 485.0])) "the world must wrap")
  (assert (ast/hit? [10 10] [12 12] 5))
  (assert (not (ast/hit? [10 10] [200 200] 5)))
  (assert (ast/hit? [5 5] [635 475] 20) "a hit across the seam still counts")
  (let [g (ast/new-game)
        ;; thrust moves the ship; nothing else does
        drifting (nth (iterate #(ast/step % #{0x77}) g) 5)]
    (assert (not= (get-in g [:ship :pos]) (get-in drifting [:ship :pos]))
            "thrust did not move the ship")
    (assert (:thrusting (:ship drifting)))
    ;; turning is a rotation, not a translation
    (let [turned (ast/step g #{0xff53})]
      (assert (pos? (get-in turned [:ship :angle])) "right did not turn"))
    ;; holding space auto-fires, but paced -- not one bullet per frame
    (let [a (ast/step g #{0x20})
          b (ast/step a #{0x20})
          held (nth (iterate #(ast/step % #{0x20}) g) 20)]
      (assert (= 1 (count (:bullets a))) "space did not fire")
      (assert (= 1 (count (:bullets b))) "the cooldown did not hold the trigger")
      (assert (< 1 (count (:bullets held)) 20) "auto-fire is off, or unpaced"))
    ;; a bullet placed on a rock splits it and scores
    (let [rk (assoc (first (:rocks g)) :pos [100 100] :vel [0 0] :size 3)
          st (ast/step (assoc g :rocks [rk]
                                :bullets [{:pos [100 100] :vel [0 0] :life 30}])
                       #{})]
      (assert (= 2 (count (:rocks st))) "the rock did not split in two")
      (assert (every? #(= 2 (:size %)) (:rocks st)) "the pieces are the wrong size")
      (assert (= 10 (:score st)) "no score for the hit")
      (assert (empty? (:bullets st)) "the bullet survived its own hit"))
    ;; the smallest rock leaves nothing behind, and an empty field respawns
    (let [rk (assoc (first (:rocks g)) :pos [100 100] :vel [0 0] :size 1)
          st (ast/step (assoc g :rocks [rk]
                                :bullets [{:pos [100 100] :vel [0 0] :life 30}])
                       #{})]
      (assert (seq (:rocks st)) "an empty field should respawn")
      (assert (every? #(= 3 (:size %)) (:rocks st)) "respawned rocks are not full size"))
    ;; a rock on top of the ship ends it
    (let [rk (assoc (first (:rocks g)) :pos (get-in g [:ship :pos]) :vel [0 0])]
      (assert (:lost? (ast/step (assoc g :rocks [rk]) #{}))))
    ;; and it all paints: poly! into a real framebuffer, nothing thrown
    (let [buf (r/buf 640 480)]
      (@#'ast/draw! buf (nth (iterate #(ast/step % #{0x77 0x20}) g) 30))
      (assert (some #(not= (:bg @#'ast/colours) %) (seq ^ints (:px buf)))
              "the frame painted nothing"))
    ;; bullets expire
    (let [st (ast/step (assoc g :bullets [{:pos [10 10] :vel [0 0] :life 1}]) #{})]
      (assert (empty? (:bullets st)) "the bullet outlived its life"))))

;; --- the maze -----------------------------------------------------------------

(defn- check-maze! []
  (let [level ["####" "#..#" "#..#" "####"]
        C 24]
    (assert (maze/wall? level 0 0))
    (assert (not (maze/wall? level 1 1)))
    (assert (maze/wall? level 9 9) "off the map must read as wall")
    (assert (maze/free? level C C) "the open cell should be free")
    (assert (not (maze/free? level (+ (* 2 C) 1) C))
            "a box straddling the far wall is not free")
    ;; walking into a wall costs the blocked axis only: this slides down it
    (let [p [C C]]
      (assert (= p (maze/move level p [-1 0])) "moved through a wall")
      (assert (= p (maze/move level p [0 0])))
      (let [[x y] (maze/move level [(* 2 C) C] [1 1])]
        (assert (= x (* 2 C)) "should have been stopped by the wall on the right")
        (assert (> y C) "but should still have slid downward")))
    ;; the dot under the player's centre is the one that goes
    (assert (= #{[2 1]} (maze/eat #{[1 1] [2 1]} [C C])))))

;; --- the game ----------------------------------------------------------------

(defn- check-tictactoe! []
  (let [empty (vec (repeat 9 nil))]
    (assert (nil? (ttt/winner empty)))
    (assert (= :x (ttt/winner [:x :x :x nil nil nil nil nil nil])))
    (assert (= :o (ttt/winner [:x :x nil nil nil nil :o :o :o])))
    (assert (nil? (ttt/winner [:x :x :o nil nil nil nil nil nil])))
    ;; X plays 4, O answers in the first free square
    (let [b (ttt/play empty 4)]
      (assert (= :x (b 4)) "X did not take the square it clicked")
      (assert (= :o (b 0)) "O did not reply"))
    ;; an occupied square, and a finished game, are both no-ops
    (assert (= (ttt/play empty 4) (ttt/play (ttt/play empty 4) 4)))
    (let [won [:x :x :x :o :o nil nil nil nil]]
      (assert (= won (ttt/play won 5)) "the board moved after the game was over"))
    ;; a winning move ends it: no reply gets appended
    (let [b (ttt/play [:x :x nil :o :o nil nil nil nil] 2)]
      (assert (= :x (ttt/winner b)))
      (assert (nil? (b 5)) "O replied to a move that had already won"))))

(defn -main [& _]
  (check-raster!)
  (check-tictactoe!)
  (check-maze!)
  (check-asteroids!)
  (let [root (gfx/root-node)
        buf  (r/buf 400 240)]
    (gui/mount root :vbox [counter])
    (gfx/render-once root buf 400)
    (check-tree! root)
    (check-layout! root)
    (check-clicks! root buf)
    (check-painted! root buf)
    (check-scheduled! root buf))
  (println "ok"))