# [ʞ] tui.janet
#  ~ lexi hale <lexi@hale.su>
#  🄯 AGPLv3
#  ? quick and extremely dirty rawterm interface

(use /alg)

# FIXME use ffi to directly munge termios where feasible
(defn raw [fd] 
	(os/execute ["stty" "raw" "-echo" "opost"] :p))

(defn unraw [fd]
	(os/execute ["stty" "-raw" "echo"] :p))

(defmacro use-raw [fd]
	~(upscope
		 (,raw ,fd)
		 (,defer ,unraw ,fd)))

(defmacro with-raw [fd & x]
	~(do (,raw ,fd)
		 ,;x
		 (,unraw ,fd)))

(def- capq-resp (peg/compile ~{
	:lst (* '(+ (some (range "09"))
				(constant "0"))
			  (? (* ";" :lst)))
	:resp "\e[?"
	:seq (* :resp (group :lst))
	:tc (* :seq "c")
	:pg (* :resp (number (any (range "09"))) "u")
	:main (* (+ :pg (constant false))
			  :tc)
}))
(def- pg-flags {0x01 :E # disambig events
			    0x02 :e # report evt types
			    0x04 :k # keycode alts
			    0x08 :K # all keys as alts
			    0x16 :t}) # text
(defn release [env]
	(defn send [& x] (ev/write (env :fd) (string ;x)))
	(when (string/check-set (env :caps) :p)
		(send "\e[<1u"))
	(unraw (env :fd))
	(:close (env :fd)))

(defn- read-until [pred fd]
	(def buf @"")
	(label matched
		   (forever
			   # (ev/write fd (string/format "buf: %j\r\n" buf))
			   (ev/read fd 1 buf)
			   (spit "dbgkeys" buf)
			   (def p (pred buf))
			   (when p (return matched p)))))

(defn- text-key [c & args]
	(struct :text c
			:key ((string/ascii-lower c) 0)
			:case (c 0)
			:base (c 0)
			:how :press
			;args))

