Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Brig/scaling redux #88

Merged
merged 17 commits into from
Jun 22, 2018
Merged

Brig/scaling redux #88

Show file tree
Hide file tree
Changes from 16 commits
Commits
Show all changes
17 commits
Select commit Hold shift + click to select a range
9c464f9
First pass, use dc<%> scaling for zoom.
IonoclastBrigham Apr 30, 2018
1d4310a
Resolves a contract issue in del-embed-tags!.
IonoclastBrigham May 5, 2018
a6029d7
Second pass, use dc<%> scaling for zoom.
IonoclastBrigham May 5, 2018
a32a160
Refactors zoom menu.
IonoclastBrigham May 16, 2018
c282eba
Expands zoom menu à la Firefox.
IonoclastBrigham May 18, 2018
06f613e
Adds zoom level to status bar.
IonoclastBrigham May 18, 2018
b905f89
Refactors zoom buttons to use DC zoom.
IonoclastBrigham May 18, 2018
972a77d
Void out menu separators to avoid contaminating stdout.
IonoclastBrigham May 21, 2018
ded058f
Special zoom status label for fit, hidden for 1X.
IonoclastBrigham May 23, 2018
9f7c578
Make zoom-to-fit "sticky" when resizing the window.
IonoclastBrigham May 23, 2018
557fcbe
WIP: commenting code to disable image rescaling.
IonoclastBrigham May 24, 2018
7f54917
WIP: enable dc-zoom on image load, fix centering bug.
IonoclastBrigham May 24, 2018
77aa9cc
Adds center-fit zoom mode as default when loading image.
IonoclastBrigham May 26, 2018
f9af220
First pass, reenable scrollbars for dc-zoom.
IonoclastBrigham May 27, 2018
1973e1e
Second pass, reenable scrollbars for dc-zoom.
IonoclastBrigham May 28, 2018
e51d9a6
Factors out ivy-canvas% to its own source file, more modular.
IonoclastBrigham May 28, 2018
9531217
Changes equality operator to work with booleans.
IonoclastBrigham May 29, 2018
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
249 changes: 37 additions & 212 deletions base.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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?)
Expand Down Expand Up @@ -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))
Expand Down Expand Up @@ -507,33 +425,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)]
Expand Down Expand Up @@ -597,18 +498,19 @@
; 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))
(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
Expand All @@ -635,7 +537,7 @@
(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"
(string-truncate (path->string name) 30))))])
Expand All @@ -648,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))
(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"
Expand Down Expand Up @@ -682,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))
(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
Expand Down Expand Up @@ -720,12 +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)))
(define size (file-size (image-path)))
(cond
[(flif? (image-path))
Expand Down Expand Up @@ -824,21 +722,21 @@
; 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))]
; 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)))])
(set! image-lst-timings empty)])

(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 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)))
Expand All @@ -853,95 +751,22 @@
; otherwise, display the static image
(send canvas set-on-paint!
(λ (canvas dc)
(when (and (path? img) (eq? scale 'default))
; 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))))

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

; 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))]))))

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

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

; center the image on the canvas
(send canvas recenter)
(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
; 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
Expand Down
8 changes: 6 additions & 2 deletions embed.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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))))
Expand Down
Loading