1 ;; TTY rendering routines
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
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.")))
14 (defmethod frame-start-render ((frame clisp-frame
))
17 (defmethod frame-end-render ((frame clisp-frame
))
18 ;; (screen:window-refresh (frame-window-stream frame))
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
))))
25 (defmethod frame-move-cursor ((frame clisp-frame
) win x y
)
26 (window-move-cursor win x y
(frame-window-stream frame
)))
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
)))
34 (defun putstr (s x y w frame
)
35 (loop for i from
0 below
(length s
)
37 do
(putch (aref s i
) j y w frame
)))
39 (defun line-height (buffer p
)
40 "Return the height of the line starting at p."
41 (declare (ignore buffer p
)))
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
)))
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
)
56 (when (window-seperator window
)
57 (putch #\|
(+ (window-x window
) (1- (window-width window t
))) y window frame
))))
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
))))
67 (defmethod window-render (w (frame clisp-frame
))
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
))
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)
84 (dotimes (y (window-height w
))
85 (clear-to-eol y
0 w frame
))
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
)
102 for x below
(window-width w
) do
105 (when (= p
(buffer-gap-start buf
))
106 (incf p
(buffer-gap-size buf
)))
107 ;; Record point position on screen
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
)
117 (when (>= bp next-prop
)
118 (turn-on-attributes (window-buffer w
) bp frame
))
119 (let ((ch (elt (buffer-data buf
) p
)))
121 (cond ((char= ch
#\Newline
)
122 (putch #\Space x y w frame
))
124 (putch ch x y w frame
)))
125 ;; go to the next character in the buffer
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
)))
142 ;; Set the cursor at the right spot
143 (values cursor-x cursor-y
)))
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
))))
153 (when (and (characterp ch
)
155 (setf input
(read-char EXT
:*KEYBOARD-INPUT
*)
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
)
163 (sys::char-bit input
:meta
)))))
171 (close (frame-window-stream (selected-frame))))
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
187 :window-tree
(list w mb
)
189 :minibuffer-window mb
192 :2d-double-buffer d
)))
193 (setf (window-frame w
) frame
194 (window-frame mb
) frame
)