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)
(def scroll-interval 8)

(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))

(defn set-cur-buffer! (buf)
      (set! scroll-interval (max 4 (int (/ screen-height 3))))
      (set! buf :scroll-interval scroll-interval)
      (set! cur-buffer buf))

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

(defn yank () (:insert-text cur-buffer clipboard))
(defn kill-line () (set! clipboard (:kill-line 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 id (:line-indent-depth buf (ref buf :pos-y)))
      (def keys (join keycodes " "))
      (fmt " L{y}:{x} - {ll}:{id} - {bufname} - ({keys})"))

(defn draw-modeline (buf)
      (:move-cursor term 1 (dec screen-height))
      (:set-color term :white :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 :white :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 buf-off 0)
      (def buf-max (:length line))
      (def max-w (min (- buf-max buf-off) (- term-w 7)))
      (def mark-start 0)
      (def mark-end 0)
      (when (:use-region? cur-buffer)
        (def rs-y (:region-start-y cur-buffer))
        (def re-y (:region-end-y cur-buffer))
        (def rs-x (:region-start-x cur-buffer))
        (def re-x (:region-end-x cur-buffer))
        (when (and (>= line-y rs-y)
                   (<= line-y re-y))
          (set! mark-end max-w)
          (when (= line-y rs-y)
            (set! mark-start rs-x))
          (when (= line-y re-y)
            (set! mark-end re-x))))

      (def c 0)
      (dotimes (i max-w)
               (set! c (ref line (+ i buf-off)))
               (when (zero? c)
                 (:set-color term :default)
                 (return))
               (when (= i mark-start)
                 (:set-color term :white :black))
               (when (= i mark-end)
                 (:set-color term :default))
               (:put-char term c))
      (:set-color term :default))

(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 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-nav-key (method)
      (def c (poll-key "U-"))
      (when (= c #x7E)
        (if (lambda? method)
            (method)
            (method cur-buffer))))

(defn read-bracketed-input ()
      (def c (poll-key "[-"))
      (case c
            (#\A (:previous-line cur-buffer))
            (#\B (:next-line cur-buffer))
            (#\C (:forward-char cur-buffer))
            (#\D (:backward-char cur-buffer))
            (#x32 (read-nav-key yank))
            (#x33 (read-nav-key :delete-forward-char))
            (#x35 (read-nav-key :scroll-down-command))
            (#x36 (read-nav-key :scroll-up-command))
            (#x46 (:end-of-line cur-buffer))
            (#x48 (:start-of-line cur-buffer))))

(defn read-escaped-input ()
      (def c (poll-key "E-"))
      (case c
            (#\[ (read-bracketed-input))
            (#x3C (:beginning-of-buffer cur-buffer))
            (#x3E (:end-of-buffer cur-buffer))
            (#x77 (set! clipboard (:get-region cur-buffer)) (:keyboard-quit cur-buffer))
            (otherwise (:insert-char cur-buffer #\[))))

(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))
            (#x17 (set! clipboard (:get-region cur-buffer)) (:delete-region cur-buffer)) ; C-w
            (#x18 (read-cx-input)) ; C-x
            (#x19 (yank)) ; C-y
            (#x00 (:set-mark-command cur-buffer))
            (#x01 (:start-of-line cur-buffer))
            (#x02 (:backward-char cur-buffer))
            (#x05 (:end-of-line cur-buffer)) ; C-e
            (#x06 (:forward-char cur-buffer)) ; C-f
            (#x07 (:keyboard-quit cur-buffer)) ; C-g
            (#x0B (kill-line)) ; C-k
            (#x10 (:previous-line cur-buffer)) ; C-p
            (#x0E (:next-line cur-buffer)) ; C-n
            (#x7E (:delete-forward-char cur-buffer))
            (#x7F (:backward-delete-char cur-buffer))
            (#x0D (:insert-newline cur-buffer))
            (otherwise (when (and (>= c #x20)
                                  (<  c #x80))
                         (return (:insert-char cur-buffer c))))))

(defn load-buffer (filename)
      (def buf (new-buffer filename))
      (def text (slurp filename))
      (def raw-lines (if text (split text "\n") #nil))
      (def lines (:alloc Array (max 1 (:length raw-lines))))
      (set! buf :lines lines)
      (def i 0)
      (doseq (line raw-lines buf)
             (def cur-line (buffer/allocate (bit-shift-left (inc (bit-shift-right (:length line) 4)) 4)))
             (buffer/copy cur-line line 0 (:length line))
             (set! lines i cur-line)
             (inc! i)))

(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)))