Skip to content

Commit 3887f7f

Browse files
cxxxrcxxxr
committed
add a new drawing method
1 parent d356d30 commit 3887f7f

File tree

2 files changed

+291
-0
lines changed

2 files changed

+291
-0
lines changed

‎frontends/sdl2/lem-sdl2.asd‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,5 +11,6 @@
1111
(:file "font")
1212
(:file "icon")
1313
(:file "main")
14+
(:file "text-buffer")
1415
(:file "image-buffer")
1516
(:file "tree")))

‎frontends/sdl2/text-buffer.lisp‎

Lines changed: 290 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,290 @@
1+
(in-package :lem-sdl2)
2+
3+
(defstruct string-with-attribute-item
4+
string
5+
attribute)
6+
7+
(defstruct cursor-item
8+
attribute
9+
string)
10+
11+
(defstruct eol-cursor-item
12+
attribute)
13+
14+
15+
(defmethod item-string ((item string-with-attribute-item))
16+
(string-with-attribute-item-string item))
17+
18+
(defmethod item-string ((item cursor-item))
19+
(cursor-item-string item))
20+
21+
(defmethod item-string ((item eol-cursor-item))
22+
" ")
23+
24+
25+
(defmethod item-attribute ((item string-with-attribute-item))
26+
(string-with-attribute-item-attribute item))
27+
28+
(defmethod item-attribute ((item cursor-item))
29+
(cursor-item-attribute item))
30+
31+
(defmethod item-attribute ((item eol-cursor-item))
32+
(eol-cursor-item-attribute item))
33+
34+
35+
(defclass v2-text-buffer (lem:text-buffer) ())
36+
37+
(defun view-width-by-pixel (window)
38+
(* (char-width) (view-width (lem:window-view window))))
39+
40+
(defun view-height-by-pixel (window)
41+
(* (char-height) (view-width (lem:window-view window))))
42+
43+
(defun cursor-attribute-p (attribute)
44+
(lem:attribute-value attribute :cursor))
45+
46+
(defun set-cursor-attribute (attribute)
47+
(setf (lem:attribute-value attribute :cursor) t))
48+
49+
(defun overlay-cursor-p (overlay)
50+
(lem:overlay-get overlay :cursor))
51+
52+
(defun make-cursor-overlay (point)
53+
(let ((overlay (lem-core::make-temporary-overlay
54+
point
55+
(lem:with-point ((p point))
56+
(lem:character-offset p 1)
57+
p)
58+
(if (typep point 'lem:fake-cursor)
59+
'lem:fake-cursor
60+
'lem:cursor))))
61+
(lem:overlay-put overlay :cursor t)
62+
overlay))
63+
64+
(defun collect-overlays (window)
65+
(let ((overlays (lem-core::get-window-overlays window)))
66+
(if (and (eq window (lem:current-window))
67+
(not (lem:window-cursor-invisible-p window)))
68+
(append overlays
69+
(mapcar #'make-cursor-overlay
70+
(lem:buffer-cursors (lem:window-buffer window))))
71+
overlays)))
72+
73+
(defun overlay-within-point-p (overlay point)
74+
(cond
75+
;; TODO: !!!
76+
((or (lem:overlay-get overlay :display-line-end)
77+
(lem:overlay-get overlay :display-line))
78+
nil)
79+
(t
80+
(or (lem:point<= (lem:overlay-start overlay)
81+
point
82+
(lem:overlay-end overlay))
83+
(lem:same-line-p (lem:overlay-start overlay)
84+
point)
85+
(lem:same-line-p (lem:overlay-end overlay)
86+
point)))))
87+
88+
(defun overlay-start-charpos (overlay point)
89+
(if (lem:same-line-p point (lem:overlay-start overlay))
90+
(lem:point-charpos (lem:overlay-start overlay))
91+
0))
92+
93+
(defun overlay-end-charpos (overlay point)
94+
(cond ((and (overlay-cursor-p overlay)
95+
(lem:point= (lem:overlay-start overlay) (lem:overlay-end overlay)))
96+
;; cursor is end-of-buffer
97+
nil)
98+
((lem:same-line-p point (lem:overlay-end overlay))
99+
(lem:point-charpos (lem:overlay-end overlay)))
100+
(t
101+
nil)))
102+
103+
(defun line-string-and-attributes-with-overlays (point overlays)
104+
(let ((end-of-line-cursor-attribute nil))
105+
(destructuring-bind (string . attributes)
106+
(lem-base::line-string/attributes (lem-base::point-line point))
107+
(loop :for overlay :in overlays
108+
:when (overlay-within-point-p overlay point)
109+
:do (let ((overlay-start-charpos (overlay-start-charpos overlay point))
110+
(overlay-end-charpos (overlay-end-charpos overlay point))
111+
(overlay-attribute (lem:overlay-attribute overlay)))
112+
(when (overlay-cursor-p overlay)
113+
(set-cursor-attribute overlay-attribute)
114+
(unless overlay-end-charpos
115+
(setf end-of-line-cursor-attribute overlay-attribute)))
116+
(setf attributes
117+
(lem-core::overlay-attributes attributes
118+
overlay-start-charpos
119+
(or overlay-end-charpos (length string))
120+
overlay-attribute))))
121+
(values string
122+
attributes
123+
end-of-line-cursor-attribute))))
124+
125+
(defun compute-items-from-string-and-attributes (string attributes end-of-line-cursor-attribute)
126+
(let ((items '()))
127+
(flet ((add (item)
128+
(if (null items)
129+
(push item items)
130+
(let ((last-item (first items)))
131+
(if (and (string-with-attribute-item-p last-item)
132+
(string-with-attribute-item-p item)
133+
(equal (string-with-attribute-item-attribute last-item)
134+
(string-with-attribute-item-attribute item)))
135+
(setf (string-with-attribute-item-string (first items))
136+
(str:concat (string-with-attribute-item-string last-item)
137+
(string-with-attribute-item-string item)))
138+
(push item items))))))
139+
(loop :for last-pos := 0 :then end
140+
:for (start end attribute) :in attributes
141+
:do (unless (= last-pos start)
142+
(add (make-string-with-attribute-item :string (subseq string last-pos start))))
143+
(add (if (and attribute
144+
(lem:attribute-p attribute)
145+
(cursor-attribute-p attribute))
146+
(make-cursor-item :string (subseq string start end) :attribute attribute)
147+
(make-string-with-attribute-item
148+
:string (subseq string start end)
149+
:attribute attribute)))
150+
:finally (push (make-string-with-attribute-item :string (subseq string last-pos))
151+
items)))
152+
(when end-of-line-cursor-attribute
153+
(push (make-eol-cursor-item :attribute end-of-line-cursor-attribute)
154+
items))
155+
(nreverse items)))
156+
157+
(defun line-items (point overlays)
158+
(multiple-value-bind (string attributes end-of-line-cursor-attribute)
159+
(line-string-and-attributes-with-overlays point overlays)
160+
(compute-items-from-string-and-attributes string attributes end-of-line-cursor-attribute)))
161+
162+
(defun underline-color (attribute)
163+
(alexandria:when-let ((underline (lem:attribute-underline attribute)))
164+
(if (eq underline t)
165+
(attribute-foreground-color attribute)
166+
(or (lem:parse-color underline)
167+
(attribute-foreground-color attribute)))))
168+
169+
(defclass drawing-object ()
170+
())
171+
172+
(defclass void-object (drawing-object) ())
173+
174+
(defclass text-object (drawing-object)
175+
((surface :initarg :surface :reader text-object-surface)
176+
(background :initarg :background :reader text-object-background)
177+
(attribute :initarg :attribute :reader text-object-attribute)))
178+
179+
180+
(defmethod draw-object ((drawing-object void-object) x bottom-y)
181+
nil)
182+
183+
(defmethod draw-object ((drawing-object text-object) x bottom-y)
184+
(let* ((surface-width (object-width drawing-object))
185+
(surface-height (object-height drawing-object))
186+
(background (text-object-background drawing-object))
187+
(texture (sdl2:create-texture-from-surface
188+
(current-renderer)
189+
(text-object-surface drawing-object)))
190+
(y (- bottom-y surface-height)))
191+
(sdl2:with-rects ((rect x y surface-width surface-height))
192+
(set-color background)
193+
(sdl2:render-fill-rect (current-renderer) rect))
194+
(render-texture (current-renderer)
195+
texture
196+
x
197+
y
198+
surface-width
199+
surface-height)
200+
(sdl2:destroy-texture texture)
201+
(when (and (text-object-attribute drawing-object)
202+
(lem:attribute-underline (text-object-attribute drawing-object)))
203+
(render-line x
204+
(1- (+ y surface-height))
205+
(+ x surface-width)
206+
(1- (+ y surface-height))
207+
:color (underline-color (text-object-attribute drawing-object))))))
208+
209+
(defmethod object-width ((drawing-object void-object))
210+
0)
211+
212+
(defmethod object-width ((drawing-object text-object))
213+
(sdl2:surface-width (text-object-surface drawing-object)))
214+
215+
216+
(defmethod object-height ((drawing-object void-object))
217+
0)
218+
219+
(defmethod object-height ((drawing-object text-object))
220+
(sdl2:surface-height (text-object-surface drawing-object)))
221+
222+
223+
(defun max-height-of-objects (objects)
224+
(max (loop :for object :in objects
225+
:maximize (object-height object))
226+
(char-height)))
227+
228+
(defun create-drawing-object (item)
229+
(let ((string (item-string item))
230+
(attribute (item-attribute item)))
231+
(if (alexandria:emptyp string)
232+
(make-instance 'void-object)
233+
(cffi:with-foreign-string (c-string string)
234+
(let* ((attribute (lem:ensure-attribute attribute nil))
235+
(bold (and attribute (lem:attribute-bold attribute)))
236+
(reverse (and attribute (lem:attribute-reverse attribute)))
237+
(foreground (if reverse
238+
(attribute-background-color attribute)
239+
(attribute-foreground-color attribute)))
240+
(background (if reverse
241+
(attribute-foreground-color attribute)
242+
(attribute-background-color attribute)))
243+
(surface
244+
(sdl2-ttf:render-utf8-blended (get-display-font *display*
245+
:type :latin
246+
:bold bold)
247+
c-string
248+
(lem:color-red foreground)
249+
(lem:color-green foreground)
250+
(lem:color-blue foreground)
251+
0)))
252+
(make-instance 'text-object
253+
:surface surface
254+
:background background
255+
:attribute attribute))))))
256+
257+
(defun clear-to-end-of-line (window x y height)
258+
(sdl2:with-rects ((rect x y (- (view-width-by-pixel window) x) height))
259+
(set-render-color *display* (display-background-color *display*))
260+
(sdl2:render-fill-rect (current-renderer) rect)))
261+
262+
(defun redraw-line (window point y overlays)
263+
(let* ((objects (loop :for item :in (line-items point overlays)
264+
:collect (create-drawing-object item)))
265+
(height (max-height-of-objects objects)))
266+
(clear-to-end-of-line window 0 y height)
267+
(loop :for x := 0 :then (+ x (object-width object))
268+
:for object :in objects
269+
:do (draw-object object x (+ y height)))
270+
height))
271+
272+
(defun redraw-lines (window)
273+
(lem:with-point ((point (lem:window-view-point window)))
274+
(let ((overlays (collect-overlays window)))
275+
(loop :with y := 0 :and height := (view-height-by-pixel window)
276+
:do (incf y (redraw-line window point y overlays))
277+
:while (and (lem:line-offset point 1)
278+
(< y height))
279+
:finally (sdl2:with-rects ((rect 0
280+
y
281+
(view-width-by-pixel window)
282+
(- (view-height-by-pixel window)
283+
y)))
284+
(set-render-color *display* (display-background-color *display*))
285+
(sdl2:render-fill-rect (current-renderer) rect))))))
286+
287+
(defmethod lem-core::redraw-buffer ((buffer v2-text-buffer) window force)
288+
(assert (eq buffer (lem:window-buffer window)))
289+
(sdl2:set-render-target (current-renderer) (view-texture (lem:window-view window)))
290+
(redraw-lines window))

0 commit comments

Comments
 (0)