nandi/jolt-native · tests.clj

⑂ 789bb134c91bfdee346df2dc9656bf2e7f9bbd1a

tests.clj · 123 lines · 5.4 KBClojure    Blame HistoryRaw
Paint glimmer with nothing under it   1(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]))
12;; --- the rasterizer ----------------------------------------------------------
14(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")))
28;; --- a component, through the real reconciler --------------------------------
30(def ^:private clicks (ra/atom 0))
32(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)}]]])
40(defn- walk [n] (cons n (mapcat walk (:children @n))))
41(defn- tagged [root tag] (first (filter #(= tag (:tag @%)) (walk root))))
42(defn- buttons [root] (filter #(= :button (:tag @%)) (walk root)))
43(defn- labelled? [root prefix]
(some #(and (= :label (:tag @%))
            (str/starts-with? (str (:label (:props @%))) prefix))
      (walk root)))
47(defn- centre [n]
(let [[x y w h] (:rect @n)] [(+ x (quot w 2)) (+ y (quot h 2))]))
50(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"))
55(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")))
68(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")))
86(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")))
95(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)
  (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))))
112(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"))

Paint glimmer with nothing under it f554a01 nandi 12d ago	1	(ns glimmer-gfx.tests
	2	"Every check here runs headless: the backend measures, places, paints and
	3	dispatches into a plain framebuffer, so none of it needs a window or a
	4	display. `jolt test`."
	5	(:require [glimmer.ratom :as ra]
	6	[glimmer.core :as gui]
	7	[glimmer.backend :as backend]
	8	[glimmer-gfx.core :as gfx]
	9	[glimmer-gfx.raster :as r]
	10	[clojure.string :as str]))
	11
	12	;; --- the rasterizer ----------------------------------------------------------
	13
	14	(defn- check-raster! []
	15	(let [b (r/buf 200 120)
	16	at (fn [x y] (aget ^ints (:px b) (+ (* y (:w b)) x)))]
	17	(r/clear b 0)
	18	(r/rect! b 10 10 5 5 0xff0000)
	19	(assert (= 0xff0000 (at 12 12)))
	20	(assert (= 0 (at 9 9)) "a rect must not bleed past its edge")
	21	(r/rect! b -5 -5 3 3 0x00ff00) ; offscreen, must not throw
	22	(r/line! b 0 0 199 119 0x0000ff)
	23	(assert (= 0x0000ff (at 0 0)))
	24	(r/clear b 0)
	25	(r/text! b 0 0 "A" 0xffffff 1)
	26	(assert (some #(= 0xffffff (at % 0)) (range 3)) "the glyph drew nothing")))
	27
	28	;; --- a component, through the real reconciler --------------------------------
	29
	30	(def ^:private clicks (ra/atom 0))
	31
	32	(defn- counter []
	33	[:card {}
	34	[:title {:label "Counter"}]
	35	[:label {:label (str "Count: " (ra/deref clicks))}]
	36	[:hbox {:spacing 8}
	37	[:button {:label "-1" :on-click #(ra/swap! clicks dec)}]
	38	[:button {:label "+1" :kind :primary :on-click #(ra/swap! clicks inc)}]]])
	39
	40	(defn- walk [n] (cons n (mapcat walk (:children @n))))
	41	(defn- tagged [root tag] (first (filter #(= tag (:tag @%)) (walk root))))
	42	(defn- buttons [root] (filter #(= :button (:tag @%)) (walk root)))
	43	(defn- labelled? [root prefix]
	44	(some #(and (= :label (:tag @%))
	45	(str/starts-with? (str (:label (:props @%))) prefix))
	46	(walk root)))
	47	(defn- centre [n]
	48	(let [[x y w h] (:rect @n)] [(+ x (quot w 2)) (+ y (quot h 2))]))
	49
	50	(defn- check-tree! [root]
	51	(assert (tagged root :card) "no card in the tree")
	52	(assert (= 2 (count (buttons root))) "expected two buttons")
	53	(assert (labelled? root "Count: 0") "the label did not render the ratom"))
	54
	55	(defn- check-layout! [root]
	56	(let [[cx cy] (:rect @(tagged root :card))
	57	[tx ty] (:rect @(tagged root :title))
	58	[_ by bw bh] (:rect @(first (buttons root)))]
	59	(assert (= [0 0] [cx cy]) "the card should sit at the origin")
	60	(assert (= [10 10] [tx ty]) "a card must inset its child by PAD")
	61	(assert (and (pos? bw) (= 26 bh)) "button box is the wrong size")
	62	(assert (> by ty) "the title must be placed above the buttons"))
	63	;; an hbox lays its children left to right, with the gap it was given
	64	(let [[b1 b2] (map #(:rect @%) (buttons root))]
65	(assert (= (second b1) (second b2)) "hbox children must share a baseline")
66	(assert (= (+ (first b1) (nth b1 2) 8) (first b2)) "hbox gap not honoured")))
67
68	(defn- check-clicks! [root buf]
69	(let [plus (second (buttons root))
70	p (centre plus)
71	state (atom {})
72	before (ra/deref clicks)]
73	(gfx/render-once root buf 400 {:mouse p :down? true :released? false} state)
74	(assert (= before (ra/deref clicks)) "a press alone must not fire the handler")
75	(gfx/render-once root buf 400 {:mouse p :down? false :released? true} state)
76	(assert (= (inc before) (ra/deref clicks)) "the click did not fire")
77	(gfx/render-once root buf 400)
78	(assert (labelled? root (str "Count: " (inc before)))
79	"the reactive re-render never reached the tree")
80
81	;; press, then release somewhere else: not a click
82	(gfx/render-once root buf 400 {:mouse p :down? true :released? false} state)
83	(gfx/render-once root buf 400 {:mouse [399 239] :down? false :released? true} state)
84	(assert (= (inc before) (ra/deref clicks)) "releasing off the button must not fire")))
85
86	(defn- check-painted! [root buf]
87	(gfx/render-once root buf 400)
88	(let [at (fn [x y] (aget ^ints (:px buf) (+ (* y (:w buf)) x)))
89	[x y] (:rect @(tagged root :card))
90	row (+ 4 (second (:rect @(second (buttons root)))))]
91	(assert (= (:card gfx/theme) (at (+ x 2) (+ y 2))) "card background not painted")
92	(assert (some #(= (:accent gfx/theme) (at % row)) (range 400))
93	"the primary button is not painted in the accent colour")))
94
95	(defn- check-scheduled! [root buf]
96	;; With a loop running, glimmer refuses to re-render inline and posts the work
97	;; through :schedule instead. That is the path a real window takes, and a
98	;; different one from every check above.
99	(reset! backend/loop-running? true)
100	(try
101	(let [before (ra/deref clicks)
102	p (centre (second (buttons root)))
103	state (atom {})]
104	(gfx/render-once root buf 400 {:mouse p :down? true :released? false} state)
105	(gfx/render-once root buf 400 {:mouse p :down? false :released? true} state)
106	(assert (= (inc before) (ra/deref clicks)) "the handler did not fire under a loop")
107	(gfx/render-once root buf 400) ; the next frame drains the queue
108	(assert (labelled? root (str "Count: " (inc before)))
109	"the scheduled re-render never reached the tree"))
110	(finally (reset! backend/loop-running? false))))
111
112	(defn -main [& _]
113	(check-raster!)
114	(let [root (gfx/root-node)
115	buf (r/buf 400 240)]
116	(gui/mount root :vbox [counter])
117	(gfx/render-once root buf 400)
118	(check-tree! root)
119	(check-layout! root)
120	(check-clicks! root buf)
121	(check-painted! root buf)
122	(check-scheduled! root buf))
123	(println "ok"))