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