add a new drawing method

frontends/sdl2/lem-sdl2.asd

@@ -11,5 +11,6 @@
                (:file "font")
                (:file "icon")
                (:file "main")
+               (:file "text-buffer")
                (:file "image-buffer")
                (:file "tree")))

frontends/sdl2/text-buffer.lisp

@@ -0,0 +1,388 @@
+(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)
+
+
+(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-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))
+
+
+(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)
+  (cond
+    ;; TODO: !!!
+    ((or (lem:overlay-get overlay :display-line-end)
+         (lem:overlay-get overlay :display-line))
+     nil)
+    (t
+     (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 line-string-and-attributes-with-overlays (point overlays)
+  (let ((end-of-line-cursor-attribute 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 (let ((overlay-start-charpos (overlay-start-charpos overlay point))
+                      (overlay-end-charpos (overlay-end-charpos overlay point))
+                      (overlay-attribute (lem:overlay-attribute overlay)))
+                  (when (overlay-cursor-p overlay)
+                    (set-cursor-attribute overlay-attribute)
+                    (unless overlay-end-charpos
+                      (setf end-of-line-cursor-attribute overlay-attribute)))
+                  (setf attributes
+                        (lem-core::overlay-attributes attributes
+                                                      overlay-start-charpos
+                                                      (or overlay-end-charpos (length string))
+                                                      overlay-attribute))))
+      (values string
+              attributes
+              end-of-line-cursor-attribute))))
+
+(defun compute-items-from-string-and-attributes (string attributes end-of-line-cursor-attribute)
+  (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)))
+    (when end-of-line-cursor-attribute
+      (push (make-eol-cursor-item :attribute end-of-line-cursor-attribute)
+            items))
+    (nreverse items)))
+
+(defun line-items (point overlays)
+  (multiple-value-bind (string attributes end-of-line-cursor-attribute)
+      (line-string-and-attributes-with-overlays point overlays)
+    (compute-items-from-string-and-attributes string attributes end-of-line-cursor-attribute)))
+
+(defun underline-color (attribute)
+  (alexandria:when-let ((underline (lem:attribute-underline attribute)))
+    (if (eq underline t)
+        (attribute-foreground-color attribute)
+        (or (lem:parse-color underline)
+            (attribute-foreground-color attribute)))))
+
+(defclass drawing-object ()
+  ())
+
+(defclass void-object (drawing-object) ())
+
+(defclass text-object (drawing-object)
+  ((surface :initarg :surface :reader text-object-surface)
+   (background :initarg :background :reader text-object-background)
+   (string :initarg :string :reader text-object-string)
+   (attribute :initarg :attribute :reader text-object-attribute)))
+
+(defclass letter-object (drawing-object)
+  ((surface :initarg :surface :reader letter-object-surface)
+   (background :initarg :background :reader letter-object-background)
+   (character :initarg :character :reader letter-object-character)
+   (attribute :initarg :attribute :reader letter-object-attribute)))
+
+;;; draw-object
+(defmethod draw-object ((drawing-object void-object) x bottom-y)
+  nil)
+
+(defmethod draw-object ((drawing-object text-object) x bottom-y)
+  (let* ((surface-width (object-width drawing-object))
+         (surface-height (object-height drawing-object))
+         (background (text-object-background drawing-object))
+         (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 (text-object-attribute drawing-object)
+               (lem:attribute-underline (text-object-attribute drawing-object)))
+      (render-line x
+                   (1- (+ y surface-height))
+                   (+ x surface-width)
+                   (1- (+ y surface-height))
+                   :color (underline-color (text-object-attribute drawing-object))))))
+
+(defmethod draw-object ((drawing-object letter-object) x bottom-y)
+  ;; TODO: text-objectとの重複を解消する
+  (let* ((surface-width (object-width drawing-object))
+         (surface-height (object-height drawing-object))
+         (background (letter-object-background drawing-object))
+         (texture (sdl2:create-texture-from-surface
+                   (current-renderer)
+                   (letter-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 (letter-object-attribute drawing-object)
+               (lem:attribute-underline (letter-object-attribute drawing-object)))
+      (render-line x
+                   (1- (+ y surface-height))
+                   (+ x surface-width)
+                   (1- (+ y surface-height))
+                   :color (underline-color (letter-object-attribute drawing-object))))))
+
+;;; 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 letter-object))
+  (sdl2:surface-width (letter-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 letter-object))
+  (sdl2:surface-height (letter-object-surface drawing-object)))
+
+
+(defun max-height-of-objects (objects)
+  (loop :for object :in objects
+        :maximize (object-height object)))
+
+(defun create-drawing-object (item)
+  (let ((string (item-string item))
+        (attribute (item-attribute item)))
+    (if (alexandria:emptyp string)
+        (make-instance 'void-object)
+        (cffi:with-foreign-string (c-string string)
+          (let* ((attribute (lem:ensure-attribute attribute nil))
+                 (bold (and attribute (lem:attribute-bold attribute)))
+                 (reverse (and attribute (lem:attribute-reverse attribute)))
+                 (foreground (if reverse
+                                 (attribute-background-color attribute)
+                                 (attribute-foreground-color attribute)))
+                 (background (if reverse
+                                 (attribute-foreground-color attribute)
+                                 (attribute-background-color attribute)))
+                 (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
+                           :background background
+                           :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 (point overlays)
+  (loop :for item :in (line-items point overlays)
+        :collect (create-drawing-object item)))
+
+(defun make-letter-object (character attribute)
+  (let* ((bold (and attribute (lem:attribute-bold attribute)))
+         (reverse (and attribute (lem:attribute-reverse attribute)))
+         (foreground (if reverse
+                         (attribute-background-color attribute)
+                         (attribute-foreground-color attribute)))
+         (background (if reverse
+                         (attribute-foreground-color attribute)
+                         (attribute-background-color 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 'letter-object
+                       :surface surface
+                       :background background
+                       :character 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 ((typep object 'text-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-logical-line (window point y overlays)
+  (loop :for objects :in
+           (separate-objects-by-width (create-drawing-objects point overlays)
+                                      (view-width-by-pixel window))
+        :for height := (max-height-of-objects objects)
+        :do (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)))
+            (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 point y 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))