diff --git a/frontends/sdl2/main.lisp b/frontends/sdl2/main.lisp index f3d64df64..aa601ff8c 100644 --- a/frontends/sdl2/main.lisp +++ b/frontends/sdl2/main.lisp @@ -174,8 +174,10 @@ (font-config-size (display-font-config *display*))))))))) (defmethod get-display-font ((display display) &key type bold character) - (check-type type (member :latin :cjk :braille :emoji :icon)) - (cond ((eq type :icon) + (check-type type lem-core/display-3::char-type) + (cond ((eq type :control) + (display-latin-font display)) + ((eq type :icon) (or (and character (icon-font character)) (display-emoji-font display))) ((eq type :emoji) diff --git a/frontends/sdl2/text-buffer-impl.lisp b/frontends/sdl2/text-buffer-impl.lisp index 7913c3f0b..1d9e68902 100644 --- a/frontends/sdl2/text-buffer-impl.lisp +++ b/frontends/sdl2/text-buffer-impl.lisp @@ -70,6 +70,9 @@ (defmethod object-width ((drawing-object lem-core/display-3::text-object)) (sdl2:surface-width (get-surface drawing-object))) +(defmethod object-width ((drawing-object lem-core/display-3::control-character-object)) + (* 2 (lem-sdl2::char-width))) + (defmethod object-width ((drawing-object lem-core/display-3::icon-object)) (sdl2:surface-width (get-surface drawing-object))) @@ -104,6 +107,9 @@ (defmethod object-height ((drawing-object lem-core/display-3::icon-object)) (lem-sdl2::char-height)) +(defmethod object-height ((drawing-object lem-core/display-3::control-character-object)) + (lem-sdl2::char-height)) + (defmethod object-height ((drawing-object lem-core/display-3::folder-object)) (lem-sdl2::char-height)) @@ -131,7 +137,7 @@ ;;; draw-object (defmethod draw-object ((drawing-object lem-core/display-3::void-object) x bottom-y window) - (values)) + 0) (defmethod draw-object ((drawing-object lem-core/display-3::text-object) x bottom-y window) (let* ((surface-width (object-width drawing-object)) @@ -164,7 +170,8 @@ (if (eq underline t) (lem-sdl2::attribute-foreground-color attribute) (or (lem:parse-color underline) - (lem-sdl2::attribute-foreground-color attribute)))))))) + (lem-sdl2::attribute-foreground-color attribute)))))) + surface-width)) (defmethod draw-object ((drawing-object lem-core/display-3::eol-cursor-object) x bottom-y window) (lem-sdl2::set-color (lem-core/display-3::eol-cursor-object-color drawing-object)) @@ -174,7 +181,8 @@ y (lem-sdl2::char-width) (object-height drawing-object))) - (sdl2:render-fill-rect (lem-sdl2::current-renderer) rect)))) + (sdl2:render-fill-rect (lem-sdl2::current-renderer) rect))) + (object-width drawing-object)) (defmethod draw-object ((drawing-object lem-core/display-3::extend-to-eol-object) x bottom-y window) (lem-sdl2::set-color (lem-core/display-3::extend-to-eol-object-color drawing-object)) @@ -183,7 +191,8 @@ (- (lem-core/display-3::window-view-width window) x) (lem-sdl2::char-height))) (sdl2:render-fill-rect (lem-sdl2::current-renderer) - rect))) + rect)) + (object-width drawing-object)) (defmethod draw-object ((drawing-object lem-core/display-3::line-end-object) x bottom-y window) (call-next-method drawing-object @@ -199,12 +208,13 @@ (lem-core/display-3::image-object-image drawing-object))) (y (- bottom-y surface-height))) (lem-sdl2::render-texture (lem-sdl2::current-renderer) texture x y surface-width surface-height) - (sdl2:destroy-texture texture))) + (sdl2:destroy-texture texture) + surface-width)) (defun redraw-physical-line (window x y objects height) - (loop :for current-x := x :then (+ current-x (object-width object)) + (loop :with current-x := x :for object :in objects - :do (draw-object object current-x (+ y height) window))) + :do (incf current-x (draw-object object current-x (+ y height) window)))) (defun clear-to-end-of-line (window x y height) (sdl2:with-rects ((rect x y (- (lem-core/display-3::window-view-width window) x) height)) diff --git a/src/display-2.lisp b/src/display-2.lisp index c7e78c331..3857f7d0f 100644 --- a/src/display-2.lisp +++ b/src/display-2.lisp @@ -86,6 +86,28 @@ (t nil))) +(defun expand-tab (string attributes tab-width) + (setf attributes (copy-tree attributes)) + (values (with-output-to-string (out) + (loop :with i := 0 + :for c :across string + :do (cond ((char= c #\tab) + (let ((n (- tab-width (mod i tab-width)))) + (loop :for elt :in attributes + :do (cond ((< i (first elt)) + (incf (first elt) (1- n)) + (incf (second elt) (1- n))) + ((and (< i (second elt)) + (not (cursor-attribute-p (third elt)))) + (incf (second elt) (1- n))))) + (loop :repeat n + :do (write-char #\space out)) + (incf i n))) + (t + (write-char c out) + (incf i))))) + attributes)) + (defun create-logical-line (point overlays active-modes) (let* ((end-of-line-cursor-attribute nil) (extend-to-end-attribute nil) @@ -93,7 +115,8 @@ (left-content (lem-core::compute-left-display-area-content active-modes (lem-base:point-buffer point) - point))) + point)) + (tab-width (lem-core:variable-value 'lem-core:tab-width :default point))) (destructuring-bind (string . attributes) (lem-base::line-string/attributes (lem-base::point-line point)) (loop :for overlay :in overlays @@ -101,12 +124,13 @@ :do (cond ((typep overlay 'lem-core::overlay-line-endings) (setf line-end-overlay overlay)) ((typep overlay 'lem-core::overlay-line) - (setf attributes - (lem-core::overlay-attributes attributes - 0 - (length string) - (lem-core:overlay-attribute overlay))) - (setf extend-to-end-attribute (lem-core:overlay-attribute overlay))) + (let ((attribute (lem-core:overlay-attribute overlay))) + (setf attributes + (lem-core::overlay-attributes attributes + 0 + (length string) + attribute)) + (setf extend-to-end-attribute attribute))) (t (let ((overlay-start-charpos (overlay-start-charpos overlay point)) (overlay-end-charpos (overlay-end-charpos overlay point)) @@ -124,6 +148,7 @@ overlay-start-charpos (or overlay-end-charpos (length string)) overlay-attribute)))))) + (setf (values string attributes) (expand-tab string attributes tab-width)) (make-logical-line :string string :attributes attributes :left-content left-content @@ -176,42 +201,48 @@ nil) (defun compute-items-from-string-and-attributes (string attributes) - (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)))))) - (loop :for last-pos := 0 :then end - :for (start end attribute) :in attributes - :do (unless (= last-pos start) - (add (make-string-with-attribute-item :string (subseq string last-pos start)))) - (add (if (and attribute - (lem-core: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))) - items)) + (handler-case + (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)))))) + (loop :for last-pos := 0 :then end + :for (start end attribute) :in attributes + :do (unless (= last-pos start) + (add (make-string-with-attribute-item :string (subseq string last-pos start)))) + (add (if (and attribute + (lem-core: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))) + items) + (error (e) + (log:info e string attributes) + nil))) (defun attribute-foreground-color (attribute) (or (and attribute (lem-core:parse-color (lem-core:attribute-foreground attribute))) + ;; TODO: fix (display-foreground-color *display*))) (defun attribute-background-color (attribute) (or (and attribute (lem-core:parse-color (lem-core:attribute-background attribute))) + ;; TODO: fix (display-background-color *display*))) (defun compute-items-from-logical-line (logical-line) diff --git a/src/display-3.lisp b/src/display-3.lisp index 4e03a95db..e8bc96119 100644 --- a/src/display-3.lisp +++ b/src/display-3.lisp @@ -24,6 +24,9 @@ (defvar *line-wrap*) +(deftype char-type () + '(member :latin :cjk :braille :emoji :icon :control)) + (defclass text-buffer-v2 (lem-core:text-buffer) ()) (defun attribute-image (attribute) @@ -79,7 +82,9 @@ (defun char-type (char) (let ((code (char-code char))) - (cond ((eql code #x1f4c1) + (cond ((lem-base:control-char char) + :control) + ((eql code #x1f4c1) :folder) ((<= code 128) :latin) @@ -108,6 +113,8 @@ (type :initarg :type :reader text-object-type) (within-cursor :initform nil :initarg :within-cursor :reader text-object-within-cursor-p))) +(defclass control-character-object (text-object) ()) + (defclass icon-object (text-object) ()) (defclass folder-object (text-object) ()) (defclass emoji-object (text-object) ()) @@ -179,15 +186,15 @@ (defun object-height (drawing-object) (lem-if:object-height (lem-core:implementation) drawing-object)) -;;; draw-object (defun split-string-by-character-type (string) (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) + :while (and (< pos (length string)) + (eq type (char-type (char string pos))) + (not (eq type :control))) :finally (push (cons type (subseq string start pos)) items)) :finally (return (nreverse items)))) @@ -205,8 +212,11 @@ (:folder 'folder-object) (:icon 'icon-object) (:emoji 'emoji-object) + (:control 'control-character-object) (otherwise 'text-object)) - :string string + :string (if (eq type :control) + (lem-base:control-char (char string 0)) + string) :attribute attribute :type type :within-cursor (and attribute