Commonization of graphical text buffer

extensions/lisp-mode/eval.lisp

@@ -96,7 +96,7 @@
           (background-attribute
            (make-attribute :background (compute-evaluated-background-color))))
   (let ((popup-overlay
-          (make-overlay-line-endings
+          (make-line-endings-overlay
            start
            end
            (or attribute

extensions/vi-mode/visual.lisp

@@ -89,7 +89,7 @@
 (defmethod state-setup ((state visual-line))
   (apply-region-lines *start-point* (current-point)
                       (lambda (p)
-                        (push (make-overlay-line p 'region)
+                        (push (make-line-overlay p 'region)
                               *visual-overlays*))))
 
 (defmethod state-setup ((state visual-block))

frontends/ncurses/lem-ncurses.asd

@@ -10,4 +10,5 @@
                (:file "clipboard")
                (:file "style")
                (:file "key")
-               (:file "ncurses")))
+               (:file "ncurses")
+               (:file "text-buffer-impl")))

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)

frontends/ncurses/text-buffer-impl.lisp

@@ -0,0 +1,133 @@
+(defpackage :lem-ncurses/text-buffer-impl
+  (:use :cl)
+  (:import-from :lem-core
+                :control-character-object
+                :cursor-attribute-p
+                :emoji-object
+                :eol-cursor-object
+                :eol-cursor-object-color
+                :extend-to-eol-object
+                :extend-to-eol-object-color
+                :folder-object
+                :icon-object
+                :image-object
+                :image-object-height
+                :image-object-image
+                :image-object-width
+                :line-end-object
+                :line-end-object-offset
+                :text-object
+                :text-object-attribute
+                :text-object-string
+                :text-object-surface
+                :text-object-type
+                :void-object
+                :window-view-height
+                :window-view-width
+                :text-object))
+(in-package :lem-ncurses/text-buffer-impl)
+
+(defgeneric object-width (drawing-object))
+
+(defmethod object-width ((drawing-object void-object))
+  0)
+
+(defmethod object-width ((drawing-object text-object))
+  (lem-core:string-width (text-object-string 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))
+  0)
+
+(defmethod object-width ((drawing-object 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 void-object) x y window)
+  (values))
+
+(defmethod draw-object ((object text-object) x y window)
+  (let ((string (text-object-string object))
+        (attribute (text-object-attribute object)))
+    (when (and attribute (cursor-attribute-p attribute))
+      (lem-core::set-last-print-cursor window x 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 eol-cursor-object) x y window)
+  (lem-core::set-last-print-cursor window x y)
+  (lem-if:print (lem:implementation)
+                (lem:window-view window)
+                x
+                y
+                " "
+                (lem:make-attribute :foreground
+                                    (color-to-hex-string (eol-cursor-object-color object)))))
+
+(defmethod draw-object ((object 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 (extend-to-eol-object-color object)))))
+
+(defmethod draw-object ((object line-end-object) x y window)
+  (let ((string (text-object-string object))
+        (attribute (text-object-attribute object)))
+    (lem-if:print (lem-core:implementation)
+                  (lem-core::window-view window)
+                  (+ x (line-end-object-offset object))
+                  y
+                  string
+                  attribute)))
+
+(defmethod draw-object ((object image-object) x y window)
+  (values))
+
+(defmethod lem-if: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 (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))))
+
+(defmethod lem-if:get-char-width ((implementation lem-ncurses::ncurses))
+  1)

frontends/sdl2/lem-sdl2.asd

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

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::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)
@@ -243,14 +245,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 +276,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,30 +342,29 @@
     (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)
         ((icon-char-code-p code)
          :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)))
 
 (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 +885,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))))