1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222

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