3 (defclass mcl-window
(ccl:window
)
6 (defclass mcl-frame
(frame mcl-window
)
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.")
13 (cursor :initform
#(0 0) :accessor mcl-frame-cursor
)
14 (font-width :initarg
:font-width
:accessor mcl-frame-font-width
)
15 (font-height :initarg
:font-height
:accessor mcl-frame-font-height
)
16 (font-ascent :initarg
:font-ascent
:accessor mcl-frame-font-ascent
)))
18 (defmethod frame-start-render ((frame mcl-frame
))
19 (declare (ignore frame
))
22 (defmethod frame-end-render ((frame mcl-frame
))
23 (declare (ignore frame
))
27 (defun window-move-cursor (window x y
)
28 (declare (ignore window x y
))
31 (defmethod frame-move-cursor ((frame mcl-frame
) win x y
)
32 ;; (setf x (* x (mcl-frame-font-width frame))
33 ;; y (+ (* y (mcl-frame-font-height frame)) 10))
34 ;; (ccl:invert-rect frame x y (+ x (mcl-frame-font-width frame)) (+ y (mcl-frame-font-height frame)))
35 (setf (mcl-frame-cursor frame
) (vector (+ (window-x win
) x
) (+ (window-y win
) y
)))
36 (window-move-cursor win x y
))
38 (defun putch (ch x y window frame
)
39 ;; (0,0) is above the visible area of the window. so add 25 (experimentally determined).
40 ;; (setf x (* x (mcl-frame-font-width frame))
41 ;; y (+ (* y (mcl-frame-font-height frame)) 10))
42 ;; (ccl:move-to (mcl-frame-window frame) x y)
43 ;; (princ ch (mcl-frame-window frame))
44 (setf (aref (frame-2d-double-buffer frame
) (+ y
(window-y window
)) (+ (window-x window
) x
)) ch
)
47 (defun putstr (s x y w frame
)
48 (loop for i from
0 below
(length s
)
50 ;;if (char/= (aref (window-2d-display w) y j) (aref s i))
51 do
(putch (char s i
) j y w frame
)))
53 (defun clear-line-between (w y start end frame
)
54 "insert LEN spaces from START on line Y."
55 (window-move-cursor w start y
)
56 ;; FIXME: this could be done faster
57 (loop for i from start to end
58 do
(putch #\Space i y w frame
)))
60 (defun clear-to-eol (y start window frame
)
61 (declare (type window window
)
62 (type fixnum y start
))
63 ;; (let ((display (frame-2d-double-buffer frame))
64 ;; (linear (frame-double-buffer frame)))
65 (clear-line-between window y start
(1- (window-width window
)) frame
)
67 (when (window-seperator window
)
68 (putch #\|
(+ (window-x window
) (1- (window-width window t
))) y window frame
)))
70 (defun turn-on-attributes (buffer point
)
71 (declare (ignore buffer point
))
74 (defmethod frame-end-render ((frame mcl-frame
))
75 (ccl:invalidate-view frame
))
77 (defmethod window-render (w (frame mcl-frame
))
80 ;; (ccl:with-fore-color ccl:*white-color*
81 ;; (ccl:paint-rect (mcl-frame-window frame) 0 0
82 ;; (ccl:point-h (ccl:view-size (mcl-frame-window frame)))
83 ;; (ccl:point-v (ccl:view-size (mcl-frame-window frame))))
84 ;; (ccl:event-dispatch))
85 (let ((p (buffer-char-to-aref (window-buffer w
) (marker-position (window-top w
))))
86 ;; current point in buffer buffer
87 (bp (marker-position (window-top w
)))
88 (buf (window-buffer w
))
89 ;; The cursor point in the buffer. When the buffer isn't
90 ;; current, then use the window's backup of the point.
91 (point (window-point w
))
94 (cache-size (length (lc-cache (window-cache w
))))
95 (linear (frame-double-buffer frame
))
96 (display (frame-2d-double-buffer frame
)))
97 (declare (ignore display linear
))
99 ;; (ccl:erase-rect (mcl-frame-window frame) 0 0
100 ;; (ccl:point-h (ccl:view-size (mcl-frame-window frame)))
101 ;; (ccl:point-v (ccl:view-size (mcl-frame-window frame))))
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 ;; Check if the rest of the line is blank
135 (clear-to-eol y x w frame
)
138 (when (>= bp next-prop
)
139 (turn-on-attributes (window-buffer w
) bp
))
140 (let ((ch (elt (buffer-data buf
) p
)))
142 (cond ((char= ch
#\Newline
)
143 (putch #\Space x y w frame
))
145 (putch ch x y w frame
)))
146 ;; go to the next character in the buffer
149 ;; Check if the bottom of the window needs to be erased.
150 (when (< end
(1- (window-height w
)))
151 (loop for i from end below
(window-height w
) do
152 (clear-to-eol i
0 w frame
)))))
153 ;; Update the mode-line if it exists. FIXME: Not the right place
154 ;; to update the mode-line.
155 (when (buffer-mode-line (window-buffer w
))
156 (update-mode-line (window-buffer w
))
157 (putstr (truncate-mode-line (window-buffer w
) (window-width w
))
158 0 (window-height w nil
) w frame
)
159 ;; don't forget the seperator on the modeline line
160 (when (window-seperator w
)
161 (putch #\|
(+ (window-x w
) (window-width w
)) (window-height w
) w frame
)))
163 ;; Set the cursor at the right spot
164 (values cursor-x cursor-y
)))
166 (defvar *mcl-stackgroup
* (ccl:make-stack-group
"lice")
171 (ccl:stack-group-preset
*mcl-stackgroup
* #'lice
)
172 (funcall *mcl-stackgroup
* nil
))
181 (defvar *mcl-key-list
* nil
182 "List of keys pressed.")
184 (defmethod ccl:view-key-event-handler
:after
((w mcl-window
) ch
)
185 (declare (ignore ch
))
186 (let* ((keystroke (ccl:keystroke-name
(ccl:event-keystroke
(ccl:rref ccl
:*current-event
* :event.message
) (ccl:rref ccl
:*current-event
* :event.modifiers
))))
187 (ch (if (listp keystroke
)
188 (car (last keystroke
))
190 (mods (and (listp keystroke
)
191 (butlast keystroke
))))
192 ;;(format t "k: ~s ~s ~s~%" keystroke ch mods)
193 (setf *mcl-key-list
* (nconc *mcl-key-list
*
195 :meta
(and (find :meta mods
) t
)
196 :control
(and (find :control mods
) t
)
198 (funcall *mcl-stackgroup
* nil
)))
200 (defmethod ccl:view-draw-contents
((win frame
))
201 (ccl:erase-rect win
0 0
202 (ccl:point-h
(ccl:view-size win
))
203 (ccl:point-v
(ccl:view-size win
)))
206 for y from
0 below
(array-dimension (frame-2d-double-buffer win
) 0)
207 for i from
(mcl-frame-font-ascent win
) by
(mcl-frame-font-height win
) do
209 for x from
0 below
(array-dimension (frame-2d-double-buffer win
) 1)
210 for j from
0 by
(mcl-frame-font-width win
) do
211 (ccl:move-to win j i
)
212 (princ (aref (frame-2d-double-buffer win
) y x
) win
)))
214 (let ((x (* (elt (mcl-frame-cursor win
) 0) (mcl-frame-font-width win
)))
215 (y (* (elt (mcl-frame-cursor win
) 1) (mcl-frame-font-height win
))))
216 (ccl:invert-rect win x y
(+ x
(mcl-frame-font-width win
)) (+ y
(mcl-frame-font-height win
)))))
218 (defmethod frame-read-event ((frame mcl-frame
))
219 ;; wait for more input
220 (unless *mcl-key-list
*
221 (ccl:stack-group-return nil
))
222 ;; process the new input
223 (pop *mcl-key-list
*))
225 (defun mcl-font-width (font-name font-size
)
226 (multiple-value-bind (ascent descent maxwidth leading
) (ccl::font-info
(list font-name font-size
))
227 (declare (ignore ascent descent leading
))
230 (defun mcl-font-height (font-name font-size
)
231 (multiple-value-bind (ascent descent maxwidth leading
) (ccl::font-info
(list font-name font-size
))
232 (declare (ignore maxwidth
))
233 (+ ascent descent leading
)))
235 (defun mcl-font-ascent (font-name font-size
)
236 (multiple-value-bind (ascent descent maxwidth leading
) (ccl::font-info
(list font-name font-size
))
237 (declare (ignore descent maxwidth leading
))
240 (defun make-default-mcl-frame (buffer)
243 (fw (mcl-font-width "Monaco" 12))
244 (fh (mcl-font-height "Monaco" 12))
245 (ascent (mcl-font-ascent "Monaco" 12))
247 (l (make-array (* lines cols
)
248 :element-type
'character
))
249 (d (make-array (list lines cols
)
250 :element-type
'character
251 :displaced-to l
:displaced-index-offset
0))
252 (w (make-window :x
0 :y
0 :cols cols
:rows height
:buffer buffer
))
253 (mb (make-minibuffer-window lines cols
))
254 (frame (make-instance 'mcl-frame
257 :window-tree
(list w mb
)
259 :minibuffer-window mb
265 :view-size
(ccl:make-point
(* cols fw
) (* lines fh
))
266 :view-font
'("Monaco" 12))))
267 (setf (window-frame w
) frame
268 (window-frame mb
) frame
)