3 ;; TTY rendering routines
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
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.")
16 (defmethod frame-start-render ((frame movitz-frame
))
19 (defmethod frame-end-render ((frame movitz-frame
))
22 (defvar *current-attribute
* 0
23 "The currently set character attribute. Used while rendering a window.")
25 (defun window-move-cursor (window x y
)
26 (muerte.x86-pc
::move-vga-cursor
(+ x
(window-x window
)) (+ y
(window-y window
))))
28 (defmethod frame-move-cursor ((frame movitz-frame
) win x y
)
29 (window-move-cursor win x y
))
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
))
35 (defun set-char-attr (x y ch attr
)
37 (setxy x y
(logior (ash attr
8) (char-code ch
))))
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
))
44 (defun putstr (s x y w frame
)
45 (loop for i from
0 below
(length s
)
47 ;;if (char/= (aref (window-2d-display w) y j) (aref s i))
48 do
(putch (aref s i
) j y w frame
)))
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
)))
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))
64 (clear-line-between window y start
(1- (window-width window
)) frame
)
66 (when (window-seperator window
)
67 (putch #\|
(+ (window-x window
) (1- (window-width window t
))) y window frame
))))
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
)
85 (defmethod window-render (w (frame movitz-frame
))
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
))
96 (cache-size (length (lc-cache (window-cache w
))))
97 (linear (frame-double-buffer frame
))
98 ;; (display (frame-2d-double-buffer frame))
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)
105 (dotimes (y (window-height w
))
106 (clear-to-eol y
0 w frame
))
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
)
123 for x below
(window-width w
) do
126 (when (= p
(buffer-gap-start buf
))
127 (incf p
(buffer-gap-size buf
)))
128 ;; Record point position on screen
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
)
140 (when (>= bp next-prop
)
141 (turn-on-attributes (window-buffer w
) bp
))
142 (let ((ch (elt (buffer-data buf
) p
)))
144 (cond ((char= ch
#\Newline
)
145 (putch #\Space x y w frame
))
147 (putch ch x y w frame
)))
148 ;; go to the next character in the buffer
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
)))
171 ;; Set the cursor at the right spot
172 (values cursor-x cursor-y
)))
176 (defmethod frame-read-event ((frame movitz-frame
))
177 "Return a key structure."
178 (let (control meta shift
)
180 (multiple-value-bind (key release
) (muerte.x86-pc.keyboard
::get-key
)
184 (return-from frame-read-event
(make-instance '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
*))))))))
193 (defun init-movitz ()
196 (defun shutdown-movitz ()
199 (defun make-default-movitz-frame (buffer)
200 (let* ((lines muerte.x86-pc
::*screen-height
*)
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
213 :window-tree
(list w mb
)
215 :minibuffer-window mb
217 ;; :2d-double-buffer d
219 (setf (window-frame w
) frame
220 (window-frame mb
) frame
)
223 ;; (defun make-test-frame (buffer)
224 ;; "This can be used to create a frame configuration for testing."
226 ;; (height (1- lines))
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
239 ;; :window-tree (list w mb)
241 ;; :minibuffer-window mb
243 ;; :2d-double-buffer d)))
244 ;; (setf (window-frame w) frame
245 ;; (window-frame mb) frame)
248 (provide :lice-0.1
/movitz-render
)