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