(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}] (set self.scrollheight (- (+ y (or h 0) style.padding.y) (+ self.position.y style.padding.y (- self.scroll.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))) (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 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 ...)) (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)) (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 (= 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] (do (lume.extend orig-form group) (lume.clear group) orig-form))))) (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)))) {: attach-imstate : cmd-predicate : postpone : mouse-inside : activate : active? : button : checkbox : textbox : textfield : textbutton : dropdown : labelled-dropdown : reform : under : right-of : horiz-wrapper : group-wrapper : with-style : form-defaults}