141 lines
6.8 KiB
Racket
141 lines
6.8 KiB
Racket
#lang typed/racket/base
|
|
|
|
(require racket/match racket/unsafe/ops
|
|
"flonum.rkt"
|
|
"flomap-struct.rkt")
|
|
|
|
(provide flomap-pin flomap-pin*
|
|
flomap-lt-superimpose flomap-lc-superimpose flomap-lb-superimpose
|
|
flomap-ct-superimpose flomap-cc-superimpose flomap-cb-superimpose
|
|
flomap-rt-superimpose flomap-rc-superimpose flomap-rb-superimpose
|
|
flomap-vl-append flomap-vc-append flomap-vr-append
|
|
flomap-ht-append flomap-hc-append flomap-hb-append)
|
|
|
|
(: flomap-pin (case-> (flomap Integer Integer flomap -> flomap)
|
|
(flomap Integer Integer flomap Integer Integer -> flomap)))
|
|
(define flomap-pin
|
|
(case-lambda
|
|
[(fm1 x1 y1 fm2)
|
|
(match-define (flomap argb1-vs c w1 h1) fm1)
|
|
(match-define (flomap argb2-vs c2 w2 h2) fm2)
|
|
|
|
(unless (c . > . 0)
|
|
(raise-type-error 'flomap-pin "flomap with at least one component" fm1))
|
|
|
|
(unless (= c c2)
|
|
(error 'flomap-pin
|
|
(string-append "expected two flomaps with the same number of components; "
|
|
"given one with ~e and one with ~e")
|
|
c c2))
|
|
|
|
;; fm1 and fm2 offsets, in final image coordinates
|
|
(define dx1 (fxmax 0 (fx- 0 x1)))
|
|
(define dy1 (fxmax 0 (fx- 0 y1)))
|
|
(define dx2 (fxmax 0 x1))
|
|
(define dy2 (fxmax 0 y1))
|
|
|
|
;; final image size
|
|
(define w (fxmax (unsafe-fx+ dx1 w1) (unsafe-fx+ dx2 w2)))
|
|
(define h (fxmax (unsafe-fx+ dy1 h1) (unsafe-fx+ dy2 h2)))
|
|
|
|
(define argb-vs (make-flvector (* c w h)))
|
|
(let: y-loop : Void ([y : Nonnegative-Fixnum 0])
|
|
(when (y . fx< . h)
|
|
(define y1 (unsafe-fx- y dy1))
|
|
(define y2 (unsafe-fx- y dy2))
|
|
(let: x-loop : Void ([x : Nonnegative-Fixnum 0])
|
|
(cond
|
|
[(x . fx< . w)
|
|
(define x1 (unsafe-fx- x dx1))
|
|
(define x2 (unsafe-fx- x dx2))
|
|
|
|
(define i (coords->index c w 0 x y))
|
|
(define-values (i1 a1)
|
|
(cond [(and (x1 . fx>= . 0) (x1 . fx< . w1) (y1 . fx>= . 0) (y1 . fx< . h1))
|
|
(define i1 (coords->index c w1 0 x1 y1))
|
|
(values i1 (flvector-ref argb1-vs i1))]
|
|
[else (values 0 0.0)]))
|
|
(define-values (i2 a2)
|
|
(cond [(and (x2 . fx>= . 0) (x2 . fx< . w2) (y2 . fx>= . 0) (y2 . fx< . h2))
|
|
(define i2 (coords->index c w2 0 x2 y2))
|
|
(values i2 (flvector-ref argb2-vs i2))]
|
|
[else (values 0 0.0)]))
|
|
|
|
(cond
|
|
[(and (a1 . > . 0.0) (a2 . > . 0.0))
|
|
(let: k-loop : Void ([k : Nonnegative-Fixnum 0])
|
|
(cond [(k . fx< . c) (define v1 (flvector-ref argb1-vs (unsafe-fx+ i1 k)))
|
|
(define v2 (flvector-ref argb2-vs (unsafe-fx+ i2 k)))
|
|
(define v (fl-alpha-blend v1 v2 a2))
|
|
(flvector-set! argb-vs (unsafe-fx+ i k) v)
|
|
(k-loop (unsafe-fx+ k 1))]
|
|
[else (x-loop (unsafe-fx+ x 1))]))]
|
|
[(a1 . > . 0.0)
|
|
(let: k-loop : Void ([k : Nonnegative-Fixnum 0])
|
|
(cond [(k . fx< . c) (define v1 (flvector-ref argb1-vs (unsafe-fx+ i1 k)))
|
|
(flvector-set! argb-vs (unsafe-fx+ i k) v1)
|
|
(k-loop (unsafe-fx+ k 1))]
|
|
[else (x-loop (unsafe-fx+ x 1))]))]
|
|
[(a2 . > . 0.0)
|
|
(let: k-loop : Void ([k : Nonnegative-Fixnum 0])
|
|
(cond [(k . fx< . c) (define v2 (flvector-ref argb2-vs (unsafe-fx+ i2 k)))
|
|
(flvector-set! argb-vs (unsafe-fx+ i k) v2)
|
|
(k-loop (unsafe-fx+ k 1))]
|
|
[else (x-loop (unsafe-fx+ x 1))]))]
|
|
[else (x-loop (unsafe-fx+ x 1))])]
|
|
[else (y-loop (unsafe-fx+ y 1))]))))
|
|
(flomap argb-vs c w h)]
|
|
[(fm1 x1 y1 fm2 x2 y2) (flomap-pin fm1 (- x1 x2) (- y1 y2) fm2)]))
|
|
|
|
(: flomap-pin* (Real Real Real Real flomap flomap * -> flomap))
|
|
(define (flomap-pin* x1-frac y1-frac x2-frac y2-frac fm0 . fms)
|
|
(define-values (fm _x _y)
|
|
(for/fold: ([fm : flomap fm0]
|
|
[x : Exact-Rational 0]
|
|
[y : Exact-Rational 0]
|
|
) ([fm1 : flomap (in-list (cons fm0 fms))]
|
|
[fm2 : flomap (in-list fms)])
|
|
(define-values (w1 h1) (flomap-size fm1))
|
|
(define-values (w2 h2) (flomap-size fm2))
|
|
(define x1 (+ x (- (inexact->exact (* x1-frac w1))
|
|
(inexact->exact (* x2-frac w2)))))
|
|
(define y1 (+ y (- (inexact->exact (* y1-frac h1))
|
|
(inexact->exact (* y2-frac h2)))))
|
|
(values (flomap-pin fm (round x1) (round y1) fm2)
|
|
(max 0 x1) (max 0 y1))))
|
|
fm)
|
|
|
|
(: flomap-lt-superimpose (flomap flomap * -> flomap))
|
|
(: flomap-lc-superimpose (flomap flomap * -> flomap))
|
|
(: flomap-lb-superimpose (flomap flomap * -> flomap))
|
|
(: flomap-ct-superimpose (flomap flomap * -> flomap))
|
|
(: flomap-cc-superimpose (flomap flomap * -> flomap))
|
|
(: flomap-cb-superimpose (flomap flomap * -> flomap))
|
|
(: flomap-rt-superimpose (flomap flomap * -> flomap))
|
|
(: flomap-rc-superimpose (flomap flomap * -> flomap))
|
|
(: flomap-rb-superimpose (flomap flomap * -> flomap))
|
|
|
|
(define (flomap-lt-superimpose fm . fms) (apply flomap-pin* 0 0 0 0 fm fms))
|
|
(define (flomap-lc-superimpose fm . fms) (apply flomap-pin* 0 1/2 0 1/2 fm fms))
|
|
(define (flomap-lb-superimpose fm . fms) (apply flomap-pin* 0 1 0 1 fm fms))
|
|
(define (flomap-ct-superimpose fm . fms) (apply flomap-pin* 1/2 0 1/2 0 fm fms))
|
|
(define (flomap-cc-superimpose fm . fms) (apply flomap-pin* 1/2 1/2 1/2 1/2 fm fms))
|
|
(define (flomap-cb-superimpose fm . fms) (apply flomap-pin* 1/2 1 1/2 1 fm fms))
|
|
(define (flomap-rt-superimpose fm . fms) (apply flomap-pin* 1 0 1 0 fm fms))
|
|
(define (flomap-rc-superimpose fm . fms) (apply flomap-pin* 1 1/2 1 1/2 fm fms))
|
|
(define (flomap-rb-superimpose fm . fms) (apply flomap-pin* 1 1 1 1 fm fms))
|
|
|
|
(: flomap-vl-append (flomap flomap * -> flomap))
|
|
(: flomap-vc-append (flomap flomap * -> flomap))
|
|
(: flomap-vr-append (flomap flomap * -> flomap))
|
|
(: flomap-ht-append (flomap flomap * -> flomap))
|
|
(: flomap-hc-append (flomap flomap * -> flomap))
|
|
(: flomap-hb-append (flomap flomap * -> flomap))
|
|
|
|
(define (flomap-vl-append fm . fms) (apply flomap-pin* 0 1 0 0 fm fms))
|
|
(define (flomap-vc-append fm . fms) (apply flomap-pin* 1/2 1 1/2 0 fm fms))
|
|
(define (flomap-vr-append fm . fms) (apply flomap-pin* 1 1 1 0 fm fms))
|
|
(define (flomap-ht-append fm . fms) (apply flomap-pin* 1 0 0 0 fm fms))
|
|
(define (flomap-hc-append fm . fms) (apply flomap-pin* 1 1/2 0 1/2 fm fms))
|
|
(define (flomap-hb-append fm . fms) (apply flomap-pin* 1 1 0 1 fm fms))
|