nandi/jolt-native · core.clj

⑂ main

core.clj · 245 lines · 9.7 KBClojure    Blame HistoryRaw
Paint glimmer with nothing under it   1(ns glimmer-gfx.core
"A glimmer backend that paints with gfx's software rasterizer.
glimmer owns the reactive core -- ratoms, components, the reconciler -- and
knows nothing about any toolkit. glimmer-gtk fills that in with GtkWidgets and
glimmer-vidya with a Rust node arena painted by egui. This fills it in with
`gfx.raster`, so the same components render to pixels this project computes
itself, with no toolkit underneath.
A widget here is an atom holding {:tag :props :children :size :rect}. The
reconciler mutates that tree; once a frame the loop measures it, places it,
paints it, and dispatches the mouse against the rects it just computed.
What the reconciler patches is a RETAINED tree, which gfx.core is not -- its
widgets draw and return in one call. So this namespace is the second half that
an immediate-mode library does not have: a tree to hold still between frames.
glimmer-vidya needed the same thing and built it in Rust behind a second C
ABI; here it is 60 lines of Clojure, because there is no ABI to cross."
(:require [glimmer.backend :as b]
          [glimmer-gfx.raster :as r]
          [glimmer-gfx.x11 :as w]))
23(def theme {:bg 0x1c1e26 :card 0x22252e :panel 0x373b49 :hot 0x46506e
          :active 0x5a6ea0 :fg 0xffffff :dim 0x9aa0b0 :accent 0x5a6ea0})
