application/octet-stream
•
4.82 KB
•
152 lines
[import [start stop clear-screen get-size poll-input draw-box move-cursor put-char put-string set-color] :core/term]
[import [new-buffer :as new-buffer* get-line line-length forward-char backward-char backward-delete-line backward-delete-char insert-char insert-newline get-buf-name set-cur-buffer! get-cur-buffer previous-line next-line] :app/termed/buffer]
[def buffers #[]]
[def screen-width #nil]
[def screen-height #nil]
[def last-char 0]
[def scroll-interval 10]
[defn new-buffer [filename]
[def buf [new-buffer* filename]]
[array/push buffers buf]
buf]
[defn draw-gutter []
[draw-box :red 1 2 4 [- screen-height 2]]]
[defn get-modeline [buf]
[def x [tree/ref buf :pos-x]]
[def y [inc [tree/ref buf :pos-y]]]
[def bufname [get-buf-name buf]]
[def saved [if [tree/ref buf :changed] "*" ""]]
[fmt " L{y} - {bufname} - KeyCode: {last-char:X}"]]
[defn draw-modeline [buf]
[draw-box :blue 1 [dec screen-height] screen-width 1]
[move-cursor 1 [dec screen-height]]
[set-color :yellow :blue]
[put-string [get-modeline buf]]
[set-color :default :default]]
[defn draw-buffer-line [buf term-x term-y term-w line-y]
[def line [get-line buf line-y]]
[when-not line [return]]
[when [= line-y [tree/ref buf :pos-y]]
[set-color :yellow :blue]]
[move-cursor term-x term-y]
[def ln [fmt " {:4} " [inc line-y]]]
[put-string ln]
[set-color :default]
[move-cursor [+ 1 [buffer/length ln] term-x] term-y]
[put-string line]]
[defn draw-buffer [buf x y w h]
[dotimes [cy h]
[def line-y [+ cy [tree/ref buf :scroll-y]]]
[draw-buffer-line buf x [+ cy y] w line-y]]
[draw-modeline buf]]
[defn draw-screen []
[clear-screen]
[def cur-buffer [get-cur-buffer]]
[draw-buffer cur-buffer 1 1 screen-width [- screen-height 2]]
[move-cursor [+ 1 1 6 [tree/ref cur-buffer :pos-x]] [- [inc [tree/ref cur-buffer :pos-y]]
[tree/ref cur-buffer :scroll-y]]]]
[defn quit []
[stop]
[exit 0]]
[defn beginning-of-line []
[tree/set! [get-cur-buffer] :pos-x 0]]
[defn end-of-line []
[def buf [get-cur-buffer]]
[tree/set! buf :pos-x [inc [line-length [tree/ref buf :pos-y]]]]]
[defn scroll-into-view []
[def buf [get-cur-buffer]]
[def frame-height [- screen-height 3]]
[when [< [- [tree/ref buf :pos-y]
[tree/ref buf :scroll-y]] 0]
[tree/set! buf :scroll-y [* scroll-interval [int [floor [/ [tree/ref buf :pos-y] scroll-interval]]]]]]
[when [> [- [tree/ref buf :pos-y]
[tree/ref buf :scroll-y]] frame-height]
[tree/set! buf :scroll-y [* scroll-interval [int [ceil [/ [- [tree/ref buf :pos-y] frame-height] scroll-interval]]]]]]
[when [< [tree/ref buf :scroll-y] 0]
[tree/set! buf :scroll-y]]]
[defn read-bracketed-input []
[def c [poll-input]]
[when [= c #\A]
[return [previous-line]]]
[when [= c #\B]
[return [next-line]]]
[when [= c #\C]
[return [forward-char]]]
[when [= c #\D]
[return [backward-char]]]
[return]]
[defn read-escaped-input []
[def c [poll-input]]
[when [= c #\[]
[return [read-bracketed-input]]]
[return [insert-char #\[]]]
[defn read-cx-input []
[def c [poll-input]]
[when [= c 3]
[return [quit]]]
]
[defn read-input []
[def c [poll-input]]
[set! last-char c]
[when [= c #x1B]
[return [read-escaped-input]]]
[when [= c #x01] ; C-a
[return [beginning-of-line]]]
[when [= c #x02] ; C-b
[return [backward-char]]]
[when [= c #x05] ; C-e
[return [end-of-line]]]
[when [= c #x06] ; C-f
[return [forward-char]]]
[when [= c #x10] ; C-f
[return [previous-line]]]
[when [= c #x0e] ; C-f
[return [next-line]]]
[when [= c #x18] ; C-f
[return [read-cx-input]]]
[when [= c #x7F]
[return [backward-delete-char]]]
[when [= c #x0D]
[return [insert-newline]]]
[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 [tree/set! buf :lines [apply array/new [map [split text "\n"] string->buffer]]]]]
[defn main [args]
:export
[start]
[def s [get-size]]
[set! screen-width [tree/ref s :width]]
[set! screen-height [tree/ref s :height]]
[for-each args load-buffer]
[when [zero? [array/length buffers]]
[new-buffer "*scratch*"]]
[set-cur-buffer! [array/ref buffers [dec [array/length buffers]]]]
[while #t
[scroll-into-view]
[draw-screen]
[read-input]]]
