1;;; Virtual Character Mode Terminal (virtty) that can be used to build very simple interfaces, e.g. editors or simple games. 2;;; Interface (but not implementation) inspired by OpenLisp ( http://www.eligis.com ) and 3;;; Le-Lisp ( https://github.com/c-jullien/lelisp ). 4;;; 5;;; This has moderate dependencies on ncurses. 6;;; 7;;; NB: this should be used under "eisl -r", otherwise keyboard echo may end up disabled! 8 9(c-define "NCURSES_OPAQUE" "1") 10(c-include "<ncurses.h>") 11(c-include "<locale.h>") 12(c-include "<unistd.h>") 13(c-option "-lncurses") 14 15(defun typrologue () 16 ;; Enter the terminal into a mode for drawing characters. 17 (c-lang "initscr();") 18 (c-lang "start_color();") 19 (c-lang "use_default_colors();") 20 (c-lang "scrollok(stdscr, TRUE);") 21 (c-lang "idlok(stdscr, TRUE);") 22 (c-lang "noecho();") 23 (c-lang "keypad(stdscr, TRUE);") 24 (c-lang "cbreak();") 25 (c-lang "nonl();") 26 (c-lang "intrflush(stdscr, FALSE);") 27 (tyshowcursor t) 28 (c-lang "res = set_tabsize(8) | INT_FLAG;")) 29 30(defun tyepilogue () 31 ;; Reset the terminal to its original mode. 32 (c-lang "res = endwin() | INT_FLAG;")) 33 34(defun tycls () 35 ;; Clears the entire screen. 36 (c-lang "res = clear() | INT_FLAG;")) 37 38(defun tycursor (column row) 39 ;; Moves the cursor to position (x, y) on the screen. 40 (the <fixnum> column)(the <fixnum> row) 41 (c-lang "res = move(ROW & INT_MASK, COLUMN & INT_MASK) | INT_FLAG;")) 42 43(defun tycleol () 44 ;; Clears the current line to end of line. 45 (c-lang "res = clrtoeol() | INT_FLAG;")) 46 47(defun tyattrib (x) 48 ;; Set, if flag is t, or reset, if flag is nil, the reverse-video attribute. 49 (if x 50 (c-lang "res = attron(A_REVERSE) | INT_FLAG;") 51 (c-lang "res = attroff(A_REVERSE) | INT_FLAG;"))) 52 53(defun tyo (&rest objs) 54 (for ((xs objs (cdr xs))) 55 ((null xs)) 56 (tyo1 (car xs)))) 57 58(defgeneric tyo1 (o) 59 ;; Output the object o (a character, string or list of characters) at the current position. 60 ) 61(defmethod tyo1 ((o <character>)) 62 (the <character> o) 63 (tycn o)) 64(defmethod tyo1 ((o <string>)) 65 (the <string> o) 66 (tystring o (length o))) 67(defmethod tyo1 ((o <list>)) 68 (the <list> o) 69 (for ((xs o (cdr xs))) 70 ((null xs)) 71 (tyo (car xs)))) 72 73(defun tyxmax () 74 ;; The maximum number of characters that can fit on a single line. 75 (c-lang "int x, y;") 76 (c-lang "getmaxyx(stdscr, y, x);") 77 (c-lang "res = x | INT_FLAG;")) 78 79(defun tyymax () 80 ;; The maximum number of character that can fit on a single column. 81 (c-lang "int x, y;") 82 (c-lang "getmaxyx(stdscr, y, x);") 83 (c-lang "res = y | INT_FLAG;")) 84 85(defun tyflush () 86 ;; Flush unsent characters. 87 (c-lang "res = refresh() | INT_FLAG;")) 88 89(defun tybeep () 90 ;; Sounds the bell. 91 (c-lang "res = beep() | INT_FLAG;")) 92 93(defun tyi () 94 ;; Reads a single character without echo. 95 (c-lang "res = getch() | INT_FLAG;")) 96 97;; Various ncurses ( https://man.openbsd.org/curses ) constants. 98;; I got these from https://github.com/HiTECNOLOGYs/cl-charms/blob/master/src/low-level/curses-bindings.lisp but the header file would have done as well. 99 100(defconstant KEY_HOME #o406) 101(defconstant KEY_END #o550) 102(defconstant KEY_NPAGE #o552) 103(defconstant KEY_PPAGE #o553) 104(defconstant KEY_F0 #o410) 105 106(defun key_fn (n) 107 (the <fixnum> n) 108 (+ KEY_F0 n)) 109 110(defconstant KEY_IC #o513) 111 112(defconstant ERR -1) 113 114(defun tys () 115 ;; Tests whether or not a character can be read from the keyboard. 116 (let ((response 0)) 117 (setq response (c-lang "getch() | INT_FLAG")) 118 (if (= response ERR) 119 nil 120 (progn (c-lang "ungetch(RESPONSE & INT_MASK);") 121 t)))) 122 123(defun tycn (ch) 124 ;; Output character ch at the current position. 125 (the <character> ch) 126 (let ((ch-code (convert ch <integer>))) 127 (c-lang "res = addch(CH_CODE & INT_MASK) | INT_FLAG;"))) 128 129(defun tyshowcursor (flag) 130 ;; Shows, if flag is t, or hides, if flag is nil, the cursor. 131 (if flag 132 (c-lang "res = curs_set(1) | INT_FLAG;") 133 (c-lang "res = curs_set(0) | INT_FLAG;"))) 134 135(defun tyco (x y &rest os) 136 ;; Output the object o at position (x, y). 137 (the <fixnum> x)(the <fixnum> y) 138 (tycursor x y) 139 (apply #'tyo os)) 140 141(defun tystring (str n) 142 ;; Output the first n characters of string str at the current position. 143 (the <string> str)(the <fixnum> n) 144 (let ((substr (subseq str 0 n))) 145 (c-lang "res = addstr(Fgetname(SUBSTR)) | INT_FLAG;"))) 146 147;; Further functions from Le-Lisp. 148 149(defun tyinstring () 150 ;; Read a line from the keyboard 151 (c-lang "static char str[133];") 152 (c-lang "echo();") 153 (c-lang "getnstr(str, 132);") 154 (c-lang "noecho();") 155 (c-lang "res = Fmakestr(str);")) ; Fmakestr copies its argument 156 157(defun tynewline () 158 ;; Send an end-of-line marker to the screen. 159 (tyo #\newline)) 160 161(defconstant +bs+ (convert 8 <character>)) 162(defun tyback (cn) 163 ;; Erase the character immediately before the cursor on screen and move the cursor back one space. 164 (tyo +bs+) 165 (tyo #\space) 166 (tyo +bs+)) 167 168(defun tyod (n nc) 169 ;; Print the base-10 nc-character representation of the number n. 170 (the <fixnum> n)(the <fixnum> nc) 171 (let ((str (create-string-output-stream))) 172 (format str "~D" n) 173 (tyo (subseq (get-output-stream-string str) 0 nc)))) 174 175(defun tybs (cn) 176 ;; Moves the cursor position back one space without erasing anything on the screen. 177 (tyo +bs+)) 178 179(defconstant +cr+ (convert 13 <character>)) 180(defun tycr () 181 ;; Place the cursor at the beginning of the current line. 182 (tyo +cr+)) 183 184(defun tyupkey () 185 ;; Returns the key code associated with the up arrow key. 186 #o403) 187(defun tydownkey () 188 ;; Returns the key code associated with the down arrow key. 189 #o402) 190(defun tyleftkey () 191 ;; Returns the key code associated with the left arrow key. 192 #o404) 193(defun tyrightkey () 194 ;; Returns the key code associated with the right arrow key. 195 #o405) 196 197(defun tycleos () 198 ;; Erase from the cursor to the end of screen. 199 (c-lang "res = clrtobot() | INT_FLAG;")) 200 201(defun tyinsch (ch) 202 ;; Insert a character at the current cursor position. 203 (the <character> ch) 204 (c-lang "res = insch(CH) | INT_FLAG;")) 205 206(defun tyinscn (cn) 207 (tyinsch cn)) 208 209(defun tydelch () 210 ;; Erase the character at the current cursor position. 211 (c-lang "res = delch() | INT_FLAG;")) 212 213(defun tydelcn (cn) 214 (tydelch)) 215 216(defun tyinsln () 217 ;; Insert a new line at the current cursor position. 218 (c-lang "res = insertln() | INT_FLAG;")) 219 220(defun tydelln () 221 ;; Erase the line at the current cursor position. 222 (c-lang "res = deleteln() | INT_FLAG;")) 223 224(defun tycot (x y &rest os) 225 (the <fixnum> x)(the <fixnum> y) 226 (tyattrib t) 227 (apply #'tyco x y os) 228 (tyattrib nil)) 229 230;; Further extensions from curses: 231 232(defun inch () 233 ;; Get a character from the screen. 234 (c-lang "res = inch() | INT_FLAG;")) 235 236(defun getyx (pair) 237 ;; Get cursor coordinates. 238 (the <cons> pair) 239 (c-lang "int y, x;") 240 (c-lang "getyx(stdscr, y, x);") 241 (setf (car pair) (c-lang "y | INT_FLAG")) 242 (setf (cdr pair) (c-lang "x | INT_FLAG"))) 243 244(defun nodelay () 245 ;; Cause tyi to be a non-blocking call. 246 (c-lang "res = nodelay(stdscr, TRUE) | INT_FLAG;")) 247 248;; Historic version of UNIX curses had extensions for forms and menus. 249;; These weren't standardised, but some minimal feature like this is useful. 250 251;; First, menus. 252;; This is a fairly straightforward port of the Rosetta Code task. 253 254(defun virtty--get-digit (num-choices) 255 (the <fixnum> num-choices) 256 (let ((res (- (tyi) 48))) 257 (while (or (< res 0) (>= res num-choices)) 258 (setq res (- (tyi) 48))) 259 res)) 260 261(defun virtty--head (title) 262 (the <string> title) 263 (tycls) 264 (tyattrib t) 265 (tyco 4 0 title) 266 (tyattrib nil)) 267 268(defun select (prompt choices) 269 (the <string> prompt)(the <list> choices) 270 (if (null choices) 271 -1 272 (progn (virtty--head prompt) 273 (for ((n 0 (+ n 1)) 274 (c choices (cdr c))) 275 ((null c)) 276 (let ((str (create-string-output-stream))) 277 (format str "~D) ~A" n (car c)) 278 (tyco 2 (+ n 2) (get-output-stream-string str)))) 279 (virtty--get-digit (length choices))))) 280 281;;; Forms are more involved. 282;;; We need to support a few modes depending on C/R/U. 283;;; I tried using ILOS, but that really doesn't work well from compiled code. 284;;; A functional interface is just as good anyway. 285 286(defun form (title keys) 287 ;; Display a form to "create" a record 288 (the <string> title>)(the <list> keys) 289 (if (not (null keys)) 290 (progn (virtty--head title) 291 (for ((n 0 (+ n 1)) 292 (f keys (cdr f)) 293 (res nil)) 294 ((null f) (reverse res)) 295 (tyco 2 (+ n 2) (string-append (car f) ": ")) 296 (setq res (cons (tyinstring) res)))))) 297 298(defun print-form (title keys vals) 299 ;; Display a record's contents after it has been retrieved 300 (the <string> title)(the <list> keys)(the <list> vals) 301 (virtty--head title) 302 (for ((n 0 (+ n 1)) 303 (rest-keys keys (cdr rest-keys)) 304 (rest-vals vals (cdr rest-vals))) 305 ((or (null rest-keys) (null rest-vals))) 306 (tyco 2 (+ n 2) (string-append (car rest-keys) ": " (car rest-vals))))) 307 308(defun virtty--edit-field (choice key-len old-val) 309 (the <fixnum> choice)(the <fixnum> key-len)(the <string> old-val) 310 (tyco (+ 7 key-len) (+ choice 2) (string-append "(" old-val ") ")) 311 (tyflush) 312 (tyinstring)) 313 314(defun edit-form (title keys vals) 315 ;; Display a retrieved record's contents, and allow editing of one field 316 (the <string> title)(the <list> keys)(the <list> vals) 317 (virtty--head title) 318 (for ((n 0 (+ n 1)) 319 (rest-keys keys (cdr rest-keys)) 320 (rest-vals vals (cdr rest-vals))) 321 ((or (null rest-keys) (null rest-vals))) 322 (let ((str (create-string-output-stream))) 323 (format str "~D) ~A: ~A" n (car rest-keys) (car rest-vals)) 324 (tyco 2 (+ n 2) (get-output-stream-string str)))) 325 (tyflush) 326 (let ((choice (virtty--get-digit (length keys)))) 327 (setf (elt vals choice) 328 (virtty--edit-field choice 329 (length (elt keys choice)) 330 (elt vals choice))) 331 vals)) 332 333;; From here on is test code 334 335#| 336(defglobal *key* nil) 337(defglobal *pos* (cons 0 0)) 338 339(defun my-test () 340 (typrologue) 341 (tycls) 342 (tycursor 10 5) 343 (tyattrib t) 344 (tyo "Hello world") 345 (tyattrib nil) 346 (tycursor 10 10) 347 (let ((str (create-string-output-stream))) 348 (format str "~A" (tyxmax)) 349 (tyo (get-output-stream-string str))) 350 (tyflush) 351 (tybeep) 352 (setq *key* (tyi)) 353 (getyx *pos*) 354 (tyepilogue)) 355|# 356