gtk-screen: Implement screen/window-mark->x.

diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm
index 0c5ba8b9a90d8b1c47e6ae5d14bf8cbcc280a45d..285c71025b3f1b52a296a54ceee1a67548376c56 100644 (file)
--- a/src/gtk-screen/gtk-screen.scm
+++ b/src/gtk-screen/gtk-screen.scm
@@ -370,25 +370,37 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (define-method screen/window-mark->x ((screen <gtk-screen>) frame mark)
   (%trace "; screen/window-mark->x "screen" "frame" "mark"\n")
-  0                                    ; Need a real X???
-  )
+  (with-updated-window
+   screen frame 'MARK->X
+   (lambda (widget)
+     (let ((line (find-line-at mark widget)))
+       (if (not line)
+          0
+          (line->column mark line widget screen))))))
+
+(define-integrable (line->column mark line widget screen)
+  (let ((view (fix-layout-view widget))
+       (column-width (gtk-screen-char-width screen)))
+    (fix:- (image-column mark line)
+          (fix:quotient (fix-rect-x view) column-width))))
 
 (define-method screen/window-mark->y ((screen <gtk-screen>) frame mark)
   (%trace "; screen/window-mark->y "screen" "frame" "mark"\n")
   (with-updated-window
    screen frame 'MARK->Y
    (lambda (widget)
-     (line->row screen widget (find-line-at mark widget)))))
-
-(define-integrable (line->row screen widget line)
-  (let* ((view (fix-layout-view widget))
-        (spacing (gtk-screen-line-spacing screen))
-        (height (gtk-screen-line-height screen))
-        (y (if (not line)
-               0
-               (fix-rect-y (fix-ink-extent line)))))
-    (fix:quotient (fix:- y (fix-rect-y view))
-                 (fix:+ height spacing))))
+     (let ((line (find-line-at mark widget)))
+       (if (not line)
+          0
+          (line->row line widget screen))))))
+
+(define-integrable (line->row line widget screen)
+  (let ((view (fix-layout-view widget))
+       (row-height (fix:+ (gtk-screen-line-spacing screen)
+                          (gtk-screen-line-height screen))))
+    (fix:quotient (fix:- (fix-rect-y (fix-ink-extent line))
+                        (fix-rect-y view))
+                 row-height)))
 
 (define-method screen/window-mark->coordinates ((screen <gtk-screen>)
                                                frame mark)
@@ -397,9 +409,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
    screen frame 'MARK->COORDINATES
    (lambda (widget)
      (let ((line (find-line-at mark widget)))
-       (cons
-       0                               ; Need a real X???
-       (line->row screen widget line))))))
+       (if (not line)
+          (cons 0 0)
+          (cons (line->column mark line widget screen)
+                (line->row line widget screen)))))))
 
 (define-method screen/window-point-x ((screen <gtk-screen>) frame)
   (screen/window-mark->x screen frame (window-point frame)))
@@ -413,14 +426,42 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define-method screen/window-coordinates->mark ((screen <gtk-screen>)
                                                frame x y)
   (%trace "; screen/window-coordinates->mark "screen" "frame" "x" "y"\n")
+  (%trace-buttons "coordinates->mark "screen" "frame" "x" "y)
   (with-updated-window
    screen frame 'COORDINATES->MARK
    (lambda (widget)
-     (let* ((y* (fix:+ (row->y screen y)
-                      (fix-rect-y (fix-layout-view widget))))
-           (line (find-line-after y* widget)))
-       (%trace ";  line at "y*": "line"\n")
-       (mark-temporary-copy (line-start line widget))))))
+     (let ((drawing (fix-layout-drawing widget))
+          (view (fix-layout-view widget))
+          (column-width (gtk-screen-char-width screen))
+          (row-height (fix:+ (gtk-screen-line-spacing screen)
+                             (gtk-screen-line-height screen))))
+       (let ((buffer (buffer-drawing-buffer drawing))
+            (drawing-x (fix:+ (fix:* x column-width) (fix-rect-x view)))
+            (drawing-y (fix:+ (fix:* y row-height) (fix-rect-y view))))
+        (%trace-buttons "drawing y "drawing-y)
+        (let ((line (find-line-after drawing-y widget)))
+          (%trace-buttons "line after "drawing-y": "line)
+          (cond ((not line)
+                 (%trace-buttons "empty buffer")
+                 (mark-temporary-copy (buffer-start buffer)))
+                ((fix:< (fix-rect-max-y (fix-ink-extent line))
+                        drawing-y)     ;mouse was beyond the last line
+                 (%trace-buttons "past last line")
+                 (mark-temporary-copy (buffer-end buffer)))
+                (else
+                 (let ((index
+                        (vector-ref
+                         (group-column->index
+                          (buffer-group buffer)
+                          (line-ink-start-index line)
+                          (line-ink-end-index line)
+                          0 ;; start column
+                          (fix:quotient drawing-x column-width)
+                          (buffer-drawing-tab-width drawing)
+                          (buffer-drawing-char-image-strings drawing))
+                         0)))
+                   (%trace-buttons "index at "(fix:quotient drawing-x column-width)": "index)
+                   (make-mark (buffer-group buffer) index))))))))))
 
 (define-integrable (update-start-mark widget)
   ;; Set WIDGET's window's start-mark to the start of the first
@@ -763,7 +804,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (define (button-down-handler widget type button modifiers x y)
   (declare (ignore type))
-  (%trace "; Button down: "button" "modifiers" "x" "y" "widget"\n")
+  (%trace-buttons "down "button" "modifiers" "x" "y" "widget)
   (queue-input-event (edwin-widget-screen widget)
                     (make-input-event
                      'BUTTON
@@ -772,11 +813,25 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   #t)
 
 (define (execute-gtk-button-command widget button modifiers x y)
+  (%trace-buttons "execute "widget" "button" "modifiers" "x" "y)
   (let ((screen (edwin-widget-screen widget))
        (frame (text-widget-buffer-frame widget)))
     (let ((inferior (find-inferior (window-inferiors (window-superior frame))
                                   frame)))
-      (%trace "; button inferior "inferior"\n")
+      (%trace-buttons "window position"
+                     " " (fix:quotient x (gtk-screen-char-width screen))
+                     "," (fix:quotient
+                          y
+                          (fix:+ (gtk-screen-line-height screen)
+                                 (gtk-screen-line-spacing screen))))
+      (%trace-buttons "inferior "inferior)
+      (%trace-buttons "screen position"
+                     " " (fix:+ (inferior-x-start inferior)
+                                (fix:quotient x (gtk-screen-char-width screen)))
+                     "," (fix:+ (inferior-y-start inferior)
+                                (fix:quotient y
+                                              (fix:+ (gtk-screen-line-height screen)
+                                                     (gtk-screen-line-spacing screen)))))
       (execute-button-command
        screen
        (make-down-button (fix:-1+ button) (modifiers->char-bits modifiers))
@@ -2693,4 +2748,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (syntax-rules ()
     ((_ ARGS ...) (if %trace2? (outf-error ARGS ...)))))
 
+(define %trace-buttons? #f)
+
+(define-syntax %trace-buttons
+  (syntax-rules ()
+    ((_ ARGS ...) (if %trace-buttons? (%%trace-buttons ARGS ...)))))
+
+(define (%%trace-buttons . msg)
+  (apply outf-error `("; Button ",@msg"\n")))
+
 (initialize-package!)
\ No newline at end of file