movitz-render.lisp

   1 (in-package :lice)
   2
   3 ;; TTY rendering routines
   4
   5 (in-package :lice)
   6
   7 (defclass movitz-frame (frame)
   8   ((double-buffer :type (array character 1) :initarg :double-buffer :accessor frame-double-buffer :documentation
   9                   "The display double buffer. This structure is compared to
  10 the characters we want to blit. Only differences are sent to the video
  11 hardware.")
  12    ;; (2d-double-buffer :type (array character 2) :initarg :2d-double-buffer :accessor frame-2d-double-buffer :documentation
  13 ;;                   "Displaced from DISPLAY. This array is divided into rows and columns.")
  14    ))
  15
  16 (defmethod frame-start-render ((frame movitz-frame))
  17   )
  18
  19 (defmethod frame-end-render ((frame movitz-frame))
  20   )
  21
  22 (defvar *current-attribute* 0
  23   "The currently set character attribute. Used while rendering a window.")
  24
  25 (defun window-move-cursor (window x y)
  26   (muerte.x86-pc::move-vga-cursor (+ x (window-x window)) (+ y (window-y window))))
  27
  28 (defmethod frame-move-cursor ((frame movitz-frame) win x y)
  29   (window-move-cursor win x y))
  30
  31 (defun setxy (x y n)
  32   "A very raw character & attribute blitter"
  33   (setf (muerte::memref-int muerte.x86-pc::*screen* :index (+ x (* y muerte.x86-pc::*screen-stride*)) :type :unsigned-byte16) n))
  34
  35 (defun set-char-attr (x y ch attr)
  36   ""
  37   (setxy x y (logior (ash attr 8) (char-code ch))))
  38
  39 (defun putch (ch x y window frame)
  40   (set-char-attr (+ x (window-x window)) (+ y (window-y window)) ch *current-attribute*)
  41   (setf (aref (frame-double-buffer frame) (+ (* (+ y (window-y window)) (frame-width frame))
  42                                              (+ x (window-x window)))) ch))
  43
  44 (defun putstr (s x y w frame)
  45   (loop for i from 0 below (length s)
  46         for j from x by 1
  47         ;;if (char/= (aref (window-2d-display w) y j) (aref s i))
  48         do (putch (aref s i) j y w frame)))
  49
  50 (defun clear-line-between (w y start end frame)
  51   "insert LEN spaces from START on line Y."
  52   ;;(window-move-cursor w start y)
  53   ;; FIXME: this could be done faster
  54   (loop for i from start to end
  55         do (putch #\Space i y w frame)))
  56
  57 ;; Helper function for window-render
  58 (defun clear-to-eol (y start window frame)
  59   (declare (type window window)
  60            (type fixnum y start))
  61   (let (;; (display (frame-2d-double-buffer frame))
  62         ;; (linear (frame-double-buffer frame))
  63         )
  64     (clear-line-between window y start (1- (window-width window)) frame)
  65     ;; draw the seperator
  66     (when (window-seperator window)
  67       (putch #\| (+ (window-x window) (1- (window-width window t))) y window frame))))
  68
  69 (defun turn-on-attributes (buffer point)
  70   "Given the buffer and point, turn on the appropriate colors based on
  71 the text properties present."
  72   ;; These are hardcoded for now
  73   (setf *current-attribute*
  74         (case (get-text-property point :face buffer)
  75           (:face-1 7)
  76           (:face-2 112)
  77           (:face-3 14)
  78           (:face-4 34)
  79           (:face-5 8)
  80           (:face-6 9)
  81           (:face-7 2)
  82           (:face-8 1)
  83           (t 7))))
  84
  85 (defmethod window-render (w (frame movitz-frame))
  86   "Render a window."
  87   (let ((p (buffer-char-to-aref (window-buffer w) (marker-position (window-top w))))
  88         ;; current point in buffer buffer
  89         (bp (marker-position (window-top w)))
  90         (buf (window-buffer w))
  91         ;; The cursor point in the buffer. When the buffer isn't
  92         ;; current, then use the window's backup of the point.
  93         (point (window-point w))
  94         cursor-x
  95         cursor-y
  96         (cache-size (length (lc-cache (window-cache w))))
  97         (linear (frame-double-buffer frame))
  98         ;; (display (frame-2d-double-buffer frame))
  99         )
 100     ;; rxvt draws black on black if i don't turn on a color
 101     (setf *current-attribute* 7)
 102     ;; Special case: when the buffer is empty
 103     (if (= (buffer-size (window-buffer w)) 0)
 104         (progn
 105           (dotimes (y (window-height w))
 106             (clear-to-eol y 0 w frame))
 107           (setf cursor-x 0
 108                 cursor-y 0))
 109       (let ((end (loop named row
 110                        for y below (window-height w)
 111                        for line from (window-top-line w) below cache-size
 112                        ;; return the last line, so we can erase the rest
 113                        finally (return-from row y)
 114                        ;; go to the next line
 115                        do (let* ((line-end (cache-item-end (item-in-cache w line)))
 116                                  (line-start (cache-item-start (item-in-cache w line)))
 117                                  (next-prop (next-single-property-change line-start :face (window-buffer w) line-end)))
 118                             (setf bp (cache-item-start (item-in-cache w line))
 119                                   p (buffer-char-to-aref (window-buffer w) bp))
 120                             ;; setup the display properties.
 121                             (turn-on-attributes (window-buffer w) bp)
 122                             (loop named col
 123                                 for x below (window-width w) do
 124                                 (progn
 125                                   ;; Skip the gap
 126                                   (when (= p (buffer-gap-start buf))
 127                                     (incf p (buffer-gap-size buf)))
 128                                   ;; Record point position on screen
 129                                   (when (eq bp point)
 130                                     (setf cursor-x x)
 131                                     (setf cursor-y y))
 132                                   (when (or (> bp line-end)
 133                                             (>= p (length (buffer-data buf))))
 134                                     ;; gotta turn off attributes to do this
 135                                     (setf *current-attribute* 7)
 136                                     ;; Check if the rest of the line is blank
 137                                     (clear-to-eol y x w frame)
 138                                     (return-from col))
 139                                   ;; update attributes
 140                                   (when (>= bp next-prop)
 141                                     (turn-on-attributes (window-buffer w) bp))
 142                                   (let ((ch (elt (buffer-data buf) p)))
 143                                     ;; Update display
 144                                     (cond ((char= ch #\Newline)
 145                                            (putch #\Space x y w frame))
 146                                           (t
 147                                            (putch ch x y w frame)))
 148                                     ;; go to the next character in the buffer
 149                                     (incf p)
 150                                     (incf bp))))))))
 151         ;; Check if the bottom of the window needs to be erased.
 152         (when (< end (1- (window-height w)))
 153           (loop for i from end below (window-height w) do
 154                 (clear-to-eol i 0 w frame)))))
 155     ;; rxvt draws black on black if i don't turn on a color
 156     (setf *current-attribute* 7)
 157     ;; Update the mode-line if it exists. FIXME: Not the right place
 158     ;; to update the mode-line.
 159     (when (buffer-mode-line (window-buffer w))
 160       (update-mode-line (window-buffer w))
 161       ;;(cl-ncurses::attron cl-ncurses::A_REVERSE)
 162       (setf *current-attribute* 18)
 163       (putstr (truncate-mode-line (window-buffer w) (window-width w))
 164               0 (window-height w nil) w frame)
 165       (setf *current-attribute* 7)
 166       ;;(cl-ncurses::attroff cl-ncurses::A_REVERSE)
 167       ;; don't forget the seperator on the modeline line
 168       (when (window-seperator w)
 169         (putch #\| (+ (window-x w) (window-width w)) (window-height w) w frame)))
 170     (reset-line-state w)
 171     ;; Set the cursor at the right spot
 172     (values cursor-x cursor-y)))
 173
 174 ;;; keyboard stuff
 175
 176 (defmethod frame-read-event ((frame movitz-frame))
 177   "Return a key structure."
 178   (let (control meta shift)
 179     (loop
 180        (multiple-value-bind (key release) (muerte.x86-pc.keyboard::get-key)
 181          (when (and key
 182                     (characterp key)
 183                     (not release))
 184            (return-from frame-read-event (make-key
 185                                           :char key
 186                                           :control (logbitp muerte.x86-pc.keyboard::+qualifier-ctrl+
 187                                                             muerte.x86-pc.keyboard::*qualifier-state*)
 188                                           :meta (logbitp muerte.x86-pc.keyboard::+qualifier-alt+
 189                                                          muerte.x86-pc.keyboard::*qualifier-state*))))))))
 190
 191 ;;; some frame stuff
 192
 193 (defun init-movitz ()
 194   )
 195
 196 (defun shutdown-movitz ()
 197   )
 198
 199 (defun make-default-movitz-frame (buffer)
 200   (let* ((lines muerte.x86-pc::*screen-height*)
 201          (height (1- lines))
 202          (cols muerte.x86-pc::*screen-width*)
 203          (l (make-array (* lines cols)
 204                         :element-type 'character))
 205 ;;       (d (make-array (list lines cols)
 206 ;;                      :element-type 'character
 207 ;;                      :displaced-to l :displaced-index-offset 0))
 208          (w (make-window :x 0 :y 0 :cols cols :rows height :buffer buffer))
 209          (mb (make-minibuffer-window lines cols))
 210          (frame (make-instance 'movitz-frame
 211                                :width cols
 212                                :height lines
 213                                :window-tree (list w mb)
 214                                :current-window w
 215                                :minibuffer-window mb
 216                                :double-buffer l
 217                                ;; :2d-double-buffer d
 218                                )))
 219     (setf (window-frame w) frame
 220           (window-frame mb) frame)
 221     frame))
 222
 223 ;; (defun make-test-frame (buffer)
 224 ;;   "This can be used to create a frame configuration for testing."
 225 ;;   (let* ((lines 20)
 226 ;;       (height (1- lines))
 227 ;;       (cols 78)
 228 ;;       (l (make-array (* lines cols)
 229 ;;                      :element-type 'character
 230 ;;                      :initial-element #\Space))
 231 ;;       (d (make-array (list lines cols)
 232 ;;                      :element-type 'character
 233 ;;                      :displaced-to l :displaced-index-offset 0))
 234 ;;       (w (make-window :x 0 :y 0 :cols cols :rows height :buffer buffer))
 235 ;;       (mb (make-minibuffer-window lines cols))
 236 ;;       (frame (make-instance 'tty-frame
 237 ;;                             :width cols
 238 ;;                             :height lines
 239 ;;                             :window-tree (list w mb)
 240 ;;                             :current-window w
 241 ;;                             :minibuffer-window mb
 242 ;;                             :double-buffer l
 243 ;;                             :2d-double-buffer d)))
 244 ;;     (setf (window-frame w) frame
 245 ;;        (window-frame mb) frame)
 246 ;;     frame))
 247
 248 (provide :lice-0.1/movitz-render)