26(def ^:private PAD 10)       ; container inset
27(def ^:private GAP 6)        ; default gap between siblings
28(def ^:private LINE 14)      ; label box height at scale 2
29(def ^:private BTN-H 26)
30(def ^:private ROW-H 20)
32;; --- the widget tree ---------------------------------------------------------
34(defn- node [tag props] (atom {:tag tag :props props :children []}))
36(defn- create! [tag props] (node tag props))
37(defn- apply-props! [_tag n props] (swap! n assoc :props props) nil)
38(defn- append-child! [_t parent child] (swap! parent update :children conj child) nil)
39(defn- remove-child! [_t parent child]
(swap! parent update :children #(vec (remove #{child} %))) nil)
41(defn- replace-child! [_t parent old new]
(swap! parent update :children #(mapv (fn [c] (if (= c old) new c)) %)) nil)
43(defn- reorder-child! [_t parent child sibling]
(swap! parent update :children
       (fn [cs]
         (let [cs (vec (remove #{child} cs))
               i  (if (nil? sibling) 0 (inc (.indexOf cs sibling)))]
           (vec (concat (subvec cs 0 i) [child] (subvec cs i))))))
51;; --- measure -----------------------------------------------------------------
52;; Bottom-up: every node learns its own [w h] given the width available to it.
54(defn- container? [tag] (contains? #{:vbox :hbox :card :page} tag))
55(defn- horizontal? [n] (= :hbox (:tag @n)))
56(defn- inset [tag] (if (#{:card :page} tag) PAD 0))
57(defn- txt [props] (str (or (:label props) (:text props) "")))
59(defn- measure! [n avail]
(let [{:keys [tag props children]} @n
      gap   (or (:spacing props) GAP)
      pad   (inset tag)
      avail (- (min avail (or (:max-width props) avail)) (* 2 pad))
      size
      (cond
        (container? tag)
        (let [sizes (mapv #(measure! % avail) children)
              ws (map first sizes) hs (map second sizes)
              n' (max 0 (dec (count children)))]
          (if (= :hbox tag)
            [(+ (reduce + 0 ws) (* gap n')) (reduce max 0 hs)]
            [(reduce max 0 ws) (+ (reduce + 0 hs) (* gap n'))]))
        (= :title tag)    [(r/text-w (txt props) 3) 22]
        (= :label tag)    [(r/text-w (txt props) 2) LINE]
        (= :button tag)   [(+ 24 (r/text-w (txt props) 2)) BTN-H]
        (= :checkbox tag) [(+ 24 (r/text-w (txt props) 2)) ROW-H]
        (= :slider tag)   [(min avail 200) ROW-H]
        (= :spacer tag)   [0 (or (:size props) 8)]
        :else             [(r/text-w (txt props) 2) LINE])
      size [(+ (first size) (* 2 pad)) (+ (second size) (* 2 pad))]]
  (swap! n assoc :size size)
83
85;; --- place -------------------------------------------------------------------
86;; Top-down: every node learns where it sits. Children keep their measured
87;; width, left-aligned. ponytail: no :align/:grow -- add them when a layout
88;; actually needs to stretch.
90(defn- place! [n x y]
(let [{:keys [tag props children size]} @n
      pad (inset tag)
      gap (or (:spacing props) GAP)]
  (swap! n assoc :rect (into [x y] size))
  (loop [cs children, cx (+ x pad), cy (+ y pad)]
    (when-let [c (first cs)]
      (place! c cx cy)
      (let [[cw ch] (:size @c)]
        (if (= :hbox tag)
          (recur (rest cs) (+ cx cw gap) cy)
          (recur (rest cs) cx (+ cy ch gap))))))))
103;; --- paint -------------------------------------------------------------------
105(defn- paint! [buf n hot active]
(let [{:keys [tag props children rect]} @n
      [x y wd ht] rect
      s (txt props)]
  (case tag
    :card (r/rect! buf x y wd ht (:card theme))
    :page nil
    (:vbox :hbox) nil
    :title (r/text! buf x (+ y 4) s (:fg theme) 3)
    :label (r/text! buf x (+ y 2) s (if (:dim props) (:dim theme) (:fg theme)) 2)
    :button
    (do (r/rect! buf x y wd ht
                 (cond (= n active) (:active theme)
                       (= n hot)    (:hot theme)
                       (= :primary (:kind props)) (:accent theme)
                       :else        (:panel theme)))
        (r/text! buf (+ x (quot (- wd (r/text-w s 2)) 2)) (+ y 8) s (:fg theme) 2))
    :checkbox
    (do (r/rect! buf x (+ y 3) 14 14 (:panel theme))
        (when (:checked props) (r/rect! buf (+ x 3) (+ y 6) 8 8 (:accent theme)))
        (r/text! buf (+ x 20) (+ y 4) s (:fg theme) 2))
    :slider
    (let [{:keys [value min max] :or {value 0 min 0 max 100}} props
          t (if (= max min) 0 (/ (- value min) (double (- max min))))]
      (r/rect! buf x y wd ht (:panel theme))
      (r/rect! buf x y (int (* wd t)) ht (:accent theme))
      (r/text! buf (+ x 6) (+ y 5) (str (long value)) (:fg theme) 2))
132
  (doseq [c children] (paint! buf c hot active))))
135;; --- hit testing and events --------------------------------------------------
137(defn- interactive? [n]
(let [{:keys [tag props]} @n]
  (or (= :slider tag) (:on-click props) (:on-change props))))
141(defn- in? [[x y wd ht] [mx my]]
(and (<= x mx (+ x wd)) (<= y my (+ y ht))))
144
"Deepest interactive node under the point. Children paint over parents, so
 the last match wins."
(let [{:keys [children rect]} @n]
  (or (some #(hit % p) (reverse children))
      (when (and rect (in? rect p) (interactive? n)) n))))
152(defn- fire! [n k & args]
(when-let [f (get (:props @n) k)] (apply f args)))
155(defn- slider-value [n [mx _]]
(let [{:keys [props rect]} @n
      {:keys [min max] :or {min 0 max 100}} props
      [x _ wd _] rect]
  (-> (- mx x) (/ (double wd)) (clojure.core/max 0.0) (clojure.core/min 1.0)
      (* (- max min)) (+ min))))
162(defn- dispatch!
"Route one frame of mouse input against the rects just placed."
[root input state]
(let [{:keys [mouse down? released?]} input
      {:keys [active prev-down]} @state
      over (hit root mouse)]
  (swap! state assoc :hot over :prev-down down?)
169
    ;; press edge: claim the widget under the cursor
    (and down? (not prev-down))
    (do (swap! state assoc :active over)
        (when (and over (= :slider (:tag @over)))
          (fire! over :on-change (slider-value over mouse))))
    ;; drag: only a slider tracks outside its own rect
    (and down? active (= :slider (:tag @active)))
    (fire! active :on-change (slider-value active mouse))
    released?
    (do (when (and active (= active over)) (fire! active :on-click))
        (swap! state assoc :active nil)))))
184;; --- the loop ----------------------------------------------------------------
186(defonce ^:private pending (atom []))
188(defn- schedule! [work]
(swap! pending conj work) nil)
191(defn- drain-pending! []
(let [[ws] (reset-vals! pending [])]
  (doseq [w ws] (w))))
195(defn- run!
"glimmer.backend's :run. Creates the root container, mounts into it, then owns
 the loop until the window closes."
[opts mount-root!]
(let [{:keys [title width height auto-quit-ms]
       :or {title "glimmer" width 480 height 320}} opts
      root  (create! :vbox {:padding PAD})
      state (atom {})]
  (mount-root! root :vbox)
  (reset! b/loop-running? true)
205
    (w/run-window
      {:width width :height height :title title :auto-quit-ms auto-quit-ms}
      (fn [buf input]
        (drain-pending!)                    ; re-renders queued by handlers
        (measure! root width)
        (place! root 0 0)
        (dispatch! root input state)
        (r/clear buf (:bg theme))
        (paint! buf root (:hot @state) (:active @state))))
    (finally (reset! b/loop-running? false)))))
217;; --- registration ------------------------------------------------------------
219(def backend
{:name :gfx
 :create! create!             :apply-props!   apply-props!
 :append-child! append-child! :remove-child!  remove-child!
 :replace-child! replace-child! :reorder-child! reorder-child!
 :schedule schedule!          :run            run!})
226(b/register! backend)
228;; --- headless driving, for tests ---------------------------------------------
230(defn render-once
"Measure, place and paint `root` into `buf` with no window. Returns the state
 atom after dispatching `input`, so a test can drive clicks without X11."
([root buf w] (render-once root buf w {:mouse [-1 -1] :down? false} (atom {})))
([root buf w input state]
 (drain-pending!)                       ; same order as the real loop
 (measure! root w)
 (place! root 0 0)
 (dispatch! root input state)
 (r/clear buf (:bg theme))
 (paint! buf root (:hot @state) (:active @state))
241
243(defn root-node
"A bare root container, for mounting into without a window."
[] (create! :vbox {}))

Paint glimmer with nothing under it f554a01 nandi 12d ago	1	(ns glimmer-gfx.core
	2	"A glimmer backend that paints with gfx's software rasterizer.
	3
	4	glimmer owns the reactive core -- ratoms, components, the reconciler -- and
	5	knows nothing about any toolkit. glimmer-gtk fills that in with GtkWidgets and
	6	glimmer-vidya with a Rust node arena painted by egui. This fills it in with
	7	`gfx.raster`, so the same components render to pixels this project computes
	8	itself, with no toolkit underneath.
	9
	10	A widget here is an atom holding {:tag :props :children :size :rect}. The
	11	reconciler mutates that tree; once a frame the loop measures it, places it,
	12	paints it, and dispatches the mouse against the rects it just computed.
	13
	14	What the reconciler patches is a RETAINED tree, which gfx.core is not -- its
	15	widgets draw and return in one call. So this namespace is the second half that
	16	an immediate-mode library does not have: a tree to hold still between frames.
	17	glimmer-vidya needed the same thing and built it in Rust behind a second C
	18	ABI; here it is 60 lines of Clojure, because there is no ABI to cross."
	19	(:require [glimmer.backend :as b]
	20	[glimmer-gfx.raster :as r]
	21	[glimmer-gfx.x11 :as w]))
	22
	23	(def theme {:bg 0x1c1e26 :card 0x22252e :panel 0x373b49 :hot 0x46506e
	24	:active 0x5a6ea0 :fg 0xffffff :dim 0x9aa0b0 :accent 0x5a6ea0})
	25
	26	(def ^:private PAD 10) ; container inset
	27	(def ^:private GAP 6) ; default gap between siblings
	28	(def ^:private LINE 14) ; label box height at scale 2
	29	(def ^:private BTN-H 26)
	30	(def ^:private ROW-H 20)
	31
	32	;; --- the widget tree ---------------------------------------------------------
	33
	34	(defn- node [tag props] (atom {:tag tag :props props :children []}))
	35
	36	(defn- create! [tag props] (node tag props))
	37	(defn- apply-props! [_tag n props] (swap! n assoc :props props) nil)
	38	(defn- append-child! [_t parent child] (swap! parent update :children conj child) nil)
	39	(defn- remove-child! [_t parent child]
	40	(swap! parent update :children #(vec (remove #{child} %))) nil)
	41	(defn- replace-child! [_t parent old new]
	42	(swap! parent update :children #(mapv (fn [c] (if (= c old) new c)) %)) nil)
	43	(defn- reorder-child! [_t parent child sibling]
	44	(swap! parent update :children
	45	(fn [cs]
	46	(let [cs (vec (remove #{child} cs))
	47	i (if (nil? sibling) 0 (inc (.indexOf cs sibling)))]
	48	(vec (concat (subvec cs 0 i) [child] (subvec cs i))))))
	49	nil)
	50
	51	;; --- measure -----------------------------------------------------------------
	52	;; Bottom-up: every node learns its own [w h] given the width available to it.
	53
	54	(defn- container? [tag] (contains? #{:vbox :hbox :card :page} tag))
	55	(defn- horizontal? [n] (= :hbox (:tag @n)))
	56	(defn- inset [tag] (if (#{:card :page} tag) PAD 0))
	57	(defn- txt [props] (str (or (:label props) (:text props) "")))
	58
	59	(defn- measure! [n avail]
	60	(let [{:keys [tag props children]} @n
	61	gap (or (:spacing props) GAP)
	62	pad (inset tag)
	63	avail (- (min avail (or (:max-width props) avail)) (* 2 pad))
	64	size
65	(cond
66	(container? tag)
67	(let [sizes (mapv #(measure! % avail) children)
68	ws (map first sizes) hs (map second sizes)
69	n' (max 0 (dec (count children)))]
70	(if (= :hbox tag)
71	[(+ (reduce + 0 ws) (* gap n')) (reduce max 0 hs)]
72	[(reduce max 0 ws) (+ (reduce + 0 hs) (* gap n'))]))
73
74	(= :title tag) [(r/text-w (txt props) 3) 22]
75	(= :label tag) [(r/text-w (txt props) 2) LINE]
76	(= :button tag) [(+ 24 (r/text-w (txt props) 2)) BTN-H]
77	(= :checkbox tag) [(+ 24 (r/text-w (txt props) 2)) ROW-H]
78	(= :slider tag) [(min avail 200) ROW-H]
79	(= :spacer tag) [0 (or (:size props) 8)]
80	:else [(r/text-w (txt props) 2) LINE])
81	size [(+ (first size) (* 2 pad)) (+ (second size) (* 2 pad))]]
82	(swap! n assoc :size size)
83	size))
84
85	;; --- place -------------------------------------------------------------------
86	;; Top-down: every node learns where it sits. Children keep their measured
87	;; width, left-aligned. ponytail: no :align/:grow -- add them when a layout
88	;; actually needs to stretch.
89
90	(defn- place! [n x y]
91	(let [{:keys [tag props children size]} @n
92	pad (inset tag)
93	gap (or (:spacing props) GAP)]
94	(swap! n assoc :rect (into [x y] size))
95	(loop [cs children, cx (+ x pad), cy (+ y pad)]
96	(when-let [c (first cs)]
97	(place! c cx cy)
98	(let [[cw ch] (:size @c)]
99	(if (= :hbox tag)
100	(recur (rest cs) (+ cx cw gap) cy)
101	(recur (rest cs) cx (+ cy ch gap))))))))
102
103	;; --- paint -------------------------------------------------------------------
104
105	(defn- paint! [buf n hot active]
106	(let [{:keys [tag props children rect]} @n
107	[x y wd ht] rect
108	s (txt props)]
109	(case tag
110	:card (r/rect! buf x y wd ht (:card theme))
111	:page nil
112	(:vbox :hbox) nil
113	:title (r/text! buf x (+ y 4) s (:fg theme) 3)
114	:label (r/text! buf x (+ y 2) s (if (:dim props) (:dim theme) (:fg theme)) 2)
115	:button
116	(do (r/rect! buf x y wd ht
117	(cond (= n active) (:active theme)
118	(= n hot) (:hot theme)
119	(= :primary (:kind props)) (:accent theme)
120	:else (:panel theme)))
121	(r/text! buf (+ x (quot (- wd (r/text-w s 2)) 2)) (+ y 8) s (:fg theme) 2))
122	:checkbox
123	(do (r/rect! buf x (+ y 3) 14 14 (:panel theme))
124	(when (:checked props) (r/rect! buf (+ x 3) (+ y 6) 8 8 (:accent theme)))
125	(r/text! buf (+ x 20) (+ y 4) s (:fg theme) 2))
126	:slider
127	(let [{:keys [value min max] :or {value 0 min 0 max 100}} props
128	t (if (= max min) 0 (/ (- value min) (double (- max min))))]
129	(r/rect! buf x y wd ht (:panel theme))
130	(r/rect! buf x y (int (* wd t)) ht (:accent theme))
131	(r/text! buf (+ x 6) (+ y 5) (str (long value)) (:fg theme) 2))
132	nil)
133	(doseq [c children] (paint! buf c hot active))))
134
135	;; --- hit testing and events --------------------------------------------------
136
137	(defn- interactive? [n]
138	(let [{:keys [tag props]} @n]
139	(or (= :slider tag) (:on-click props) (:on-change props))))
140
141	(defn- in? [[x y wd ht] [mx my]]
142	(and (<= x mx (+ x wd)) (<= y my (+ y ht))))
143
144	(defn- hit
145	"Deepest interactive node under the point. Children paint over parents, so
146	the last match wins."
147	[n p]
148	(let [{:keys [children rect]} @n]
149	(or (some #(hit % p) (reverse children))
150	(when (and rect (in? rect p) (interactive? n)) n))))
151
152	(defn- fire! [n k & args]
153	(when-let [f (get (:props @n) k)] (apply f args)))
154
155	(defn- slider-value [n [mx _]]
156	(let [{:keys [props rect]} @n
157	{:keys [min max] :or {min 0 max 100}} props
158	[x _ wd _] rect]
159	(-> (- mx x) (/ (double wd)) (clojure.core/max 0.0) (clojure.core/min 1.0)
160	(* (- max min)) (+ min))))
161
162	(defn- dispatch!
163	"Route one frame of mouse input against the rects just placed."
164	[root input state]
165	(let [{:keys [mouse down? released?]} input
166	{:keys [active prev-down]} @state
167	over (hit root mouse)]
168	(swap! state assoc :hot over :prev-down down?)
169	(cond
170	;; press edge: claim the widget under the cursor
171	(and down? (not prev-down))
172	(do (swap! state assoc :active over)
173	(when (and over (= :slider (:tag @over)))
174	(fire! over :on-change (slider-value over mouse))))
175
176	;; drag: only a slider tracks outside its own rect
177	(and down? active (= :slider (:tag @active)))
178	(fire! active :on-change (slider-value active mouse))
179
180	released?
181	(do (when (and active (= active over)) (fire! active :on-click))
182	(swap! state assoc :active nil)))))
183
184	;; --- the loop ----------------------------------------------------------------
185
186	(defonce ^:private pending (atom []))
187
188	(defn- schedule! [work]
189	(swap! pending conj work) nil)
190
191	(defn- drain-pending! []
192	(let [[ws] (reset-vals! pending [])]
193	(doseq [w ws] (w))))
194
195	(defn- run!
196	"glimmer.backend's :run. Creates the root container, mounts into it, then owns
197	the loop until the window closes."
198	[opts mount-root!]
199	(let [{:keys [title width height auto-quit-ms]
200	:or {title "glimmer" width 480 height 320}} opts
201	root (create! :vbox {:padding PAD})
202	state (atom {})]
203	(mount-root! root :vbox)
204	(reset! b/loop-running? true)
205	(try
206	(w/run-window
207	{:width width :height height :title title :auto-quit-ms auto-quit-ms}
208	(fn [buf input]
209	(drain-pending!) ; re-renders queued by handlers
210	(measure! root width)
211	(place! root 0 0)
212	(dispatch! root input state)
213	(r/clear buf (:bg theme))
214	(paint! buf root (:hot @state) (:active @state))))
215	(finally (reset! b/loop-running? false)))))
216
217	;; --- registration ------------------------------------------------------------
218
219	(def backend
220	{:name :gfx
221	:create! create! :apply-props! apply-props!
222	:append-child! append-child! :remove-child! remove-child!
223	:replace-child! replace-child! :reorder-child! reorder-child!
224	:schedule schedule! :run run!})
225
226	(b/register! backend)
227
228	;; --- headless driving, for tests ---------------------------------------------
229
230	(defn render-once
231	"Measure, place and paint `root` into `buf` with no window. Returns the state
232	atom after dispatching `input`, so a test can drive clicks without X11."
233	([root buf w] (render-once root buf w {:mouse [-1 -1] :down? false} (atom {})))
234	([root buf w input state]
235	(drain-pending!) ; same order as the real loop
236	(measure! root w)
237	(place! root 0 0)
238	(dispatch! root input state)
239	(r/clear buf (:bg theme))
240	(paint! buf root (:hot @state) (:active @state))
241	state))
242
243	(defn root-node
244	"A bare root container, for mounting into without a window."
245	[] (create! :vbox {}))