Merge pull request #1011 from lem-project/implement-no-line-wrap-for-…

…graphical-text-buffer

Added support for drawing when line-wrap is nil in graphical-text-buffer

frontends/sdl2/text-buffer.lisp

@@ -1,5 +1,7 @@
 (in-package :lem-sdl2)
 
+(defvar *line-wrap*)
+
 (defclass graphical-text-buffer (lem:text-buffer) ())
 
 (defun view-width-by-pixel (window)
@@ -188,7 +190,10 @@
   (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)))
+         (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
@@ -283,7 +288,8 @@
   ((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)))
+   (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
@@ -303,6 +309,15 @@
    (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)
@@ -447,7 +462,7 @@
       (values surface attribute))))
 
 (defun create-drawing-object (item)
-  (cond ((typep item 'eol-cursor-item)
+  (cond ((and *line-wrap* (typep item 'eol-cursor-item))
          (list (make-instance 'eol-cursor-object
                               :color (lem:parse-color
                                       (lem:attribute-background
@@ -483,11 +498,14 @@
                         :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)))))))))
+                                   (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))
@@ -587,7 +605,7 @@
 
 (defvar *invalidate-cache* nil)
 
-(defun redraw-logical-line (window y logical-line)
+(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
@@ -597,12 +615,9 @@
          (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))))
-    #+(or)
-    (when (and (not (alexandria:length= 1 objects-per-physical-line))
-               *invalidate-cache*)
-      (setf (drawing-cache window) '()))
+           (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
@@ -613,15 +628,83 @@
               (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 (redraw-logical-line window
-                                             y
-                                             (create-logical-line point overlays active-modes)))
+            :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
@@ -634,9 +717,10 @@
 
 (defmethod lem-core::redraw-buffer ((buffer graphical-text-buffer) window force)
   (assert (eq buffer (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))
+  (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)))