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

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

(defn -main [& _]
  (check-raster!)
  (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"))