split files/packages

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,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))))

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")))

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,30 +340,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 +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))))