src/tty-render.lisp

   1 ;; TTY rendering routines
   2
   3 (in-package "LICE")
   4
   5 (defclass tty-frame (frame)
   6   ((double-buffer :type (array character 1) :initarg :double-buffer :accessor frame-double-buffer :documentation
   7                   "The display double buffer. This structure is compared to
   8 the characters we want to blit. Only differences are sent to the video
   9 hardware.")
  10    (2d-double-buffer :type (array character 2) :initarg :2d-double-buffer :accessor frame-2d-double-buffer :documentation
  11                      "Displaced from DISPLAY. This array is divided into rows and columns.")))
  12
  13 (defmethod frame-start-render ((frame tty-frame))
  14   )
  15
  16 (defmethod frame-end-render ((frame tty-frame))
  17   (cl-ncurses::refresh))
  18
  19 (defun window-move-cursor (window x y)
  20   (cl-ncurses::move (+ y (window-y window)) (+ x (window-x window))))
  21
  22 (defmethod frame-move-cursor ((frame tty-frame) win x y)
  23   (window-move-cursor win x y))
  24
  25 (defun putch (ch x y window frame)
  26   (window-move-cursor window x y)
  27   (cl-ncurses::addch (char-int ch))
  28   (setf (aref (frame-2d-double-buffer frame) (+ y (window-y window)) (+ x (window-x window))) ch))
  29
  30 (defun putstr (s x y w frame)
  31   (loop for i from 0 below (length s)
  32         for j from x by 1
  33         ;;if (char/= (aref (window-2d-display w) y j) (aref s i))
  34         do (putch (aref s i) j y w frame)))
  35
  36 (defun line-height (buffer p)
  37   "Return the height of the line starting at p."
  38   (declare (ignore buffer p)))
  39
  40 (defun clear-line-between (w y start end frame)
  41   "insert LEN spaces from START on line Y."
  42   (window-move-cursor w start y)
  43   ;; FIXME: this could be done faster
  44   (loop for i from start to end
  45         do (putch #\Space i y w frame)))
  46
  47 ;; Helper function for window-render
  48 (defun clear-to-eol (y start window frame)
  49   (declare (type window window)
  50            (type fixnum y start))
  51   (clear-line-between window y start (1- (window-width window nil)) frame)
  52   ;; draw the seperator
  53   (when (window-seperator window)
  54     (putch #\| (+ (window-x window) (1- (window-width window t))) y window frame)))
  55
  56 (defun turn-on-attributes (buffer point)
  57   "Given the buffer and point, turn on the appropriate colors based on
  58 the text properties present."
  59   ;; These are hardcoded for now
  60   (case (get-text-property point :face buffer)
  61     (:face-1
  62      (cl-ncurses::attrset (cl-ncurses::COLOR-PAIR 1)))
  63     (:face-2
  64      (cl-ncurses::attrset (cl-ncurses::COLOR-PAIR 2)))
  65     (:face-3
  66      (cl-ncurses::attrset (cl-ncurses::COLOR-PAIR 3)))
  67     (:face-4
  68      (cl-ncurses::attrset (cl-ncurses::COLOR-PAIR 4)))
  69     (:face-5
  70      (cl-ncurses::attrset (cl-ncurses::COLOR-PAIR 5)))
  71     (:face-6
  72      (cl-ncurses::attrset (cl-ncurses::COLOR-PAIR 6)))
  73     (:face-7
  74      (cl-ncurses::attrset (cl-ncurses::COLOR-PAIR 7)))
  75     (:face-8
  76      (cl-ncurses::attrset (cl-ncurses::COLOR-PAIR 8)))
  77     (t
  78      (cl-ncurses::attrset (cl-ncurses::COLOR-PAIR 1)))))
  79
  80 (defmethod window-render (w (frame tty-frame))
  81   "Render a window."
  82   (let ((p (buffer-char-to-aref (window-buffer w) (marker-position (window-top w))))
  83         ;; current point in buffer buffer
  84         (bp (marker-position (window-top w)))
  85         (buf (window-buffer w))
  86         ;; The cursor point in the buffer. When the buffer isn't
  87         ;; current, then use the window's backup of the point.
  88         (point (window-point w))
  89         cursor-x
  90         cursor-y
  91         (cache-size (length (lc-cache (window-cache w))))
  92         ;; (linear (frame-double-buffer frame))
  93         ;; (display (frame-2d-double-buffer frame))
  94         )
  95     ;; rxvt draws black on black if i don't turn on a color
  96     (cl-ncurses::attron (cl-ncurses::COLOR-PAIR 1))
  97     ;; Special case: when the buffer is empty
  98     (if (= (buffer-size (window-buffer w)) 0)
  99         (progn
 100           (dotimes (y (window-height w nil))
 101             (clear-to-eol y 0 w frame))
 102           (setf cursor-x 0
 103                 cursor-y 0))
 104       (let ((end (loop named row
 105                        for y below (window-height w nil)
 106                        for line from (window-top-line w) below cache-size
 107                        ;; return the last line, so we can erase the rest
 108                        finally (return-from row y)
 109                        ;; go to the next line
 110                        do (let* ((line-end (cache-item-end (item-in-cache w line)))
 111                                  (line-start (cache-item-start (item-in-cache w line)))
 112                                  (next-prop (next-single-property-change line-start :face (window-buffer w) line-end)))
 113                             (setf bp (cache-item-start (item-in-cache w line))
 114                                   p (buffer-char-to-aref (window-buffer w) bp))
 115                             ;; setup the display properties.
 116                             (turn-on-attributes (window-buffer w) bp)
 117                             (loop named col
 118                                 for x below (window-width w nil) do
 119                                 (progn
 120                                   ;; Skip the gap
 121                                   (when (= p (buffer-gap-start buf))
 122                                     (incf p (buffer-gap-size buf)))
 123                                   ;; Record point position on screen
 124                                   (when (eq bp point)
 125                                     (setf cursor-x x)
 126                                     (setf cursor-y y))
 127                                   (when (or (> bp line-end)
 128                                             (>= p (length (buffer-data buf))))
 129                                     ;; gotta turn off attributes to do this
 130                                     (cl-ncurses::attrset (cl-ncurses::COLOR-PAIR 1))
 131                                     ;; Check if the rest of the line is blank
 132                                     (clear-to-eol y x w frame)
 133                                     (return-from col))
 134                                   ;; update attributes
 135                                   (when (>= bp next-prop)
 136                                     (turn-on-attributes (window-buffer w) bp))
 137                                   (let ((ch (elt (buffer-data buf) p)))
 138                                     ;; Update display
 139                                     (cond ((char= ch #\Newline)
 140                                            (putch #\Space x y w frame))
 141                                           (t
 142                                            (putch ch x y w frame)))
 143                                     ;; go to the next character in the buffer
 144                                     (incf p)
 145                                     (incf bp))))))))
 146         ;; Check if the bottom of the window needs to be erased.
 147         (when (< end (1- (window-height w nil)))
 148           (loop for i from end below (window-height w nil) do
 149                 (clear-to-eol i 0 w frame)))))
 150     ;; rxvt draws black on black if i don't turn on a color
 151     (cl-ncurses::attroff (cl-ncurses::COLOR-PAIR 1))
 152     ;; Update the mode-line if it exists. FIXME: Not the right place
 153     ;; to update the mode-line.
 154     (when (buffer-local '*mode-line-format* (window-buffer w))
 155       (update-mode-line (window-buffer w))
 156       ;;(cl-ncurses::attron cl-ncurses::A_REVERSE)
 157       (cl-ncurses::attron (cl-ncurses::COLOR-PAIR 2))
 158       (putstr (truncate-mode-line (window-buffer w) (window-width w nil))
 159               0 (window-height w nil) w frame)
 160       (cl-ncurses::attroff (cl-ncurses::COLOR-PAIR 2))
 161       ;;(cl-ncurses::attroff cl-ncurses::A_REVERSE)
 162       ;; don't forget the seperator on the modeline line
 163       (when (window-seperator w)
 164         (putch #\| (+ (window-x w) (window-width w nil)) (window-height w nil) w frame)))
 165     (reset-line-state w)
 166     ;; Set the cursor at the right spot
 167     (values cursor-x cursor-y)))
 168
 169 ;;; keyboard stuff
 170
 171 (defmethod frame-read-event ((frame tty-frame))
 172   (when (listen *standard-input*)
 173     (let ((ch (char-code (read-char)))
 174           key meta control)
 175       (dformat +debug-v+ "read: ~a~%" ch)
 176       ;; ESC mean Meta
 177       (when (= ch +key-escape+)
 178         (dformat +debug-v+ "meta~%")
 179         (setf ch (char-code (read-char))
 180               meta t))
 181       ;; the 8th bit could also mean meta
 182       (when (= (logand ch 128) 128)
 183         (decf ch 128)
 184         (setf meta t))
 185       ;; <27 means Control
 186       (when (< ch 27)
 187         (incf ch 96)
 188         (setf control t))
 189       ;; set key to the character
 190       (setf key (case ch
 191                   (+key-backspace+
 192                    #\Backspace)
 193                   (+key-enter+
 194                    #\Return)
 195                   (+key-tab+
 196                    #\Tab)
 197                   (t
 198                    (code-char ch))))
 199       (make-key
 200        :char key
 201        :control control
 202        :meta meta))))
 203
 204 ;;; some frame stuff
 205
 206 (defun init-tty-colors ()
 207   (cl-ncurses::start-color)
 208   (cl-ncurses::init-pair 1 cl-ncurses::COLOR_WHITE cl-ncurses::COLOR_BLACK)
 209   (cl-ncurses::init-pair 2 cl-ncurses::COLOR_GREEN cl-ncurses::COLOR_BLUE)
 210   (cl-ncurses::init-pair 3 cl-ncurses::COLOR_WHITE cl-ncurses::COLOR_BLACK)
 211   (cl-ncurses::init-pair 4 cl-ncurses::COLOR_RED cl-ncurses::COLOR_BLACK)
 212   (cl-ncurses::init-pair 5 cl-ncurses::COLOR_MAGENTA cl-ncurses::COLOR_GREEN)
 213   (cl-ncurses::init-pair 6 cl-ncurses::COLOR_BLACK cl-ncurses::COLOR_BLUE)
 214   (cl-ncurses::init-pair 7 cl-ncurses::COLOR_WHITE cl-ncurses::COLOR_CYAN)
 215   (cl-ncurses::init-pair 8 cl-ncurses::COLOR_RED cl-ncurses::COLOR_MAGENTA))
 216 ;;     (cl-ncurses::attron (cl-ncurses::COLOR-PAIR 1)))
 217
 218 (defun init-tty ()
 219   (let ((scr (cl-ncurses::initscr)))
 220     (init-tty-colors)
 221     ;;(cl-ncurses::raw)
 222     (cl-ncurses::cbreak)
 223     (cl-ncurses::meta scr 1)
 224     (cl-ncurses::noecho)
 225     (cl-ncurses::erase)
 226     (cl-ncurses::scrollok scr 0)
 227     (enable-sigint-handler)
 228     (term-backup-settings)
 229     (term-set-quit-char *quit-code*)))
 230
 231 (defun shutdown-tty ()
 232   (term-restore-settings)
 233   (cl-ncurses::endwin))
 234
 235 (defun make-default-tty-frame (buffer)
 236   (let* ((lines cl-ncurses::*lines*)
 237          (height (1- lines))
 238          (cols (prog1 cl-ncurses::*cols*))
 239          (l (make-array (* lines cols)
 240                         :element-type 'character))
 241          (d (make-array (list lines cols)
 242                         :element-type 'character
 243                         :displaced-to l :displaced-index-offset 0))
 244          (w (make-window :x 0 :y 0 :cols cols :rows height :buffer buffer))
 245          (mb (make-minibuffer-window lines cols))
 246          (frame (make-instance 'tty-frame
 247                                :width cols
 248                                :height lines
 249                                :window-tree (list w mb)
 250                                :selected-window w
 251                                :minibuffer-window mb
 252                                :double-buffer l
 253                                :2d-double-buffer d)))
 254     (setf (window-frame w) frame
 255           (window-frame mb) frame)
 256     frame))
 257
 258 (defun make-test-frame (buffer)
 259   "This can be used to create a frame configuration for testing."
 260   (let* ((lines 20)
 261          (height (1- lines))
 262          (cols 78)
 263          (l (make-array (* lines cols)
 264                         :element-type 'character
 265                         :initial-element #\Space))
 266          (d (make-array (list lines cols)
 267                         :element-type 'character
 268                         :displaced-to l :displaced-index-offset 0))
 269          (w (make-window :x 0 :y 0 :cols cols :rows height :buffer buffer))
 270          (mb (make-minibuffer-window lines cols))
 271          (frame (make-instance 'tty-frame
 272                                :width cols
 273                                :height lines
 274                                :window-tree (list w mb)
 275                                :selected-window w
 276                                :minibuffer-window mb
 277                                :double-buffer l
 278                                :2d-double-buffer d)))
 279     (setf (window-frame w) frame
 280           (window-frame mb) frame)
 281     frame))