Ben / Nujel

(import (Term) :core/term)
(import (TextBuffer) :app/termed/buffer)

(def term (:new Term))
(def buffers [])
(def cur-buffer #nil)
(def screen-width #nil)
(def screen-height #nil)
(def last-char 0)
(def clipboard "")
(def keycodes #nil)

(defn add-keycode (c t)
      (set! keycodes (cons (fmt "{t}{c:02X}") keycodes))
      (when (> (:length keycodes) 8)
        (set! keycodes (except-last-pair keycodes)))
      (return c))

(defn poll-key (t)
      (add-keycode (:poll-input term) t))

(def scroll-interval 10)

(defn set-cur-buffer! (buf)
      (set! buf :scroll-interval (max 4 (bit-shift-right screen-height 1)))
      (set! cur-buffer buf))

(defn new-buffer (filename)
      (def buf (:new TextBuffer filename))
      (array/push buffers buf)
      buf)

(defn backward-char () (:backward-char cur-buffer))
(defn forward-char () (:forward-char cur-buffer))
(defn previous-line () (:previous-line cur-buffer))
(defn next-line () (:next-line cur-buffer))
(defn delete-forward-char () (:delete-forward-char cur-buffer))
(defn backward-delete-char () (:backward-delete-char cur-buffer))
(defn insert-newline () (:insert-newline cur-buffer))
(defn insert-char (c) (:insert-char cur-buffer c))
(defn next-line () (:next-line cur-buffer))
(defn forward-char () (:forward-char cur-buffer))
(defn backward-char () (:backward-char cur-buffer))
(defn kill-line () (set! clipboard (:kill-line cur-buffer)))
(defn yank () (:insert-text cur-buffer clipboard))
(defn scroll-down-command () (:scroll-down-command cur-buffer))
(defn scroll-up-command () (:scroll-up-command cur-buffer))

(defn draw-gutter ()
      (:draw-box term :red 1 2 4 (- screen-height 2)))

(defn get-modeline (buf)
      (def x (ref buf :pos-x))
      (def y (inc (ref buf :pos-y)))
      (def bufname (:get-buf-name buf))
      (def saved (if (ref buf :changed) "*" ""))
      (def ll (:line-length buf (ref buf :pos-y)))
      (def keys (join keycodes " "))
      (fmt " L{y} - {bufname} - ({keys})"))

(defn draw-modeline (buf)
      (:move-cursor term 1 (dec screen-height))
      (:set-color term :yellow :blue)
      (def colored-modeline (cat " " (pad-end (get-modeline buf) (dec screen-width))))
      (:put-string term colored-modeline)
      (:set-color term :default :default))

(defn draw-buffer-line (buf term-x term-y term-w line-y)
      (def line (:get-line buf line-y))
      (:move-cursor term term-x term-y)
      (:clear-line term)
      (when-not line (return))
      (when (= line-y (ref buf :pos-y))
        (:set-color term :yellow :blue))
      (def ln (fmt " {:4} " (inc line-y)))
      (:put-string term ln)
      (:set-color term :default)
      (:move-cursor term (+ 1 (:length ln) term-x) term-y)
      (def max-w (- term-w 7))
      (when (>= (:length line) max-w)
        (set! line (:clone (:cut (buffer->string line) 0 max-w))))
      (:put-string term line))

(defn draw-buffer (buf x y w h)
      (dotimes (cy h)
               (def line-y (+ cy (ref buf :scroll-y)))
               (draw-buffer-line buf x (+ cy y) w line-y))
      (draw-modeline buf))

(defn draw-screen ()
      (def cur-buffer cur-buffer)
      (:hide-cursor term)
      (draw-buffer cur-buffer 1 1 screen-width (- screen-height 2))
      (:show-cursor term)
      (:move-cursor term (+ 1 1 6 (ref cur-buffer :pos-x)) (- (inc (ref cur-buffer :pos-y))
                                                              (ref cur-buffer :scroll-y)))
      (:flip term))

(defn quit ()
      (:stop term)
      (exit 0))

(defn beginning-of-line ()
      (set! cur-buffer :pos-x 0))

(defn end-of-line ()
      (set! cur-buffer :pos-x (:line-length cur-buffer (ref cur-buffer :pos-y))))

(defn clear-frame ()
      (dotimes (y (- screen-height 1))
               (:move-cursor term 0 y)
               (:clear-line term)))

(defn scroll-into-view ()
      (def buf cur-buffer)
      (def frame-height (- screen-height 3))
      (when (< (- (ref buf :pos-y)
                  (ref buf :scroll-y)) 0)
        (clear-frame)
        (set! buf :scroll-y (* scroll-interval (int (floor (/ (ref buf :pos-y) scroll-interval))))))

      (when (> (- (ref buf :pos-y)
                  (ref buf :scroll-y)) frame-height)
        (clear-frame)
        (set! buf :scroll-y (* scroll-interval (int (ceil (/ (- (ref buf :pos-y) frame-height) scroll-interval))))))

      (when (< (ref buf :scroll-y) 0)
        (set! buf :scroll-y)))

(defn read-page-up-input ()
      (def c (poll-key "U-"))
      (case c
            (#x7E (scroll-down-command))))

(defn read-page-down-input ()
      (def c (poll-key "U-"))
      (case c
            (#x7E (scroll-up-command))))

(defn read-bracketed-input ()
      (def c (poll-key "[-"))
      (case c
            (#\A (previous-line))
            (#\B (next-line))
            (#\C (forward-char))
            (#\D (backward-char))
            (#x35 (read-page-up-input))
            (#x36 (read-page-down-input))
            (#x46 (end-of-line))
            (#x48 (beginning-of-line))))

(defn read-escaped-input ()
      (def c (poll-key "E-"))
      (case c
            (#\[ (read-bracketed-input))
            (otherwise (insert-char #\[))))

(defn read-cx-input ()
      (def c (poll-key "C-"))
      (when (= c 3)
        (return (quit))))

(defn read-input ()
      (def c (poll-key #nil))
      (set! last-char c)
      (case c
            (#x1B (read-escaped-input))
            (#x01 (beginning-of-line))
            (#x02 (backward-char))
            (#x05 (end-of-line)) ; C-e
            (#x06 (forward-char)) ; C-f
            (#x0B (kill-line)) ; C-k
            (#x10 (previous-line)) ; C-p
            (#x0E (next-line)) ; C-n
            (#x18 (read-cx-input)) ; C-x
            (#x19 (yank)) ; C-y
            (#x7E (delete-forward-char))
            (#x7F (backward-delete-char))
            (#x0D (insert-newline))
            (otherwise (when (and (>= c #x20)
                                  (<  c #x80))
                         (return (insert-char c))))))

(defn load-buffer (filename)
      (def buf (new-buffer filename))
      (def text (slurp filename))
      (when text
        (set! buf :lines (apply array/new (map (split text "\n") :clone)))))

(defn main (args)
      :export
      (:start term)
      (:clear-screen term)
      (def s (:get-size term))
      (set! screen-width (ref s :width))
      (set! screen-height (ref s :height))
      (for-each args load-buffer)
      (when (zero? (:length buffers))
        (new-buffer "*scratch*"))
      (set-cur-buffer! (ref buffers (dec (:length buffers))))
      (while #t
        (scroll-into-view)
        (draw-screen)
        (read-input)))