honeylisp/editor/imgui.fnl

(local core (require :core))
(local config (require :core.config))
(local command (require :core.command))
(local keymap (require :core.keymap))
(local style (require :core.style))
(local lume (require :lib.lume))

(fn attach-imstate [view]
  (set view.imstate {})
  (fn view.on_mouse_pressed [self button x y clicks]
    (tset self.imstate button :pressed)
    (self.__index.on_mouse_pressed self button x y clicks))
  (fn view.on_mouse_released [self button x y]
    (tset self.imstate button :released)
    (self.__index.on_mouse_released self button x y))
  (fn view.on_key_pressed [self key]
    (when (= self.imstate.keys nil)
      (set self.imstate.keys []))
    (table.insert self.imstate.keys key))
  (fn view.on_text_input [self text]
    (set self.imstate.text (.. (or self.imstate.text "") text))
    (self.__index.on_text_input self text))
  (fn view.form [self ?overrides]
    (lume.merge {:x (+ self.position.x style.padding.x (- self.scroll.x))
                 :y (+ self.position.y style.padding.y (- self.scroll.y))
                 :w (- self.size.x (* style.padding.x 2))
                 :view self}
                (or ?overrides {})))
  (fn view.end-scroll [self {: y : h}]
    (let [pin-to-bottom (>= self.scroll.to.y (- self.scrollheight self.size.y))]
      (set self.scrollheight (- (+ y (or h 0) style.padding.y) (+ self.position.y style.padding.y (- self.scroll.y))))
      (when pin-to-bottom (set self.scroll.to.y (- self.scrollheight self.size.y)))))
  (fn view.draw [self]
    (set self.cursor nil)
    (self.__index.draw self)
    (when self.imstate.postponed
      (each [_ action (ipairs self.imstate.postponed)]
        (action))
      (set self.imstate.postponed nil))
    (when (= self.cursor nil) (set self.cursor :arrow))
    (set self.imstate.keys nil)
    (set self.imstate.text nil)
    (when (= self.imstate.left :released)
      (set self.imstate.active nil))
    (each [_ button (pairs [:left :middle :right])]
      (tset self.imstate button
        (match (. self.imstate button)
          :pressed  :down
          :down     :down
          :released nil)))))

