diff --git a/frontends/ncurses/lem-ncurses.asd b/frontends/ncurses/lem-ncurses.asd index da943e53a..d2abb7897 100644 --- a/frontends/ncurses/lem-ncurses.asd +++ b/frontends/ncurses/lem-ncurses.asd @@ -10,4 +10,5 @@ (:file "clipboard") (:file "style") (:file "key") - (:file "ncurses"))) + (:file "ncurses") + (:file "text-buffer-impl"))) diff --git a/frontends/ncurses/ncurses.lisp b/frontends/ncurses/ncurses.lisp index 6f18f385f..910a8a344 100644 --- a/frontends/ncurses/ncurses.lisp +++ b/frontends/ncurses/ncurses.lisp @@ -81,8 +81,9 @@ bits)) (defun attribute-to-bits (attribute-or-name) - (let ((attribute (ensure-attribute attribute-or-name nil)) - (cursorp (eq attribute-or-name 'cursor))) + (let* ((attribute (ensure-attribute attribute-or-name nil)) + (cursorp (or (eq attribute-or-name 'cursor) + (and attribute (lem-core:attribute-value attribute :cursor))))) (when (and lem-if:*background-color-of-drawing-window* (null attribute)) (setf attribute (make-attribute :background lem-if:*background-color-of-drawing-window*))) (if (null attribute) diff --git a/frontends/ncurses/text-buffer-impl.lisp b/frontends/ncurses/text-buffer-impl.lisp new file mode 100644 index 000000000..e9b7ddd53 --- /dev/null +++ b/frontends/ncurses/text-buffer-impl.lisp @@ -0,0 +1,109 @@ +(defpackage :lem-ncurses/text-buffer-impl + (:use :cl)) +(in-package :lem-ncurses/text-buffer-impl) + +(defgeneric object-width (drawing-object)) + +(defmethod object-width ((drawing-object lem-core/display-3::void-object)) + 0) + +(defmethod object-width ((drawing-object lem-core/display-3::text-object)) + (lem-core:string-width (lem-core/display-3::text-object-string drawing-object))) + +(defmethod object-width ((drawing-object lem-core/display-3::eol-cursor-object)) + 0) + +(defmethod object-width ((drawing-object lem-core/display-3::extend-to-eol-object)) + 0) + +(defmethod object-width ((drawing-object lem-core/display-3::line-end-object)) + 0) + +(defmethod object-width ((drawing-object lem-core/display-3::image-object)) + 0) + +(defmethod lem-if:view-width ((implementation lem-ncurses::ncurses) view) + (lem-ncurses::ncurses-view-width view)) + +(defmethod lem-if:view-height ((implementation lem-ncurses::ncurses) view) + (lem-ncurses::ncurses-view-height view)) + +(defgeneric draw-object (object x y window)) + +(defmethod draw-object ((object lem-core/display-3::void-object) x y window) + (values)) + +(defmethod draw-object ((object lem-core/display-3::text-object) x y window) + (let ((string (lem-core/display-3::text-object-string object)) + (attribute (lem-core/display-3::text-object-attribute object))) + (when (and attribute (lem-core/display-3::cursor-attribute-p attribute)) + (let ((screen (lem:window-screen window))) + (setf (lem-core::screen-last-print-cursor-x screen) x + (lem-core::screen-last-print-cursor-y screen) y))) + (lem-if:print (lem-core:implementation) + (lem-core::window-view window) + x + y + string + attribute))) + +(defun color-to-hex-string (color) + (format nil "#~2,'0X~2,'0X~2,'0X" + (lem:color-red color) + (lem:color-green color) + (lem:color-blue color))) + +(defmethod draw-object ((object lem-core/display-3::eol-cursor-object) x y window) + (let ((screen (lem:window-screen window))) + (setf (lem-core::screen-last-print-cursor-x screen) x + (lem-core::screen-last-print-cursor-y screen) y)) + (lem-if:print (lem:implementation) + (lem:window-view window) + x + y + " " + (lem:make-attribute :foreground + (color-to-hex-string (lem-core/display-3::eol-cursor-object-color object))))) + +(defmethod draw-object ((object lem-core/display-3::extend-to-eol-object) x y window) + (lem-if:print (lem:implementation) + (lem:window-view window) + x + y + (make-string (- (lem:window-width window) x) :initial-element #\space) + (lem:make-attribute :background + (color-to-hex-string (lem-core/display-3::extend-to-eol-object-color object))))) + +(defmethod draw-object ((object lem-core/display-3::line-end-object) x y window) + (let ((string (lem-core/display-3::text-object-string object)) + (attribute (lem-core/display-3::text-object-attribute object))) + (lem-if:print (lem-core:implementation) + (lem-core::window-view window) + (+ x (lem-core/display-3::line-end-object-offset object)) + y + string + attribute))) + +(defmethod draw-object ((object lem-core/display-3::image-object) x y window) + (values)) + +(defmethod lem-core/display-3::%render-line ((implementation lem-ncurses::ncurses) window x y objects height) + (let ((view (lem::window-view window))) + (charms/ll:wmove (lem-ncurses::ncurses-view-scrwin view) y x) + (charms/ll:wclrtoeol (lem-ncurses::ncurses-view-scrwin view)) + (loop :for object :in objects + :do (draw-object object x y window) + (incf x (lem-core/display-3::object-width object))))) + +(defmethod lem-if:object-width ((implementation lem-ncurses::ncurses) drawing-object) + (object-width drawing-object)) + +(defmethod lem-if:object-height ((implementation lem-ncurses::ncurses) drawing-object) + 1) + +(defmethod lem-if:clear-to-end-of-window ((implementation lem-ncurses::ncurses) window y) + (let* ((view (lem-core::window-view window)) + (win (lem-ncurses::ncurses-view-scrwin view))) + (unless (= y (lem-if:view-height (lem:implementation) view)) + (charms/ll:wmove win y 0) + (charms/ll:wclrtobot win)))) diff --git a/frontends/sdl2/lem-sdl2.asd b/frontends/sdl2/lem-sdl2.asd index 27dc19f76..e48fc6c78 100644 --- a/frontends/sdl2/lem-sdl2.asd +++ b/frontends/sdl2/lem-sdl2.asd @@ -11,6 +11,6 @@ (:file "font") (:file "icon") (:file "main") - (:file "text-buffer") + (:file "text-buffer-impl") (:file "image-buffer") (:file "tree"))) diff --git a/frontends/sdl2/main.lisp b/frontends/sdl2/main.lisp index 68b3baa82..f3d64df64 100644 --- a/frontends/sdl2/main.lisp +++ b/frontends/sdl2/main.lisp @@ -243,14 +243,10 @@ (lem:update-on-display-resized)))) (defun attribute-foreground-color (attribute) - (or (and attribute - (lem:parse-color (lem:attribute-foreground attribute))) - (display-foreground-color *display*))) + (lem-core::attribute-foreground-color attribute)) (defun attribute-background-color (attribute) - (or (and attribute - (lem:parse-color (lem:attribute-background attribute))) - (display-background-color *display*))) + (lem-core::attribute-background-color attribute)) (defun render-fill-rect-to-current-texture (x y width height &key color) (let ((x (* x (char-width))) @@ -278,21 +274,23 @@ :dest-rect dest-rect :flip (list :none)))) -(defun cjk-char-code-p (display code) - (and (typep code '(UNSIGNED-BYTE 16)) - (not (eql 0 - (sdl2-ffi.functions:ttf-glyph-is-provided (display-cjk-normal-font display) - code))))) +(defun cjk-char-code-p (code) + (or (<= #x4E00 code #x9FFF) + (<= #x3040 code #x309F) + (<= #x30A0 code #x30FF) + (<= #xAC00 code #xD7A3))) -(defun latin-char-code-p (display code) - (and (typep code '(UNSIGNED-BYTE 16)) - (not (eql 0 - (sdl2-ffi.functions:ttf-glyph-is-provided (display-latin-font display) - code))))) +(defun latin-char-code-p (code) + (or (<= #x0000 code #x007F) + (<= #x0080 code #x00FF) + (<= #x0100 code #x017F) + (<= #x0180 code #x024F))) -(defun emoji-char-code-p (display code) - (and (typep code '(UNSIGNED-BYTE 16)) - (not (eql 0 (sdl2-ffi.functions:ttf-glyph-is-provided (display-emoji-font display) code))))) +(defun emoji-char-code-p (code) + (or (<= #x1F300 code #x1F6FF) + (<= #x1F900 code #x1F9FF) + (<= #x1F600 code #x1F64F) + (<= #x1F700 code #x1F77F))) (defun braille-char-code-p (code) (<= #x2800 code #x28ff)) @@ -342,10 +340,9 @@ (sdl2:free-surface image) (sdl2:destroy-texture texture))) -(defun guess-font-type (display code) - (cond #+windows - ((eql code #x1f4c1) - ;; sdl2_ttf.dllでなぜか絵文字を表示できないので代わりにフォルダの画像を使う +(defun guess-font-type (code) + (cond ((eql code #x1f4c1) + ;; sdl2_ttf.dllでなぜか絵文字を表示できない環境があるので代わりにフォルダの画像を使う :folder) ((<= code 128) :latin) @@ -353,11 +350,11 @@ :icon) ((braille-char-code-p code) :braille) - ((cjk-char-code-p display code) + ((cjk-char-code-p code) :cjk) - ((latin-char-code-p display code) + ((latin-char-code-p code) :latin) - ((emoji-char-code-p display code) + ((emoji-char-code-p code) :emoji) (t :emoji))) @@ -365,7 +362,7 @@ (defun render-character (character x y &key color bold) (handler-case (let* ((code (char-code character)) - (type (guess-font-type *display* code))) + (type (guess-font-type code))) (case type (:folder (render-folder-icon x y) @@ -886,6 +883,10 @@ (with-debug ("lem-if:get-background-color") (display-background-color *display*))) +(defmethod lem-if:get-foreground-color ((implementation sdl2)) + (with-debug ("lem-if:get-foreground-color") + (display-foreground-color *display*))) + (defmethod lem-if:update-foreground ((implementation sdl2) color) (with-debug ("lem-if:update-foreground" color) (setf (display-foreground-color *display*) (lem:parse-color color)))) diff --git a/frontends/sdl2/text-buffer-impl.lisp b/frontends/sdl2/text-buffer-impl.lisp new file mode 100644 index 000000000..9bfc0ca1b --- /dev/null +++ b/frontends/sdl2/text-buffer-impl.lisp @@ -0,0 +1,202 @@ +(defpackage :lem-sdl2/text-buffer-impl + (:use :cl)) +(in-package :lem-sdl2/text-buffer-impl) + +(defmethod lem-if:view-width ((implementation lem-sdl2::sdl2) view) + (* (lem-sdl2::char-width) (lem-sdl2::view-width view))) + +(defmethod lem-if:view-height ((implementation lem-sdl2::sdl2) view) + (* (lem-sdl2::char-height) (lem-sdl2::view-height view))) + +(defun set-cursor-position (window x y) + (let ((view (lem:window-view window))) + (setf (lem-sdl2::view-last-cursor-x view) x + (lem-sdl2::view-last-cursor-y view) y))) + +(defun attribute-font (attribute) + (let ((attribute (lem:ensure-attribute attribute nil))) + (when attribute + (lem:attribute-value attribute 'font)))) + +(defun get-font (&key attribute type bold) + (or (alexandria:when-let (attribute (and attribute (lem:ensure-attribute attribute))) + (attribute-font attribute)) + (lem-sdl2::get-display-font lem-sdl2::*display* :type type :bold bold))) + +(defun render-string (string attribute type) + (let ((foreground (lem-core::attribute-foreground-with-reverse attribute)) + (bold (and attribute (lem:attribute-bold attribute)))) + (cffi:with-foreign-string (c-string string) + (sdl2-ttf:render-utf8-blended (get-font :attribute attribute + :type type + :bold bold) + c-string + (lem:color-red foreground) + (lem:color-green foreground) + (lem:color-blue foreground) + 0)))) + +(defmethod get-surface ((text-object lem-core/display-3::text-object)) + (or (lem-core/display-3::text-object-surface text-object) + (setf (lem-core/display-3::text-object-surface text-object) + (render-string (lem-core/display-3::text-object-string text-object) + (lem-core/display-3::text-object-attribute text-object) + (lem-core/display-3::text-object-type text-object))))) + +(defgeneric object-width (drawing-object)) + +(defmethod object-width ((drawing-object lem-core/display-3::void-object)) + 0) + +(defmethod object-width ((drawing-object lem-core/display-3::text-object)) + (if (eq :emoji (lem-core/display-3::text-object-type drawing-object)) + (* (lem-sdl2::char-width) 2 (length (lem-core/display-3::text-object-string drawing-object))) + (sdl2:surface-width (get-surface drawing-object)))) + +(defmethod object-width ((drawing-object lem-core/display-3::eol-cursor-object)) + 0) + +(defmethod object-width ((drawing-object lem-core/display-3::extend-to-eol-object)) + 0) + +(defmethod object-width ((drawing-object lem-core/display-3::line-end-object)) + (sdl2:surface-width (get-surface drawing-object))) + +(defmethod object-width ((drawing-object lem-core/display-3::image-object)) + (or (lem-core/display-3::image-object-width drawing-object) + (sdl2:surface-width (lem-core/display-3::image-object-image drawing-object)))) + + +(defgeneric object-height (drawing-object)) + +(defmethod object-height ((drawing-object lem-core/display-3::void-object)) + (lem-sdl2::char-height)) + +(defmethod object-height ((drawing-object lem-core/display-3::text-object)) + (if (eq :emoji (lem-core/display-3::text-object-type drawing-object)) + (lem-sdl2::char-height) + (sdl2:surface-height (get-surface drawing-object)))) + +(defmethod object-height ((drawing-object lem-core/display-3::eol-cursor-object)) + (lem-sdl2::char-height)) + +(defmethod object-height ((drawing-object lem-core/display-3::extend-to-eol-object)) + (lem-sdl2::char-height)) + +(defmethod object-height ((drawing-object lem-core/display-3::line-end-object)) + (lem-sdl2::char-height)) + +(defmethod object-height ((drawing-object lem-core/display-3::image-object)) + (or (lem-core/display-3::image-object-height drawing-object) + (sdl2:surface-height (lem-core/display-3::image-object-image drawing-object)))) + +(defmethod lem-if:object-width ((implementation lem-sdl2::sdl2) drawing-object) + (object-width drawing-object)) + +(defmethod lem-if:object-height ((implementation lem-sdl2::sdl2) drawing-object) + (object-height drawing-object)) + +;;; draw-object +(defmethod draw-object ((drawing-object lem-core/display-3::void-object) x bottom-y window) + (values)) + +(defmethod draw-object ((drawing-object lem-core/display-3::text-object) x bottom-y window) + (let* ((surface-width (object-width drawing-object)) + (surface-height (object-height drawing-object)) + (attribute (lem-core/display-3::text-object-attribute drawing-object)) + (background (lem-core::attribute-background-with-reverse attribute)) + (texture (sdl2:create-texture-from-surface + (lem-sdl2::current-renderer) + (get-surface drawing-object))) + (y (- bottom-y surface-height))) + (when (and attribute (lem-core/display-3::cursor-attribute-p attribute)) + (set-cursor-position window x y)) + (sdl2:with-rects ((rect x y surface-width surface-height)) + (lem-sdl2::set-color background) + (sdl2:render-fill-rect (lem-sdl2::current-renderer) rect)) + (lem-sdl2::render-texture (lem-sdl2::current-renderer) + texture + x + y + surface-width + surface-height) + (sdl2:destroy-texture texture) + (when (and attribute + (lem:attribute-underline attribute)) + (lem-sdl2::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) + (lem-sdl2::attribute-foreground-color attribute) + (or (lem:parse-color underline) + (lem-sdl2::attribute-foreground-color attribute)))))))) + +(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)) + (let ((y (- bottom-y (object-height drawing-object)))) + (set-cursor-position window x y) + (sdl2:with-rects ((rect x + y + (lem-sdl2::char-width) + (object-height drawing-object))) + (sdl2:render-fill-rect (lem-sdl2::current-renderer) rect)))) + +(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)) + (sdl2:with-rects ((rect x + (- bottom-y (lem-sdl2::char-height)) + (- (lem-core/display-3::window-view-width window) x) + (lem-sdl2::char-height))) + (sdl2:render-fill-rect (lem-sdl2::current-renderer) + rect))) + +(defmethod draw-object ((drawing-object lem-core/display-3::line-end-object) x bottom-y window) + (call-next-method drawing-object + (+ x + (* (lem-core/display-3::line-end-object-offset drawing-object) + (lem-sdl2::char-width))) + bottom-y)) + +(defmethod draw-object ((drawing-object lem-core/display-3::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 (lem-sdl2::current-renderer) + (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))) + +(defun redraw-physical-line (window x y objects height) + (loop :for current-x := x :then (+ current-x (object-width object)) + :for object :in objects + :do (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)) + (lem-sdl2::set-render-color lem-sdl2::*display* (lem-sdl2::display-background-color lem-sdl2::*display*)) + (sdl2:render-fill-rect (lem-sdl2::current-renderer) rect))) + +(defmethod lem-core/display-3::%render-line ((implementation lem-sdl2::sdl2) window x y objects height) + (clear-to-end-of-line window 0 y height) + (redraw-physical-line window x y objects height)) + +(defmethod lem-if:clear-to-end-of-window ((implementation lem-sdl2::sdl2) window y) + (lem-sdl2::set-render-color + lem-sdl2::*display* + (lem-sdl2::display-background-color lem-sdl2::*display*)) + (sdl2:with-rects ((rect 0 + y + (lem-core/display-3::window-view-width window) + (- (lem-core/display-3::window-view-height window) y))) + (sdl2:render-fill-rect (lem-sdl2::current-renderer) rect))) + +(defmethod lem-core::redraw-buffer :around ((implementation lem-sdl2::sdl2) + (buffer lem-core/display-3::text-buffer-v2) + window + force) + (sdl2:in-main-thread () + (sdl2:set-render-target (lem-sdl2::current-renderer) + (lem-sdl2::view-texture (lem:window-view window))) + (call-next-method))) diff --git a/frontends/sdl2/text-buffer.lisp b/frontends/sdl2/text-buffer.lisp deleted file mode 100644 index 3e49d8676..000000000 --- a/frontends/sdl2/text-buffer.lisp +++ /dev/null @@ -1,726 +0,0 @@ -(in-package :lem-sdl2) - -(defvar *line-wrap*) - -(defclass graphical-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 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))) - -(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-width (attribute) - (let ((attribute (lem:ensure-attribute attribute nil))) - (when attribute - (lem:attribute-value attribute :width)))) - -(defun attribute-height (attribute) - (let ((attribute (lem:ensure-attribute attribute nil))) - (when attribute - (lem:attribute-value attribute :height)))) - -(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 - 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 make-cursor-overlay (point) - (let ((overlay - (lem-core::make-overlay point - (lem:with-point ((p point)) - (lem:character-offset p 1) - p) - (if (typep point 'lem:fake-cursor) - 'lem:fake-cursor - 'lem:cursor) - :temporary t))) - (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))) - -(defstruct logical-line - string - attributes - left-content - end-of-line-cursor-attribute - 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 active-modes) - (let* ((end-of-line-cursor-attribute nil) - (extend-to-end-attribute nil) - (line-end-overlay nil) - (left-content - (lem-core::compute-left-display-area-content active-modes - (lem-base:point-buffer point) - point))) - (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 ((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: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 - :left-content left-content - :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 (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: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)) - -(defun compute-items-from-logical-line (logical-line) - (let ((items - (compute-items-from-string-and-attributes (logical-line-string logical-line) - (logical-line-attributes logical-line)))) - (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-core::overlay-line-endings-offset overlay)))))) - -(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) - (type :initarg :type :reader text-object-type) - (within-cursor :initform nil :initarg :within-cursor :reader text-object-within-cursor-p))) - -(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))) - -(defclass image-object (drawing-object) - ((surface :initarg :surface :reader image-object-surface) - (width :initarg :width :reader image-object-width) - (height :initarg :height :reader image-object-height) - (attribute :initarg :attribute :reader image-object-attribute))) - -(defmethod cursor-object-p (drawing-object) - nil) - -(defmethod cursor-object-p ((drawing-object text-object)) - (text-object-within-cursor-p drawing-object)) - -(defmethod cursor-object-p ((drawing-object eol-cursor-object)) - t) - -;;; 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))) - (when (and attribute (cursor-attribute-p attribute)) - (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)) - (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)) - (let ((y (- bottom-y (object-height drawing-object)))) - (set-cursor-position window x 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)) - (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)) - -(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) - -(defmethod object-width ((drawing-object text-object)) - (if (eq :emoji (text-object-type drawing-object)) - (* (char-width) 2 (length (text-object-string drawing-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))) - -(defmethod object-width ((drawing-object image-object)) - (or (image-object-width drawing-object) - (sdl2:surface-width (image-object-surface drawing-object)))) - -;;; object-height -(defmethod object-height ((drawing-object void-object)) - (char-height)) - -(defmethod object-height ((drawing-object text-object)) - (if (eq :emoji (text-object-type drawing-object)) - (char-height) - (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)) - -(defmethod object-height ((drawing-object image-object)) - (or (image-object-height drawing-object) - (sdl2:surface-height (image-object-surface drawing-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) - :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-font :attribute attribute - :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 ((and *line-wrap* (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) - :unless (alexandria:emptyp 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 - :type type))))) - (t - (let ((string (item-string item)) - (attribute (item-attribute item))) - (cond ((alexandria:emptyp string) - (list (make-instance 'void-object))) - ((and attribute (attribute-image attribute)) - (list (make-instance 'image-object - :surface (attribute-image attribute) - :width (attribute-width attribute) - :height (attribute-height attribute) - :attribute attribute))) - (t - (loop :for (type . string) :in (split-string-by-character-type string) - :unless (alexandria:emptyp 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 - :type type - :within-cursor (and attribute - (cursor-attribute-p 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-logical-line 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)) - (type (char-type character))) - (cffi:with-foreign-string (c-string (string character)) - (let ((surface - (sdl2-ttf:render-utf8-blended - (get-font :attribute attribute - :type type - :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 - :type type))))) - - -(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 x y height objects) - (loop :for current-x := x :then (+ current-x (object-width object)) - :for object :in objects - :do (draw-object object current-x (+ y height) window))) - -(defun validate-cache-p (window y height logical-line) - (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 (drawing-cache window) - (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))))) - (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) - (drawing-cache window)) - nil))) - -(defun max-height-of-objects (objects) - (loop :for object :in objects - :maximize (object-height object))) - -(defvar *invalidate-cache* nil) - -(defun redraw-logical-line-when-line-wrapping (window y logical-line) - (let* ((left-side-objects - (alexandria:when-let (content (logical-line-left-content logical-line)) - (mapcan #'create-drawing-object - (compute-items-from-string-and-attributes - (lem-base::content-string content) - (lem-base::content-attributes content))))) - (left-side-width - (loop :for object :in left-side-objects :sum (object-width object))) - (objects-per-physical-line - (separate-objects-by-width - (append left-side-objects (create-drawing-objects logical-line)) - (view-width-by-pixel window)))) - (loop :for objects :in objects-per-physical-line - :for height := (max-height-of-objects objects) - :for x := 0 :then left-side-width - :do (unless (update-and-validate-cache-p window y height logical-line) - (setf *invalidate-cache* t) - (clear-to-end-of-line window 0 y height) - (redraw-physical-line window x y height objects)) - (incf y height) - :sum height))) - -(defun find-cursor-object (objects) - (loop :for object :in objects - :and x := 0 :then (+ x (object-width object)) - :when (cursor-object-p object) - :return (values object x))) - -(defun horizontal-scroll-start (window) - (or (lem:window-parameter window 'horizontal-scroll-start) - 0)) - -(defun (setf horizontal-scroll-start) (x window) - (setf (lem:window-parameter window 'horizontal-scroll-start) x)) - -(defun extract-object-in-display-range (objects start-x end-x) - (loop :for object :in objects - :and x := 0 :then (+ x (object-width object)) - :when (and (<= start-x x) - (<= (+ x (object-width object)) end-x)) - :collect object)) - -(defun redraw-logical-line-when-horizontal-scroll (window y logical-line) - (let* ((left-side-objects - (alexandria:when-let (content (logical-line-left-content logical-line)) - (mapcan #'create-drawing-object - (compute-items-from-string-and-attributes - (lem-base::content-string content) - (lem-base::content-attributes content))))) - (left-side-width - (loop :for object :in left-side-objects :sum (object-width object))) - (objects - (append left-side-objects (create-drawing-objects logical-line))) - (height - (max-height-of-objects objects))) - (multiple-value-bind (cursor-object cursor-x) - (find-cursor-object objects) - (when cursor-object - (let ((width (- (view-width-by-pixel window) left-side-width))) - (cond ((< cursor-x (horizontal-scroll-start window)) - (setf (horizontal-scroll-start window) cursor-x)) - ((< (+ (horizontal-scroll-start window) - width) - (+ cursor-x (object-width cursor-object))) - (setf (horizontal-scroll-start window) - (+ (- cursor-x width) - (object-width cursor-object)))))) - (setf objects - (extract-object-in-display-range - (mapcan (lambda (object) - (if (typep object 'text-object) - (explode-object object) - (list object))) - objects) - (horizontal-scroll-start window) - (+ (horizontal-scroll-start window) - (view-width-by-pixel window))))) - (unless (update-and-validate-cache-p window y height logical-line) - (setf *invalidate-cache* t) - (clear-to-end-of-line window 0 y height) - (redraw-physical-line window 0 y height objects))) - height)) - -(defun redraw-lines (window) - (lem:with-point ((point (lem:window-view-point window))) - (let ((*invalidate-cache* nil) - (overlays (collect-overlays window)) - (active-modes (lem-core::get-active-modes-class-instance (lem:window-buffer window)))) - (loop :with y := 0 :and height := (view-height-by-pixel window) - :do (incf y - (if *line-wrap* - (redraw-logical-line-when-line-wrapping - window - y - (create-logical-line point overlays active-modes)) - (redraw-logical-line-when-horizontal-scroll - window - y - (create-logical-line point overlays active-modes)))) - :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 graphical-text-buffer) window force) - (assert (eq buffer (lem:window-buffer window))) - (let ((*line-wrap* (lem:variable-value 'lem:line-wrap :default (lem:window-buffer window)))) - (when (or force - (lem-core::screen-modified-p (lem:window-screen window))) - (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))) diff --git a/lem.asd b/lem.asd index 84dc647f0..aea3f06c0 100644 --- a/lem.asd +++ b/lem.asd @@ -65,6 +65,8 @@ (:file "command-advices") (:file "interface") (:file "display") + (:file "display-2") + (:file "display-3") (:file "site-init") (:file "lem") diff --git a/src/display-2.lisp b/src/display-2.lisp new file mode 100644 index 000000000..c7e78c331 --- /dev/null +++ b/src/display-2.lisp @@ -0,0 +1,246 @@ +(defpackage :lem-core/display-2 + (:use :cl)) +(in-package :lem-core/display-2) + +(defun make-cursor-overlay (point) + (let ((overlay + (lem-core:make-overlay point + (lem-core:with-point ((p point)) + (lem-core:character-offset p 1) + p) + (if (typep point 'lem-core:fake-cursor) + 'lem-core:fake-cursor + 'lem-core:cursor) + :temporary t))) + (lem-core:overlay-put overlay :cursor t) + overlay)) + +(defun collect-overlays (window) + (let ((overlays (lem-core::get-window-overlays window))) + (if (and (eq window (lem-core:current-window)) + (not (lem-core:window-cursor-invisible-p window))) + (append overlays + (mapcar #'make-cursor-overlay + (lem-core:buffer-cursors (lem-core:window-buffer window)))) + overlays))) + +(defstruct logical-line + string + attributes + left-content + end-of-line-cursor-attribute + 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-core:ensure-attribute a) + (lem-core: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 overlay-within-point-p (overlay point) + (or (lem-core:point<= (lem-core:overlay-start overlay) + point + (lem-core:overlay-end overlay)) + (lem-core:same-line-p (lem-core:overlay-start overlay) + point) + (lem-core:same-line-p (lem-core:overlay-end overlay) + point))) + +(defun overlay-cursor-p (overlay) + (lem-core:overlay-get overlay :cursor)) + +(defun cursor-attribute-p (attribute) + (lem-core:attribute-value attribute :cursor)) + +(defun set-cursor-attribute (attribute) + (setf (lem-core:attribute-value attribute :cursor) t)) + +(defun overlay-start-charpos (overlay point) + (if (lem-core:same-line-p point (lem-core:overlay-start overlay)) + (lem-core:point-charpos (lem-core:overlay-start overlay)) + 0)) + +(defun overlay-end-charpos (overlay point) + (cond ((and (overlay-cursor-p overlay) + (lem-core:point= (lem-core:overlay-start overlay) (lem-core:overlay-end overlay))) + ;; cursor is end-of-buffer + nil) + ((lem-core:same-line-p point (lem-core:overlay-end overlay)) + (lem-core:point-charpos (lem-core:overlay-end overlay))) + (t + nil))) + +(defun create-logical-line (point overlays active-modes) + (let* ((end-of-line-cursor-attribute nil) + (extend-to-end-attribute nil) + (line-end-overlay nil) + (left-content + (lem-core::compute-left-display-area-content active-modes + (lem-base:point-buffer point) + point))) + (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 ((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))) + (t + (let ((overlay-start-charpos (overlay-start-charpos overlay point)) + (overlay-end-charpos (overlay-end-charpos overlay point)) + (overlay-attribute (lem-core: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-core: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 + :left-content left-content + :extend-to-end extend-to-end-attribute + :end-of-line-cursor-attribute end-of-line-cursor-attribute + :line-end-overlay line-end-overlay)))) + + +(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 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)) + +(defun attribute-foreground-color (attribute) + (or (and attribute + (lem-core:parse-color (lem-core:attribute-foreground attribute))) + (display-foreground-color *display*))) + +(defun attribute-background-color (attribute) + (or (and attribute + (lem-core:parse-color (lem-core:attribute-background attribute))) + (display-background-color *display*))) + +(defun compute-items-from-logical-line (logical-line) + (let ((items + (compute-items-from-string-and-attributes (logical-line-string logical-line) + (logical-line-attributes logical-line)))) + (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-core::overlay-line-endings-text overlay) + :attribute (lem-core:overlay-attribute overlay) + :offset (lem-core::overlay-line-endings-offset overlay)))))) + +(defun call-do-logical-line (window function) + (lem-core:with-point ((point (lem-core:window-view-point window))) + (let ((overlays (collect-overlays window)) + (active-modes (lem-core::get-active-modes-class-instance (lem-core:window-buffer window)))) + (loop :for logical-line := (create-logical-line point overlays active-modes) + :do (funcall function logical-line) + (unless (lem-core:line-offset point 1) + (return)))))) + +(defmacro do-logical-line ((logical-line window) &body body) + `(call-do-logical-line ,window (lambda (,logical-line) ,@body))) diff --git a/src/display-3.lisp b/src/display-3.lisp new file mode 100644 index 000000000..a5f9faab1 --- /dev/null +++ b/src/display-3.lisp @@ -0,0 +1,423 @@ +(defpackage :lem-core/display-3 + (:use :cl) + (:import-from :lem-core/display-2 + :attribute-equal-careful-null-and-symbol + :eol-cursor-item + :eol-cursor-item-attribute + :extend-to-eol-item + :extend-to-eol-item-color + :line-end-item + :line-end-item-text + :line-end-item-attribute + :line-end-item-offset + :item-string + :item-attribute + :cursor-attribute-p + :compute-items-from-logical-line + :logical-line-equal + :logical-line-left-content + :compute-items-from-string-and-attributes + :create-logical-line + :collect-overlays + :do-logical-line)) +(in-package :lem-core/display-3) + +(defvar *line-wrap*) + +(defclass text-buffer-v2 (lem-core:text-buffer) ()) + +(defun attribute-image (attribute) + (let ((attribute (lem-core:ensure-attribute attribute nil))) + (when attribute + (lem-core:attribute-value attribute 'image)))) + +(defun attribute-width (attribute) + (let ((attribute (lem-core:ensure-attribute attribute nil))) + (when attribute + (lem-core:attribute-value attribute :width)))) + +(defun attribute-height (attribute) + (let ((attribute (lem-core:ensure-attribute attribute nil))) + (when attribute + (lem-core:attribute-value attribute :height)))) + +(defun window-view-width (window) + (lem-if:view-width (lem-core:implementation) (lem-core:window-view window))) + +(defun window-view-height (window) + (lem-if:view-height (lem-core:implementation) (lem-core:window-view window))) + +(defun drawing-cache (window) + (lem-core:window-parameter window 'redrawing-cache)) + +(defun (setf drawing-cache) (value window) + (setf (lem-core:window-parameter window 'redrawing-cache) value)) + +(defun cjk-char-code-p (code) + (or (<= #x4E00 code #x9FFF) + (<= #x3040 code #x309F) + (<= #x30A0 code #x30FF) + (<= #xAC00 code #xD7A3))) + +(defun latin-char-code-p (code) + (or (<= #x0000 code #x007F) + (<= #x0080 code #x00FF) + (<= #x0100 code #x017F) + (<= #x0180 code #x024F))) + +(defun emoji-char-code-p (code) + (or (<= #x1F300 code #x1F6FF) + (<= #x1F900 code #x1F9FF) + (<= #x1F600 code #x1F64F) + (<= #x1F700 code #x1F77F))) + +(defun braille-char-code-p (code) + (<= #x2800 code #x28ff)) + +(defun icon-char-code-p (code) + (lem-core:icon-value code :font)) + +(defun char-type (char) + (let ((code (char-code char))) + (cond ((eql code #x1f4c1) + :folder) + ((<= code 128) + :latin) + ((icon-char-code-p code) + :icon) + ((braille-char-code-p code) + :braille) + ((cjk-char-code-p code) + :cjk) + ((latin-char-code-p code) + :latin) + ((emoji-char-code-p code) + :emoji) + (t + :emoji)))) + +(defclass drawing-object () + ()) + +(defclass void-object (drawing-object) ()) + +(defclass text-object (drawing-object) + ((surface :initarg :surface :initform nil :accessor text-object-surface) + (string :initarg :string :reader text-object-string) + (attribute :initarg :attribute :reader text-object-attribute) + (type :initarg :type :reader text-object-type) + (within-cursor :initform nil :initarg :within-cursor :reader text-object-within-cursor-p))) + +(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))) + +(defclass image-object (drawing-object) + ((image :initarg :image :reader image-object-image) + (width :initarg :width :reader image-object-width) + (height :initarg :height :reader image-object-height) + (attribute :initarg :attribute :reader image-object-attribute))) + +(defmethod cursor-object-p (drawing-object) + nil) + +(defmethod cursor-object-p ((drawing-object text-object)) + (text-object-within-cursor-p drawing-object)) + +(defmethod cursor-object-p ((drawing-object eol-cursor-object)) + t) + +(defgeneric object-equal (drawing-object-1 drawing-object-2)) + +(defmethod object-equal (drawing-object-1 drawing-object-2) + nil) + +(defmethod object-equal ((drawing-object-1 void-object) (drawing-object-2 void-object)) + t) + +(defmethod object-equal ((drawing-object-1 text-object) (drawing-object-2 text-object)) + (and (equal (text-object-string drawing-object-1) + (text-object-string drawing-object-2)) + (attribute-equal-careful-null-and-symbol + (text-object-attribute drawing-object-1) + (text-object-attribute drawing-object-2)) + (eq (text-object-type drawing-object-1) + (text-object-type drawing-object-2)) + (eq (text-object-within-cursor-p drawing-object-1) + (text-object-within-cursor-p drawing-object-2)))) + +(defmethod object-equal ((drawing-object-1 eol-cursor-object) (drawing-object-2 eol-cursor-object)) + (equal (eol-cursor-object-color drawing-object-1) + (eol-cursor-object-color drawing-object-2))) + +(defmethod object-equal ((drawing-object-1 extend-to-eol-object) (drawing-object-2 extend-to-eol-object)) + (equal (extend-to-eol-object-color drawing-object-1) + (extend-to-eol-object-color drawing-object-2))) + +(defmethod object-equal ((drawing-object-1 line-end-object) (drawing-object-2 line-end-object)) + (equal (line-end-object-offset drawing-object-1) + (line-end-object-offset drawing-object-2))) + +(defmethod object-equal ((drawing-object-1 image-object) (drawing-object-2 image-object)) + nil) + +(defun object-width (drawing-object) + (lem-if:object-width (lem-core:implementation) drawing-object)) + +(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) + :finally (push (cons type (subseq string start pos)) items)) + :finally (return (nreverse items)))) + +(defun make-line-end-object (string attribute type offset) + (let ((attribute (and attribute (lem-core:ensure-attribute attribute)))) + (make-instance 'line-end-object + :offset offset + :string string + :attribute attribute + :type type))) + +(defun make-text-object (string attribute type) + (let ((attribute (and attribute (lem-core:ensure-attribute attribute)))) + (make-instance 'text-object + :string string + :attribute attribute + :type type + :within-cursor (and attribute + (cursor-attribute-p attribute))))) + +(defun create-drawing-object (item) + (cond ((and *line-wrap* (typep item 'eol-cursor-item)) + (list (make-instance 'eol-cursor-object + :color (lem-core:parse-color + (lem-core: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) + :unless (alexandria:emptyp string) + :collect (make-line-end-object string + attribute + type + (line-end-item-offset item))))) + (t + (let ((string (item-string item)) + (attribute (item-attribute item))) + (cond ((alexandria:emptyp string) + (list (make-instance 'void-object))) + ((and attribute (attribute-image attribute)) + (list (make-instance 'image-object + :image (attribute-image attribute) + :width (attribute-width attribute) + :height (attribute-height attribute) + :attribute attribute))) + (t + (loop :for (type . string) :in (split-string-by-character-type string) + :unless (alexandria:emptyp string) + :collect (make-text-object string attribute type)))))))) + +(defun create-drawing-objects (logical-line) + (multiple-value-bind (items line-end-item) + (compute-items-from-logical-line 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) + (make-text-object (string character) + attribute + (char-type character))) + +(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 render-line (window x y objects height) + (%render-line (lem-core:implementation) window x y objects height)) + +(defun validate-cache-p (window y height objects) + (loop :for (cache-y cache-height cache-objects) :in (drawing-cache window) + :when (and (= y cache-y) + (= height cache-height) + (alexandria:length= objects cache-objects) + (every #'object-equal objects cache-objects)) + :return t)) + +(defun invalidate-cache (window y height) + (setf (drawing-cache window) + (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))))) + (drawing-cache window)))) + +(defun update-and-validate-cache-p (window y height objects) + (cond ((validate-cache-p window y height objects) t) + (t + (invalidate-cache window y height) + (push (list y height objects) + (drawing-cache window)) + nil))) + +(defun max-height-of-objects (objects) + (loop :for object :in objects + :maximize (object-height object))) + +(defun redraw-logical-line-when-line-wrapping (window y logical-line) + (let* ((left-side-objects + (alexandria:when-let (content (logical-line-left-content logical-line)) + (mapcan #'create-drawing-object + (compute-items-from-string-and-attributes + (lem-base::content-string content) + (lem-base::content-attributes content))))) + (left-side-width + (loop :for object :in left-side-objects :sum (object-width object))) + (objects-per-physical-line + (separate-objects-by-width + (append left-side-objects (create-drawing-objects logical-line)) + (window-view-width window)))) + (loop :for objects :in objects-per-physical-line + :for height := (max-height-of-objects objects) + :for x := 0 :then left-side-width + :do (unless (update-and-validate-cache-p window y height objects) + (render-line window x y objects height)) + (incf y height) + :sum height))) + +(defun find-cursor-object (objects) + (loop :for object :in objects + :and x := 0 :then (+ x (object-width object)) + :when (cursor-object-p object) + :return (values object x))) + +(defun horizontal-scroll-start (window) + (or (lem-core:window-parameter window 'horizontal-scroll-start) + 0)) + +(defun (setf horizontal-scroll-start) (x window) + (setf (lem-core:window-parameter window 'horizontal-scroll-start) x)) + +(defun extract-object-in-display-range (objects start-x end-x) + (loop :for object :in objects + :and x := 0 :then (+ x (object-width object)) + :when (and (<= start-x x) + (<= (+ x (object-width object)) end-x)) + :collect object)) + +(defun redraw-logical-line-when-horizontal-scroll (window y logical-line) + (let* ((left-side-objects + (alexandria:when-let (content (logical-line-left-content logical-line)) + (mapcan #'create-drawing-object + (compute-items-from-string-and-attributes + (lem-base::content-string content) + (lem-base::content-attributes content))))) + (left-side-width + (loop :for object :in left-side-objects :sum (object-width object))) + (objects + (append left-side-objects (create-drawing-objects logical-line))) + (height + (max-height-of-objects objects))) + (multiple-value-bind (cursor-object cursor-x) + (find-cursor-object objects) + (when cursor-object + (let ((width (- (window-view-width window) left-side-width))) + (cond ((< cursor-x (horizontal-scroll-start window)) + (setf (horizontal-scroll-start window) cursor-x)) + ((< (+ (horizontal-scroll-start window) + width) + (+ cursor-x (object-width cursor-object))) + (setf (horizontal-scroll-start window) + (+ (- cursor-x width) + (object-width cursor-object)))))) + (setf objects + (extract-object-in-display-range + (mapcan (lambda (object) + (if (typep object 'text-object) + (explode-object object) + (list object))) + objects) + (horizontal-scroll-start window) + (+ (horizontal-scroll-start window) + (window-view-width window))))) + (unless (update-and-validate-cache-p window y height objects) + (render-line window 0 y objects height))) + height)) + +(defun redraw-lines (window) + (let* ((*line-wrap* (lem-core:variable-value 'lem-core:line-wrap + :default (lem-core:window-buffer window))) + (redraw-fn (if *line-wrap* + #'redraw-logical-line-when-line-wrapping + #'redraw-logical-line-when-horizontal-scroll))) + (let ((y 0) + (height (window-view-height window))) + (block outer + (do-logical-line (logical-line window) + (incf y (funcall redraw-fn window y logical-line)) + (unless (< y height) + (return-from outer)))) + (lem-if:clear-to-end-of-window (lem-core:implementation) window y)))) + +(defun redraw-buffer-internal (buffer window force) + (assert (eq buffer (lem-core:window-buffer window))) + (when (or force + (lem-core::screen-modified-p (lem-core:window-screen window))) + (setf (drawing-cache window) '())) + (redraw-lines window) + (lem-core::update-screen-cache (lem-core:window-screen window) buffer)) + +(defmethod lem-core::redraw-buffer (implementation (buffer text-buffer-v2) window force) + (redraw-buffer-internal buffer window force)) + +(lem-core:define-command change-buffer-to-v2 () () + (change-class (lem-core:current-buffer) 'text-buffer-v2)) + +(lem-core:define-command change-buffer-to-v1 () () + (change-class (lem-core:current-buffer) 'lem-base:text-buffer)) diff --git a/src/display.lisp b/src/display.lisp index 32673587f..eddaf7929 100644 --- a/src/display.lisp +++ b/src/display.lisp @@ -508,9 +508,9 @@ ((< point-column (screen-horizontal-scroll-start screen)) (setf (screen-horizontal-scroll-start screen) point-column))))))) -(defgeneric redraw-buffer (buffer window force)) +(defgeneric redraw-buffer (implementation buffer window force)) -(defmethod redraw-buffer :around (buffer window force) +(defmethod redraw-buffer :around (implementation buffer window force) (with-display-error () (let ((lem-if:*background-color-of-drawing-window* (get-background-color-of-window window))) @@ -528,11 +528,11 @@ *inactive-window-background-color*) (t nil))) -(defmethod redraw-buffer :before ((buffer text-buffer) window force) +(defmethod redraw-buffer :before (implementation (buffer text-buffer) window force) (lem-if:redraw-view-before (implementation) (screen-view (window-screen window)))) -(defmethod redraw-buffer :after ((buffer text-buffer) window force) +(defmethod redraw-buffer :after (implementation (buffer text-buffer) window force) (when (window-use-modeline-p window) (redraw-modeline window (or (screen-modified-p (window-screen window)) force))) @@ -545,7 +545,7 @@ (window-point window)) -1)) -(defmethod redraw-buffer ((buffer text-buffer) window force) +(defmethod redraw-buffer (implementation (buffer text-buffer) window force) (assert (eq buffer (window-buffer window))) (let ((screen (window-screen window))) (draw-window-to-screen window) diff --git a/src/interface.lisp b/src/interface.lisp index 92fad8544..fd2c5bd49 100644 --- a/src/interface.lisp +++ b/src/interface.lisp @@ -36,6 +36,7 @@ (defgeneric lem-if:invoke (implementation function)) (defgeneric lem-if:get-background-color (implementation)) +(defgeneric lem-if:get-foreground-color (implementation)) (defgeneric lem-if:update-foreground (implementation color-name)) (defgeneric lem-if:update-background (implementation color-name)) (defgeneric lem-if:update-cursor-shape (implementation cursor-type) @@ -47,6 +48,8 @@ (defgeneric lem-if:display-fullscreen-p (implementation)) (defgeneric lem-if:set-display-fullscreen-p (implementation fullscreen-p)) (defgeneric lem-if:make-view (implementation window x y width height use-modeline)) +(defgeneric lem-if:view-width (implementation view)) +(defgeneric lem-if:view-height (implementation view)) (defgeneric lem-if:delete-view (implementation view)) (defgeneric lem-if:clear (implementation view)) (defgeneric lem-if:set-view-size (implementation view width height)) @@ -77,17 +80,19 @@ print-spec style max-display-items)) -(defgeneric lem-if:popup-menu-update (implementation popup-menu items &key print-spec max-display-items keep-focus)) +(defgeneric lem-if:popup-menu-update + (implementation popup-menu items &key print-spec max-display-items keep-focus)) (defgeneric lem-if:popup-menu-quit (implementation popup-menu)) (defgeneric lem-if:popup-menu-down (implementation popup-menu)) (defgeneric lem-if:popup-menu-up (implementation popup-menu)) (defgeneric lem-if:popup-menu-first (implementation popup-menu)) (defgeneric lem-if:popup-menu-last (implementation popup-menu)) (defgeneric lem-if:popup-menu-select (implementation popup-menu)) -(defgeneric lem-if:display-popup-message (implementation buffer-or-string &key timeout - destination-window - source-window - style)) +(defgeneric lem-if:display-popup-message + (implementation buffer-or-string &key timeout + destination-window + source-window + style)) (defgeneric lem-if:delete-popup-message (implementation popup-message)) (defgeneric lem-if:display-context-menu (implementation context-menu style) (:method (implementation context-menu style))) @@ -115,6 +120,11 @@ (defgeneric lem-if:get-char-width (implementation)) (defgeneric lem-if:get-char-height (implementation)) +(defgeneric lem-if:render-line (implementation window x y objects height)) +(defgeneric lem-if:object-width (implementation drawing-object)) +(defgeneric lem-if:object-height (implementation drawing-object)) +(defgeneric lem-if:clear-to-end-of-window (implementation window y)) + (defvar *display-background-mode* nil) (defun implementation () @@ -140,6 +150,26 @@ (defun set-background (name) (lem-if:update-background (implementation) name)) +(defun attribute-foreground-color (attribute) + (or (and attribute + (parse-color (attribute-foreground attribute))) + (lem-if:get-foreground-color (implementation)))) + +(defun attribute-background-color (attribute) + (or (and attribute + (parse-color (attribute-background attribute))) + (lem-if:get-background-color (implementation)))) + +(defun attribute-foreground-with-reverse (attribute) + (if (and attribute (attribute-reverse attribute)) + (attribute-background-color attribute) + (attribute-foreground-color attribute))) + +(defun attribute-background-with-reverse (attribute) + (if (and attribute (attribute-reverse attribute)) + (attribute-foreground-color attribute) + (attribute-background-color attribute))) + (defun display-width () (lem-if:display-width (implementation))) (defun display-height () (lem-if:display-height (implementation))) (defun display-title () (lem-if:display-title (implementation))) diff --git a/src/internal-packages.lisp b/src/internal-packages.lisp index 6cdab35a5..9eb078edf 100644 --- a/src/internal-packages.lisp +++ b/src/internal-packages.lisp @@ -524,6 +524,7 @@ :*background-color-of-drawing-window* :invoke :get-background-color + :get-foreground-color :update-foreground :update-background :update-cursor-shape @@ -534,6 +535,8 @@ :display-fullscreen-p :set-display-fullscreen-p :make-view + :view-width + :view-height :delete-view :clear :set-view-size @@ -569,4 +572,8 @@ :get-font-list :get-mouse-position :get-char-width - :get-char-height)) + :get-char-height + :clear-to-end-of-window + :render-line + :object-width + :object-height)) diff --git a/src/window.lisp b/src/window.lisp index 533b81647..37713edeb 100644 --- a/src/window.lisp +++ b/src/window.lisp @@ -1344,7 +1344,7 @@ You can pass in the optional argument WINDOW-LIST to replace the default (defgeneric window-redraw (window force) (:method (window force) - (redraw-buffer (window-buffer window) window force))) + (redraw-buffer (implementation) (window-buffer window) window force))) (defun redraw-current-window (window force) (assert (eq window (current-window)))