clisp-render.lisp

   1 ;; TTY rendering routines
   2
   3 (in-package :lice)
   4
   5 (defclass clisp-frame (frame)
   6   ((window-stream :type window-stream :initarg :window-stream :accessor frame-window-stream)
   7    (double-buffer :type (array character 1) :initarg :double-buffer :accessor frame-double-buffer :documentation
   8                   "The display double buffer. This structure is compared to
   9 the characters we want to blit. Only differences are sent to the video
  10 hardware.")
  11    (2d-double-buffer :type (array character 2) :initarg :2d-double-buffer :accessor frame-2d-double-buffer :documentation
  12                      "Displaced from DISPLAY. This array is divided into rows and columns.")))
  13
  14 (defmethod frame-start-render ((frame clisp-frame))
  15   )
  16
  17 (defmethod frame-end-render ((frame clisp-frame))
  18   ;; (screen:window-refresh (frame-window-stream frame))
  19   )
  20
  21 ;; This has to be defined (it should be a generic function)
  22 (defun window-move-cursor (window x y window-stream)
  23   (screen:set-window-cursor-position window-stream (+ y (window-y window)) (+ x (window-x window))))
  24
  25 (defmethod frame-move-cursor ((frame clisp-frame) win x y)
  26   (window-move-cursor win x y (frame-window-stream frame)))
  27
  28 (defun putch (ch x y window frame)
  29   (when (char/= (aref (frame-2d-double-buffer frame) (+ y (window-y window)) (+ x (window-x window))) ch)
  30     (window-move-cursor window x y (frame-window-stream frame))
  31     (write-char ch (frame-window-stream frame))
  32     (setf (aref (frame-2d-double-buffer frame) (+ y (window-y window)) (+ x (window-x window))) ch)))
  33
  34 (defun putstr (s x y w frame)
  35   (loop for i from 0 below (length s)
  36         for j from x by 1
  37         do (putch (aref s i) j y w frame)))
  38
  39 (defun line-height (buffer p)
  40   "Return the height of the line starting at p."
  41   (declare (ignore buffer p)))
  42
  43 (defun clear-line-between (w y start end frame)
  44   "insert LEN spaces from START on line Y."
  45   (loop for i from start to end
  46         do (putch #\Space i y w frame)))
  47
  48 ;; Helper function for window-render
  49 (defun clear-to-eol (y start window frame)
  50   (declare (type window window)
  51            (type fixnum y start))
  52   (let ((display (frame-2d-double-buffer frame))
  53         (linear (frame-double-buffer frame)))
  54     (clear-line-between window y start (1- (window-width window)) frame)
  55     ;; draw the seperator
  56     (when (window-seperator window)
  57       (putch #\| (+ (window-x window) (1- (window-width window t))) y window frame))))
  58
  59 (defun turn-on-attributes (buffer point frame)
  60   "Given the buffer and point, turn on the appropriate colors based on
  61 the text properties present."
  62   ;; These are hardcoded for now
  63   (if (get-text-property point :face buffer)
  64       (screen:highlight-on (frame-window-stream frame))
  65     (screen:highlight-off (frame-window-stream frame))))
  66
  67 (defmethod window-render (w (frame clisp-frame))
  68   "Render a window."
  69   (let ((p (buffer-char-to-aref (window-buffer w) (marker-position (window-top w))))
  70         ;; current point in buffer buffer
  71         (bp (marker-position (window-top w)))
  72         (buf (window-buffer w))
  73         ;; The cursor point in the buffer. When the buffer isn't
  74         ;; current, then use the window's backup of the point.
  75         (point (window-point w))
  76         cursor-x
  77         cursor-y
  78         (cache-size (length (lc-cache (window-cache w))))
  79         (linear (frame-double-buffer frame))
  80         (display (frame-2d-double-buffer frame)))
  81     ;; Special case: when the buffer is empty
  82     (if (= (buffer-size (window-buffer w)) 0)
  83         (progn
  84           (dotimes (y (window-height w))
  85             (clear-to-eol y 0 w frame))
  86           (setf cursor-x 0
  87                 cursor-y 0))
  88       (let ((end (loop named row
  89                        for y below (window-height w)
  90                        for line from (window-top-line w) below cache-size
  91                        ;; return the last line, so we can erase the rest
  92                        finally (return-from row y)
  93                        ;; go to the next line
  94                        do (let* ((line-end (cache-item-end (item-in-cache w line)))
  95                                  (line-start (cache-item-start (item-in-cache w line)))
  96                                  (next-prop (next-single-property-change line-start :face (window-buffer w) line-end)))
  97                             (setf bp (cache-item-start (item-in-cache w line))
  98                                   p (buffer-char-to-aref (window-buffer w) bp))
  99                             ;; setup the display properties.
 100                             (turn-on-attributes (window-buffer w) bp frame)
 101                             (loop named col
 102                                 for x below (window-width w) do
 103                                 (progn
 104                                   ;; Skip the gap
 105                                   (when (= p (buffer-gap-start buf))
 106                                     (incf p (buffer-gap-size buf)))
 107                                   ;; Record point position on screen
 108                                   (when (eq bp point)
 109                                     (setf cursor-x x)
 110                                     (setf cursor-y y))
 111                                   (when (or (> bp line-end)
 112                                             (>= p (length (buffer-data buf))))
 113                                     ;; Check if the rest of the line is blank
 114                                     (clear-to-eol y x w frame)
 115                                     (return-from col))
 116                                   ;; update attributes
 117                                   (when (>= bp next-prop)
 118                                     (turn-on-attributes (window-buffer w) bp frame))
 119                                   (let ((ch (elt (buffer-data buf) p)))
 120                                     ;; Update display
 121                                     (cond ((char= ch #\Newline)
 122                                            (putch #\Space x y w frame))
 123                                           (t
 124                                            (putch ch x y w frame)))
 125                                     ;; go to the next character in the buffer
 126                                     (incf p)
 127                                     (incf bp))))))))
 128         ;; Check if the bottom of the window needs to be erased.
 129         (when (< end (1- (window-height w)))
 130           (loop for i from end below (window-height w) do
 131                 (clear-to-eol i 0 w frame)))))
 132     ;; Update the mode-line if it exists. FIXME: Not the right place
 133     ;; to update the mode-line.
 134     (when (buffer-mode-line (window-buffer w))
 135       (update-mode-line (window-buffer w))
 136       (putstr (truncate-mode-line (window-buffer w) (window-width w))
 137               0 (window-height w nil) w frame)
 138       ;; don't forget the seperator on the modeline line
 139       (when (window-seperator w)
 140         (putch #\| (+ (window-x w) (window-width w)) (window-height w) w frame)))
 141     (reset-line-state w)
 142     ;; Set the cursor at the right spot
 143     (values cursor-x cursor-y)))
 144
 145 ;;; keyboard stuff
 146
 147 (defmethod frame-read-event ((frame clisp-frame))
 148   (let* ((input (read-char EXT:*KEYBOARD-INPUT*));; (input (screen::read-keyboard-char (frame-window-stream frame)))
 149          (ch (if (sys::input-character-char input)
 150                                  (char-downcase (sys::input-character-char input))
 151                                (char-downcase (sys::input-character-key input))))
 152          meta)
 153     (when (and (characterp ch)
 154                (char= ch #\Escape))
 155       (setf input (read-char EXT:*KEYBOARD-INPUT*)
 156             meta t))
 157     (make-instance 'key
 158                    :char (if (sys::input-character-char input)
 159                              (char-downcase (sys::input-character-char input))
 160                            (char-downcase (sys::input-character-key input)))
 161                    :control (sys::char-bit input :control)
 162                    :meta (or meta
 163                              (sys::char-bit input :meta)))))
 164
 165 ;;; some frame stuff
 166
 167 (defun init-clisp ()
 168   )
 169
 170 (defun shutdown ()
 171   (close (frame-window-stream (selected-frame))))
 172
 173 (defun make-default-clisp-frame (buffer)
 174   (let ((ws (screen:make-window)))
 175     (multiple-value-bind (lines cols) (screen:window-size ws)
 176       (let* ((height (1- lines))
 177              (l (make-array (* lines cols)
 178                             :element-type 'character))
 179              (d (make-array (list lines cols)
 180                             :element-type 'character
 181                             :displaced-to l :displaced-index-offset 0))
 182              (w (make-window :x 0 :y 0 :cols cols :rows height :buffer buffer))
 183              (mb (make-minibuffer-window lines cols))
 184              (frame (make-instance 'clisp-frame
 185                                    :width cols
 186                                    :height lines
 187                                    :window-tree (list w mb)
 188                                    :current-window w
 189                                    :minibuffer-window mb
 190                                    :window-stream ws
 191                                    :double-buffer l
 192                                    :2d-double-buffer d)))
 193         (setf (window-frame w) frame
 194               (window-frame mb) frame)
 195         frame))))