107 lines
4.4 KiB
Racket
107 lines
4.4 KiB
Racket
#lang typed/racket/base
|
||
|
||
(require racket/math racket/match racket/list
|
||
"flonum.rkt"
|
||
"flomap-struct.rkt"
|
||
"flomap-stats.rkt"
|
||
"flomap-pointwise.rkt"
|
||
"flomap-blur.rkt"
|
||
"flomap-composite.rkt"
|
||
"flomap-resize.rkt"
|
||
"flomap-transform.rkt")
|
||
|
||
(provide flomap-shadow flomap-outline
|
||
flomap-whirl-morph)
|
||
|
||
(: colorize-alpha (flomap (U (Vectorof Real) FlVector) -> flomap))
|
||
(define (colorize-alpha fm vs)
|
||
(match-define (flomap _ 1 w h) fm)
|
||
(fm* fm (make-flomap* w h vs)))
|
||
|
||
(: shadow-color (Integer (Option (U (Vectorof Real) FlVector)) -> (U (Vectorof Real) FlVector)))
|
||
(define (shadow-color c color)
|
||
(cond [color color]
|
||
[else (define vs (make-flvector c))
|
||
(flvector-set! vs 0 1.0)
|
||
vs]))
|
||
|
||
(: flomap-shadow (case-> (flomap Real -> flomap)
|
||
(flomap Real (Option (U (Vectorof Real) FlVector)) -> flomap)))
|
||
(define flomap-shadow
|
||
(case-lambda
|
||
[(fm σ) (flomap-shadow fm σ #f)]
|
||
[(fm σ color)
|
||
(define c (flomap-components fm))
|
||
(cond [(= c 0) (raise-type-error 'flomap-shadow "flomap with at least one component" fm)]
|
||
[(= c 1) (flomap-blur fm σ)]
|
||
[else (colorize-alpha (flomap-blur (flomap-ref-component fm 0) σ)
|
||
(shadow-color c color))])]))
|
||
|
||
(: flomap-outline (case-> (flomap Real -> flomap)
|
||
(flomap Real (Option (U (Vectorof Real) FlVector)) -> flomap)))
|
||
(define flomap-outline
|
||
(case-lambda
|
||
[(fm amt) (flomap-outline fm amt #f)]
|
||
[(fm amt color)
|
||
(define c (flomap-components fm))
|
||
(unless (c . > . 0)
|
||
(raise-type-error 'flomap-outline "flomap with at least one component" fm))
|
||
(let ([amt (real->double-flonum amt)])
|
||
(define σ (* 0.5 (max 1.0 amt)))
|
||
(define ceiling-amt (fl->fx (ceiling amt)))
|
||
(define test-size (fx* 2 (fx+ 1 ceiling-amt)))
|
||
(define test-mid (fxquotient test-size 2))
|
||
(define alpha-fm (flomap-ref-component fm 0))
|
||
(define-values (a-min a-max) (flomap-extreme-values alpha-fm))
|
||
(define a-size (- a-max a-min))
|
||
(define test-fm (inline-build-flomap 1 test-size 1
|
||
(λ (k x y i) (if (x . fx>= . test-mid) a-max a-min))))
|
||
(define blur-test-fm (flomap-blur-x test-fm σ))
|
||
(define v-min (flomap-bilinear-ref blur-test-fm 0 (+ 0.5 (- test-mid amt 1.0)) 0.5))
|
||
(define v-max (flomap-bilinear-ref blur-test-fm 0 (+ 0.5 (- test-mid amt)) 0.5))
|
||
(define av-scale (/ a-size (- v-max v-min)))
|
||
(let* ([outline-fm (flomap-blur alpha-fm σ)]
|
||
[outline-fm ((inline-flomap-lift
|
||
(λ (v) (+ a-min (max 0.0 (min a-size (* av-scale (- v v-min)))))))
|
||
outline-fm)]
|
||
[outline-fm ((inline-flomap-lift2
|
||
'subtract-alpha
|
||
(λ (o a) (if (= a 1.0) 0.0 (/ (- o a) (- 1.0 a)))))
|
||
outline-fm alpha-fm)])
|
||
(define color-vs (shadow-color c color))
|
||
(colorize-alpha outline-fm color-vs)))]))
|
||
|
||
(define blend-start 1/3)
|
||
(define blend-end 2/3)
|
||
|
||
(: flomap-whirl-morph (flomap flomap -> (Real -> flomap)))
|
||
(define (flomap-whirl-morph fm1 fm2)
|
||
(define w (max (flomap-width fm1) (flomap-width fm2)))
|
||
(define h (max (flomap-height fm1) (flomap-height fm2)))
|
||
(let ([fm1 (flomap-cc-crop fm1 w h)]
|
||
[fm2 (flomap-cc-crop fm2 w h)])
|
||
|
||
(define: (whirled-fm1 [t : Real]) : flomap
|
||
(define t1 (sqr t))
|
||
(define trans1
|
||
(flomap-transform-compose (flomap-rotate-transform (* t1 (* -1 pi)))
|
||
(flomap-whirl-transform (* t1 (* -8 pi)))))
|
||
(flomap-transform fm1 trans1 0 0 w h))
|
||
|
||
(define: (whirled-fm2 [t : Real]) : flomap
|
||
(define t2 (sqr (- 1 t)))
|
||
(define trans2
|
||
(flomap-transform-compose (flomap-rotate-transform (* t2 (* 1 pi)))
|
||
(flomap-whirl-transform (* t2 (* 8 pi)))))
|
||
(flomap-transform fm2 trans2 0 0 w h))
|
||
|
||
(λ (t)
|
||
(cond [(t . <= . 0) fm1]
|
||
[(t . >= . 1) fm2]
|
||
[else
|
||
(cond [(t . <= . blend-start) (whirled-fm1 t)]
|
||
[(t . >= . blend-end) (whirled-fm2 t)]
|
||
[else
|
||
(define b (/ (- t blend-start) (- blend-end blend-start)))
|
||
(fm+ (fm* (- 1 b) (whirled-fm1 t)) (fm* b (whirled-fm2 t)))])]))))
|