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)) 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     ;; rxvt draws black on black if i don't turn on a color
  95     (cl-ncurses::attron (cl-ncurses::COLOR-PAIR 1))
  96     ;; Special case: when the buffer is empty
  97     (if (= (buffer-size (window-buffer w)) 0)
  98         (progn
  99           (dotimes (y (window-height w))
 100             (clear-to-eol y 0 w frame))
 101           (setf cursor-x 0
 102                 cursor-y 0))
 103       (let ((end (loop named row
 104                        for y below (window-height w)
 105                        for line from (window-top-line w) below cache-size
 106                        ;; return the last line, so we can erase the rest
 107                        finally (return-from row y)
 108                        ;; go to the next line
 109                        do (let* ((line-end (cache-item-end (item-in-cache w line)))
 110                                  (line-start (cache-item-start (item-in-cache w line)))
 111                                  (next-prop (next-single-property-change line-start :face (window-buffer w) line-end)))
 112                             (setf bp (cache-item-start (item-in-cache w line))
 113                                   p (buffer-char-to-aref (window-buffer w) bp))
 114                             ;; setup the display properties.
 115                             (turn-on-attributes (window-buffer w) bp)
 116                             (loop named col
 117                                 for x below (window-width w) do
 118                                 (progn
 119                                   ;; Skip the gap
 120                                   (when (= p (buffer-gap-start buf))
 121                                     (incf p (buffer-gap-size buf)))
 122                                   ;; Record point position on screen
 123                                   (when (eq bp point)
 124                                     (setf cursor-x x)
 125                                     (setf cursor-y y))
 126                                   (when (or (> bp line-end)
 127                                             (>= p (length (buffer-data buf))))
 128                                     ;; gotta turn off attributes to do this
 129                                     (cl-ncurses::attrset (cl-ncurses::COLOR-PAIR 1))
 130                                     ;; Check if the rest of the line is blank
 131                                     (clear-to-eol y x w frame)
 132                                     (return-from col))
 133                                   ;; update attributes
 134                                   (when (>= bp next-prop)
 135                                     (turn-on-attributes (window-buffer w) bp))
 136                                   (let ((ch (elt (buffer-data buf) p)))
 137                                     ;; Update display
 138                                     (cond ((char= ch #\Newline)
 139                                            (putch #\Space x y w frame))
 140                                           (t
 141                                            (putch ch x y w frame)))
 142                                     ;; go to the next character in the buffer
 143                                     (incf p)
 144                                     (incf bp))))))))
 145         ;; Check if the bottom of the window needs to be erased.
 146         (when (< end (1- (window-height w)))
 147           (loop for i from end below (window-height w) do
 148                 (clear-to-eol i 0 w frame)))))
 149     ;; rxvt draws black on black if i don't turn on a color
 150     (cl-ncurses::attroff (cl-ncurses::COLOR-PAIR 1))
 151     ;; Update the mode-line if it exists. FIXME: Not the right place
 152     ;; to update the mode-line.
 153     (when (buffer-mode-line (window-buffer w))
 154       (update-mode-line (window-buffer w))
 155       ;;(cl-ncurses::attron cl-ncurses::A_REVERSE)
 156       (cl-ncurses::attron (cl-ncurses::COLOR-PAIR 2))
 157       (putstr (truncate-mode-line (window-buffer w) (window-width w))
 158               0 (window-height w nil) w frame)
 159       (cl-ncurses::attroff (cl-ncurses::COLOR-PAIR 2))
 160       ;;(cl-ncurses::attroff cl-ncurses::A_REVERSE)
 161       ;; don't forget the seperator on the modeline line
 162       (when (window-seperator w)
 163         (putch #\| (+ (window-x w) (window-width w)) (window-height w) w frame)))
 164     (reset-line-state w)
 165     ;; Set the cursor at the right spot
 166     (values cursor-x cursor-y)))
 167
 168 ;;; keyboard stuff
 169
 170 (defmethod frame-read-event ((frame tty-frame))
 171   (let ((ch (char-code (read-char)))
 172         key meta control)
 173     (dformat +debug-v+ "read: ~a~%" ch)
 174     ;; ESC mean Meta
 175     (when (= ch +key-escape+)
 176       (dformat +debug-v+ "meta~%")
 177       (setf ch (char-code (read-char))
 178             meta t))
 179     ;; the 8th bit could also mean meta
 180     (when (= (logand ch 128) 128)
 181       (decf ch 128)
 182       (setf meta t))
 183     ;; <27 means Control
 184     (when (< ch 27)
 185       (incf ch 96)
 186       (setf control t))
 187     ;; set key to the character
 188     (setf key (case ch
 189                 (+key-backspace+
 190                  #\Backspace)
 191                 (+key-enter+
 192                  #\Return)
 193                 (+key-tab+
 194                  #\Tab)
 195                 (t
 196                  (code-char ch))))
 197     (make-instance 'key
 198                    :char key
 199                    :control control
 200                    :meta meta)))
 201
 202 ;;; some frame stuff
 203
 204 (defun init-tty-colors ()
 205   (cl-ncurses::start-color)
 206   (cl-ncurses::init-pair 1 cl-ncurses::COLOR_WHITE cl-ncurses::COLOR_BLACK)
 207   (cl-ncurses::init-pair 2 cl-ncurses::COLOR_GREEN cl-ncurses::COLOR_BLUE)
 208   (cl-ncurses::init-pair 3 cl-ncurses::COLOR_WHITE cl-ncurses::COLOR_BLACK)
 209   (cl-ncurses::init-pair 4 cl-ncurses::COLOR_RED cl-ncurses::COLOR_BLACK)
 210   (cl-ncurses::init-pair 5 cl-ncurses::COLOR_MAGENTA cl-ncurses::COLOR_GREEN)
 211   (cl-ncurses::init-pair 6 cl-ncurses::COLOR_BLACK cl-ncurses::COLOR_BLUE)
 212   (cl-ncurses::init-pair 7 cl-ncurses::COLOR_WHITE cl-ncurses::COLOR_CYAN)
 213   (cl-ncurses::init-pair 8 cl-ncurses::COLOR_RED cl-ncurses::COLOR_MAGENTA))
 214 ;;     (cl-ncurses::attron (cl-ncurses::COLOR-PAIR 1)))
 215
 216 (defun init-tty ()
 217   (let ((scr (cl-ncurses::initscr)))
 218     (init-tty-colors)
 219     (cl-ncurses::raw)
 220     (cl-ncurses::meta scr 1)
 221     (cl-ncurses::noecho)
 222     (cl-ncurses::erase)
 223     (cl-ncurses::scrollok scr 0)))
 224
 225 (defun shutdown-tty ()
 226   (cl-ncurses::endwin))
 227
 228 (defun make-default-tty-frame (buffer)
 229   (let* ((lines cl-ncurses::*lines*)
 230          (height (1- lines))
 231          (cols (prog1 cl-ncurses::*cols*))
 232          (l (make-array (* lines cols)
 233                         :element-type 'character))
 234          (d (make-array (list lines cols)
 235                         :element-type 'character
 236                         :displaced-to l :displaced-index-offset 0))
 237          (w (make-window :x 0 :y 0 :cols cols :rows height :buffer buffer))
 238          (mb (make-minibuffer-window lines cols))
 239          (frame (make-instance 'tty-frame
 240                                :width cols
 241                                :height lines
 242                                :window-tree (list w mb)
 243                                :current-window w
 244                                :minibuffer-window mb
 245                                :double-buffer l
 246                                :2d-double-buffer d)))
 247     (setf (window-frame w) frame
 248           (window-frame mb) frame)
 249     frame))
 250
 251 (defun make-test-frame (buffer)
 252   "This can be used to create a frame configuration for testing."
 253   (let* ((lines 20)
 254          (height (1- lines))
 255          (cols 78)
 256          (l (make-array (* lines cols)
 257                         :element-type 'character
 258                         :initial-element #\Space))
 259          (d (make-array (list lines cols)
 260                         :element-type 'character
 261                         :displaced-to l :displaced-index-offset 0))
 262          (w (make-window :x 0 :y 0 :cols cols :rows height :buffer buffer))
 263          (mb (make-minibuffer-window lines cols))
 264          (frame (make-instance 'tty-frame
 265                                :width cols
 266                                :height lines
 267                                :window-tree (list w mb)
 268                                :current-window w
 269                                :minibuffer-window mb
 270                                :double-buffer l
 271                                :2d-double-buffer d)))
 272     (setf (window-frame w) frame
 273           (window-frame mb) frame)
 274     frame))