(def- event-code-ptn (peg/compile ~{
	:csi "\e["
	:ss3 "\e\x4f"
	:cs3 (+ :csi :ss3)
	:key-basic (cmt (* :csi :keycode :keyev "~" )
				,(fn [kc ks kb mods how]
					(def basis
						(case kc
						   2 :ins
						   3 :del
						   5 :pgup
						   6 :pgdn
						   7 :home
						   8 :end
						   (cond (<= 11 kc 24) (keyword :f (- kc 11))
							     :else :unknown)))
					 {:key  basis
					  :mods mods
					  :how how}))
	:key-magic (cmt (* :csi "1" :keyev '(+ (range "AF") "H" "P" "Q" "S"))
					,(fn [mods how cue]
						{:mods mods
						 :how how
						 :key (case cue
								  "A" :up "C" :rt
								  "B" :dn "D" :lf
								  "H" :home "F" :end
								  "E" :kp-begin )}))
	:legacy-ctl (cmt '(range "\x01\x07" "\x0b\x0c" "\x0e\x1a")
			        ,(fn [ccode]
						(def code (+ 0x60 (ccode 0)))
						(def lc (string/format "%c" code))
						{ :text lc
						  :key code
						  :case code
						  :base code
						  :how :press
						  :mods :c }))
	:key (+ (* "\x0D"            (constant {:key :enter :how :press}))
	        (* (+ "\x7F" "\x08") (constant {:key :bksp  :how :press}))
			(* "\x09"            (constant ,(text-key "\t" :key :tab)))
			(* "\x00"            (constant ,(text-key " "  :key :sp :mods :c)))
			:legacy-ctl
	        (* :cs3 "A"          (constant {:key :up :how :press}))
	        (* :cs3 "B"          (constant {:key :dn :how :press}))
	        (* :cs3 "C"          (constant {:key :rt :how :press}))
	        (* :cs3 "D"          (constant {:key :lf :how :press}))
	        (* :cs3 "E"          (constant {:key :kp-begin :how :press}))
			(+ (* :csi :keyspec "u")
			   (* "\e"  (cmt :legacy-ctl
						,(fn [c] (struct/with-proto c
									:mods (keyword (get c :mods :) :a)))))
			   (* "\e" (not "[") (cmt '1 ,|(text-key $ :mods :a)))
			   (*     (not "\e") (cmt '1 ,|(text-key $)))))
	:ctl (cmt :num0 ,(fn [c]
			(defn b [n k]
				(if (not= 0 (band (- c 1) n)) k :))
			(keyword (b 0x01 :s) (b 0x10 :H)
			         (b 0x02 :a) (b 0x20 :m)
			         (b 0x04 :c) (b 0x40 :C)
			         (b 0x08 :S) (b 0x80 :N))))
	:keyev (+ (* ";" :ctl
	             (+ (* ":1" (constant :press))
	                (* ":2" (constant :repeat))
	                (* ":3" (constant :release))
	                (constant :press)))
			   (* ";" (constant :) (constant :press))
	           (* (constant :) (constant :press)))
	:text (+ (cmt (group (some (* ";" :num0)))
				 ,(fn [chars] #FIXME
					(string ;(map |(string/format "%c" $) chars))))
			 (constant false))
	:keycode (+ (* :num0 ":" :num0 ":" :num0)
	            (* :num0 ":" :num0 (constant false))
	            (* :num0 (constant false) (constant false)))
	:keyspec (cmt (* :keycode :keyev :text)
				,(fn keyspec-translate [kc ks kb mods how t]
					(def basis
						(case kc
						   9 {:key :tab }
						   13 {:key :enter }
						   127 {:key :bksp }

						   57358 {:key :lock-caps }
						   57360 {:key :lock-num }
						   57414 {:key :kp-enter }
						   57413 {:key :kp-plus  :text "+"}
						   57412 {:key :kp-minus :text "-"}
						   57411 {:key :kp-mul   :text "*"}
						   57410 {:key :kp-div   :text "/"}
						   43    {:key :add :text "+"}
						   8722  {:key :sub :text "−"}
						   215   {:key :mul :text "×" }
						   243   {:key :div :text "÷" }
						   57441 {:key :shift-l} 57447 {:key :shift-r}
						   57443 {:key :alt-l}   57449 {:key :alt-r}
						   57444 {:key :super-l} 57450 {:key :super-r}
						   57445 {:key :hyper-l} 57451 {:key :hyper-r}
						   57442 {:key :ctl-l}   57448 {:key :ctl-r}
						   57453 {:key :lvl3}
						   57454 {:key :lvl5}
						   (cond (<= 57376 kc 57398) {:key (keyword :f (- kc 57363))}
								:else {:key kc
									   :text (or t (string/format "%c" (or ks kc)))})))
					 {:text (get basis :text nil)
					  :key  (get basis :key nil)
					  :case (or ks kc)
					  :base (or kb kc)
					  :mods mods
					  :how how}))
	:main (* (+ :key-basic :key-magic :key) -1)

	:num (some (range "09"))
	:num0 (+ (number :num)
	         (constant 0))
}))

(def- color-cmd
	(do (def env (os/environ))
		(def ct (env "COLORTERM"))
		(def term (env "TERM"))
		(defn mode-char [mode]
			(case mode :fg    "3" :bg    "4"
				       :fg-br "9" :bg-br "10"
				(error "bad mode")))

		(cond (or (= ct "truecolor")
				  (= term "xterm")) # modern xterm supports tc
				(fn colorize-tc [mode rgb]
					(as-> rgb v
						(map |(math/floor (* 255 (clamp $))) v)
						(string/join (map string v) ";")
						(string "\e[" (mode-char mode) "8;2;" v "m")))

			(or (string/has-suffix? "256color" term)
				(not (nil? ct)))
				(fn colorize-256 [mode rgb]
					(def code (math/floor
						(cond (= 0 ;rgb) 0
						      (=   ;rgb) (lerp (rgb 0) 232 255)
						      :else      (+ 16 ;(vect * [36 6 1]
													  (map clamp rgb))))))
					(string "\e[" (mode-char mode) "8;5;" code "m"))

			:else
				(fn colorize-8 [mode rgb] "")))) #FIXME

(defn- vbar [tty f & grad]
	(def c [ " " "▁" "▂" "▃" "▄" "▅" "▆" "▇" "█" ])
	# (def fg (vect |(lerp f ;$&) bright dim))
	(def fg (vlut f grad))
	(def bg (vect |(lerp .5 ;$&) fg [0 0 0]))
	(def idx (math/floor (* (max 0 (min 1 f))
							(dec (length c)))))
	(:color tty fg bg (c idx)))

(def- <env> {:close release
			 :write |(ev/write ($ :fd) $1)
			 :read  |(ev/read  ($ :fd) $1)
			 :color (fn tui:color [me fg bg str]
				(as-> str cmd
					(if fg (string (color-cmd :fg fg) cmd) cmd)
					(if bg (string (color-cmd :bg bg) cmd) cmd)
					(if (or fg bg) (string cmd "\e[m"))))
			 :vbar vbar
			 :await (fn tui:await [me]
			 # (print "awaiting")
				(def [evt] (read-until |(peg/match event-code-ptn $) (me :fd)))
				evt)})

# (def- chord-pat (peg/compile ~{
# 	:wd (some (* (not "-") wd))
# }))

(defn- subset [a b]
	(var matches true)
	(loop [[k v] :pairs a :while matches]
		(when (not= v (get b k nil))
			(set matches false)))
	matches)
(defn chord [& fm]
	(def ksym (last fm))
	(def mods (keyword ;(slice fm 0 -2)))
	(merge {:mods mods
		    :how :press}
		(cond
			(keyword? ksym) {:key ksym}
			(string?  ksym)
				{#:text ksym
				 :key (in (string/ascii-lower ksym) 0)
				 :case (in ksym 0)})))
(defn event<chord? [evt & fm]
	(subset evt (chord ;fm)))

(defn init [fd]
	(raw fd)
	(defn send [& x] (ev/write fd (string ;x)))
	(defn recv [n &opt buf] (string (ev/read fd n buf)))
	(var caps :)
	(send "\e[?u\e[c") # query caps
	(def lists (label done
					  (def buf @"")
					  (forever
						  (recv 1 buf)
						  (def m (peg/match capq-resp buf))
						  (when m
							  (return done m)))))
	(defn set-caps! [which tbl]
		(each e which
			(when (has-key? tbl e)
				(set caps (keyword caps (tbl e))))))
	(set-caps! (lists 1) {
	   "4" :6 # sixel
	})

	(when (lists 0)
		(set caps (keyword caps :p))
		(each [c f] (pairs pg-flags)
			(when (not= 0 (band c (lists 0)))
				(set caps (keyword caps f)))))

	(when (string/check-set caps :p)
		(def fmap (invert pg-flags))
		(def f (bor (lists 0) (fmap :k) (fmap :e) (fmap :K)))
		(send "\e[>" (string (inc f) "u")))

	(struct/with-proto <env>
					   :fd fd
					   :caps caps))

