racket/collects/images/private/flomap-resize.rkt
2012-03-09 11:30:34 -07:00

221 lines
10 KiB
Racket
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

#lang typed/racket/base
(require racket/match racket/math
(only-in racket/unsafe/ops unsafe-fx+)
"flonum.rkt"
"flomap-struct.rkt"
"flomap-stats.rkt"
"flomap-blur.rkt")
(provide flomap-inset flomap-trim flomap-crop
flomap-lt-crop flomap-lc-crop flomap-lb-crop
flomap-ct-crop flomap-cc-crop flomap-cb-crop
flomap-rt-crop flomap-rc-crop flomap-rb-crop
flomap-scale flomap-resize)
(: flomap-inset (case-> (flomap Integer -> flomap)
(flomap Integer Integer -> flomap)
(flomap Integer Integer Integer Integer -> flomap)))
(define flomap-inset
(case-lambda
[(fm amt) (flomap-inset fm amt amt amt amt)]
[(fm h-amt v-amt) (flomap-inset fm h-amt v-amt h-amt v-amt)]
[(fm l-amt t-amt r-amt b-amt)
(cond [(and (= l-amt 0) (= t-amt 0) (= r-amt 0) (= b-amt 0)) fm]
[else
(match-define (flomap src-vs c src-w src-h) fm)
(define dst-w (fxmax 0 (fx+ src-w (fx+ l-amt r-amt))))
(define dst-h (fxmax 0 (fx+ src-h (fx+ t-amt b-amt))))
(define dst-vs (make-flvector (* c dst-w dst-h)))
(cond
[(or (dst-w . fx= . 0) (dst-h . fx= . 0))
(flomap dst-vs c dst-w dst-h)]
[else
(let: y-loop : Void ([dst-y : Nonnegative-Fixnum 0])
(when (dst-y . fx< . dst-h)
(define src-y (fx- dst-y t-amt))
(when (and (src-y . fx>= . 0) (src-y . fx< . src-h))
(let: x-loop : Void ([dst-x : Nonnegative-Fixnum 0])
(when (dst-x . fx< . dst-w)
(define src-x (fx- dst-x l-amt))
(when (and (src-x . fx>= . 0) (src-x . fx< . src-w))
(let: k-loop : Void ([k : Nonnegative-Fixnum 0])
(when (k . fx< . c)
(define src-i (coords->index c src-w k src-x src-y))
(define dst-i (coords->index c dst-w k dst-x dst-y))
(flvector-set! dst-vs dst-i (flvector-ref src-vs src-i))
(k-loop (unsafe-fx+ k 1)))))
(x-loop (unsafe-fx+ dst-x 1)))))
(y-loop (unsafe-fx+ dst-y 1))))
(flomap dst-vs c dst-w dst-h)])])]))
(: flomap-trim (flomap -> flomap))
(define (flomap-trim fm)
(match-define (flomap _ c w h) fm)
(cond [(c . = . 0) (make-flomap 0 0 0)]
[else (define-values (x-min y-min x-max y-max)
(flomap-nonzero-rect (flomap-ref-component fm 0)))
(flomap-inset fm (- x-min) (- y-min) (- x-max w) (- y-max h))]))
(: flomap-crop (flomap Integer Integer Real Real -> flomap))
(define (flomap-crop fm width height x-frac y-frac)
(unless (width . >= . 0)
(raise-type-error 'flomap-crop "nonnegative integer" 1 fm width height x-frac y-frac))
(unless (height . >= . 0)
(raise-type-error 'flomap-crop "nonnegative integer" 2 fm width height x-frac y-frac))
(let ([x-frac (exact->inexact x-frac)]
[y-frac (exact->inexact y-frac)])
(match-define (flomap _ c w h) fm)
(define l-amt (fl->fx (round (* x-frac (fx->fl (fx- width w))))))
(define r-amt (fx- (fx- width w) l-amt))
(define t-amt (fl->fx (round (* y-frac (fx->fl (fx- height h))))))
(define b-amt (fx- (fx- height h) t-amt))
(flomap-inset fm l-amt t-amt r-amt b-amt)))
(: flomap-lt-crop (flomap Integer Integer -> flomap))
(: flomap-lc-crop (flomap Integer Integer -> flomap))
(: flomap-lb-crop (flomap Integer Integer -> flomap))
(: flomap-ct-crop (flomap Integer Integer -> flomap))
(: flomap-cc-crop (flomap Integer Integer -> flomap))
(: flomap-cb-crop (flomap Integer Integer -> flomap))
(: flomap-rt-crop (flomap Integer Integer -> flomap))
(: flomap-rc-crop (flomap Integer Integer -> flomap))
(: flomap-rb-crop (flomap Integer Integer -> flomap))
(define (flomap-lt-crop fm w h) (flomap-crop fm w h 0 0))
(define (flomap-lc-crop fm w h) (flomap-crop fm w h 0 1/2))
(define (flomap-lb-crop fm w h) (flomap-crop fm w h 0 1))
(define (flomap-ct-crop fm w h) (flomap-crop fm w h 1/2 0))
(define (flomap-cc-crop fm w h) (flomap-crop fm w h 1/2 1/2))
(define (flomap-cb-crop fm w h) (flomap-crop fm w h 1/2 1))
(define (flomap-rt-crop fm w h) (flomap-crop fm w h 1 0))
(define (flomap-rc-crop fm w h) (flomap-crop fm w h 1 1/2))
(define (flomap-rb-crop fm w h) (flomap-crop fm w h 1 1))
(: flomap-scale (case-> (flomap Real -> flomap)
(flomap Real Real -> flomap)))
(define flomap-scale
(case-lambda
[(fm scale)
(cond [(< scale 0) (raise-type-error 'flomap-scale "nonnegative real" 1 fm scale)]
[else (flomap-scale fm scale scale)])]
[(fm x-scale y-scale)
(cond [(< x-scale 0) (raise-type-error 'flomap-scale "nonnegative real" 1 fm x-scale y-scale)]
[(< y-scale 0) (raise-type-error 'flomap-scale "nonnegative real" 2 fm x-scale y-scale)]
[else (flomap-scale-x (flomap-scale-y fm (exact->inexact y-scale))
(exact->inexact x-scale))])]))
(: flomap-resize (flomap (Option Integer) (Option Integer) -> flomap))
(define (flomap-resize fm width height)
(when (and width (width . < . 0))
(raise-type-error 'flomap-resize "nonnegative integer" 1 fm width height))
(when (and height (height . < . 0))
(raise-type-error 'flomap-resize "nonnegative integer" 2 fm width height))
(match-define (flomap _ c w h) fm)
(cond [(and width height) (flomap-resize-x (flomap-resize-y fm height) width)]
[width (cond [(= w 0) (error 'flomap-resize
"cannot proportionally scale ~e×~e flomap's height"
w h)]
[else (define s (exact->inexact (/ width w)))
(flomap-resize-x (flomap-scale-y fm s) width)])]
[height (cond [(= h 0) (error 'flomap-resize
"cannot proportionally scale ~e×~e flomap's width"
w h)]
[else (define s (exact->inexact (/ height h)))
(flomap-scale-x (flomap-resize-y fm height) s)])]
[else (error 'flomap-resize "can't happen")]))
(: flomap-scale-x (flomap Flonum -> flomap))
(define (flomap-scale-x fm scale)
(match-define (flomap _ c w h) fm)
(cond [(= 0 scale) (make-flomap c 0 h)]
[else (let ([scale (abs scale)])
(flomap-scale*-x fm scale (abs (fl->fx (ceiling (* (exact->inexact w) scale))))))]))
(: flomap-scale-y (flomap Flonum -> flomap))
(define (flomap-scale-y fm scale)
(match-define (flomap _ c w h) fm)
(cond [(= 0 scale) (make-flomap c w 0)]
[else (let ([scale (abs scale)])
(flomap-scale*-y fm scale (abs (fl->fx (ceiling (* (exact->inexact h) scale))))))]))
(: flomap-resize-x (flomap Integer -> flomap))
(define (flomap-resize-x fm width)
(match-define (flomap _ c w h) fm)
(cond [(= 0 width) (make-flomap c 0 h)]
[else (let ([width (abs width)])
(flomap-scale*-x fm (abs (exact->inexact (/ width w))) width))]))
(: flomap-resize-y (flomap Integer -> flomap))
(define (flomap-resize-y fm height)
(match-define (flomap _ c w h) fm)
(cond [(= 0 height) (make-flomap c w 0)]
[else (let ([height (abs height)])
(flomap-scale*-y fm (abs (exact->inexact (/ height h))) height))]))
;; standard deviation of an unscaled box filter (i.e. f([-1/2,1/2]) = {1}, zero elsewhere)
(define box-filter-variance (/ 1.0 12.0))
;; standard deviation of an unscaled triangle filter (simulates effect of linear interpolation)
(define triangle-filter-variance (/ 1.0 24.0))
;; calculates the standard deviation of downscaling blur, assuming linear interpolation will be
;; carried out on the blurred image
(: stddev-for-scale (Nonnegative-Flonum -> Nonnegative-Flonum))
(define (stddev-for-scale scale)
(define var (- (/ box-filter-variance (sqr scale))
triangle-filter-variance))
(abs (flsqrt (max 0.0 var))))
(: flomap-scale*-x (flomap Nonnegative-Flonum Exact-Nonnegative-Integer -> flomap))
(define (flomap-scale*-x fm scale width)
(cond [(scale . = . 1.0) fm]
[(scale . > . 1.0) (flomap-scale*-x/linear fm scale width)]
[else (define low-res-fm
(flomap-gaussian-blur-x fm (stddev-for-scale scale)))
(flomap-scale*-x/linear low-res-fm scale width)]))
(: flomap-scale*-y (flomap Nonnegative-Flonum Exact-Nonnegative-Integer -> flomap))
(define (flomap-scale*-y fm scale height)
(cond [(scale . = . 1.0) fm]
[(scale . > . 1.0) (flomap-scale*-y/linear fm scale height)]
[else (define low-res-fm
(flomap-gaussian-blur-y fm (stddev-for-scale scale)))
(flomap-scale*-y/linear low-res-fm scale height)]))
(: flomap-scale*-x/linear (flomap Nonnegative-Flonum Exact-Nonnegative-Integer -> flomap))
(define (flomap-scale*-x/linear fm s new-w)
(match-define (flomap vs c w h) fm)
(define w-1 (fx- w 1))
(inline-build-flomap
c new-w h
(λ (k new-x y _i)
(define scaled-x (- (/ (+ (fx->fl new-x) 0.5) s) 0.5))
(define floor-scaled-x (floor scaled-x))
(define x0 (fl->fx floor-scaled-x))
(cond [(or (x0 . fx< . 0) (x0 . fx>= . w)) 0.0]
[else
(define i0 (coords->index c w k x0 y))
(define v0 (flvector-ref vs i0))
(define v1 (cond [(x0 . fx= . w-1) 0.0]
[else (flvector-ref vs (unsafe-fx+ i0 c))]))
(fl-convex-combination v0 v1 (- scaled-x floor-scaled-x))]))))
(: flomap-scale*-y/linear (flomap Nonnegative-Flonum Exact-Nonnegative-Integer -> flomap))
(define (flomap-scale*-y/linear fm s new-h)
(match-define (flomap vs c w h) fm)
(define h-1 (fx- h 1))
(define cw (* c w))
(inline-build-flomap
c w new-h
(λ (k x new-y _i)
(define scaled-y (- (/ (+ (fx->fl new-y) 0.5) s) 0.5))
(define floor-scaled-y (floor scaled-y))
(define y0 (fl->fx floor-scaled-y))
(cond [(or (y0 . fx< . 0) (y0 . fx>= . h)) 0.0]
[else
(define i0 (coords->index c w k x y0))
(define v0 (flvector-ref vs i0))
(define v1 (cond [(y0 . fx= . h-1) 0.0]
[else (flvector-ref vs (unsafe-fx+ i0 cw))]))
(fl-convex-combination v0 v1 (- scaled-y floor-scaled-y))]))))