From: Matt Birkholz Date: Thu, 26 Jan 2017 17:20:36 +0000 (-0700) Subject: gtk-screen: Implement screen/window-mark->x. X-Git-Tag: mit-scheme-pucked-9.2.12~236 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=92eb14252dfd587bbcfe8736261997139d87bbdb;p=mit-scheme.git gtk-screen: Implement screen/window-mark->x. --- diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index 0c5ba8b9a..285c71025 100644 --- 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 ) 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 ) 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 ) 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 ) 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 ) 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