1 ;; TTY rendering routines
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
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.")))
13 (defmethod frame-start-render ((frame tty-frame
))
16 (defmethod frame-end-render ((frame tty-frame
))
17 (cl-ncurses::refresh
))
19 (defun window-move-cursor (window x y
)
20 (cl-ncurses::move
(+ y
(window-y window
)) (+ x
(window-x window
))))
22 (defmethod frame-move-cursor ((frame tty-frame
) win x y
)
23 (window-move-cursor win x y
))
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
))
30 (defun putstr (s x y w frame
)
31 (loop for i from
0 below
(length s
)
33 ;;if (char/= (aref (window-2d-display w) y j) (aref s i))
34 do
(putch (aref s i
) j y w frame
)))
36 (defun line-height (buffer p
)
37 "Return the height of the line starting at p."
38 (declare (ignore buffer p
)))
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
)))
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
)
53 (when (window-seperator window
)
54 (putch #\|
(+ (window-x window
) (1- (window-width window t
))) y window frame
)))
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
)
62 (cl-ncurses::attrset
(cl-ncurses::COLOR-PAIR
1)))
64 (cl-ncurses::attrset
(cl-ncurses::COLOR-PAIR
2)))
66 (cl-ncurses::attrset
(cl-ncurses::COLOR-PAIR
3)))
68 (cl-ncurses::attrset
(cl-ncurses::COLOR-PAIR
4)))
70 (cl-ncurses::attrset
(cl-ncurses::COLOR-PAIR
5)))
72 (cl-ncurses::attrset
(cl-ncurses::COLOR-PAIR
6)))
74 (cl-ncurses::attrset
(cl-ncurses::COLOR-PAIR
7)))
76 (cl-ncurses::attrset
(cl-ncurses::COLOR-PAIR
8)))
78 (cl-ncurses::attrset
(cl-ncurses::COLOR-PAIR
1)))))
80 (defmethod window-render (w (frame tty-frame
))
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
))
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)
99 (dotimes (y (window-height w
))
100 (clear-to-eol y
0 w frame
))
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
)
117 for x below
(window-width w
) do
120 (when (= p
(buffer-gap-start buf
))
121 (incf p
(buffer-gap-size buf
)))
122 ;; Record point position on screen
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
)
134 (when (>= bp next-prop
)
135 (turn-on-attributes (window-buffer w
) bp
))
136 (let ((ch (elt (buffer-data buf
) p
)))
138 (cond ((char= ch
#\Newline
)
139 (putch #\Space x y w frame
))
141 (putch ch x y w frame
)))
142 ;; go to the next character in the buffer
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
)))
165 ;; Set the cursor at the right spot
166 (values cursor-x cursor-y
)))
170 (defmethod frame-read-event ((frame tty-frame
))
171 (let ((ch (char-code (read-char)))
173 (dformat +debug-v
+ "read: ~a~%" ch
)
175 (when (= ch
+key-escape
+)
176 (dformat +debug-v
+ "meta~%")
177 (setf ch
(char-code (read-char))
179 ;; the 8th bit could also mean meta
180 (when (= (logand ch
128) 128)
187 ;; set key to the character
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)))
217 (let ((scr (cl-ncurses::initscr
)))
220 (cl-ncurses::meta scr
1)
223 (cl-ncurses::scrollok scr
0)))
225 (defun shutdown-tty ()
226 (cl-ncurses::endwin
))
228 (defun make-default-tty-frame (buffer)
229 (let* ((lines cl-ncurses
::*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
242 :window-tree
(list w mb
)
244 :minibuffer-window mb
246 :2d-double-buffer d
)))
247 (setf (window-frame w
) frame
248 (window-frame mb
) frame
)
251 (defun make-test-frame (buffer)
252 "This can be used to create a frame configuration for testing."
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
267 :window-tree
(list w mb
)
269 :minibuffer-window mb
271 :2d-double-buffer d
)))
272 (setf (window-frame w
) frame
273 (window-frame mb
) frame
)