From c92b4d82653f661ec57f8d46ae9d440279ab2a60 Mon Sep 17 00:00:00 2001 From: cxxxr Date: Wed, 26 Jul 2023 21:04:49 +0900 Subject: [PATCH 01/12] add a new drawing method --- frontends/sdl2/lem-sdl2.asd | 1 + frontends/sdl2/text-buffer.lisp | 480 ++++++++++++++++++++++++++++++++ 2 files changed, 481 insertions(+) create mode 100644 frontends/sdl2/text-buffer.lisp diff --git a/frontends/sdl2/lem-sdl2.asd b/frontends/sdl2/lem-sdl2.asd index 8e97912b4..27dc19f76 100644 --- a/frontends/sdl2/lem-sdl2.asd +++ b/frontends/sdl2/lem-sdl2.asd @@ -11,5 +11,6 @@ (:file "font") (:file "icon") (:file "main") + (:file "text-buffer") (:file "image-buffer") (:file "tree"))) diff --git a/frontends/sdl2/text-buffer.lisp b/frontends/sdl2/text-buffer.lisp new file mode 100644 index 000000000..fdf9838b2 --- /dev/null +++ b/frontends/sdl2/text-buffer.lisp @@ -0,0 +1,480 @@ +(in-package :lem-sdl2) + +(defclass v2-text-buffer (lem:text-buffer) ()) + + +(defstruct string-with-attribute-item + string + attribute) + +(defstruct cursor-item + attribute + string) + +(defstruct eol-cursor-item + attribute) + +(defstruct extend-to-eol-item + color) + +(defstruct line-end-item + text + attribute + offset) + +(defmethod item-string ((item string-with-attribute-item)) + (string-with-attribute-item-string item)) + +(defmethod item-string ((item cursor-item)) + (cursor-item-string item)) + +(defmethod item-string ((item eol-cursor-item)) + " ") + +(defmethod item-string ((item extend-to-eol-item)) + "") + +(defmethod item-attribute ((item string-with-attribute-item)) + (string-with-attribute-item-attribute item)) + +(defmethod item-attribute ((item cursor-item)) + (cursor-item-attribute item)) + +(defmethod item-attribute ((item eol-cursor-item)) + (eol-cursor-item-attribute item)) + +(defmethod item-attribute ((item extend-to-eol-item)) + nil) + +(defun view-width-by-pixel (window) + (* (char-width) (view-width (lem:window-view window)))) + +(defun view-height-by-pixel (window) + (* (char-height) (view-width (lem:window-view window)))) + +(defun cursor-attribute-p (attribute) + (lem:attribute-value attribute :cursor)) + +(defun set-cursor-attribute (attribute) + (setf (lem:attribute-value attribute :cursor) t)) + +(defun overlay-cursor-p (overlay) + (lem:overlay-get overlay :cursor)) + +(defun make-cursor-overlay (point) + (let ((overlay (lem-core::make-temporary-overlay + point + (lem:with-point ((p point)) + (lem:character-offset p 1) + p) + (if (typep point 'lem:fake-cursor) + 'lem:fake-cursor + 'lem:cursor)))) + (lem:overlay-put overlay :cursor t) + overlay)) + +(defun collect-overlays (window) + (let ((overlays (lem-core::get-window-overlays window))) + (if (and (eq window (lem:current-window)) + (not (lem:window-cursor-invisible-p window))) + (append overlays + (mapcar #'make-cursor-overlay + (lem:buffer-cursors (lem:window-buffer window)))) + overlays))) + +(defun overlay-within-point-p (overlay point) + (or (lem:point<= (lem:overlay-start overlay) + point + (lem:overlay-end overlay)) + (lem:same-line-p (lem:overlay-start overlay) + point) + (lem:same-line-p (lem:overlay-end overlay) + point))) + +(defun overlay-start-charpos (overlay point) + (if (lem:same-line-p point (lem:overlay-start overlay)) + (lem:point-charpos (lem:overlay-start overlay)) + 0)) + +(defun overlay-end-charpos (overlay point) + (cond ((and (overlay-cursor-p overlay) + (lem:point= (lem:overlay-start overlay) (lem:overlay-end overlay))) + ;; cursor is end-of-buffer + nil) + ((lem:same-line-p point (lem:overlay-end overlay)) + (lem:point-charpos (lem:overlay-end overlay))) + (t + nil))) + +(defun attribute-foreground-with-reverse (attribute) + (if (and attribute (lem:attribute-reverse attribute)) + (attribute-background-color attribute) + (attribute-foreground-color attribute))) + +(defun attribute-background-with-reverse (attribute) + (if (and attribute (lem:attribute-reverse attribute)) + (attribute-foreground-color attribute) + (attribute-background-color attribute))) + +(defstruct logical-line + string + attributes + end-of-line-cursor-attribute + extend-to-end + line-end-overlay) + +(defun create-logical-line (point overlays) + (let ((end-of-line-cursor-attribute nil) + (extend-to-end-attribute nil) + (line-end-overlay nil)) + (destructuring-bind (string . attributes) + (lem-base::line-string/attributes (lem-base::point-line point)) + (loop :for overlay :in overlays + :when (overlay-within-point-p overlay point) + :do (cond ((lem:overlay-get overlay :display-line-end) + (setf line-end-overlay overlay)) + ((lem:overlay-get overlay :display-line) + (setf attributes + (lem-core::overlay-attributes attributes + 0 + (length string) + (lem:overlay-attribute overlay))) + (setf extend-to-end-attribute (lem:overlay-attribute overlay))) + (t + (let ((overlay-start-charpos (overlay-start-charpos overlay point)) + (overlay-end-charpos (overlay-end-charpos overlay point)) + (overlay-attribute (lem:overlay-attribute overlay))) + (cond ((overlay-cursor-p overlay) + (set-cursor-attribute overlay-attribute) + (unless overlay-end-charpos + (setf end-of-line-cursor-attribute overlay-attribute))) + ((null overlay-end-charpos) + (setf extend-to-end-attribute + (lem:overlay-attribute overlay)))) + (setf attributes + (lem-core::overlay-attributes + attributes + overlay-start-charpos + (or overlay-end-charpos (length string)) + overlay-attribute)))))) + (make-logical-line :string string + :attributes attributes + :extend-to-end extend-to-end-attribute + :end-of-line-cursor-attribute end-of-line-cursor-attribute + :line-end-overlay line-end-overlay)))) + +(defun compute-items-from-string-and-attributes (logical-line) + (let ((items '())) + (flet ((add (item) + (if (null items) + (push item items) + (let ((last-item (first items))) + (if (and (string-with-attribute-item-p last-item) + (string-with-attribute-item-p item) + (equal (string-with-attribute-item-attribute last-item) + (string-with-attribute-item-attribute item))) + (setf (string-with-attribute-item-string (first items)) + (str:concat (string-with-attribute-item-string last-item) + (string-with-attribute-item-string item))) + (push item items)))))) + (let ((string (logical-line-string logical-line))) + (loop :for last-pos := 0 :then end + :for (start end attribute) :in (logical-line-attributes logical-line) + :do (unless (= last-pos start) + (add (make-string-with-attribute-item :string (subseq string last-pos start)))) + (add (if (and attribute + (lem:attribute-p attribute) + (cursor-attribute-p attribute)) + (make-cursor-item :string (subseq string start end) :attribute attribute) + (make-string-with-attribute-item + :string (subseq string start end) + :attribute attribute))) + :finally (push (make-string-with-attribute-item :string (subseq string last-pos)) + items)))) + (alexandria:when-let (attribute + (logical-line-extend-to-end logical-line)) + (push (make-extend-to-eol-item :color (attribute-background-color attribute)) + items)) + (alexandria:when-let (attribute + (logical-line-end-of-line-cursor-attribute logical-line)) + (push (make-eol-cursor-item :attribute attribute) + items)) + (values (nreverse items) + (alexandria:when-let (overlay + (logical-line-line-end-overlay logical-line)) + (make-line-end-item :text (lem:overlay-get overlay :text) + :attribute (lem:overlay-attribute overlay) + :offset (lem:overlay-get overlay :display-line-end-offset)))))) + +(defclass drawing-object () + ()) + +(defclass void-object (drawing-object) ()) + +(defclass text-object (drawing-object) + ((surface :initarg :surface :reader text-object-surface) + (string :initarg :string :reader text-object-string) + (attribute :initarg :attribute :reader text-object-attribute))) + +(defclass eol-cursor-object (drawing-object) + ((color :initarg :color + :reader eol-cursor-object-color))) + +(defclass extend-to-eol-object (drawing-object) + ((color :initarg :color + :reader extend-to-eol-object-color))) + +(defclass line-end-object (text-object) + ((offset :initarg :offset + :reader line-end-object-offset))) + +;;; draw-object +(defmethod draw-object ((drawing-object void-object) x bottom-y window) + nil) + +(defmethod draw-object ((drawing-object text-object) x bottom-y window) + (let* ((surface-width (object-width drawing-object)) + (surface-height (object-height drawing-object)) + (attribute (text-object-attribute drawing-object)) + (background (attribute-background-with-reverse attribute)) + (texture (sdl2:create-texture-from-surface + (current-renderer) + (text-object-surface drawing-object))) + (y (- bottom-y surface-height))) + (sdl2:with-rects ((rect x y surface-width surface-height)) + (set-color background) + (sdl2:render-fill-rect (current-renderer) rect)) + (render-texture (current-renderer) + texture + x + y + surface-width + surface-height) + (sdl2:destroy-texture texture) + (when (and attribute + (lem:attribute-underline attribute)) + (render-line x + (1- (+ y surface-height)) + (+ x surface-width) + (1- (+ y surface-height)) + :color (let ((underline (lem:attribute-underline attribute))) + (if (eq underline t) + (attribute-foreground-color attribute) + (or (lem:parse-color underline) + (attribute-foreground-color attribute)))))))) + +(defmethod draw-object ((drawing-object eol-cursor-object) x bottom-y window) + (set-color (eol-cursor-object-color drawing-object)) + (sdl2:with-rects ((rect x + (- bottom-y (object-height drawing-object)) + (char-width) + (object-height drawing-object))) + (sdl2:render-fill-rect (current-renderer) rect))) + +(defmethod draw-object ((drawing-object extend-to-eol-object) x bottom-y window) + (set-color (extend-to-eol-object-color drawing-object)) + (sdl2:with-rects ((rect x + (- bottom-y (char-height)) + (- (view-width-by-pixel window) x) + (char-height))) + (sdl2:render-fill-rect (current-renderer) + rect))) + +(defmethod draw-object ((drawing-object line-end-object) x bottom-y window) + (call-next-method drawing-object + (+ x + (* (line-end-object-offset drawing-object) + (char-width))) + bottom-y)) + +;;; object-width +(defmethod object-width ((drawing-object void-object)) + 0) + +(defmethod object-width ((drawing-object text-object)) + (sdl2:surface-width (text-object-surface drawing-object))) + +(defmethod object-width ((drawing-object eol-cursor-object)) + 0) + +(defmethod object-width ((drawing-object extend-to-eol-object)) + 0) + +(defmethod object-width ((drawing-object line-end-object)) + (sdl2:surface-width (text-object-surface drawing-object))) + +;;; object-height +(defmethod object-height ((drawing-object void-object)) + (char-height)) + +(defmethod object-height ((drawing-object text-object)) + (sdl2:surface-height (text-object-surface drawing-object))) + +(defmethod object-height ((drawing-object eol-cursor-object)) + (char-height)) + +(defmethod object-height ((drawing-object extend-to-eol-object)) + (char-height)) + +(defmethod object-height ((drawing-object line-end-object)) + (char-height)) + +(defun max-height-of-objects (objects) + (loop :for object :in objects + :maximize (object-height object))) + +(defun split-string-by-character-type (string) + (flet ((char-type (char) + (guess-font-type *display* (char-code char)))) + (loop :with pos := 0 :and items := '() + :while (< pos (length string)) + :for type := (char-type (char string pos)) + :do (loop :with start := pos + :while (and (< pos (length string)) + (eq type (char-type (char string pos)))) + :do (incf pos) + :finally (push (cons type (subseq string start pos)) items)) + :finally (return (nreverse items))))) + +(defun make-text-surface-with-attribute (string attribute &key (type :latin)) + (cffi:with-foreign-string (c-string string) + (let* ((attribute (and attribute (lem:ensure-attribute attribute))) + (bold (and attribute (lem:attribute-bold attribute))) + (foreground (attribute-foreground-with-reverse attribute)) + (surface + (sdl2-ttf:render-utf8-blended (get-display-font *display* + :type type + :bold bold) + c-string + (lem:color-red foreground) + (lem:color-green foreground) + (lem:color-blue foreground) + 0))) + (values surface attribute)))) + +(defun create-drawing-object (item) + (cond ((typep item 'eol-cursor-item) + (list (make-instance 'eol-cursor-object + :color (lem:parse-color + (lem:attribute-background + (eol-cursor-item-attribute item)))))) + ((typep item 'extend-to-eol-item) + (list (make-instance 'extend-to-eol-object :color (extend-to-eol-item-color item)))) + ((typep item 'line-end-item) + (let ((string (line-end-item-text item)) + (attribute (line-end-item-attribute item))) + (loop :for (type . string) :in (split-string-by-character-type string) + :collect (multiple-value-bind (surface attribute) + (make-text-surface-with-attribute string attribute :type type) + (make-instance 'line-end-object + :offset (line-end-item-offset item) + :surface surface + :string string + :attribute attribute))))) + (t + (let ((string (item-string item)) + (attribute (item-attribute item))) + (if (alexandria:emptyp string) + (list (make-instance 'void-object)) + (loop :for (type . string) :in (split-string-by-character-type string) + :collect (multiple-value-bind (surface attribute) + (make-text-surface-with-attribute string attribute :type type) + (make-instance 'text-object + :surface surface + :string string + :attribute attribute)))))))) + +(defun clear-to-end-of-line (window x y height) + (sdl2:with-rects ((rect x y (- (view-width-by-pixel window) x) height)) + (set-render-color *display* (display-background-color *display*)) + (sdl2:render-fill-rect (current-renderer) rect))) + +(defun create-drawing-objects (logical-line) + (multiple-value-bind (items line-end-item) + (compute-items-from-string-and-attributes logical-line) + (append (loop :for item :in items + :append (create-drawing-object item)) + (when line-end-item + (create-drawing-object line-end-item))))) + +(defun make-letter-object (character attribute) + (let* ((bold (and attribute (lem:attribute-bold attribute))) + (foreground (attribute-foreground-with-reverse attribute))) + (cffi:with-foreign-string (c-string (string character)) + (let ((surface + (sdl2-ttf:render-utf8-blended (get-display-font *display* + :type :latin + :bold bold) + c-string + (lem:color-red foreground) + (lem:color-green foreground) + (lem:color-blue foreground) + 0))) + (make-instance 'text-object + :surface surface + :string (string character) + :attribute attribute))))) + + +(defun explode-object (text-object) + (check-type text-object text-object) + (loop :for c :across (text-object-string text-object) + :collect (make-letter-object c (text-object-attribute text-object)))) + +(defun separate-objects-by-width (objects view-width) + (loop + :until (null objects) + :collect (loop :with total-width := 0 + :and physical-line-objects := '() + :for object := (pop objects) + :while object + :do (cond ((<= view-width (+ total-width (object-width object))) + (cond ((and (typep object 'text-object) + (< 1 (length (text-object-string object)))) + (setf objects (nconc (explode-object object) objects))) + (t + (push object objects) + (push (make-letter-object #\\ nil) + physical-line-objects) + (return (nreverse physical-line-objects))))) + (t + (incf total-width (object-width object)) + (push object physical-line-objects))) + :finally (return (nreverse physical-line-objects))))) + +(defun redraw-physical-line (window y height objects) + (clear-to-end-of-line window 0 y height) + (loop :for x := 0 :then (+ x (object-width object)) + :for object :in objects + :do (draw-object object x (+ y height) window))) + +(defun redraw-logical-line (window y logical-line) + (loop :for objects :in + (separate-objects-by-width (create-drawing-objects logical-line) + (view-width-by-pixel window)) + :for height := (max-height-of-objects objects) + :do (redraw-physical-line window y height objects) + (incf y height) + :sum height)) + +(defun redraw-lines (window) + (lem:with-point ((point (lem:window-view-point window))) + (let ((overlays (collect-overlays window))) + (loop :with y := 0 :and height := (view-height-by-pixel window) + :do (incf y (redraw-logical-line window + y + (create-logical-line point overlays))) + :while (and (lem:line-offset point 1) + (< y height)) + :finally (sdl2:with-rects ((rect 0 + y + (view-width-by-pixel window) + (- (view-height-by-pixel window) + y))) + (set-render-color *display* (display-background-color *display*)) + (sdl2:render-fill-rect (current-renderer) rect)))))) + +(defmethod lem-core::redraw-buffer ((buffer v2-text-buffer) window force) + (assert (eq buffer (lem:window-buffer window))) + (sdl2:set-render-target (current-renderer) (view-texture (lem:window-view window))) + (redraw-lines window)) From 95924fa8a4e65656a1ca359ecfeb5c5ec4780364 Mon Sep 17 00:00:00 2001 From: cxxxr Date: Sun, 30 Jul 2023 18:21:43 +0900 Subject: [PATCH 02/12] cache drawing --- frontends/sdl2/text-buffer.lisp | 58 +++++++++++++++++++++++++++++++-- 1 file changed, 55 insertions(+), 3 deletions(-) diff --git a/frontends/sdl2/text-buffer.lisp b/frontends/sdl2/text-buffer.lisp index fdf9838b2..8e28fef3d 100644 --- a/frontends/sdl2/text-buffer.lisp +++ b/frontends/sdl2/text-buffer.lisp @@ -50,7 +50,7 @@ (* (char-width) (view-width (lem:window-view window)))) (defun view-height-by-pixel (window) - (* (char-height) (view-width (lem:window-view window)))) + (* (char-height) (view-height (lem:window-view window)))) (defun cursor-attribute-p (attribute) (lem:attribute-value attribute :cursor)) @@ -123,6 +123,27 @@ extend-to-end line-end-overlay) +(defun attribute-equal-careful-null-and-symbol (a b) + (if (or (null a) (null b)) + (and (null a) (null b)) + (lem-core::attribute-equal (lem:ensure-attribute a) + (lem:ensure-attribute b)))) + +(defun logical-line-equal (a b) + (and (string= (logical-line-string a) (logical-line-string b)) + (= (length (logical-line-attributes a)) + (length (logical-line-attributes b))) + (every (lambda (elt1 elt2) + (and (equal (first elt1) (first elt2)) + (equal (second elt1) (second elt2)) + (attribute-equal-careful-null-and-symbol (third elt1) (third elt2)))) + (logical-line-attributes a) + (logical-line-attributes b)) + (attribute-equal-careful-null-and-symbol (logical-line-end-of-line-cursor-attribute a) + (logical-line-end-of-line-cursor-attribute b)) + (attribute-equal-careful-null-and-symbol (logical-line-extend-to-end a) + (logical-line-extend-to-end b)))) + (defun create-logical-line (point overlays) (let ((end-of-line-cursor-attribute nil) (extend-to-end-attribute nil) @@ -448,12 +469,39 @@ :for object :in objects :do (draw-object object x (+ y height) window))) +(defun validate-cache-p (window y height logical-line) + (loop :for (cache-y cache-height cache-logical-line) :in (lem:window-parameter window 'cache-redrawing) + :when (and (= y cache-y) + (= height cache-height) + (logical-line-equal logical-line cache-logical-line)) + :return t)) + +(defun invalidate-cache (window y height) + (setf (lem:window-parameter window 'cache-redrawing) + (remove-if (lambda (elt) + (destructuring-bind (cache-y cache-height cache-logical-line) elt + (declare (ignore cache-logical-line)) + (not (or (<= (+ y height) + cache-y) + (<= (+ cache-y cache-height) + y))))) + (lem:window-parameter window 'cache-redrawing)))) + +(defun update-and-validate-cache-p (window y height logical-line) + (cond ((validate-cache-p window y height logical-line) t) + (t + (invalidate-cache window y height) + (push (list y height logical-line) + (lem:window-parameter window 'cache-redrawing)) + nil))) + (defun redraw-logical-line (window y logical-line) (loop :for objects :in (separate-objects-by-width (create-drawing-objects logical-line) (view-width-by-pixel window)) :for height := (max-height-of-objects objects) - :do (redraw-physical-line window y height objects) + :do (unless (update-and-validate-cache-p window y height logical-line) + (redraw-physical-line window y height objects)) (incf y height) :sum height)) @@ -476,5 +524,9 @@ (defmethod lem-core::redraw-buffer ((buffer v2-text-buffer) window force) (assert (eq buffer (lem:window-buffer window))) + (when (or force + (lem-core::screen-modified-p (lem:window-screen window))) + (setf (lem:window-parameter window 'cache-redrawing) '())) (sdl2:set-render-target (current-renderer) (view-texture (lem:window-view window))) - (redraw-lines window)) + (redraw-lines window) + (lem-core::update-screen-cache (lem:window-screen window) buffer)) From a9a968f04900c75540c434b3a0e0b1bd4683055f Mon Sep 17 00:00:00 2001 From: cxxxr Date: Sun, 30 Jul 2023 21:43:29 +0900 Subject: [PATCH 03/12] tweak --- frontends/sdl2/main.lisp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/frontends/sdl2/main.lisp b/frontends/sdl2/main.lisp index f8bf65e54..0859141f3 100644 --- a/frontends/sdl2/main.lisp +++ b/frontends/sdl2/main.lisp @@ -998,13 +998,13 @@ (defun set-input-method () (let* ((view (lem:window-view (lem:current-window))) - (cursor-x (lem:last-print-cursor-x (lem:current-window))) - (cursor-y (lem:last-print-cursor-y (lem:current-window))) + (cursor-x (* (lem:last-print-cursor-x (lem:current-window)) (char-width))) + (cursor-y (* (lem:last-print-cursor-y (lem:current-window)) (char-height))) (text lem-sdl2/keyboard::*textediting-text*) (x (+ (* (view-x view) (char-width)) - (* cursor-x (char-width)))) + cursor-x)) (y (+ (* (view-y view) (char-height)) - (* cursor-y (char-height))))) + cursor-y))) (sdl2:with-rects ((rect x y (* (char-width) (lem:string-width text)) (char-height))) (sdl2-ffi.functions:sdl-set-text-input-rect rect) (when (plusp (length text)) From 19e88f91948a9f7363a6e666734b22b186bbe096 Mon Sep 17 00:00:00 2001 From: cxxxr Date: Sun, 30 Jul 2023 22:07:32 +0900 Subject: [PATCH 04/12] fix merge-attribute: also included plist --- src/attribute.lisp | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/attribute.lisp b/src/attribute.lisp index affb26fde..5eb330b35 100644 --- a/src/attribute.lisp +++ b/src/attribute.lisp @@ -22,6 +22,7 @@ :initform nil :accessor attribute-cache) (plist + :initarg :plist :initform nil :accessor attribute-plist))) @@ -43,13 +44,14 @@ (defun (setf attribute-value) (value attribute key) (setf (getf (attribute-plist attribute) key) value)) -(defun make-attribute (&key foreground background reverse bold underline) +(defun make-attribute (&key foreground background reverse bold underline plist) (make-instance 'attribute :foreground (or (maybe-base-color foreground) nil) :background (or (maybe-base-color background) nil) :reverse reverse :bold bold - :underline (or (maybe-base-color underline) underline))) + :underline (or (maybe-base-color underline) underline) + :plist plist)) (defun ensure-attribute (x &optional (errorp t)) (cond ((symbolp x) @@ -72,7 +74,9 @@ :reverse (or (attribute-reverse over) (attribute-reverse under)) :underline (or (attribute-underline over) - (attribute-underline under)))) + (attribute-underline under)) + :plist (append (attribute-plist over) + (attribute-plist under)))) (defun attribute-equal (attribute1 attribute2) (and (equal (attribute-foreground attribute1) From 4175d6f3a627a3993d4e11df9afa92e815411bfb Mon Sep 17 00:00:00 2001 From: cxxxr Date: Sun, 30 Jul 2023 22:08:16 +0900 Subject: [PATCH 05/12] set cursor position for input-method --- frontends/sdl2/main.lisp | 24 +++++++++++++++++++++--- frontends/sdl2/text-buffer.lisp | 21 ++++++++++++++++----- 2 files changed, 37 insertions(+), 8 deletions(-) diff --git a/frontends/sdl2/main.lisp b/frontends/sdl2/main.lisp index 0859141f3..089399509 100644 --- a/frontends/sdl2/main.lisp +++ b/frontends/sdl2/main.lisp @@ -559,7 +559,25 @@ :reader view-use-modeline) (texture :initarg :texture - :accessor view-texture))) + :accessor view-texture) + (last-cursor-x + :initform nil + :accessor view-last-cursor-x) + (last-cursor-y + :initform nil + :accessor view-last-cursor-y))) + +(defmethod last-cursor-x ((view view)) + (or (view-last-cursor-x view) + ;; fallback to v1 + (* (lem:last-print-cursor-x (view-window view)) + (char-width)))) + +(defmethod last-cursor-y ((view view)) + (or (view-last-cursor-y view) + ;; fallback to v1 + (* (lem:last-print-cursor-y (view-window view)) + (char-height)))) (defun create-view (window x y width height use-modeline) (when use-modeline (incf height)) @@ -998,8 +1016,8 @@ (defun set-input-method () (let* ((view (lem:window-view (lem:current-window))) - (cursor-x (* (lem:last-print-cursor-x (lem:current-window)) (char-width))) - (cursor-y (* (lem:last-print-cursor-y (lem:current-window)) (char-height))) + (cursor-x (last-cursor-x view)) + (cursor-y (last-cursor-y view)) (text lem-sdl2/keyboard::*textediting-text*) (x (+ (* (view-x view) (char-width)) cursor-x)) diff --git a/frontends/sdl2/text-buffer.lisp b/frontends/sdl2/text-buffer.lisp index 8e28fef3d..2ef05f97c 100644 --- a/frontends/sdl2/text-buffer.lisp +++ b/frontends/sdl2/text-buffer.lisp @@ -116,6 +116,11 @@ (attribute-foreground-color attribute) (attribute-background-color attribute))) +(defun set-cursor-position (window x y) + (let ((view (lem:window-view window))) + (setf (view-last-cursor-x view) x + (view-last-cursor-y view) y))) + (defstruct logical-line string attributes @@ -262,6 +267,9 @@ (current-renderer) (text-object-surface drawing-object))) (y (- bottom-y surface-height))) + (when (and attribute (cursor-attribute-p attribute)) + (setf (view-last-cursor-x (lem:window-view window)) x + (view-last-cursor-y (lem:window-view window)) y)) (sdl2:with-rects ((rect x y surface-width surface-height)) (set-color background) (sdl2:render-fill-rect (current-renderer) rect)) @@ -286,11 +294,14 @@ (defmethod draw-object ((drawing-object eol-cursor-object) x bottom-y window) (set-color (eol-cursor-object-color drawing-object)) - (sdl2:with-rects ((rect x - (- bottom-y (object-height drawing-object)) - (char-width) - (object-height drawing-object))) - (sdl2:render-fill-rect (current-renderer) rect))) + (let ((y (- bottom-y (object-height drawing-object)))) + (setf (view-last-cursor-x (lem:window-view window)) x + (view-last-cursor-y (lem:window-view window)) y) + (sdl2:with-rects ((rect x + y + (char-width) + (object-height drawing-object))) + (sdl2:render-fill-rect (current-renderer) rect)))) (defmethod draw-object ((drawing-object extend-to-eol-object) x bottom-y window) (set-color (extend-to-eol-object-color drawing-object)) From 47c70ad9ddb3694a86125e99796a30eadb8a124f Mon Sep 17 00:00:00 2001 From: cxxxr Date: Sun, 30 Jul 2023 22:22:24 +0900 Subject: [PATCH 06/12] fix the character when wrapping --- frontends/sdl2/text-buffer.lisp | 40 +++++++++++++++++---------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/frontends/sdl2/text-buffer.lisp b/frontends/sdl2/text-buffer.lisp index 2ef05f97c..b5750cc5b 100644 --- a/frontends/sdl2/text-buffer.lisp +++ b/frontends/sdl2/text-buffer.lisp @@ -355,18 +355,19 @@ (loop :for object :in objects :maximize (object-height object))) +(defun char-type (char) + (guess-font-type *display* (char-code char))) + (defun split-string-by-character-type (string) - (flet ((char-type (char) - (guess-font-type *display* (char-code char)))) - (loop :with pos := 0 :and items := '() - :while (< pos (length string)) - :for type := (char-type (char string pos)) - :do (loop :with start := pos - :while (and (< pos (length string)) - (eq type (char-type (char string pos)))) - :do (incf pos) - :finally (push (cons type (subseq string start pos)) items)) - :finally (return (nreverse items))))) + (loop :with pos := 0 :and items := '() + :while (< pos (length string)) + :for type := (char-type (char string pos)) + :do (loop :with start := pos + :while (and (< pos (length string)) + (eq type (char-type (char string pos)))) + :do (incf pos) + :finally (push (cons type (subseq string start pos)) items)) + :finally (return (nreverse items)))) (defun make-text-surface-with-attribute (string attribute &key (type :latin)) (cffi:with-foreign-string (c-string string) @@ -434,14 +435,15 @@ (foreground (attribute-foreground-with-reverse attribute))) (cffi:with-foreign-string (c-string (string character)) (let ((surface - (sdl2-ttf:render-utf8-blended (get-display-font *display* - :type :latin - :bold bold) - c-string - (lem:color-red foreground) - (lem:color-green foreground) - (lem:color-blue foreground) - 0))) + (sdl2-ttf:render-utf8-blended + (get-display-font *display* + :type (char-type character) + :bold bold) + c-string + (lem:color-red foreground) + (lem:color-green foreground) + (lem:color-blue foreground) + 0))) (make-instance 'text-object :surface surface :string (string character) From ec356f93f471acb0d8dd7d6caa333871ea0ab5e4 Mon Sep 17 00:00:00 2001 From: cxxxr Date: Sun, 30 Jul 2023 22:43:27 +0900 Subject: [PATCH 07/12] Allow fonts to be specified in attribute --- frontends/sdl2/text-buffer.lisp | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/frontends/sdl2/text-buffer.lisp b/frontends/sdl2/text-buffer.lisp index b5750cc5b..eb0d3c54b 100644 --- a/frontends/sdl2/text-buffer.lisp +++ b/frontends/sdl2/text-buffer.lisp @@ -358,6 +358,11 @@ (defun char-type (char) (guess-font-type *display* (char-code char))) +(defun get-font (&key attribute type bold) + (or (alexandria:when-let (attribute (and attribute (lem:ensure-attribute attribute))) + (lem:attribute-value attribute 'font)) + (get-display-font *display* :type type :bold bold))) + (defun split-string-by-character-type (string) (loop :with pos := 0 :and items := '() :while (< pos (length string)) @@ -375,9 +380,9 @@ (bold (and attribute (lem:attribute-bold attribute))) (foreground (attribute-foreground-with-reverse attribute)) (surface - (sdl2-ttf:render-utf8-blended (get-display-font *display* - :type type - :bold bold) + (sdl2-ttf:render-utf8-blended (get-font :attribute attribute + :type type + :bold bold) c-string (lem:color-red foreground) (lem:color-green foreground) @@ -436,9 +441,9 @@ (cffi:with-foreign-string (c-string (string character)) (let ((surface (sdl2-ttf:render-utf8-blended - (get-display-font *display* - :type (char-type character) - :bold bold) + (get-font :attribute attribute + :type (char-type character) + :bold bold) c-string (lem:color-red foreground) (lem:color-green foreground) From f53ca607b11d1f05c0ca4d2019ce1d6374b6142d Mon Sep 17 00:00:00 2001 From: cxxxr Date: Mon, 31 Jul 2023 00:33:08 +0900 Subject: [PATCH 08/12] add image support --- frontends/sdl2/text-buffer.lisp | 54 +++++++++++++++++++++++++++------ 1 file changed, 44 insertions(+), 10 deletions(-) diff --git a/frontends/sdl2/text-buffer.lisp b/frontends/sdl2/text-buffer.lisp index eb0d3c54b..84f348777 100644 --- a/frontends/sdl2/text-buffer.lisp +++ b/frontends/sdl2/text-buffer.lisp @@ -58,6 +58,16 @@ (defun set-cursor-attribute (attribute) (setf (lem:attribute-value attribute :cursor) t)) +(defun attribute-font (attribute) + (let ((attribute (lem:ensure-attribute attribute nil))) + (when attribute + (lem:attribute-value attribute 'font)))) + +(defun attribute-image (attribute) + (let ((attribute (lem:ensure-attribute attribute nil))) + (when attribute + (lem:attribute-value attribute 'image)))) + (defun overlay-cursor-p (overlay) (lem:overlay-get overlay :cursor)) @@ -254,6 +264,10 @@ ((offset :initarg :offset :reader line-end-object-offset))) +(defclass image-object (drawing-object) + ((surface :initarg :surface :reader image-object-surface) + (attribute :initarg :attribute :reader image-object-attribute))) + ;;; draw-object (defmethod draw-object ((drawing-object void-object) x bottom-y window) nil) @@ -319,6 +333,15 @@ (char-width))) bottom-y)) +(defmethod draw-object ((drawing-object image-object) x bottom-y window) + (let* ((surface-width (object-width drawing-object)) + (surface-height (object-height drawing-object)) + (texture (sdl2:create-texture-from-surface (current-renderer) + (image-object-surface drawing-object))) + (y (- bottom-y surface-height))) + (render-texture (current-renderer) texture x y surface-width surface-height) + (sdl2:destroy-texture texture))) + ;;; object-width (defmethod object-width ((drawing-object void-object)) 0) @@ -335,6 +358,9 @@ (defmethod object-width ((drawing-object line-end-object)) (sdl2:surface-width (text-object-surface drawing-object))) +(defmethod object-width ((drawing-object image-object)) + (sdl2:surface-width (image-object-surface drawing-object))) + ;;; object-height (defmethod object-height ((drawing-object void-object)) (char-height)) @@ -351,6 +377,9 @@ (defmethod object-height ((drawing-object line-end-object)) (char-height)) +(defmethod object-height ((drawing-object image-object)) + (sdl2:surface-height (image-object-surface drawing-object))) + (defun max-height-of-objects (objects) (loop :for object :in objects :maximize (object-height object))) @@ -360,7 +389,7 @@ (defun get-font (&key attribute type bold) (or (alexandria:when-let (attribute (and attribute (lem:ensure-attribute attribute))) - (lem:attribute-value attribute 'font)) + (attribute-font attribute)) (get-display-font *display* :type type :bold bold))) (defun split-string-by-character-type (string) @@ -412,15 +441,20 @@ (t (let ((string (item-string item)) (attribute (item-attribute item))) - (if (alexandria:emptyp string) - (list (make-instance 'void-object)) - (loop :for (type . string) :in (split-string-by-character-type string) - :collect (multiple-value-bind (surface attribute) - (make-text-surface-with-attribute string attribute :type type) - (make-instance 'text-object - :surface surface - :string string - :attribute attribute)))))))) + (cond ((alexandria:emptyp string) + (list (make-instance 'void-object))) + ((and attribute (attribute-image attribute)) + (list (make-instance 'image-object + :surface (attribute-image attribute) + :attribute attribute))) + (t + (loop :for (type . string) :in (split-string-by-character-type string) + :collect (multiple-value-bind (surface attribute) + (make-text-surface-with-attribute string attribute :type type) + (make-instance 'text-object + :surface surface + :string string + :attribute attribute))))))))) (defun clear-to-end-of-line (window x y height) (sdl2:with-rects ((rect x y (- (view-width-by-pixel window) x) height)) From 445d2ab500a2572515538e5ddb3f346d8f35065f Mon Sep 17 00:00:00 2001 From: cxxxr Date: Mon, 31 Jul 2023 20:20:15 +0900 Subject: [PATCH 09/12] refactor --- frontends/sdl2/text-buffer.lisp | 109 ++++++++++++++++---------------- 1 file changed, 53 insertions(+), 56 deletions(-) diff --git a/frontends/sdl2/text-buffer.lisp b/frontends/sdl2/text-buffer.lisp index 84f348777..72716edfe 100644 --- a/frontends/sdl2/text-buffer.lisp +++ b/frontends/sdl2/text-buffer.lisp @@ -2,6 +2,53 @@ (defclass v2-text-buffer (lem:text-buffer) ()) +(defun view-width-by-pixel (window) + (* (char-width) (view-width (lem:window-view window)))) + +(defun view-height-by-pixel (window) + (* (char-height) (view-height (lem:window-view window)))) + +(defun set-cursor-position (window x y) + (let ((view (lem:window-view window))) + (setf (view-last-cursor-x view) x + (view-last-cursor-y view) y))) + +(defun char-type (char) + (guess-font-type *display* (char-code char))) + +(defun get-font (&key attribute type bold) + (or (alexandria:when-let (attribute (and attribute (lem:ensure-attribute attribute))) + (attribute-font attribute)) + (get-display-font *display* :type type :bold bold))) + +(defun cursor-attribute-p (attribute) + (lem:attribute-value attribute :cursor)) + +(defun set-cursor-attribute (attribute) + (setf (lem:attribute-value attribute :cursor) t)) + +(defun attribute-font (attribute) + (let ((attribute (lem:ensure-attribute attribute nil))) + (when attribute + (lem:attribute-value attribute 'font)))) + +(defun attribute-image (attribute) + (let ((attribute (lem:ensure-attribute attribute nil))) + (when attribute + (lem:attribute-value attribute 'image)))) + +(defun attribute-foreground-with-reverse (attribute) + (if (and attribute (lem:attribute-reverse attribute)) + (attribute-background-color attribute) + (attribute-foreground-color attribute))) + +(defun attribute-background-with-reverse (attribute) + (if (and attribute (lem:attribute-reverse attribute)) + (attribute-foreground-color attribute) + (attribute-background-color attribute))) + +(defun overlay-cursor-p (overlay) + (lem:overlay-get overlay :cursor)) (defstruct string-with-attribute-item string @@ -46,31 +93,6 @@ (defmethod item-attribute ((item extend-to-eol-item)) nil) -(defun view-width-by-pixel (window) - (* (char-width) (view-width (lem:window-view window)))) - -(defun view-height-by-pixel (window) - (* (char-height) (view-height (lem:window-view window)))) - -(defun cursor-attribute-p (attribute) - (lem:attribute-value attribute :cursor)) - -(defun set-cursor-attribute (attribute) - (setf (lem:attribute-value attribute :cursor) t)) - -(defun attribute-font (attribute) - (let ((attribute (lem:ensure-attribute attribute nil))) - (when attribute - (lem:attribute-value attribute 'font)))) - -(defun attribute-image (attribute) - (let ((attribute (lem:ensure-attribute attribute nil))) - (when attribute - (lem:attribute-value attribute 'image)))) - -(defun overlay-cursor-p (overlay) - (lem:overlay-get overlay :cursor)) - (defun make-cursor-overlay (point) (let ((overlay (lem-core::make-temporary-overlay point @@ -116,21 +138,6 @@ (t nil))) -(defun attribute-foreground-with-reverse (attribute) - (if (and attribute (lem:attribute-reverse attribute)) - (attribute-background-color attribute) - (attribute-foreground-color attribute))) - -(defun attribute-background-with-reverse (attribute) - (if (and attribute (lem:attribute-reverse attribute)) - (attribute-foreground-color attribute) - (attribute-background-color attribute))) - -(defun set-cursor-position (window x y) - (let ((view (lem:window-view window))) - (setf (view-last-cursor-x view) x - (view-last-cursor-y view) y))) - (defstruct logical-line string attributes @@ -282,8 +289,7 @@ (text-object-surface drawing-object))) (y (- bottom-y surface-height))) (when (and attribute (cursor-attribute-p attribute)) - (setf (view-last-cursor-x (lem:window-view window)) x - (view-last-cursor-y (lem:window-view window)) y)) + (set-cursor-position window x y)) (sdl2:with-rects ((rect x y surface-width surface-height)) (set-color background) (sdl2:render-fill-rect (current-renderer) rect)) @@ -309,8 +315,7 @@ (defmethod draw-object ((drawing-object eol-cursor-object) x bottom-y window) (set-color (eol-cursor-object-color drawing-object)) (let ((y (- bottom-y (object-height drawing-object)))) - (setf (view-last-cursor-x (lem:window-view window)) x - (view-last-cursor-y (lem:window-view window)) y) + (set-cursor-position window x y) (sdl2:with-rects ((rect x y (char-width) @@ -380,18 +385,6 @@ (defmethod object-height ((drawing-object image-object)) (sdl2:surface-height (image-object-surface drawing-object))) -(defun max-height-of-objects (objects) - (loop :for object :in objects - :maximize (object-height object))) - -(defun char-type (char) - (guess-font-type *display* (char-code char))) - -(defun get-font (&key attribute type bold) - (or (alexandria:when-let (attribute (and attribute (lem:ensure-attribute attribute))) - (attribute-font attribute)) - (get-display-font *display* :type type :bold bold))) - (defun split-string-by-character-type (string) (loop :with pos := 0 :and items := '() :while (< pos (length string)) @@ -547,6 +540,10 @@ (lem:window-parameter window 'cache-redrawing)) nil))) +(defun max-height-of-objects (objects) + (loop :for object :in objects + :maximize (object-height object))) + (defun redraw-logical-line (window y logical-line) (loop :for objects :in (separate-objects-by-width (create-drawing-objects logical-line) From e1ebf42c9ccf4afb072501d74866db02a3152f34 Mon Sep 17 00:00:00 2001 From: cxxxr Date: Mon, 31 Jul 2023 20:25:48 +0900 Subject: [PATCH 10/12] extract function: drawing-cache --- frontends/sdl2/text-buffer.lisp | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/frontends/sdl2/text-buffer.lisp b/frontends/sdl2/text-buffer.lisp index 72716edfe..a621f643f 100644 --- a/frontends/sdl2/text-buffer.lisp +++ b/frontends/sdl2/text-buffer.lisp @@ -13,6 +13,12 @@ (setf (view-last-cursor-x view) x (view-last-cursor-y view) y))) +(defun drawing-cache (window) + (lem:window-parameter window 'redrawing-cache)) + +(defun (setf drawing-cache) (value window) + (setf (lem:window-parameter window 'redrawing-cache) value)) + (defun char-type (char) (guess-font-type *display* (char-code char))) @@ -515,14 +521,14 @@ :do (draw-object object x (+ y height) window))) (defun validate-cache-p (window y height logical-line) - (loop :for (cache-y cache-height cache-logical-line) :in (lem:window-parameter window 'cache-redrawing) + (loop :for (cache-y cache-height cache-logical-line) :in (drawing-cache window) :when (and (= y cache-y) (= height cache-height) (logical-line-equal logical-line cache-logical-line)) :return t)) (defun invalidate-cache (window y height) - (setf (lem:window-parameter window 'cache-redrawing) + (setf (drawing-cache window) (remove-if (lambda (elt) (destructuring-bind (cache-y cache-height cache-logical-line) elt (declare (ignore cache-logical-line)) @@ -530,14 +536,14 @@ cache-y) (<= (+ cache-y cache-height) y))))) - (lem:window-parameter window 'cache-redrawing)))) + (drawing-cache window)))) (defun update-and-validate-cache-p (window y height logical-line) (cond ((validate-cache-p window y height logical-line) t) (t (invalidate-cache window y height) (push (list y height logical-line) - (lem:window-parameter window 'cache-redrawing)) + (drawing-cache window)) nil))) (defun max-height-of-objects (objects) @@ -575,7 +581,7 @@ (assert (eq buffer (lem:window-buffer window))) (when (or force (lem-core::screen-modified-p (lem:window-screen window))) - (setf (lem:window-parameter window 'cache-redrawing) '())) + (setf (drawing-cache window) '())) (sdl2:set-render-target (current-renderer) (view-texture (lem:window-view window))) (redraw-lines window) (lem-core::update-screen-cache (lem:window-screen window) buffer)) From 97f48e772c7ab772aeb8730fb69ba149e2557db7 Mon Sep 17 00:00:00 2001 From: cxxxr Date: Mon, 31 Jul 2023 21:04:25 +0900 Subject: [PATCH 11/12] disable cache on wrap --- frontends/sdl2/text-buffer.lisp | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/frontends/sdl2/text-buffer.lisp b/frontends/sdl2/text-buffer.lisp index a621f643f..4f4e32d51 100644 --- a/frontends/sdl2/text-buffer.lisp +++ b/frontends/sdl2/text-buffer.lisp @@ -550,19 +550,27 @@ (loop :for object :in objects :maximize (object-height object))) +(defvar *invalidate-cache* nil) + (defun redraw-logical-line (window y logical-line) - (loop :for objects :in - (separate-objects-by-width (create-drawing-objects logical-line) - (view-width-by-pixel window)) - :for height := (max-height-of-objects objects) - :do (unless (update-and-validate-cache-p window y height logical-line) - (redraw-physical-line window y height objects)) - (incf y height) - :sum height)) + (let ((objects-per-physical-line + (separate-objects-by-width (create-drawing-objects logical-line) + (view-width-by-pixel window)))) + (when (and (not (alexandria:length= 1 objects-per-physical-line)) + *invalidate-cache*) + (setf (drawing-cache window) '())) + (loop :for objects :in objects-per-physical-line + :for height := (max-height-of-objects objects) + :do (unless (update-and-validate-cache-p window y height logical-line) + (setf *invalidate-cache* t) + (redraw-physical-line window y height objects)) + (incf y height) + :sum height))) (defun redraw-lines (window) (lem:with-point ((point (lem:window-view-point window))) - (let ((overlays (collect-overlays window))) + (let ((*invalidate-cache* nil) + (overlays (collect-overlays window))) (loop :with y := 0 :and height := (view-height-by-pixel window) :do (incf y (redraw-logical-line window y From e7a87e6e6a35a6bbb4f51a9498152b4f7fa2c0c3 Mon Sep 17 00:00:00 2001 From: cxxxr Date: Mon, 31 Jul 2023 23:43:32 +0900 Subject: [PATCH 12/12] rename v2-text-buffer -> graphical-text-buffer --- frontends/sdl2/text-buffer.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/frontends/sdl2/text-buffer.lisp b/frontends/sdl2/text-buffer.lisp index 4f4e32d51..88ab7bfd4 100644 --- a/frontends/sdl2/text-buffer.lisp +++ b/frontends/sdl2/text-buffer.lisp @@ -1,6 +1,6 @@ (in-package :lem-sdl2) -(defclass v2-text-buffer (lem:text-buffer) ()) +(defclass graphical-text-buffer (lem:text-buffer) ()) (defun view-width-by-pixel (window) (* (char-width) (view-width (lem:window-view window)))) @@ -585,7 +585,7 @@ (set-render-color *display* (display-background-color *display*)) (sdl2:render-fill-rect (current-renderer) rect)))))) -(defmethod lem-core::redraw-buffer ((buffer v2-text-buffer) window force) +(defmethod lem-core::redraw-buffer ((buffer graphical-text-buffer) window force) (assert (eq buffer (lem:window-buffer window))) (when (or force (lem-core::screen-modified-p (lem:window-screen window)))