Ben / Nujel

;;; Nujel - Copyright (C) 2020-2021 - Benjamin Vincent Schulenburg
;;; This project uses the MIT license, a copy should be included under /LICENSE
;;;

(def fg-colors { :default "\e[0m"

                 :black "\e[30m"
                 :red "\e[31m"
                 :green "\e[32m"
                 :yellow "\e[33m"
                 :blue "\e[34m"

                 :pink "\e[35m"
                 :magenta "\e[35m"
                 :purple "\e[35m"

                 :cyan "\e[36m"
                 :teal "\e[36m"

                 :white "\e[37m"})

(def bg-colors { :default "\e[49m"

                 :black "\e[40m"
                 :red "\e[41m"
                 :green "\e[42m"
                 :yellow "\e[43m"
                 :blue "\e[44m"

                 :pink "\e[45m"
                 :magenta "\e[45m"
                 :purple "\e[45m"

                 :cyan "\e[46m"
                 :teal "\e[46m"

                 :white "\e[47m"})

(defclass term
  "A buffered terminal connection"
  :export

  (defn new (self out in)
        (when-not in (set! in stdin))
        (when-not out (set! out stdout))
        { :in-port in
          :out-port out
          :buf-port (make-string-output-port)
          :prototype* self })

  (defn flip (self)
        (def s ((ref self :buf-port) 'return-string))
        ((ref self :buf-port) 'close!)
        (set! self :buf-port (make-string-output-port))
        ((ref self :out-port) 'block-write s)
        ((ref self :out-port) 'flush-output))

  (defn put-char (self char)
        ((ref self :buf-port) 'char-write char))

  (defn put-string (self text)
        ((ref self :buf-port) 'block-write text))

  (defn clear-screen (self)
        ((ref self :buf-port) 'block-write "\e[2J"))

  (defn clear-line (self)
        ((ref self :buf-port) 'block-write "\e[2K"))

  (defn hide-cursor (self)
        ((ref self :out-port) 'block-write "\e[?25l"))

  (defn show-cursor (self)
        ((ref self :out-port) 'block-write "\e[?25h"))

  (defn start (self)
        ((ref self :in-port) :raw!)
        ((ref self :out-port) 'block-write "\e[?1049h"))

  (defn stop (self)
        ((ref self :out-port) 'block-write "\e[?1049l"))

  (defn move-cursor (self column line)
        ((ref self :buf-port) 'block-write (fmt "\e[{line};{column}H")))

  (defn set-fg-color (self color-name)
        (def v (ref fg-colors color-name))
        (when-not v (exception "Unknown color" color-name))
        ((ref self :buf-port) 'block-write v))

  (defn set-bg-color (self color-name)
        (def v (ref bg-colors color-name))
        (when-not v (exception "Unknown color" color-name))
        ((ref self :buf-port) 'block-write v))

  (defn set-color (self fg-color-name bg-color-name)
        (when fg-color-name (:set-fg-color self fg-color-name))
        (when bg-color-name (:set-bg-color self bg-color-name)))

  (defn get-size (self)
        :export
        ((ref self :out-port) 'block-write "\e 7")
        ((ref self :out-port) 'block-write "\e[9999;9999H")
        ((ref self :out-port) 'block-write "\e[6n")
        ((ref self :out-port) 'flush-output)
        (def buf (buffer/allocate 128))
        (def i 0)
        (while #t
          (def c ((ref self :in-port) 'char-read))
          (when (= c #\R)
            ((ref self :out-port) 'block-write "\e 8")
            (def s (split (cut (buffer->string buf i) 2) ";"))
            (return { :width (read/int (cadr s))
                      :height (read/int (car s))}))
          (set! buf i c)
          (inc! i)))

  (defn get-width (self)
        (ref (:get-size self) :width))

  (defn get-height (self)
        (ref (:get-size self) :height))

  (defn poll-input (self)
        (def c ((ref self :in-port) 'char-read))
        (if (= c :end-of-file)
            0
            c))

  (defn draw-box (self color pos-x pos-y width height)
        :export
        (:set-bg-color self color)
        (dotimes (y height)
                 (:move-cursor self pos-x (+ y pos-y))
                 (dotimes (x width)
                          (:put-char self 32)))
        (:set-bg-color self :default)))