(fn register-keys [keys]
  (local commands {})
  (local keymaps {})
  (each [_ key (ipairs keys)]
    (local command-name (.. "imstate:" key))
    (tset commands command-name #(core.active_view:on_key_pressed key))
    (tset keymaps key command-name))
  (command.add #(not= (-?> core.active_view.imstate (. :focus)) nil) commands)
  (keymap.add keymaps))

(register-keys [:backspace :delete :left :right :shift+left :shift+right :home :end :shift+home :shift+end
                :ctrl+left :ctrl+right :ctrl+shift+left :ctrl+shift+right :ctrl+c :ctrl+v])

(fn cmd-predicate [p]
  (var p-fn p)
  (when (= (type p-fn) :string) (set p-fn (require p-fn)))
  (when (= (type p-fn) :table)
    (local cls p-fn)
    (set p-fn (fn [] (core.active_view:is cls))))
  (fn [] (when (= (-?> core.active_view.imstate (. :focus)) nil)
           (p-fn))))

(fn postpone [view f]
  (when (= view.imstate.postponed nil)
    (set view.imstate.postponed []))
  (table.insert view.imstate.postponed f))

(fn make-tag [tag]
  (match (type tag)
    :string tag
    :table  (table.concat tag "::")
    _       (tostring tag)))

(fn mouse-inside [x y w h]
  (local (mx my) (values (love.mouse.getX) (love.mouse.getY)))
  (and (>= mx x) (<= mx (+ x w)) (>= my y) (<= my (+ y h))))

(fn consume-pressed [view button]
  (when (= (. view.imstate button) :pressed)
    (tset view.imstate button :down)
    true))

(fn activate [{: view : tag : x : y : w : h}]
  (when (and (mouse-inside x y w h) (consume-pressed view :left))
    (set view.imstate.active (make-tag tag))
    true))

(fn set-cursor [view cursor]
  (when (= view.cursor nil) (set view.cursor cursor)))

;; styling and layout
(fn form-defaults [form k v ...]
  (when (= (. form k) nil)
    (let [v (if (= (type v) :function) (v form) v)]
      (tset form k v)))
  (if (>= (select :# ...) 2) (form-defaults form ...)
    (do (when form.tag (set form.tag (make-tag form.tag))) ; fix up tag
        form)))

(fn with-style [form ...]
  (form-defaults form :font style.font :color style.text :xpad style.padding.x :ypad style.padding.y ...))

(local form-preserved-keys (collect [_ key (ipairs [:view :x :y :font :color :xpad :ypad])] key true))
(fn reform [form overrides]
  (if (and overrides overrides.into (not= overrides.into form))
    (reform (lume.extend (lume.clear overrides.into) form) overrides)
    (do (each [key (pairs form)]
          (when (= (. form-preserved-keys key) nil)
            (tset form key nil)))
        (lume.extend form (or overrides {})))))

(fn under [form overrides]    (reform form (lume.merge (or overrides {}) {:y (+ form.y (or form.h 0) (or form.ypad 0))})))
(fn right-of [form overrides] (reform form (lume.merge (or overrides {}) {:x (+ form.x (or form.w 0) (or form.xpad 0))})))

(fn group-wrapper [orig-form]
  (let [group {}
        update-dimension
        (fn [form coord-key size-key]
          (let [coord-group (. group coord-key) size-group (. group size-key)
                coord-form (. form coord-key)   size-form (. form size-key)]
            (if (= size-form nil) ; tried to add an unsized value to the group, ignore
                nil

                (= coord-group nil) ; container takes on the size of its first item
                (do (tset group coord-key coord-form)
                    (tset group size-key size-form))

                (> coord-group coord-form) ; we have an item that is outside the bounds to the left / up; reduce the starting point and extend the size
                (do (tset group coord-key coord-form)
                    (tset group size-key (- (math.max (+ coord-form size-form) (+ coord-group size-group)) coord-form)))

              ; extend the size if the new item is outside the bounds to the right / down
              (tset group size-key (- (math.max (+ coord-form size-form) (+ coord-group size-group)) coord-group)))
            form))
        update-dimensions (fn [form] (update-dimension form :x :w) (update-dimension form :y :h))]

    (fn [?viewfn-or-form ?form ...]
      (match [(type ?viewfn-or-form) ?viewfn-or-form]
        [:function viewfn] (let [result [(viewfn ?form ...)]]
                             (update-dimensions ?form)
                             (table.unpack result))
        [:table form]      (update-dimensions form)
        [:nil]             (lume.extend orig-form group)))))

(fn horiz-wrapper [{:x orig-x :w orig-w}]
  (fn [{: x : y : w : h : xpad : ypad &as form} overrides]
    (if (> (+ x (or w 0) xpad (or w 0)) (+ orig-x orig-w))
      (reform form (lume.merge (or overrides {}) {:x orig-x :y (+ y (or h 0) (or ypad 0))}))
      (right-of form overrides))))

;; widgets and widget helpers
(fn active? [view tag] (= view.imstate.active (make-tag tag)))
(fn button [{: view : tag : x : y : w : h &as form}]
  (when (mouse-inside x y w h) (set-cursor view :hand))
  (activate form)
  (and (active? view tag) (= view.imstate.left :released) (mouse-inside x y w h)))

(fn label [form text]
  (let [(_ newlines) (text:gsub "\n" "\n")
        text-height (fn [font] (* (font:get_height) (+ newlines 1)))
        {: x : y : w : h : halign : valign : font : color}
        (with-style form
                    :w #($1.font:get_width text)
                    :h #(text-height $1.font)
                    :halign :left
                    :valign :center)
        x (match halign :left x :center (+ x (/ (- w (font:get_width text)) 2)) :right (+ x w (- (font:get_width text))))
        y (match valign :top y :center (+ y (/ (- h (text-height font)) 2)) :bottom (+ y h (- (text-height font))))]
    (renderer.draw_text font text x y color)))

(fn textbutton [form label]
  (let [{: x : y : w : h : xpad : ypad : font : color : bg}
        (with-style form
                    :bg style.selection
                    :tag label
                    :w #(+ ($1.font:get_width label) $1.xpad)
                    :h #(+ ($1.font:get_height) $1.ypad))]
    (renderer.draw_rect x y w h bg)
    (renderer.draw_text font label (+ x (/ xpad 2)) (+ y (/ ypad 2)) color)
    (button form)))

(fn checkbox [form name isset]
  (let [{: x : y : w : h : font : color : x-label}
        (with-style form
                    :tag name
                    :h (* 12 SCALE)
                    :x-label #(+ $1.x $1.h $1.xpad)
                    :w #(+ $1.x-label ($1.font:get_width name)))]
    (love.graphics.rectangle (if isset :fill :line) x y h h)
    (renderer.draw_text font name x-label y color)
    (love.graphics.setColor 1 1 1 1)
    (button form))) ; whose idea was this?? should return (not isset) >:/

(fn focused? [view tag] (= (make-tag tag) (-?> view.imstate.focus (. :tag))))
(fn focus [{: view : tag : x : y : w : h &as form} opts]
  (if (activate form)
      (set view.imstate.focus
        (doto (lume.clone (or opts {}))
          (tset :tag (make-tag tag))))

      (and (= view.imstate.left :released) (focused? view tag) (not (mouse-inside x y w h)))
      (set view.imstate.focus nil))
  (focused? view tag))

  (local blink_period 0.8)
(fn x-from-i [s i xLeft font]
  (if (or (<= i 1) (= s "")) xLeft
      (x-from-i (s:sub 2) (- i 1) (+ xLeft (font:get_width (s:sub 1 1))) font)))
(fn i-from-x [s x xLeft font ?i]
  (local i (or ?i 1))
  (local w (font:get_width (s:sub 1 1)))
  (local xMid (+ xLeft (/ w 2)))
  (if (or (<= x xMid) (= s "")) i
      (i-from-x (s:sub 2) x (+ xLeft w) font (+ i 1))))

(fn next-match [text i di pred]
  (local imax (+ (length text) 1))
  (local inext (+ i di))
  (if (<= inext 1) 1
      (> inext imax) imax
      (pred (text:sub inext inext)) (if (< di 0) i inext)
    (next-match text inext di pred)))
(fn is-nonword-char [char] (config.non_word_chars:find char nil true))
(fn next-word [text i di]
  (let [iwordboundary (next-match text i di #(is-nonword-char $1))]
    (next-match text iwordboundary di #(not (is-nonword-char $1)))))

(fn textnav [key i text]
  (local imax (+ (length text) 1))
  (match key
    :left       (math.max 1 (- i 1))
    :right      (math.min imax (+ i 1))
    :ctrl+left  (next-word text i -1)
    :ctrl+right (next-word text i 1)
    :home       1
    :end        imax))

(fn selection-span [view]
  (let [f       view.imstate.focus
        iStart  (math.min f.i f.iAnchor)
        iLim    (math.max f.i f.iAnchor)]
    (values iStart iLim)))
(fn selection-text [view text]
  (local (iStart iLim) (selection-span view))
  (text:sub iStart (- iLim 1)))

(fn replace-selection [view s replacement ?iStart ?iLim]
  (local (iStart iLim) (if ?iLim (values ?iStart ?iLim) (selection-span view)))
  (local text
    (.. (s:sub 1 (- iStart 1))
        replacement
        (s:sub iLim)))
  (local iNew (+ iStart (length replacement)))
  (set view.imstate.focus.i iNew)
  (set view.imstate.focus.iAnchor iNew)
  text)

(fn textbox [form text]
  (local {: font : color : w : h : x : y : xpad : ypad : color : view : tag}
         (with-style form :h #(+ ($1.font:get_height) $1.ypad)))
  (var textNew (or text ""))
  (local (hText xText yText) (values (font:get_height) (+ x (/ xpad 2)) (+ y (/ ypad 2))))
  (local initial-press (= view.imstate.left :pressed))

  ; handle key events
  (when (focus form {:i 1 :iAnchor 1 :blink (love.timer.getTime)})
    (local f view.imstate.focus)
    (when (> f.i (+ (length textNew) 1))       (set f.i (+ (length textNew) 1)))
    (when (> f.iAnchor (+ (length textNew) 1)) (set f.iAnchor (+ (length textNew) 1)))
    (when view.imstate.text
      (set textNew (replace-selection view textNew view.imstate.text)))
    (each [_ key (ipairs (or view.imstate.keys []))]
      (set view.imstate.focus.blink (love.timer.getTime))
      (if (= key :ctrl+c) (system.set_clipboard (selection-text view textNew))
          (= key :ctrl+v) (set textNew (replace-selection view textNew (system.get_clipboard)))
          (key:find "shift%+") (set f.i (or (textnav (key:gsub "shift%+" "") f.i textNew) f.i))
        (let [iNav (textnav key f.i textNew)]
          (when iNav
            (set f.i iNav)
            (set f.iAnchor iNav))
          (when (or (= key :delete) (= key :backspace))
            (local (iStartDel iLimDel)
              (if (not= f.i f.iAnchor) (selection-span view)
                  (= key :delete)      (values f.i (+ f.i 1))
                  (= key :backspace)   (values (math.max 1 (- f.i 1)) f.i)))
            (set textNew (replace-selection view textNew "" iStartDel iLimDel)))))))

  ; handle mouse events
  (when (mouse-inside x y w h) (set-cursor view :ibeam))
  (when (and (focused? view tag) (active? view tag) (mouse-inside x y w h))
    (local mouse-i (i-from-x textNew (love.mouse.getX) x style.font))
    (when initial-press
      (set view.imstate.focus.iAnchor mouse-i))
    (set view.imstate.focus.i mouse-i))

  ; draw box
  (love.graphics.setLineWidth 1)
  (love.graphics.rectangle :line x y w h)
  (if (focused? view tag)
    ; draw text with selection + caret
    (let [(iStart iLim) (selection-span view)
          xSelect (renderer.draw_text font (textNew:sub 1 (- iStart 1)) xText yText color)
          sSelect (textNew:sub iStart (- iLim 1))
          wSelect (font:get_width sSelect)
          xTail   (+ xSelect wSelect)]
      (when (> wSelect 0)
        (renderer.draw_rect xSelect yText wSelect hText style.selection)
        (renderer.draw_text font sSelect xSelect yText color))
      (renderer.draw_text font (textNew:sub iLim) xTail yText color)
      (when (or (active? view tag)
                 (< (% (- (love.timer.getTime) view.imstate.focus.blink) (* blink_period 2)) blink_period))
         (renderer.draw_rect (x-from-i textNew view.imstate.focus.i xText font) yText style.caret_width hText style.caret)))
    ; just draw the text
    (renderer.draw_text font textNew xText yText color))
  (love.graphics.setColor 1 1 1)
  textNew)

(fn textfield [form label text]
  (let [{: x : y : w : wlabel : wtext : font : color}
        (with-style form :wlabel #(+ ($1.font:get_width label) $1.xpad)
                         :wtext (* 150 SCALE)
                         :w #(+ $1.wlabel $1.wtext)
                         :tag label)
        form-textbox (lume.merge form {:w wtext :x (+ x wlabel)})
        _ (renderer.draw_text font label x y color)
        text (textbox form-textbox text)]
    (set form.h form-textbox.h)
    text))

(fn option-text [option]
  (match (type option)
    :string option
    :table (or option.label (tostring option))
    _ (tostring option)))

(fn dropdown [form selection options]
  (let [{: x : y : w :h row-h : font : color : bg : xpad : ypad : view : tag}
        (with-style form :w (* 150 SCALE)
                         :h #(+ ($1.font:get_height) $1.ypad)
                         :bg style.selection)]
    (var new-selection nil)

    (renderer.draw_rect x y w row-h bg)
    (renderer.draw_text style.font (option-text selection) (+ x xpad) (+ y (/ ypad 2)) color)
    (renderer.draw_text style.icon_font "-" (+ x w (- xpad)) (+ y (/ ypad 2)) color)

    (when (focused? view tag)
      (var row-y (+ y row-h))
      (each [i option (ipairs options)]
        (when (button (lume.merge form {:tag [(make-tag tag) i] :y row-y}))
          (set new-selection option))
        (set row-y (+ row-y row-h)))
      (postpone view (fn []
         (var row-y (+ y row-h))
         (each [i option (ipairs options)]
           (renderer.draw_rect x row-y w row-h bg)
           (renderer.draw_text font (option-text option) (+ x xpad) (+ row-y (/ ypad 2)) color)
         (set row-y (+ row-y row-h))))))
    (focus form)
    (or new-selection selection)))

(fn labelled-dropdown [form label selection options]
  (let [{: x : y : wlabel : wdropdown : font : color}
        (with-style form :wlabel #(+ ($1.font:get_width label) $1.xpad)
                         :wdropdown (* 150 SCALE)
                         :w #(+ $1.wlabel $1.wdropdown)
                         :tag label)
        form-dropdown (lume.merge form {:x (+ x wlabel) :w wdropdown})
        _ (renderer.draw_text font label x y color)
        selection (dropdown form-dropdown selection options)]
    (set form.h form-dropdown.h)
    selection))

{: attach-imstate : cmd-predicate : postpone : mouse-inside : activate : active?
 : button : checkbox : textbox : textfield : textbutton : dropdown : labelled-dropdown : label
 : reform : under : right-of : horiz-wrapper : group-wrapper
 : with-style : form-defaults}