From 9c464f914367a821545a67318b142ed64266a80a Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Sun, 29 Apr 2018 19:37:01 -0700 Subject: [PATCH 01/17] First pass, use dc<%> scaling for zoom. Calculates new scale level + or - 0.1 based on mouse scroll Clamps mouse zoom min 0.1x, max 4x. Tries to re-center origin, but some more math and bookkeeping needed. --- frame.rkt | 33 +++++++++++++++++++++++++-------- 1 file changed, 25 insertions(+), 8 deletions(-) diff --git a/frame.rkt b/frame.rkt index b18e223..1648081 100644 --- a/frame.rkt +++ b/frame.rkt @@ -1027,18 +1027,30 @@ along with this program. If not, see ." ; do nothing if we've pressed ctrl+n (unless (equal? (image-path) +root-path+) (collect-garbage 'incremental) - (if (and image-pict - (empty? image-lst)) - (load-image image-pict 'wheel-smaller) - (load-image image-lst 'wheel-smaller)))] +; (if (and image-pict +; (empty? image-lst)) +; (load-image image-pict 'wheel-smaller) +; (load-image image-lst 'wheel-smaller)) + (define dc (send this get-dc)) + (define-values [cur-scale-x cur-scale-y] (send dc get-scale)) + (define new-scale (max (- cur-scale-x 0.1) 0.1)) + (printf "New Scale: ~a~n" new-scale) + (send dc set-scale new-scale new-scale) + (send this refresh-now))] [(wheel-up) ; do nothing if we've pressed ctrl+n (unless (equal? (image-path) +root-path+) (collect-garbage 'incremental) - (if (and image-pict - (empty? image-lst)) - (load-image image-pict 'wheel-larger) - (load-image image-lst 'wheel-larger)))] +; (if (and image-pict +; (empty? image-lst)) +; (load-image image-pict 'wheel-larger) +; (load-image image-lst 'wheel-larger)) + (define dc (send this get-dc)) + (define-values [cur-scale-x cur-scale-y] (send dc get-scale)) + (define new-scale (min (+ cur-scale-x 0.1) 4.0)) + (printf "New Scale: ~a~n" new-scale) + (send dc set-scale new-scale new-scale) + (send this refresh-now))] ; osx does things a little different [(f11) (unless macosx? (toggle-fullscreen this ivy-frame))] @@ -1063,6 +1075,11 @@ along with this program. If not, see ." [paint-callback (λ (canvas dc) (send canvas set-canvas-background color-black))])) (send (ivy-canvas) accept-drop-files #t) +(let* ([canvas (ivy-canvas)] + [dc (send canvas get-dc)]) + (send dc set-origin + (/ (send canvas get-width) 2) + (/ (send canvas get-height) 2))) (define status-bar-hpanel (new horizontal-panel% From 1d4310ac69fafbc79b70be2b5027d572daa51fa9 Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Sat, 5 May 2018 15:57:53 -0700 Subject: [PATCH 02/17] Resolves a contract issue in del-embed-tags!. --- embed.rkt | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/embed.rkt b/embed.rkt index e43d3ee..1305f8c 100644 --- a/embed.rkt +++ b/embed.rkt @@ -690,12 +690,16 @@ GIF XMP keyword: #"XMP Data" with auth #"XMP" ; remove the tags in taglist from the image (define/contract (del-embed-tags! img taglist) - (embed-support? list? . -> . void?) + (embed-support? (or/c list? string?) . -> . void?) ; get the tags from the image (if any) (define embed-lst (get-embed-tags img)) + (define resolved-tag-lst + (if (list? taglist) + taglist + (list taglist))) (unless (empty? embed-lst) ; remove taglist items from embed-list - (define new-taglist (remove* taglist embed-lst)) + (define new-taglist (remove* resolved-tag-lst embed-lst)) (set-embed-tags! img new-taglist))) (define ((is-tag? sym) xexpr) (and (txexpr? xexpr) (eq? sym (get-tag xexpr)))) From a6029d7cd8a648809aaa6e4e9e13c7e0264c36da Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Sat, 5 May 2018 16:57:21 -0700 Subject: [PATCH 03/17] Second pass, use dc<%> scaling for zoom. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Properly sets dc origin to center. Updates dc origin on canvas resize. Adusts images to draw centered about origin. New ivy-canvas% methods to handle zooming more generically. Change zoom increment to ±0.05. Simplifies all the scrollbar code. General code cleanup and minor refactoring. Known Issues: * Saw centering get messed up for an animated gif (can't repro, may be fixed) * Zoom action buttons haven't been touched. --- base.rkt | 72 ++++++++++++++++--------------------------------------- frame.rkt | 59 +++++++++++++++++++++++---------------------- 2 files changed, 51 insertions(+), 80 deletions(-) diff --git a/base.rkt b/base.rkt index 74bc7d1..bebb055 100644 --- a/base.rkt +++ b/base.rkt @@ -507,33 +507,16 @@ (list (* (string->number (bytes->hex-string left) 16) (/ gif-width master-width)) (* (string->number (bytes->hex-string top) 16) (/ gif-height master-height))))] [else (make-list len (list 0 0))])) - - ; determine x and y placement as well as + + ; set the center location + (define x-loc (- img-center-x)) + (define y-loc (- img-center-y)) + ; modify the scrollbars outside the animation loop - (define x-loc 0) - (define y-loc 0) - (cond - ; if the image is really big, place it at (0,0) - [(and (> img-x canvas-x) - (> img-y canvas-y)) - ; x-loc and y-loc are already 0 - (send canvas show-scrollbars #t #t)] - ; if the image is wider than the canvas, place it at (0,y) - [(> img-x canvas-x) - (send canvas show-scrollbars #t #f) - ; x-loc is already 0 - (set! y-loc (- canvas-center-y img-center-y))] - ; if the image is taller than the canvas, place it at (x,0) - [(> img-y canvas-y) - (send canvas show-scrollbars #f #t) - ; y-loc is already 0 - (set! x-loc (- canvas-center-x img-center-x))] - ; otherwise, place it at the center of the canvas - [else - (send canvas show-scrollbars #f #f) - (set! x-loc (- canvas-center-x img-center-x)) - (set! y-loc (- canvas-center-y img-center-y))]) - + (define hscroll (> img-x canvas-x)) + (define vscroll (> img-y canvas-y)) + (send canvas show-scrollbars hscroll vscroll) + ; actual animation loop ; runs until animation-thread is killed (let loop ([img-frame (first lst)] @@ -602,13 +585,15 @@ (image-scale/c) void?) (define canvas (ivy-canvas)) + (define dc (send canvas get-dc)) (define ivy-frame (send canvas get-parent)) (define tag-tfield (ivy-tag-tfield)) (define iar (ivy-actions-rating)) (define sbd (status-bar-dimensions)) (define sbe (status-bar-error)) (define sbp (status-bar-position)) - + + (send dc set-scale 1.0 1.0) (send sbe set-label "") (cond @@ -871,31 +856,14 @@ ; keep the background black (send canvas set-canvas-background color-black) - - (cond - ; if the image is really big, place it at (0,0) - [(and (> img-width canvas-x) - (> img-height canvas-y)) - (send canvas show-scrollbars #t #t) - (send dc draw-bitmap image-bmp 0 0)] - ; if the image is wider than the canvas, - ; place it at (0,y) - [(> img-width canvas-x) - (send canvas show-scrollbars #t #f) - (send dc draw-bitmap image-bmp - 0 (- canvas-center-y img-center-y))] - ; if the image is taller than the canvas, - ; place it at (x,0) - [(> img-height canvas-y) - (send canvas show-scrollbars #f #t) - (send dc draw-bitmap image-bmp - (- canvas-center-x img-center-x) 0)] - ; otherwise, place it at the normal position - [else - (send canvas show-scrollbars #f #f) - (send dc draw-bitmap image-bmp - (- canvas-center-x img-center-x) - (- canvas-center-y img-center-y))])))) + + ; center the image on the canvas + (send dc draw-bitmap image-bmp (- img-center-x) (- img-center-y)) + + ; configure scrollbars + (define hscroll (> img-width canvas-x)) + (define vscroll (> img-width canvas-y)) + (send canvas show-scrollbars hscroll vscroll)))) ; tell the scrollbars to adjust for the size of the image (let ([img-x (inexact->exact (round (pict-width (if image-pict image-pict (first image-lst)))))] diff --git a/frame.rkt b/frame.rkt index 1648081..5352579 100644 --- a/frame.rkt +++ b/frame.rkt @@ -4,6 +4,9 @@ (require framework images/flomap pict + (only-in plot/utils + clamp-real + ivl) racket/bool racket/class racket/gui/base @@ -1026,31 +1029,11 @@ along with this program. If not, see ." [(wheel-down) ; do nothing if we've pressed ctrl+n (unless (equal? (image-path) +root-path+) - (collect-garbage 'incremental) -; (if (and image-pict -; (empty? image-lst)) -; (load-image image-pict 'wheel-smaller) -; (load-image image-lst 'wheel-smaller)) - (define dc (send this get-dc)) - (define-values [cur-scale-x cur-scale-y] (send dc get-scale)) - (define new-scale (max (- cur-scale-x 0.1) 0.1)) - (printf "New Scale: ~a~n" new-scale) - (send dc set-scale new-scale new-scale) - (send this refresh-now))] + (send this zoom-by -0.05))] [(wheel-up) ; do nothing if we've pressed ctrl+n (unless (equal? (image-path) +root-path+) - (collect-garbage 'incremental) -; (if (and image-pict -; (empty? image-lst)) -; (load-image image-pict 'wheel-larger) -; (load-image image-lst 'wheel-larger)) - (define dc (send this get-dc)) - (define-values [cur-scale-x cur-scale-y] (send dc get-scale)) - (define new-scale (min (+ cur-scale-x 0.1) 4.0)) - (printf "New Scale: ~a~n" new-scale) - (send dc set-scale new-scale new-scale) - (send this refresh-now))] + (send this zoom-by 0.05))] ; osx does things a little different [(f11) (unless macosx? (toggle-fullscreen this ivy-frame))] @@ -1064,7 +1047,32 @@ along with this program. If not, see ." [(end) (load-last-image)] [(#\,) (focus-tag-tfield) (send (send (ivy-tag-tfield) get-editor) insert ", ")] - [(#\return) (focus-tag-tfield)])))) + [(#\return) (focus-tag-tfield)])) + + ; zooms view by a specified increment (positive or negative) + (define/public (zoom-by inc) + (define dc (send this get-dc)) + (define-values [cur-scale-x cur-scale-y] + (send dc get-scale)) + (define new-scale + (clamp-real (+ cur-scale-x inc) (ivl 0.1 4.0))) + (send this zoom-to new-scale)) + + ; zooms to a specific zoom-factor (1.0 == "no zoom") + (define/public (zoom-to factor) + (define dc (send this get-dc)) + (send dc set-scale factor factor) + (send this refresh-now)) + + (define/override (on-size width height) + (recenter-origin width height) + (send this refresh-now)) + + (define/private (recenter-origin width height) + (define dc (send this get-dc)) + (send dc set-origin + (/ width 2) + (/ height 2))))) (ivy-canvas (new ivy-canvas% @@ -1075,11 +1083,6 @@ along with this program. If not, see ." [paint-callback (λ (canvas dc) (send canvas set-canvas-background color-black))])) (send (ivy-canvas) accept-drop-files #t) -(let* ([canvas (ivy-canvas)] - [dc (send canvas get-dc)]) - (send dc set-origin - (/ (send canvas get-width) 2) - (/ (send canvas get-height) 2))) (define status-bar-hpanel (new horizontal-panel% From a32a1604198fa966721507392a85c171c22beced Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Tue, 15 May 2018 19:40:11 -0700 Subject: [PATCH 04/17] Refactors zoom menu. Make zoom menu coarser. Include 200 and 400% zoom in menu. Switches zoom menu to use new style dc% zooming facilities. --- frame.rkt | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/frame.rkt b/frame.rkt index 5352579..657e3fa 100644 --- a/frame.rkt +++ b/frame.rkt @@ -519,16 +519,13 @@ [help-string "Zoom the image to a specified percentage."])) -(for ([n (in-range 10 110 10)]) +(for ([n (list 10 25 50 75 100 200 400)]) (new menu-item% [parent ivy-menu-bar-view-zoom-to] [label (format "~a%" n)] [callback (λ (i e) (unless (equal? (image-path) +root-path+) - (collect-garbage 'incremental) - (if (empty? image-lst-master) - (load-image (bitmap image-bmp-master) n) - (load-image image-lst-master n))))])) + (send (ivy-canvas) zoom-to (/ n 100.0))))])) (define ivy-menu-bar-view-rotate-left (new menu-item% From c282ebaf8f6909b94e0cadb85178ca09a81ef9b4 Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Thu, 17 May 2018 21:06:45 -0700 Subject: [PATCH 05/17] =?UTF-8?q?Expands=20zoom=20menu=20=C3=A0=20la=20Fir?= =?UTF-8?q?efox.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Adds zoom in, zoom out, and reset menu options. Reorganizes zoom menu with separators. --- frame.rkt | 45 +++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 41 insertions(+), 4 deletions(-) diff --git a/frame.rkt b/frame.rkt index 657e3fa..09d96c2 100644 --- a/frame.rkt +++ b/frame.rkt @@ -512,16 +512,53 @@ [callback (λ (i e) (show-tag-browser))])) -(define ivy-menu-bar-view-zoom-to +(define ivy-menu-bar-view-zoom (new menu% [parent ivy-menu-bar-view] - [label "Zoom To"] - [help-string "Zoom the image to a specified percentage."])) + [label "Zoom"] + [help-string "Zoom the image."])) +(define ivy-menu-bar-view-zoom-in + (new menu-item% + [parent ivy-menu-bar-view-zoom] + [label "Zoom In"] + [help-string "Zoom the image by 10%"] + [shortcut #\=] + [callback (λ (i e) + (unless (equal? (image-path) +root-path+) + (send (ivy-canvas) zoom-by 0.1)))])) + + +(define ivy-menu-bar-view-zoom-out + (new menu-item% + [parent ivy-menu-bar-view-zoom] + [label "Zoom Out"] + [help-string "Zoom the image out by 10%"] + [shortcut #\-] + [callback (λ (i e) + (unless (equal? (image-path) +root-path+) + (send (ivy-canvas) zoom-by -0.1)))])) + +(new separator-menu-item% + [parent ivy-menu-bar-view-zoom]) + +(define ivy-menu-bar-view-zoom-reset + (new menu-item% + [parent ivy-menu-bar-view-zoom] + [label "Reset"] + [help-string "Zoom the image out by 10%"] + [shortcut #\0] + [callback (λ (i e) + (unless (equal? (image-path) +root-path+) + (send (ivy-canvas) zoom-to 1.0)))])) + +(new separator-menu-item% + [parent ivy-menu-bar-view-zoom]) + (for ([n (list 10 25 50 75 100 200 400)]) (new menu-item% - [parent ivy-menu-bar-view-zoom-to] + [parent ivy-menu-bar-view-zoom] [label (format "~a%" n)] [callback (λ (i e) (unless (equal? (image-path) +root-path+) From 06f613e8014e349ba9946a72c8804c498cbecf55 Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Thu, 17 May 2018 21:08:38 -0700 Subject: [PATCH 06/17] Adds zoom level to status bar. --- frame.rkt | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/frame.rkt b/frame.rkt index 09d96c2..7ca3f16 100644 --- a/frame.rkt +++ b/frame.rkt @@ -9,6 +9,7 @@ ivl) racket/bool racket/class + (only-in racket/format ~r) racket/gui/base racket/list racket/math @@ -985,6 +986,9 @@ along with this program. If not, see ." (send txt set-position (send txt last-position))) (send (ivy-tag-tfield) focus)) +; forward define for use by zoom methods +(define status-bar-zoom (make-parameter #f)) + (define ivy-canvas% (class canvas% (super-new) @@ -1096,7 +1100,9 @@ along with this program. If not, see ." (define/public (zoom-to factor) (define dc (send this get-dc)) (send dc set-scale factor factor) - (send this refresh-now)) + (send this refresh-now) + (send (status-bar-zoom) set-label + (format "@ ~aX" (~r factor #:precision 2)))) (define/override (on-size width height) (recenter-origin width height) @@ -1147,6 +1153,12 @@ along with this program. If not, see ." [label ""] [auto-resize #t])) +(status-bar-zoom + (new message% + [parent dimensions-hpanel] + [label ""] + [auto-resize #t])) + (status-bar-error (new message% [parent error-hpanel] From b905f89f6f7117f5b82580d3bba050d9d854fcbd Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Thu, 17 May 2018 21:11:27 -0700 Subject: [PATCH 07/17] Refactors zoom buttons to use DC zoom. Hooks up zoom action buttons to ivy-canvas dc-based zoom methods. New (zoom-to-fit) method. --- frame.rkt | 33 +++++++++++++++------------------ 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/frame.rkt b/frame.rkt index 7ca3f16..319ec04 100644 --- a/frame.rkt +++ b/frame.rkt @@ -771,11 +771,7 @@ along with this program. If not, see ." [callback (λ (button event) ; do nothing if we've pressed ctrl+n (unless (equal? (image-path) +root-path+) - (collect-garbage 'incremental) - (if (and image-pict - (empty? image-lst)) - (load-image image-pict 'larger) - (load-image image-lst 'larger))))])) + (send (ivy-canvas) zoom-by 0.1)))])) (define ivy-actions-zoom-out (new button% @@ -784,11 +780,7 @@ along with this program. If not, see ." [callback (λ (button event) ; do nothing if we've pressed ctrl+n (unless (equal? (image-path) +root-path+) - (collect-garbage 'incremental) - (if (and image-pict - (empty? image-lst)) - (load-image image-pict 'smaller) - (load-image image-lst 'smaller))))])) + (send (ivy-canvas) zoom-by -0.1)))])) (define ivy-actions-zoom-normal (new button% @@ -797,10 +789,7 @@ along with this program. If not, see ." [callback (λ (button event) ; do nothing if we've pressed ctrl+n (unless (equal? (image-path) +root-path+) - (collect-garbage 'incremental) - (if (empty? image-lst) - (load-image image-bmp-master 'none) - (load-image (image-path) 'none))))])) + (send (ivy-canvas) zoom-to 1.0)))])) (define ivy-actions-zoom-fit (new button% @@ -809,10 +798,7 @@ along with this program. If not, see ." [callback (λ (button event) ; do nothing if we've pressed ctrl+n (unless (equal? (image-path) +root-path+) - (collect-garbage 'incremental) - (if (empty? image-lst) - (load-image image-bmp-master) - (load-image (image-path)))))])) + (send (ivy-canvas) zoom-to-fit)))])) (ivy-actions-rating @@ -1104,6 +1090,17 @@ along with this program. If not, see ." (send (status-bar-zoom) set-label (format "@ ~aX" (~r factor #:precision 2)))) + ; adjusts zoom level so the entire image fits, and at least one dimension + ; will be the same size as the window. + (define/public (zoom-to-fit) + (define w (send this get-width)) + (define h (send this get-height)) + (define img-w (send image-bmp-master get-width)) + (define img-h (send image-bmp-master get-height)) + (define new-zoom (min (/ w img-w) + (/ h img-h))) + (send this zoom-to new-zoom)) + (define/override (on-size width height) (recenter-origin width height) (send this refresh-now)) From 972a77d3197bcf8051d2e66182ff7603cbc60703 Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Sun, 20 May 2018 18:22:22 -0700 Subject: [PATCH 08/17] Void out menu separators to avoid contaminating stdout. --- base.rkt | 2 +- frame.rkt | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/base.rkt b/base.rkt index bebb055..975b068 100644 --- a/base.rkt +++ b/base.rkt @@ -909,7 +909,7 @@ (send canvas refresh)) ; curried procedure to abstract loading an image in a collection -; mmm... curry +; mmm... curry (see https://www.imdb.com/name/nm0000347/?ref_=fn_al_nm_1) (define ((load-image-in-collection direction)) (unless (equal? (image-path) +root-path+) ; kill the animation thread, if applicable diff --git a/frame.rkt b/frame.rkt index 319ec04..0f5c307 100644 --- a/frame.rkt +++ b/frame.rkt @@ -541,8 +541,8 @@ (unless (equal? (image-path) +root-path+) (send (ivy-canvas) zoom-by -0.1)))])) -(new separator-menu-item% - [parent ivy-menu-bar-view-zoom]) +(void (new separator-menu-item% + [parent ivy-menu-bar-view-zoom])) (define ivy-menu-bar-view-zoom-reset (new menu-item% @@ -554,8 +554,8 @@ (unless (equal? (image-path) +root-path+) (send (ivy-canvas) zoom-to 1.0)))])) -(new separator-menu-item% - [parent ivy-menu-bar-view-zoom]) +(void (new separator-menu-item% + [parent ivy-menu-bar-view-zoom])) (for ([n (list 10 25 50 75 100 200 400)]) (new menu-item% From ded058f30f5d4ea971be7cdf503f7a00c7297da0 Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Tue, 22 May 2018 20:47:02 -0700 Subject: [PATCH 09/17] Special zoom status label for fit, hidden for 1X. --- frame.rkt | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/frame.rkt b/frame.rkt index 0f5c307..d788716 100644 --- a/frame.rkt +++ b/frame.rkt @@ -1083,12 +1083,14 @@ along with this program. If not, see ." (send this zoom-to new-scale)) ; zooms to a specific zoom-factor (1.0 == "no zoom") - (define/public (zoom-to factor) + (define/public (zoom-to factor [status #f]) (define dc (send this get-dc)) (send dc set-scale factor factor) (send this refresh-now) (send (status-bar-zoom) set-label - (format "@ ~aX" (~r factor #:precision 2)))) + (cond [status status] + [(not (= factor 1.0)) (format "@ ~aX" (~r factor #:precision 2))] + [else ""]))) ; adjusts zoom level so the entire image fits, and at least one dimension ; will be the same size as the window. @@ -1099,7 +1101,7 @@ along with this program. If not, see ." (define img-h (send image-bmp-master get-height)) (define new-zoom (min (/ w img-w) (/ h img-h))) - (send this zoom-to new-zoom)) + (send this zoom-to new-zoom "[Fit]")) (define/override (on-size width height) (recenter-origin width height) From 9f7c57800f3b4e034851f30c9ad6bf6581a359fc Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Tue, 22 May 2018 22:34:13 -0700 Subject: [PATCH 10/17] Make zoom-to-fit "sticky" when resizing the window. --- frame.rkt | 32 ++++++++++++++++++++------------ 1 file changed, 20 insertions(+), 12 deletions(-) diff --git a/frame.rkt b/frame.rkt index d788716..315ea33 100644 --- a/frame.rkt +++ b/frame.rkt @@ -982,7 +982,10 @@ along with this program. If not, see ." (define mouse-x 0) (define mouse-y 0) - + + ; whether the last zoom operation was "fit" + (define fit #f) + (define/public (get-mouse-pos) (values mouse-x mouse-y)) @@ -1073,17 +1076,9 @@ along with this program. If not, see ." (send (send (ivy-tag-tfield) get-editor) insert ", ")] [(#\return) (focus-tag-tfield)])) - ; zooms view by a specified increment (positive or negative) - (define/public (zoom-by inc) - (define dc (send this get-dc)) - (define-values [cur-scale-x cur-scale-y] - (send dc get-scale)) - (define new-scale - (clamp-real (+ cur-scale-x inc) (ivl 0.1 4.0))) - (send this zoom-to new-scale)) - ; zooms to a specific zoom-factor (1.0 == "no zoom") (define/public (zoom-to factor [status #f]) + (set! fit #f) ; always make sure this is cleared when setting a new zoom level (define dc (send this get-dc)) (send dc set-scale factor factor) (send this refresh-now) @@ -1092,6 +1087,15 @@ along with this program. If not, see ." [(not (= factor 1.0)) (format "@ ~aX" (~r factor #:precision 2))] [else ""]))) + ; zooms view by a specified increment (positive or negative) + (define/public (zoom-by inc) + (define dc (send this get-dc)) + (define-values [cur-scale-x cur-scale-y] + (send dc get-scale)) + (define new-scale + (clamp-real (+ cur-scale-x inc) (ivl 0.1 4.0))) + (send this zoom-to new-scale)) + ; adjusts zoom level so the entire image fits, and at least one dimension ; will be the same size as the window. (define/public (zoom-to-fit) @@ -1101,11 +1105,15 @@ along with this program. If not, see ." (define img-h (send image-bmp-master get-height)) (define new-zoom (min (/ w img-w) (/ h img-h))) - (send this zoom-to new-zoom "[Fit]")) + (send this zoom-to new-zoom "[Fit]") + ; must set this *after* calling zoom-to, where it is reset to false + (set! fit #t)) (define/override (on-size width height) (recenter-origin width height) - (send this refresh-now)) + (if fit + (send this zoom-to-fit) + (send this refresh-now))) (define/private (recenter-origin width height) (define dc (send this get-dc)) From 557fcbeb05010e7d9ad6d0c450ae8ff70c077ced Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Wed, 23 May 2018 19:14:19 -0700 Subject: [PATCH 11/17] WIP: commenting code to disable image rescaling. --- base.rkt | 71 +++++++++++++++++++++++++++++-------------------------- frame.rkt | 20 ++++++++++------ 2 files changed, 51 insertions(+), 40 deletions(-) diff --git a/base.rkt b/base.rkt index 975b068..5ebe98f 100644 --- a/base.rkt +++ b/base.rkt @@ -48,14 +48,14 @@ ; master bitmap of loaded image-path (define image-bmp-master (make-bitmap 50 50)) ; pict of the currently displayed image -(define image-pict #f) +;(define image-pict #f) ; the cached XMP metadata of the image (define image-xmp (box empty)) (define xmp-threads (make-hash)) ; bitmap to actually display ; eliminate image "jaggies" ; reduce amount of times we use pict->bitmap, as this takes a very long time -(define image-bmp (make-bitmap 50 50)) +;(define image-bmp (make-bitmap 50 50)) ; directory containing the currently displayed image (define image-dir (make-parameter (find-system-path 'home-dir))) ; the only extensions ivy will accept - ignores everything else @@ -94,7 +94,7 @@ (define color-red (make-object color% "red")) ; contract for image scaling -(define image-scale/c +#;(define image-scale/c (or/c 'default 'cmd 'larger @@ -410,7 +410,7 @@ ; img is either a pict or a bitmap% ; type is a symbol ; returns a pict -(define/contract (scale-image img type) +#;(define/contract (scale-image img type) ((or/c (is-a?/c bitmap%) pict?) image-scale/c . -> . pict?) (define canvas (ivy-canvas)) ; width and height of the image @@ -580,9 +580,9 @@ ; procedure that loads the given image to the canvas ; takes care of updating the dimensions message and ; the position message -(define/contract (load-image img [scale 'default]) +(define/contract (load-image img #;[scale 'default]) (->* ([or/c path? pict? (is-a?/c bitmap%) (listof pict?)]) - (image-scale/c) + ;(image-scale/c) void?) (define canvas (ivy-canvas)) (define dc (send canvas get-dc)) @@ -620,7 +620,8 @@ (set! image-lst empty) (set! image-lst-timings empty) ; just load the static image instead - (load-image (bitmap img) scale) + ;(load-image (bitmap img) scale) + (load-image (bitmap img)) (send sbe set-label (format "Error loading file ~v" (string-truncate (path->string name) 30))))]) @@ -633,9 +634,9 @@ (close-input-port bmp-in-port) (bitmap bmp))) (set! image-lst-master lst) - (set! image-lst (map (λ (gif-frame) (scale-image gif-frame scale)) lst)) + (set! image-lst #;(map (λ (gif-frame) (scale-image gif-frame scale)) lst) lst) (set! image-lst-timings (gif-timings img)) - (set! image-pict #f)) + #;(set! image-pict #f)) (define size (file-size (image-path))) (send sbd set-label (format "~a x ~a pixels ~a" @@ -667,9 +668,9 @@ (define lst (flif->list img)) (set! image-bmp-master (first lst)) (set! image-lst-master lst) - (set! image-lst (map (λ (flaf-frame) (scale-image flaf-frame scale)) lst)) + (set! image-lst #;(map (λ (flaf-frame) (scale-image flaf-frame scale)) lst) lst) (set! image-lst-timings (make-list num-frames (/ timing-delay 1000))) - (set! image-pict #f) + ;(set! image-pict #f) (set! image-num-loops (flif-decoder-num-loops dec-ptr)) (flif-destroy-decoder! dec-ptr)) ; set the new frame label @@ -705,12 +706,13 @@ (cumulative? #f) (define lst (flif->list img)) (set! image-bmp-master (first lst)) - (load-image (first lst) scale)] + ;(load-image (first lst) scale)] + (load-image (first lst))] [else (send image-bmp-master load-file img 'unknown/alpha)])) (cond [load-success (send ivy-frame set-label (string-truncate (path->string name) +label-max+)) - (set! image-pict (scale-image image-bmp-master scale)) - (set! image-bmp (pict->bitmap (transparency-grid-append image-pict))) + ;(set! image-pict (scale-image image-bmp-master scale)) + ;(set! image-bmp #;(pict->bitmap (transparency-grid-append image-pict)) image-bmp-master) (define size (file-size (image-path))) (cond [(flif? (image-path)) @@ -810,20 +812,20 @@ (send tag-tfield refresh)] [(list? img) ; scale the image in the desired direction - (set! image-lst (map (λ (pct) (scale-image pct scale)) img))] + (set! image-lst #;(map (λ (pct) (scale-image pct scale)) img) img)] [else ; we already have the image loaded (set! image-lst-master empty) (set! image-lst empty) (set! image-lst-timings empty) - (set! image-pict (scale-image img scale)) - (set! image-bmp (pict->bitmap (transparency-grid-append image-pict)))]) + ;(set! image-pict (scale-image img scale)) + #;(set! image-bmp #;(pict->bitmap (transparency-grid-append image-pict)) image-bmp-master)]) (unless (or (false? (animation-thread)) (thread-dead? (animation-thread))) (kill-thread (animation-thread))) (if (not (empty? image-lst)) - ; image-lst contains a list of picts, display the animated gif + ; image-lst contains a list of picts, display the animation (send canvas set-on-paint! (λ (canvas dc) (unless (or (false? (animation-thread)) (thread-dead? (animation-thread))) @@ -838,35 +840,38 @@ ; otherwise, display the static image (send canvas set-on-paint! (λ (canvas dc) - (when (and (path? img) (eq? scale 'default)) + #;(when #;(and (path? img) (eq? scale 'default)) (path? img) ; have the canvas re-scale the image so when the canvas is ; resized, it'll also be the proper size - (set! image-pict (scale-image image-bmp-master 'default)) - (set! image-bmp (pict->bitmap (transparency-grid-append image-pict)))) - - (define img-width (inexact->exact (round (pict-width image-pict)))) - (define img-height (inexact->exact (round (pict-height image-pict)))) - + ;(set! image-pict (scale-image image-bmp-master 'default)) + #;(set! image-bmp #;(pict->bitmap (transparency-grid-append image-pict)) image-bmp-master)) + + (define img-width (inexact->exact (round #;(pict-width image-pict) (send image-bmp-master get-width)))) + (define img-height (inexact->exact (round #;(pict-height image-pict) (send image-bmp-master get-width)))) (define img-center-x (/ img-width 2)) (define img-center-y (/ img-height 2)) - (define canvas-x (send canvas get-width)) - (define canvas-y (send canvas get-height)) - (define canvas-center-x (/ canvas-x 2)) - (define canvas-center-y (/ canvas-y 2)) + + (define canvas-width (send canvas get-width)) + (define canvas-height (send canvas get-height)) + (define canvas-center-x (/ canvas-width 2)) + (define canvas-center-y (/ canvas-height 2)) ; keep the background black (send canvas set-canvas-background color-black) ; center the image on the canvas - (send dc draw-bitmap image-bmp (- img-center-x) (- img-center-y)) + (send canvas recenter) + (send dc draw-bitmap image-bmp-master (- img-center-x) (- img-center-y)) + ;(send canvas on-size canvas-width canvas-height) + ;(send canvas zoom-to-fit) ; configure scrollbars - (define hscroll (> img-width canvas-x)) - (define vscroll (> img-width canvas-y)) + (define hscroll (> img-width canvas-width)) + (define vscroll (> img-width canvas-height)) (send canvas show-scrollbars hscroll vscroll)))) ; tell the scrollbars to adjust for the size of the image - (let ([img-x (inexact->exact (round (pict-width (if image-pict image-pict (first image-lst)))))] + #;(let ([img-x (inexact->exact (round (pict-width (if image-pict image-pict (first image-lst)))))] [img-y (inexact->exact (round (pict-height (if image-pict image-pict (first image-lst)))))]) ; will complain if width/height is less than 1 (define width (if (< img-x 1) 1 img-x)) diff --git a/frame.rkt b/frame.rkt index 315ea33..88df4b9 100644 --- a/frame.rkt +++ b/frame.rkt @@ -4,6 +4,7 @@ (require framework images/flomap pict + pict/convert (only-in plot/utils clamp-real ivl) @@ -573,7 +574,7 @@ [callback (λ (i e) (unless (equal? (image-path) +root-path+) (collect-garbage 'incremental) - (load-image (rotate image-pict (/ pi 2)) 'same)))])) + (load-image (rotate (pict-convert image-bmp-master) (/ pi 2)) 'same)))])) (define ivy-menu-bar-view-rotate-right (new menu-item% @@ -583,7 +584,7 @@ [callback (λ (i e) (unless (equal? (image-path) +root-path+) (collect-garbage 'incremental) - (load-image (rotate image-pict (- (/ pi 2))) 'same)))])) + (load-image (rotate (pict-convert image-bmp-master) (- (/ pi 2))) #;'same)))])) (define ivy-menu-bar-view-flip-horizontal (new menu-item% @@ -593,9 +594,9 @@ [callback (λ (i e) (unless (equal? (image-path) +root-path+) (define flo - (flomap-flip-horizontal (bitmap->flomap (pict->bitmap image-pict)))) + (flomap-flip-horizontal (bitmap->flomap #;(pict->bitmap image-pict)) image-bmp-master)) (collect-garbage 'incremental) - (load-image (bitmap (flomap->bitmap flo)) 'same)))])) + (load-image (bitmap (flomap->bitmap flo)) #;'same)))])) (define ivy-menu-bar-view-flip-vertical (new menu-item% @@ -605,9 +606,9 @@ [callback (λ (i e) (unless (equal? (image-path) +root-path+) (define flo - (flomap-flip-vertical (bitmap->flomap (pict->bitmap image-pict)))) + (flomap-flip-vertical (bitmap->flomap #;(pict->bitmap image-pict) image-bmp-master))) (collect-garbage 'incremental) - (load-image (bitmap (flomap->bitmap flo)) 'same)))])) + (load-image (bitmap (flomap->bitmap flo)) #;'same)))])) (define ivy-menu-bar-view-sort-alpha (new menu-item% @@ -1119,7 +1120,12 @@ along with this program. If not, see ." (define dc (send this get-dc)) (send dc set-origin (/ width 2) - (/ height 2))))) + (/ height 2))) + + (define/public (recenter) + (define w (send this get-width)) + (define h (send this get-height)) + (recenter-origin w h)))) (ivy-canvas (new ivy-canvas% From 7f54917a47919c737462344522868ebddd9cecc1 Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Wed, 23 May 2018 21:07:13 -0700 Subject: [PATCH 12/17] WIP: enable dc-zoom on image load, fix centering bug. --- base.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/base.rkt b/base.rkt index 5ebe98f..9b7c7b0 100644 --- a/base.rkt +++ b/base.rkt @@ -847,7 +847,7 @@ #;(set! image-bmp #;(pict->bitmap (transparency-grid-append image-pict)) image-bmp-master)) (define img-width (inexact->exact (round #;(pict-width image-pict) (send image-bmp-master get-width)))) - (define img-height (inexact->exact (round #;(pict-height image-pict) (send image-bmp-master get-width)))) + (define img-height (inexact->exact (round #;(pict-height image-pict) (send image-bmp-master get-height)))) (define img-center-x (/ img-width 2)) (define img-center-y (/ img-height 2)) @@ -869,6 +869,8 @@ (define hscroll (> img-width canvas-width)) (define vscroll (> img-width canvas-height)) (send canvas show-scrollbars hscroll vscroll)))) + + (send canvas zoom-to-fit) ; tell the scrollbars to adjust for the size of the image #;(let ([img-x (inexact->exact (round (pict-width (if image-pict image-pict (first image-lst)))))] From 77aa9cc81d09a17f052f71200b137f451869d42d Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Sat, 26 May 2018 16:41:39 -0700 Subject: [PATCH 13/17] Adds center-fit zoom mode as default when loading image. --- base.rkt | 2 +- frame.rkt | 11 +++++++++++ 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/base.rkt b/base.rkt index 9b7c7b0..9d03af7 100644 --- a/base.rkt +++ b/base.rkt @@ -870,7 +870,7 @@ (define vscroll (> img-width canvas-height)) (send canvas show-scrollbars hscroll vscroll)))) - (send canvas zoom-to-fit) + (send canvas center-fit) ; tell the scrollbars to adjust for the size of the image #;(let ([img-x (inexact->exact (round (pict-width (if image-pict image-pict (first image-lst)))))] diff --git a/frame.rkt b/frame.rkt index 88df4b9..edb32b0 100644 --- a/frame.rkt +++ b/frame.rkt @@ -1110,6 +1110,17 @@ along with this program. If not, see ." ; must set this *after* calling zoom-to, where it is reset to false (set! fit #t)) + ; only zooms out if the image is too big to fit on either dimension + (define/public (center-fit) + (define w (send this get-width)) + (define h (send this get-height)) + (define img-w (send image-bmp-master get-width)) + (define img-h (send image-bmp-master get-height)) + (cond [(or (> img-w w) + (> img-h h)) + (send this zoom-to-fit)] + [else (send this zoom-to 1.0)])) + (define/override (on-size width height) (recenter-origin width height) (if fit From f9af22096161ccdb720f2b3a5b90ec6f9d6873c5 Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Sun, 27 May 2018 14:59:20 -0700 Subject: [PATCH 14/17] First pass, reenable scrollbars for dc-zoom. New configure-scrollbars canvas method, called on zoom change. TODO: looks like need to adjust image centering for zoomed virtual size? Clean up the old commented-out image scaling code. --- base.rkt | 169 ++++-------------------------------------------------- frame.rkt | 12 ++++ 2 files changed, 23 insertions(+), 158 deletions(-) diff --git a/base.rkt b/base.rkt index 9d03af7..e6a38ee 100644 --- a/base.rkt +++ b/base.rkt @@ -47,15 +47,9 @@ (define image-path (make-parameter +root-path+)) ; master bitmap of loaded image-path (define image-bmp-master (make-bitmap 50 50)) -; pict of the currently displayed image -;(define image-pict #f) ; the cached XMP metadata of the image (define image-xmp (box empty)) (define xmp-threads (make-hash)) -; bitmap to actually display -; eliminate image "jaggies" -; reduce amount of times we use pict->bitmap, as this takes a very long time -;(define image-bmp (make-bitmap 50 50)) ; directory containing the currently displayed image (define image-dir (make-parameter (find-system-path 'home-dir))) ; the only extensions ivy will accept - ignores everything else @@ -93,27 +87,6 @@ (define color-gold (make-object color% "gold")) (define color-red (make-object color% "red")) -; contract for image scaling -#;(define image-scale/c - (or/c 'default - 'cmd - 'larger - 'wheel-larger - 'smaller - 'wheel-smaller - 'same - 'none - 10 - 20 - 30 - 40 - 50 - 60 - 70 - 80 - 90 - 100)) - ; a supported file must have an extension (define/contract (supported-file? img) (path-string? . -> . boolean?) @@ -406,61 +379,6 @@ (hc-append (- x) grid pct) (hc-append (- offset x) grid pct))) -; scales an image to the current canvas size -; img is either a pict or a bitmap% -; type is a symbol -; returns a pict -#;(define/contract (scale-image img type) - ((or/c (is-a?/c bitmap%) pict?) image-scale/c . -> . pict?) - (define canvas (ivy-canvas)) - ; width and height of the image - (define img-width (if (pict? img) - (pict-width img) - (send img get-width))) - (define img-height (if (pict? img) - (pict-height img) - (send img get-height))) - - ; width and height of the canvas - (define max-width (send canvas get-width)) - (define max-height (send canvas get-height)) - - (case type - ; might deal with either pict or bitmap% for initial scaling - [(default) - (cond [(and (> img-width max-width) - (> img-height max-height)) - (scale-to-fit (if (pict? img) img (bitmap img)) max-width max-height)] - [(> img-width max-width) - (scale-to-fit (if (pict? img) img (bitmap img)) max-width img-height)] - [(> img-height max-height) - (scale-to-fit (if (pict? img) img (bitmap img)) img-width max-height)] - [else (bitmap img)])] - [(cmd) - ; canvas is very small before everything is completely loaded - ; these are the effective dimensions of the canvas - (set! max-width 800) - (set! max-height 516) - (cond [(and (> img-width max-width) - (> img-height max-height)) - (scale-to-fit (if (pict? img) img (bitmap img)) max-width max-height)] - [(> img-width max-width) - (scale-to-fit (if (pict? img) img (bitmap img)) max-width img-height)] - [(> img-height max-height) - (scale-to-fit (if (pict? img) img (bitmap img)) img-width max-height)] - [else (bitmap img)])] - ; only used by zoom-in, definitely a pict - [(larger wheel-larger) - (scale-to-fit img (* img-width 1.1) (* img-height 1.1))] - ; only used by zoom-out, definitely a pict - [(smaller wheel-smaller) - (scale-to-fit img (* img-width 0.9) (* img-height 0.9))] - [(same) img] - [(10 20 30 40 50 60 70 80 90 100) - (define num (/ type 100)) - (scale-to-fit img (* img-width num) (* img-height num))] - [(none) (bitmap img)])) - ; janky! (define ivy-canvas (make-parameter #f)) (define ivy-tag-tfield (make-parameter #f)) @@ -580,9 +498,8 @@ ; procedure that loads the given image to the canvas ; takes care of updating the dimensions message and ; the position message -(define/contract (load-image img #;[scale 'default]) +(define/contract (load-image img) (->* ([or/c path? pict? (is-a?/c bitmap%) (listof pict?)]) - ;(image-scale/c) void?) (define canvas (ivy-canvas)) (define dc (send canvas get-dc)) @@ -620,7 +537,6 @@ (set! image-lst empty) (set! image-lst-timings empty) ; just load the static image instead - ;(load-image (bitmap img) scale) (load-image (bitmap img)) (send sbe set-label (format "Error loading file ~v" @@ -634,9 +550,8 @@ (close-input-port bmp-in-port) (bitmap bmp))) (set! image-lst-master lst) - (set! image-lst #;(map (λ (gif-frame) (scale-image gif-frame scale)) lst) lst) - (set! image-lst-timings (gif-timings img)) - #;(set! image-pict #f)) + (set! image-lst lst) + (set! image-lst-timings (gif-timings img))) (define size (file-size (image-path))) (send sbd set-label (format "~a x ~a pixels ~a" @@ -668,9 +583,8 @@ (define lst (flif->list img)) (set! image-bmp-master (first lst)) (set! image-lst-master lst) - (set! image-lst #;(map (λ (flaf-frame) (scale-image flaf-frame scale)) lst) lst) + (set! image-lst lst) (set! image-lst-timings (make-list num-frames (/ timing-delay 1000))) - ;(set! image-pict #f) (set! image-num-loops (flif-decoder-num-loops dec-ptr)) (flif-destroy-decoder! dec-ptr)) ; set the new frame label @@ -706,13 +620,10 @@ (cumulative? #f) (define lst (flif->list img)) (set! image-bmp-master (first lst)) - ;(load-image (first lst) scale)] (load-image (first lst))] [else (send image-bmp-master load-file img 'unknown/alpha)])) (cond [load-success (send ivy-frame set-label (string-truncate (path->string name) +label-max+)) - ;(set! image-pict (scale-image image-bmp-master scale)) - ;(set! image-bmp #;(pict->bitmap (transparency-grid-append image-pict)) image-bmp-master) (define size (file-size (image-path))) (cond [(flif? (image-path)) @@ -811,15 +722,13 @@ ; ensure the text-field displays the changes we just made (send tag-tfield refresh)] [(list? img) - ; scale the image in the desired direction - (set! image-lst #;(map (λ (pct) (scale-image pct scale)) img) img)] + ; this is actually a list of frames + (set! image-lst img)] [else ; we already have the image loaded (set! image-lst-master empty) (set! image-lst empty) - (set! image-lst-timings empty) - ;(set! image-pict (scale-image img scale)) - #;(set! image-bmp #;(pict->bitmap (transparency-grid-append image-pict)) image-bmp-master)]) + (set! image-lst-timings empty)]) (unless (or (false? (animation-thread)) (thread-dead? (animation-thread))) (kill-thread (animation-thread))) @@ -840,14 +749,8 @@ ; otherwise, display the static image (send canvas set-on-paint! (λ (canvas dc) - #;(when #;(and (path? img) (eq? scale 'default)) (path? img) - ; have the canvas re-scale the image so when the canvas is - ; resized, it'll also be the proper size - ;(set! image-pict (scale-image image-bmp-master 'default)) - #;(set! image-bmp #;(pict->bitmap (transparency-grid-append image-pict)) image-bmp-master)) - - (define img-width (inexact->exact (round #;(pict-width image-pict) (send image-bmp-master get-width)))) - (define img-height (inexact->exact (round #;(pict-height image-pict) (send image-bmp-master get-height)))) + (define img-width (inexact->exact (round (send image-bmp-master get-width)))) + (define img-height (inexact->exact (round (send image-bmp-master get-height)))) (define img-center-x (/ img-width 2)) (define img-center-y (/ img-height 2)) @@ -861,59 +764,9 @@ ; center the image on the canvas (send canvas recenter) - (send dc draw-bitmap image-bmp-master (- img-center-x) (- img-center-y)) - ;(send canvas on-size canvas-width canvas-height) - ;(send canvas zoom-to-fit) + (send dc draw-bitmap image-bmp-master (- img-center-x) (- img-center-y))))) - ; configure scrollbars - (define hscroll (> img-width canvas-width)) - (define vscroll (> img-width canvas-height)) - (send canvas show-scrollbars hscroll vscroll)))) - - (send canvas center-fit) - - ; tell the scrollbars to adjust for the size of the image - #;(let ([img-x (inexact->exact (round (pict-width (if image-pict image-pict (first image-lst)))))] - [img-y (inexact->exact (round (pict-height (if image-pict image-pict (first image-lst)))))]) - ; will complain if width/height is less than 1 - (define width (if (< img-x 1) 1 img-x)) - (define height (if (< img-y 1) 1 img-y)) - (define-values (virtual-x virtual-y) (send canvas get-virtual-size)) - - (case scale - ; zoom with the center of the current center - [(smaller larger) - (define-values (client-x client-y) (send canvas get-client-size)) - (define client-center-x (/ client-x 2)) - (define client-center-y (/ client-y 2)) - (define ratio-x (exact->inexact (/ client-center-x virtual-x))) - (define ratio-y (exact->inexact (/ client-center-y virtual-y))) - (send canvas init-auto-scrollbars width height - (if (> ratio-x 1.0) - 1.0 - ratio-x) - (if (> ratio-y 1.0) - 1.0 - ratio-y))] - ; place scrollbars on mouse location - [(wheel-smaller wheel-larger) - (define-values (mouse-x mouse-y) (send canvas get-mouse-pos)) - ; coordinates of top left corner of visible section of the virtual canvas - (define-values (visible-x visible-y) (send canvas get-view-start)) - ; position of mouse over the entire displayed image - (define mouse/visible-x (if (> mouse-x virtual-x) - virtual-x - (+ mouse-x visible-x))) - (define mouse/visible-y (if (> mouse-y virtual-y) - virtual-y - (+ mouse-y visible-y))) - (send canvas init-auto-scrollbars width height - (exact->inexact (/ mouse/visible-x virtual-x)) - (exact->inexact (/ mouse/visible-y virtual-y)))] - [else - ; otherwise just set it to the top left corner - (send canvas init-auto-scrollbars width height 0.0 0.0)])) - (send canvas refresh)) + (send canvas center-fit)) ; curried procedure to abstract loading an image in a collection ; mmm... curry (see https://www.imdb.com/name/nm0000347/?ref_=fn_al_nm_1) diff --git a/frame.rkt b/frame.rkt index edb32b0..914412f 100644 --- a/frame.rkt +++ b/frame.rkt @@ -1077,11 +1077,23 @@ along with this program. If not, see ." (send (send (ivy-tag-tfield) get-editor) insert ", ")] [(#\return) (focus-tag-tfield)])) + (define/private (configure-scrollbars zoom-factor) + (define client-w (send this get-width)) + (define client-h (send this get-height)) + (define img-w (send image-bmp-master get-width)) + (define img-h (send image-bmp-master get-height)) + (define virtual-w (max client-w (inexact->exact (round (* img-w zoom-factor))))) + (define virtual-h (max client-h (inexact->exact (round (* img-h zoom-factor))))) + (define scroll-x 0.5) + (define scroll-y 0.5) + (send this init-auto-scrollbars virtual-w virtual-h scroll-x scroll-y)) + ; zooms to a specific zoom-factor (1.0 == "no zoom") (define/public (zoom-to factor [status #f]) (set! fit #f) ; always make sure this is cleared when setting a new zoom level (define dc (send this get-dc)) (send dc set-scale factor factor) + (configure-scrollbars factor) (send this refresh-now) (send (status-bar-zoom) set-label (cond [status status] From 1973e1e9d22559c977c738f243916260441961b3 Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Sun, 27 May 2018 18:32:17 -0700 Subject: [PATCH 15/17] Second pass, reenable scrollbars for dc-zoom. Fixes image centering, when zoomed beyond canvas client boundaries. General cleanup and minor code refactoring. --- base.rkt | 15 +++++------ frame.rkt | 74 ++++++++++++++++++++++++++++++------------------------- 2 files changed, 46 insertions(+), 43 deletions(-) diff --git a/base.rkt b/base.rkt index e6a38ee..d485a8f 100644 --- a/base.rkt +++ b/base.rkt @@ -732,7 +732,9 @@ (unless (or (false? (animation-thread)) (thread-dead? (animation-thread))) (kill-thread (animation-thread))) - + + (send canvas center-fit) + (if (not (empty? image-lst)) ; image-lst contains a list of picts, display the animation (send canvas set-on-paint! @@ -754,19 +756,14 @@ (define img-center-x (/ img-width 2)) (define img-center-y (/ img-height 2)) - (define canvas-width (send canvas get-width)) - (define canvas-height (send canvas get-height)) + (define-values [canvas-width canvas-height] + (send canvas get-virtual-size)) (define canvas-center-x (/ canvas-width 2)) (define canvas-center-y (/ canvas-height 2)) - - ; keep the background black - (send canvas set-canvas-background color-black) ; center the image on the canvas (send canvas recenter) - (send dc draw-bitmap image-bmp-master (- img-center-x) (- img-center-y))))) - - (send canvas center-fit)) + (send dc draw-bitmap image-bmp-master (- img-center-x) (- img-center-y)))))) ; curried procedure to abstract loading an image in a collection ; mmm... curry (see https://www.imdb.com/name/nm0000347/?ref_=fn_al_nm_1) diff --git a/frame.rkt b/frame.rkt index 914412f..d42616f 100644 --- a/frame.rkt +++ b/frame.rkt @@ -979,7 +979,8 @@ along with this program. If not, see ." (define ivy-canvas% (class canvas% (super-new) - (init-field paint-callback) + (init-field paint-callback + [canvas-backgorund color-black]) (define mouse-x 0) (define mouse-y 0) @@ -1078,25 +1079,31 @@ along with this program. If not, see ." [(#\return) (focus-tag-tfield)])) (define/private (configure-scrollbars zoom-factor) - (define client-w (send this get-width)) - (define client-h (send this get-height)) - (define img-w (send image-bmp-master get-width)) - (define img-h (send image-bmp-master get-height)) - (define virtual-w (max client-w (inexact->exact (round (* img-w zoom-factor))))) - (define virtual-h (max client-h (inexact->exact (round (* img-h zoom-factor))))) - (define scroll-x 0.5) - (define scroll-y 0.5) - (send this init-auto-scrollbars virtual-w virtual-h scroll-x scroll-y)) - - ; zooms to a specific zoom-factor (1.0 == "no zoom") - (define/public (zoom-to factor [status #f]) + (let* ([img-w (send image-bmp-master get-width)] + [img-h (send image-bmp-master get-height)] + [zoomed-img-w (inexact->exact (round (* img-w zoom-factor)))] + [zoomed-img-h (inexact->exact (round (* img-h zoom-factor)))] + [client-w (send this get-width)] + [client-h (send this get-height)] + [virtual-w (max client-w zoomed-img-w)] + [virtual-h (max client-h zoomed-img-h)] + [scroll-x 0.5] ; TODO + [scroll-y 0.5]) ; TODO + (send this init-auto-scrollbars virtual-w virtual-h scroll-x scroll-y) + (send this show-scrollbars + (> zoomed-img-w client-w) + (> zoomed-img-h client-h)))) + + ; zooms to a specific zoom-factor (1.0 == "no zoom"), + ; with optional staus bar label override + (define/public (zoom-to factor [status-label #f]) (set! fit #f) ; always make sure this is cleared when setting a new zoom level (define dc (send this get-dc)) (send dc set-scale factor factor) (configure-scrollbars factor) (send this refresh-now) (send (status-bar-zoom) set-label - (cond [status status] + (cond [status-label status-label] [(not (= factor 1.0)) (format "@ ~aX" (~r factor #:precision 2))] [else ""]))) @@ -1112,26 +1119,26 @@ along with this program. If not, see ." ; adjusts zoom level so the entire image fits, and at least one dimension ; will be the same size as the window. (define/public (zoom-to-fit) - (define w (send this get-width)) - (define h (send this get-height)) - (define img-w (send image-bmp-master get-width)) - (define img-h (send image-bmp-master get-height)) - (define new-zoom (min (/ w img-w) - (/ h img-h))) - (send this zoom-to new-zoom "[Fit]") - ; must set this *after* calling zoom-to, where it is reset to false - (set! fit #t)) + (let* ([client-w (send this get-width)] + [client-h (send this get-height)] + [img-w (send image-bmp-master get-width)] + [img-h (send image-bmp-master get-height)] + [new-zoom (min (/ client-w img-w) + (/ client-h img-h))]) + (send this zoom-to new-zoom "[Fit]") + ; must set this *after* calling zoom-to, where it is reset to false + (set! fit #t))) ; only zooms out if the image is too big to fit on either dimension (define/public (center-fit) - (define w (send this get-width)) - (define h (send this get-height)) - (define img-w (send image-bmp-master get-width)) - (define img-h (send image-bmp-master get-height)) - (cond [(or (> img-w w) - (> img-h h)) - (send this zoom-to-fit)] - [else (send this zoom-to 1.0)])) + (let ([client-w (send this get-width)] + [client-h (send this get-height)] + [img-w (send image-bmp-master get-width)] + [img-h (send image-bmp-master get-height)]) + (cond [(or (> img-w client-w) + (> img-h client-h)) + (send this zoom-to-fit)] + [else (send this zoom-to 1.0)]))) (define/override (on-size width height) (recenter-origin width height) @@ -1146,9 +1153,8 @@ along with this program. If not, see ." (/ height 2))) (define/public (recenter) - (define w (send this get-width)) - (define h (send this get-height)) - (recenter-origin w h)))) + (define-values [virtual-w virtual-h] (send this get-virtual-size)) + (recenter-origin virtual-w virtual-h)))) (ivy-canvas (new ivy-canvas% From e51d9a6edf4ab9773c64e17a1264fe3843518d9b Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Sun, 27 May 2018 22:37:03 -0700 Subject: [PATCH 16/17] Factors out ivy-canvas% to its own source file, more modular. --- frame.rkt | 208 +++++------------------------------------------ ivy-canvas.rkt | 213 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 233 insertions(+), 188 deletions(-) create mode 100644 ivy-canvas.rkt diff --git a/frame.rkt b/frame.rkt index d42616f..a63f933 100644 --- a/frame.rkt +++ b/frame.rkt @@ -5,9 +5,6 @@ images/flomap pict pict/convert - (only-in plot/utils - clamp-real - ivl) racket/bool racket/class (only-in racket/format ~r) @@ -24,6 +21,7 @@ "embed.rkt" "error-log.rkt" "files.rkt" + "ivy-canvas.rkt" "meta-editor.rkt" "search-dialog.rkt" "tag-browser.rkt") @@ -100,12 +98,17 @@ ;; Fullscreen handling ;; -(define (toggle-fullscreen canvas frame) - (define was-fullscreen? (send frame is-fullscreened?)) +(define (set-fullscreen going-to-be-fullscreen?) + (define was-fullscreen? (send ivy-frame is-fullscreened?)) + (unless (= was-fullscreen? going-to-be-fullscreen?) + (send ivy-frame fullscreen going-to-be-fullscreen?) + (unless macosx? + (on-fullscreen-event going-to-be-fullscreen?)))) + +(define (toggle-fullscreen canvas) + (define was-fullscreen? (send ivy-frame is-fullscreened?)) (define going-to-be-fullscreen? (not was-fullscreen?)) - (send frame fullscreen going-to-be-fullscreen?) - (unless macosx? - (on-fullscreen-event going-to-be-fullscreen?))) + (set-fullscreen going-to-be-fullscreen?)) (define (on-fullscreen-event is-fullscreen?) (cond [is-fullscreen? @@ -973,195 +976,24 @@ along with this program. If not, see ." (send txt set-position (send txt last-position))) (send (ivy-tag-tfield) focus)) +(define (insert-tag-tfield-comma) + (send (send (ivy-tag-tfield) get-editor) insert ", ")) + ; forward define for use by zoom methods (define status-bar-zoom (make-parameter #f)) -(define ivy-canvas% - (class canvas% - (super-new) - (init-field paint-callback - [canvas-backgorund color-black]) - - (define mouse-x 0) - (define mouse-y 0) - - ; whether the last zoom operation was "fit" - (define fit #f) - - (define/public (get-mouse-pos) - (values mouse-x mouse-y)) - - (define (do-on-paint) - (when paint-callback - (paint-callback this (send this get-dc)))) - - (define/override (on-paint) - (do-on-paint)) - - ; proc: ((is-a?/c canvas%) (is-a?/c dc<%>) . -> . any) - (define/public (set-on-paint! proc) - (set! paint-callback proc)) - - (define/override (on-drop-file pathname) - ; append the image to the current collection - (define-values (base name must-be-dir?) (split-path pathname)) - (define directory? (directory-exists? pathname)) - (cond - ; empty collection - [(equal? (first (pfs)) +root-path+) - (cond [directory? - (define files - (for/fold ([lst empty]) - ([p (in-directory pathname)]) - (if (supported-file? p) - (append lst (list p)) - lst))) - (image-dir pathname) - (pfs files) - (image-path (first files)) - (load-image (first files))] - [else - (image-dir base) - (pfs (list pathname)) - (image-path pathname) - (load-image pathname)])] - ; collection has images; appending to collection - [else - (define files - (if (directory-exists? pathname) - (for/fold ([lst empty]) - ([p (in-directory pathname)]) - (if (supported-file? p) - (append lst (list p)) - lst)) - (list pathname))) - ; no duplicate paths allowed! - (pfs (remove-duplicates (append (pfs) files))) - ; change label because it usually isn't called until - ; (load-image) is called and we want to see the changes now - (send (status-bar-position) set-label - (format "~a / ~a" - (+ (get-index (image-path) (pfs)) 1) - (length (pfs))))])) - - (define/override (on-event evt) - (define type (send evt get-event-type)) - (case type - ; track where the mouse is - [(enter motion) - (set! mouse-x (send evt get-x)) - (set! mouse-y (send evt get-y))])) - - (define/override (on-char key) - (define type (send key get-key-code)) - (case type - [(wheel-down) - ; do nothing if we've pressed ctrl+n - (unless (equal? (image-path) +root-path+) - (send this zoom-by -0.05))] - [(wheel-up) - ; do nothing if we've pressed ctrl+n - (unless (equal? (image-path) +root-path+) - (send this zoom-by 0.05))] - ; osx does things a little different - [(f11) (unless macosx? - (toggle-fullscreen this ivy-frame))] - ; only do something if we're fullscreened, - ; since the tag bar isn't available in fullscreen anyway - [(escape) (when (and (send ivy-frame is-fullscreened?) (not macosx?)) - (toggle-fullscreen this ivy-frame))] - [(left) (load-previous-image)] - [(right) (load-next-image)] - [(home) (load-first-image)] - [(end) (load-last-image)] - [(#\,) (focus-tag-tfield) - (send (send (ivy-tag-tfield) get-editor) insert ", ")] - [(#\return) (focus-tag-tfield)])) - - (define/private (configure-scrollbars zoom-factor) - (let* ([img-w (send image-bmp-master get-width)] - [img-h (send image-bmp-master get-height)] - [zoomed-img-w (inexact->exact (round (* img-w zoom-factor)))] - [zoomed-img-h (inexact->exact (round (* img-h zoom-factor)))] - [client-w (send this get-width)] - [client-h (send this get-height)] - [virtual-w (max client-w zoomed-img-w)] - [virtual-h (max client-h zoomed-img-h)] - [scroll-x 0.5] ; TODO - [scroll-y 0.5]) ; TODO - (send this init-auto-scrollbars virtual-w virtual-h scroll-x scroll-y) - (send this show-scrollbars - (> zoomed-img-w client-w) - (> zoomed-img-h client-h)))) - - ; zooms to a specific zoom-factor (1.0 == "no zoom"), - ; with optional staus bar label override - (define/public (zoom-to factor [status-label #f]) - (set! fit #f) ; always make sure this is cleared when setting a new zoom level - (define dc (send this get-dc)) - (send dc set-scale factor factor) - (configure-scrollbars factor) - (send this refresh-now) - (send (status-bar-zoom) set-label - (cond [status-label status-label] - [(not (= factor 1.0)) (format "@ ~aX" (~r factor #:precision 2))] - [else ""]))) - - ; zooms view by a specified increment (positive or negative) - (define/public (zoom-by inc) - (define dc (send this get-dc)) - (define-values [cur-scale-x cur-scale-y] - (send dc get-scale)) - (define new-scale - (clamp-real (+ cur-scale-x inc) (ivl 0.1 4.0))) - (send this zoom-to new-scale)) - - ; adjusts zoom level so the entire image fits, and at least one dimension - ; will be the same size as the window. - (define/public (zoom-to-fit) - (let* ([client-w (send this get-width)] - [client-h (send this get-height)] - [img-w (send image-bmp-master get-width)] - [img-h (send image-bmp-master get-height)] - [new-zoom (min (/ client-w img-w) - (/ client-h img-h))]) - (send this zoom-to new-zoom "[Fit]") - ; must set this *after* calling zoom-to, where it is reset to false - (set! fit #t))) - - ; only zooms out if the image is too big to fit on either dimension - (define/public (center-fit) - (let ([client-w (send this get-width)] - [client-h (send this get-height)] - [img-w (send image-bmp-master get-width)] - [img-h (send image-bmp-master get-height)]) - (cond [(or (> img-w client-w) - (> img-h client-h)) - (send this zoom-to-fit)] - [else (send this zoom-to 1.0)]))) - - (define/override (on-size width height) - (recenter-origin width height) - (if fit - (send this zoom-to-fit) - (send this refresh-now))) - - (define/private (recenter-origin width height) - (define dc (send this get-dc)) - (send dc set-origin - (/ width 2) - (/ height 2))) - - (define/public (recenter) - (define-values [virtual-w virtual-h] (send this get-virtual-size)) - (recenter-origin virtual-w virtual-h)))) - (ivy-canvas (new ivy-canvas% [parent ivy-frame] [label "Ivy Image Canvas"] [style '(hscroll vscroll)] [stretchable-height #t] + [focus-tag-tfield focus-tag-tfield] + [insert-tag-tfield-comma insert-tag-tfield-comma] + [status-bar-position status-bar-position] + [status-bar-zoom status-bar-zoom] + [set-fullscreen set-fullscreen] + [toggle-fullscreen toggle-fullscreen] [paint-callback (λ (canvas dc) (send canvas set-canvas-background color-black))])) (send (ivy-canvas) accept-drop-files #t) diff --git a/ivy-canvas.rkt b/ivy-canvas.rkt new file mode 100644 index 0000000..7dda6de --- /dev/null +++ b/ivy-canvas.rkt @@ -0,0 +1,213 @@ +#lang racket +; +; +(require (only-in plot/utils + clamp-real + ivl) + (only-in racket/gui/base + canvas%) + (only-in "base.rkt" + +root-path+ + color-black + get-index + image-bmp-master + image-dir + image-path + load-first-image + load-image + load-last-image + load-next-image + load-previous-image + macosx? + pfs + supported-file?)) + +(provide (all-defined-out)) + + +(define ivy-canvas% + (class canvas% + (super-new) + + (init-field focus-tag-tfield + insert-tag-tfield-comma + paint-callback + set-fullscreen + status-bar-position + status-bar-zoom + toggle-fullscreen + [canvas-backgorund color-black]) + + (define mouse-x 0) + (define mouse-y 0) + + ; whether the last zoom operation was "fit" + (define fit #f) + + (define/public (get-mouse-pos) + (values mouse-x mouse-y)) + + (define (do-on-paint) + (when paint-callback + (paint-callback this (send this get-dc)))) + + (define/override (on-paint) + (do-on-paint)) + + ; proc: ((is-a?/c canvas%) (is-a?/c dc<%>) . -> . any) + (define/public (set-on-paint! proc) + (set! paint-callback proc)) + + (define/override (on-drop-file pathname) + ; append the image to the current collection + (define-values (base name must-be-dir?) (split-path pathname)) + (define directory? (directory-exists? pathname)) + (cond + ; empty collection + [(equal? (first (pfs)) +root-path+) + (cond [directory? + (define files + (for/fold ([lst empty]) + ([p (in-directory pathname)]) + (if (supported-file? p) + (append lst (list p)) + lst))) + (image-dir pathname) + (pfs files) + (image-path (first files)) + (load-image (first files))] + [else + (image-dir base) + (pfs (list pathname)) + (image-path pathname) + (load-image pathname)])] + ; collection has images; appending to collection + [else + (define files + (if (directory-exists? pathname) + (for/fold ([lst empty]) + ([p (in-directory pathname)]) + (if (supported-file? p) + (append lst (list p)) + lst)) + (list pathname))) + ; no duplicate paths allowed! + (pfs (remove-duplicates (append (pfs) files))) + ; change label because it usually isn't called until + ; (load-image) is called and we want to see the changes now + (send (status-bar-position) set-label + (format "~a / ~a" + (+ (get-index (image-path) (pfs)) 1) + (length (pfs))))])) + + (define/override (on-event evt) + (define type (send evt get-event-type)) + (case type + ; track where the mouse is + [(enter motion) + (set! mouse-x (send evt get-x)) + (set! mouse-y (send evt get-y))])) + + (define/override (on-char key) + (define type (send key get-key-code)) + (case type + [(wheel-down) + ; do nothing if we've pressed ctrl+n + (unless (equal? (image-path) +root-path+) + (send this zoom-by -0.05))] + [(wheel-up) + ; do nothing if we've pressed ctrl+n + (unless (equal? (image-path) +root-path+) + (send this zoom-by 0.05))] + ; osx does things a little different + [(f11) (unless macosx? + (toggle-fullscreen this))] + ; only do something if we're fullscreened, + ; since the tag bar isn't available in fullscreen anyway + [(escape) (when (not macosx?) + (set-fullscreen #f))] + [(left) (load-previous-image)] + [(right) (load-next-image)] + [(home) (load-first-image)] + [(end) (load-last-image)] + [(#\,) (focus-tag-tfield) + (insert-tag-tfield-comma)] + [(#\return) (focus-tag-tfield)])) + + (define/private (configure-scrollbars zoom-factor) + (let* ([img-w (send image-bmp-master get-width)] + [img-h (send image-bmp-master get-height)] + [zoomed-img-w (inexact->exact (round (* img-w zoom-factor)))] + [zoomed-img-h (inexact->exact (round (* img-h zoom-factor)))] + [client-w (send this get-width)] + [client-h (send this get-height)] + [virtual-w (max client-w zoomed-img-w)] + [virtual-h (max client-h zoomed-img-h)] + [scroll-x 0.5] ; TODO + [scroll-y 0.5]) ; TODO + (send this init-auto-scrollbars virtual-w virtual-h scroll-x scroll-y) + (send this show-scrollbars + (> zoomed-img-w client-w) + (> zoomed-img-h client-h)))) + + ; zooms to a specific zoom-factor (1.0 == "no zoom"), + ; with optional staus bar label override + (define/public (zoom-to factor [status-label #f]) + (set! fit #f) ; always make sure this is cleared when setting a new zoom level + (define dc (send this get-dc)) + (send dc set-scale factor factor) + (configure-scrollbars factor) + (send this refresh-now) + (send (status-bar-zoom) set-label + (cond [status-label status-label] + [(not (= factor 1.0)) (format "@ ~aX" (~r factor #:precision 2))] + [else ""]))) + + ; zooms view by a specified increment (positive or negative) + (define/public (zoom-by inc) + (define dc (send this get-dc)) + (define-values [cur-scale-x cur-scale-y] + (send dc get-scale)) + (define new-scale + (clamp-real (+ cur-scale-x inc) (ivl 0.1 4.0))) + (send this zoom-to new-scale)) + + ; adjusts zoom level so the entire image fits, and at least one dimension + ; will be the same size as the window. + (define/public (zoom-to-fit) + (let* ([client-w (send this get-width)] + [client-h (send this get-height)] + [img-w (send image-bmp-master get-width)] + [img-h (send image-bmp-master get-height)] + [new-zoom (min (/ client-w img-w) + (/ client-h img-h))]) + (send this zoom-to new-zoom "[Fit]") + ; must set this *after* calling zoom-to, where it is reset to false + (set! fit #t))) + + ; only zooms out if the image is too big to fit on either dimension + (define/public (center-fit) + (let ([client-w (send this get-width)] + [client-h (send this get-height)] + [img-w (send image-bmp-master get-width)] + [img-h (send image-bmp-master get-height)]) + (cond [(or (> img-w client-w) + (> img-h client-h)) + (send this zoom-to-fit)] + [else (send this zoom-to 1.0)]))) + + (define/override (on-size width height) + (recenter-origin width height) + (if fit + (send this zoom-to-fit) + (send this refresh-now))) + + (define/private (recenter-origin width height) + (define dc (send this get-dc)) + (send dc set-origin + (/ width 2) + (/ height 2))) + + (define/public (recenter) + (define-values [virtual-w virtual-h] (send this get-virtual-size)) + (recenter-origin virtual-w virtual-h)))) From 9531217abed2d6da89d3dc7c4d4fccbf7656a43c Mon Sep 17 00:00:00 2001 From: Brigham Toskin Date: Mon, 28 May 2018 20:09:49 -0700 Subject: [PATCH 17/17] Changes equality operator to work with booleans. --- frame.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/frame.rkt b/frame.rkt index a63f933..945beb8 100644 --- a/frame.rkt +++ b/frame.rkt @@ -100,7 +100,7 @@ (define (set-fullscreen going-to-be-fullscreen?) (define was-fullscreen? (send ivy-frame is-fullscreened?)) - (unless (= was-fullscreen? going-to-be-fullscreen?) + (unless (eq? was-fullscreen? going-to-be-fullscreen?) (send ivy-frame fullscreen going-to-be-fullscreen?) (unless macosx? (on-fullscreen-event going-to-be-fullscreen?))))