application/octet-stream
•
15.98 KB
•
367 lines
;;; Nujel - Copyright (C) 2020-2021 - Benjamin Vincent Schulenburg
;;; This project uses the MIT license, a copy should be included under /LICENSE
;;;
(import (VT100) :term/VT100)
(import (TermAppVerticalSplit TermAppHorizontalSplit) :term/TermAppSplit)
(defclass TermApp
"A high-level I/O interface for a terminal"
:export
(defn new (self in out)
(def term (:new VT100 in out))
(:start term)
(def ret { :term term
:width 0
:height 0
:frontbuffer #nil
:backbuffer #nil
:input-buffer (buffer/allocate 16)
:input-buffer-pos 0
:event-queue #nil
:child #nil
:cursor-x -1
:cursor-y -1
:prototype* self })
(:resize ret))
(defn handle-event (self event)
(:handle-event self.child event))
(defn split-window-right (self right-child)
(def new (:new TermAppVerticalSplit self self.child right-child))
(set! self.child new)
(:handle-event new {:T :resize :width self.width :height self.height}))
(defn split-window-below (self below-child)
(def new (:new TermAppHorizontalSplit self self.child below-child))
(set! self.child new)
(:handle-event new {:T :resize :width self.width :height self.height}))
(defn run (self child)
(when self.child
(set! self.child child)
(let ((s (:get-size self)))
(:handle-event child {:T :resize :width s.width :height s.height})
(:handle-event child {:T :focus})
(:handle-event child {:T :draw}))
(return))
(try (fn (e)
(spit "err.log" (fmt "{e:?}\n"))
(:stop self)
(exit 0))
(:clear-screen self)
(def draw {:T :draw})
(let ((s (:get-size self)))
(:handle-event child {:T :resize :width s.width :height s.height})
(:handle-event child {:T :focus})
(:handle-event child draw))
(set! self.child child)
(:flip self)
(while #t
(:poll-input self) ;; Poll once so we do end up blocking on IO
(while (not (:input-would-block? self))
(:poll-input self))
(doseq (event self.event-queue)
(:handle-event self.child event))
(:handle-event self.child draw)
(:flip self)
(set! self.event-queue #nil))))
(defn stop (self)
(:stop self.term)
(exit 0))
(defn quit (self)
(:stop self.term)
(exit 0))
(defn windmove-up (self) #f)
(defn windmove-down (self) #f)
(defn windmove-left (self) #f)
(defn windmove-right (self) #f)
(defn resize (self)
(def term self.term)
(def size (:get-size term))
(def buf-size (* 2 size.width size.height))
(set! self.width size.width)
(set! self.height size.height)
(set! self.frontbuffer (buffer/allocate buf-size))
(set! self.backbuffer (buffer/allocate buf-size)))
(defn flip (self)
(def backbuffer self.backbuffer)
(def frontbuffer self.frontbuffer)
(def term self.term)
(:hide-cursor term)
(def last-color -1)
(dotimes (y self.height)
(dotimes (x self.width)
(def off (* 2 (+ x (* y self.width))))
(def bc (+ (ref backbuffer off)
(bit-shift-left (ref backbuffer (inc off)) 8)))
(def fc (+ (ref frontbuffer off)
(bit-shift-left (ref frontbuffer (inc off)) 8)))
(when (not= fc bc)
(:move-cursor term x y)
(when (not= (bit-shift-right bc 8) last-color)
(:set-color-code term (bit-shift-right bc 8))
(set! last-color (bit-shift-right bc 8)))
(:put-char term (bit-and #xFF bc))
(set! frontbuffer off (bit-and bc #xFF))
(set! frontbuffer (inc off) (bit-shift-right bc 8)))))
(when (and (> self.cursor-x 0)
(> self.cursor-y 0)
(< self.cursor-x self.width)
(< self.cursor-y self.height))
(:move-cursor term self.cursor-x self.cursor-y)
(:show-cursor term))
(:flip self.term)
self)
(defn draw-char (self char x y color)
(when (or (>= x self.width)
(>= y self.height)
(< x 0)
(< y 0))
(return))
(def off (* 2 (+ x (* y self.width))))
(def color color)
(set! self.backbuffer off char)
(set! self.backbuffer (inc off) color))
(defn set-cursor (self x y)
(set! self.cursor-x x)
(set! self.cursor-y y))
(defn clear-screen (self)
(def bb self.backbuffer)
(def fb self.frontbuffer)
(dotimes (i (:length bb) self)
(set! fb i #xFF)
(set! bb i 0)))
(defn draw-text (self text x y w h color)
(set! x (max 0 x))
(set! y (max 0 y))
(set! w (min (min w (- self.width x)) (:length text)))
(set! h (min (- self.height y) (- h 1)))
(def off (* 2 (+ x (* y self.width))))
(def bb self.backbuffer)
(dotimes (i w self)
(set! bb off (ref text i))
(set! bb (inc off) color)
(set! off (+ off 2))))
(defn get-size (self)
{ :width self.width
:height self.height })
(defn pop-input-buffer! (self bytes)
(dotimes (i (:length self.input-buffer))
(def src-pos (+ i self.input-buffer-pos))
(def src-key (if (< src-pos (:length self.input-buffer))
(ref self.input-buffer (+ i self.input-buffer-pos))
0))
(set! self.input-buffer i src-key))
(set! self.input-buffer-pos 0)
(return self))
(defn add-input-event (self event)
(set! self.event-queue (cons event self.event-queue)))
(defn parse-input-buffer (self)
(when (zero? self.input-buffer-pos) (return))
(def c (ref self.input-buffer 0))
(when (= c 194) ;; Meta digit Input
(def d (ref self.input-buffer 1))
(when (= d 0)
(return))
(when (and (>= d 160) (<= d 191))
(def key (:keyword (fmt "M-{}" (from-char-code (+ #x20 (- d 160))))))
(:add-input-event self { :T :key-down :key key })
(:pop-input-buffer! self 2)
(return (:parse-input-buffer self)))
(exception :invalid-input (fmt "Unknown meta input: {d:X}") d))
(when (= c 195) ;; Meta Char Input
(def d (ref self.input-buffer 1))
(when (= d 0)
(return))
(when (and (>= d 129) (<= d 186))
(def key (:keyword (fmt "M-{}" (from-char-code (+ #x20 (- d 96))))))
(:add-input-event self { :T :key-down :key key })
(:pop-input-buffer! self 2)
(return (:parse-input-buffer self)))
(exception :invalid-input (fmt "Unknown meta input: {d:X}") d))
(when (= c #x1B) ; Escaped Input
(def d (ref self.input-buffer 1))
(when (= d #x1B) ; Double Escape
(:add-input-event self { :T :key-down :key :escape })
(:pop-input-buffer! self 2)
(return (:parse-input-buffer self)))
(when (= d 79) ; F Input
(def e (ref self.input-buffer 2))
(when (and (>= e 80) (< e 92))
(def key (:keyword (fmt "F{}" (- e 79))))
(:add-input-event self { :T :key-down :key key })
(:pop-input-buffer! self 3)
(return (:parse-input-buffer self))))
(when (= d #\[) ; Bracketed Input
(def e (ref self.input-buffer 2))
(case e
(0 (return))
#;(0 (:add-input-event self { :T :key-down :key (:keyword "M-[") })
(:pop-input-buffer! self 2)
(return (:parse-input-buffer self)))
((#x31 #x32 #x33 #x35 #x36)
(def f (ref self.input-buffer 3))
(when (= f 0) (return))
(when (= f #x3B)
(when (zero? (ref self.input-buffer 4))
(return))
(def prefix (case (ref self.input-buffer 4)
(53 "C-")
(50 "S-")
(otherwise (exception :invalid-input (fmt "Unknown C-arrow 4 suffix: {e:X}") (ref self.input-buffer 4)))))
(def dir (ref self.input-buffer 5))
(when (zero? dir)
(return))
(case dir
(#\A (:add-input-event self { :T :key-down :key (:keyword (cat prefix "up"))}))
(#\B (:add-input-event self { :T :key-down :key (:keyword (cat prefix "down"))}))
(#\C (:add-input-event self { :T :key-down :key (:keyword (cat prefix "right"))}))
(#\D (:add-input-event self { :T :key-down :key (:keyword (cat prefix "left"))}))
(#\F (:add-input-event self { :T :key-down :key (:keyword (cat prefix "end"))}))
(#\H (:add-input-event self { :T :key-down :key (:keyword (cat prefix "home"))}))
(#x7E (case e
(#x32 (:add-input-event self { :T :key-down :key :C-insert }))
(#x33 (:add-input-event self { :T :key-down :key :C-delete }))
(#x35 (:add-input-event self { :T :key-down :key :C-page-up }))
(#x36 (:add-input-event self { :T :key-down :key :C-page-down }))
(otherwise (exception :invalid-input (fmt "Unknown C-special: {e:X}")))))
(otherwise (exception :invalid-input (fmt "Unknown C-arrow dir: {dir:X}"))))
(:pop-input-buffer! self 6)
(return (:parse-input-buffer self)))
(when (= f #x37)
(:add-input-event self { :T :key-down :key :print })
(:pop-input-buffer! self 4)
(return (:parse-input-buffer self)))
(when (= f 126)
(case e
(#x32 (:add-input-event self { :T :key-down :key :insert }))
(#x33 (:add-input-event self { :T :key-down :key :delete }))
(#x35 (:add-input-event self { :T :key-down :key :page-up }))
(#x36 (:add-input-event self { :T :key-down :key :page-down }))
(otherwise (exception :invalid-input (fmt "Unknown bracketed arrow input: {e:X}") e)))
(:pop-input-buffer! self 4)
(return (:parse-input-buffer self)))
(exception :invalid-input (fmt "Unknown bracketed input suffix: {f:X}") f))
(#\A (:add-input-event self { :T :key-down :key :up }))
(#\B (:add-input-event self { :T :key-down :key :down }))
(#\C (:add-input-event self { :T :key-down :key :right }))
(#\D (:add-input-event self { :T :key-down :key :left }))
(#\F (:add-input-event self { :T :key-down :key :end }))
(#\H (:add-input-event self { :T :key-down :key :home }))
(otherwise (exception :invalid-input (fmt "Unknown bracketed input: {e:X}") e)))
(:pop-input-buffer! self 3)
(return (:parse-input-buffer self)))
(when (= d 127)
(:add-input-event self { :T :key-down :key :M-backspace })
(:pop-input-buffer! self 2)
(return (:parse-input-buffer self)))
(when (= d #\Tab)
(:add-input-event self { :T :key-down :key :M-tab })
(:pop-input-buffer! self 2)
(return (:parse-input-buffer self)))
(when (and (>= d #\0) (<= d #\9))
(def key (:keyword (fmt "M-{}" (from-char-code d))))
(:add-input-event self { :T :key-down :key key })
(:pop-input-buffer! self 2)
(return (:parse-input-buffer self)))
(when (and (>= d #x20) (< d #x79))
(def key (:keyword (fmt "M-{}" (from-char-code d))))
(:add-input-event self { :T :key-down :key key })
(:pop-input-buffer! self 2)
(return (:parse-input-buffer self)))
(when (and (>= d #\a) (<= d #\z))
(def key (:keyword (fmt "M-{}" (from-char-code d))))
(:add-input-event self { :T :key-down :key key })
(:pop-input-buffer! self 2)
(return (:parse-input-buffer self))))
(when (< c 27)
(when (= c 0)
(:add-input-event self { :T :key-down :key :C-spc })
(:pop-input-buffer! self 1)
(return (:parse-input-buffer self)))
(when (= c 8)
(:add-input-event self { :T :key-down :key :backspace })
(:pop-input-buffer! self 1)
(return (:parse-input-buffer self)))
(when (< c 9)
(def key (:keyword (fmt "C-{}" (from-char-code (+ #\a (dec c))))))
(:add-input-event self { :T :key-down :key key })
(:pop-input-buffer! self 1)
(return (:parse-input-buffer self)))
(when (= c 9)
(:add-input-event self { :T :key-down :key :tab })
(:pop-input-buffer! self 1)
(return (:parse-input-buffer self)))
(when (= c 13)
(:add-input-event self { :T :key-down :key :ret })
(:pop-input-buffer! self 1)
(return (:parse-input-buffer self)))
(def key (:keyword (fmt "C-{}" (from-char-code (+ #\j (- c 10))))))
(:add-input-event self { :T :key-down :key key })
(:pop-input-buffer! self 1)
(return (:parse-input-buffer self)))
(when (and (> c 27) (< c 32))
(when (= c 31)
(:add-input-event self { :T :key-down :key :C-/ })
(:pop-input-buffer! self 1)
(return (:parse-input-buffer self)))
(when (> c 27)
(def key (:keyword (fmt "C-{}" (from-char-code (+ #\[ (- c 27))))))
(:add-input-event self { :T :key-down :key key })
(:pop-input-buffer! self 1)
(return (:parse-input-buffer self))))
(when (= c 127)
(:add-input-event self { :T :key-down :key :backspace })
(:pop-input-buffer! self 1)
(return (:parse-input-buffer self)))
(when (and (>= c #x20) (< c #x80))
(:add-input-event self { :T :input
:code c
:char (buffer->string self.input-buffer 1 0)
})
(:pop-input-buffer! self 1)
(return (:parse-input-buffer self))))
(defn parse-input-key (self key)
(when key
(:add-input-event self { :T :raw-input :code key })
(set! self.input-buffer self.input-buffer-pos key)
(set! self.input-buffer-pos (inc self.input-buffer-pos)))
(:parse-input-buffer self))
(defn get-events (self)
(when-not self.event-queue (return #nil))
(def ret (car self.event-queue))
(set! self.event-queue (cdr self.event-queue))
(return ret))
(defn input-would-block? (self)
(:input-would-block? self.term))
(defn input-left (self)
(:input-left self.term))
(defn poll-input (self)
(def key (:poll-input self.term))
(:parse-input-key self key)
key)
(defn poll-events (self)
(:poll-input self)
(:get-events self)))
