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
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245

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

(def theme {:bg 0x1c1e26 :card 0x22252e :panel 0x373b49 :hot 0x46506e
            :active 0x5a6ea0 :fg 0xffffff :dim 0x9aa0b0 :accent 0x5a6ea0})

(def ^:private PAD 10)       ; container inset
(def ^:private GAP 6)        ; default gap between siblings
(def ^:private LINE 14)      ; label box height at scale 2
(def ^:private BTN-H 26)
(def ^:private ROW-H 20)

;; --- the widget tree ---------------------------------------------------------

(defn- node [tag props] (atom {:tag tag :props props :children []}))

(defn- create! [tag props] (node tag props))
(defn- apply-props! [_tag n props] (swap! n assoc :props props) nil)
(defn- append-child! [_t parent child] (swap! parent update :children conj child) nil)
(defn- remove-child! [_t parent child]
  (swap! parent update :children #(vec (remove #{child} %))) nil)
(defn- replace-child! [_t parent old new]
  (swap! parent update :children #(mapv (fn [c] (if (= c old) new c)) %)) nil)
(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))))))
  nil)

;; --- measure -----------------------------------------------------------------
;; Bottom-up: every node learns its own [w h] given the width available to it.

(defn- container? [tag] (contains? #{:vbox :hbox :card :page} tag))
(defn- horizontal? [n] (= :hbox (:tag @n)))
(defn- inset [tag] (if (#{:card :page} tag) PAD 0))
(defn- txt [props] (str (or (:label props) (:text props) "")))

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

;; --- place -------------------------------------------------------------------
;; Top-down: every node learns where it sits. Children keep their measured
;; width, left-aligned. ponytail: no :align/:grow -- add them when a layout
;; actually needs to stretch.

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

;; --- paint -------------------------------------------------------------------

(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))
      nil)
    (doseq [c children] (paint! buf c hot active))))

;; --- hit testing and events --------------------------------------------------

(defn- interactive? [n]
  (let [{:keys [tag props]} @n]
    (or (= :slider tag) (:on-click props) (:on-change props))))

(defn- in? [[x y wd ht] [mx my]]
  (and (<= x mx (+ x wd)) (<= y my (+ y ht))))

(defn- hit
  "Deepest interactive node under the point. Children paint over parents, so
   the last match wins."
  [n p]
  (let [{:keys [children rect]} @n]
    (or (some #(hit % p) (reverse children))
        (when (and rect (in? rect p) (interactive? n)) n))))

(defn- fire! [n k & args]
  (when-let [f (get (:props @n) k)] (apply f args)))

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

(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?)
    (cond
      ;; 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)))))

;; --- the loop ----------------------------------------------------------------

(defonce ^:private pending (atom []))

(defn- schedule! [work]
  (swap! pending conj work) nil)

(defn- drain-pending! []
  (let [[ws] (reset-vals! pending [])]
    (doseq [w ws] (w))))

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

;; --- registration ------------------------------------------------------------

(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!})

(b/register! backend)

;; --- headless driving, for tests ---------------------------------------------

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

(defn root-node
  "A bare root container, for mounting into without a window."
  [] (create! :vbox {}))