module Graphics.Curves.Image
( module Graphics.Curves.Image
, (<>) )
where
import Control.Applicative
import Data.Monoid
import Data.List
import Data.Maybe
import Graphics.Curves.Math
import Graphics.Curves.Colour
import Graphics.Curves.Curve
import Graphics.Curves.BoundingBox
import Graphics.Curves.Attribute
type Op a = a -> a -> a
data Image = ICurve Curves
| Combine (Op (Maybe Colour)) Image Image
| IEmpty
type BlendFunc = Maybe Colour -> Maybe Colour -> Maybe Colour
unionBlend :: BlendFunc
unionBlend c1 c2 = case (c1, c2) of
(Nothing, c) -> c
(c, Nothing) -> c
(Just c1, Just c2) -> Just (blend c1 c2)
intersectBlend :: BlendFunc
intersectBlend c1 c2 = case (c1, c2) of
(_, Nothing) -> Nothing
(Nothing, _) -> Nothing
(Just c1, Just c2) -> Just $ setAlpha (getAlpha c2 * getAlpha c1) (blend c1 c2)
diffBlend :: BlendFunc
diffBlend c c' = case c' of
Nothing -> c
Just c' -> opacity (1 getAlpha c') <$> c
instance Monoid Image where
mempty = IEmpty
mappend a b = Combine unionBlend a b
combine :: BlendFunc -> Image -> Image -> Image
combine f a b = Combine f a b
mapColour :: (Colour -> Colour) -> Image -> Image
mapColour f = combine (const $ fmap f) IEmpty
infixr 7 ><
infixl 8 <->
(><) :: Image -> Image -> Image
a >< b = combine intersectBlend a b
(<->) :: Image -> Image -> Image
a <-> b = combine diffBlend a b
curve :: Scalar -> Scalar -> (Scalar -> Point) -> Image
curve t0 t1 f = curve' t0 t1 f (const id)
curve_ :: (Scalar -> Point) -> Image
curve_ = curve 0 1
curve' :: Transformable a => Scalar -> Scalar -> (Scalar -> a) -> (Scalar -> a -> Point) -> Image
curve' t0 t1 f g = ICurve $ Curves [Curve (f . tr) (g . tr) (\_ _ _ -> defaultCurveLineStyle) 1] defaultCurveFillStyle
where
tr t = t0 + t * (t1 t0)
curveLength :: Scalar -> Image -> Scalar
curveLength _ IEmpty = 0
curveLength r (ICurve (Curves cs _)) = sum $ map (curveLength' r) cs
curveLength r (Combine _ i j) = curveLength r i + curveLength r j
mapCurves :: (Curves -> Curves) -> Image -> Image
mapCurves f IEmpty = IEmpty
mapCurves f (ICurve c) = ICurve (f c)
mapCurves f (Combine b i j) = Combine b (mapCurves f i) (mapCurves f j)
mapCurve :: (Curve -> Curve) -> Image -> Image
mapCurve f = mapCurves (\(Curves cs s) -> Curves (map f cs) s)
reverseImage :: Image -> Image
reverseImage = mapCurve reverseCurve
freezeImageSize :: Point -> Image -> Image
freezeImageSize p = mapCurve (freezeCurve fr p)
where
fr = Freeze{ freezeSize = True, freezeOrientation = False }
freezeImageOrientation :: Point -> Image -> Image
freezeImageOrientation p = mapCurve (freezeCurve fr p)
where
fr = Freeze{ freezeSize = False, freezeOrientation = True }
freezeImage :: Point -> Image -> Image
freezeImage p = mapCurve (freezeCurve fr p)
where
fr = Freeze{ freezeSize = True, freezeOrientation = True }
unfreezeImage :: Image -> Image
unfreezeImage = mapCurve unfreeze
where
unfreeze (Curve f g st n) = Curve (\t -> g t (f t)) (const id) st n
instance HasAttribute CurveAttribute Image where
modifyAttribute attr f = mapCurves (modifyAttribute attr f)
instance Transformable Image where
transform f = mapCurves (transform f)
infixl 9 ++>
infixr 8 +++, <++
(+++) :: Image -> Image -> Image
ICurve c1 +++ ICurve c2 = ICurve $ joinCurve c1 c2
i +++ IEmpty = i
IEmpty +++ i = i
Combine f i j +++ c = Combine f i (j +++ c)
c +++ Combine f i j = Combine f (c +++ i) j
(<++) :: Point -> Image -> Image
p <++ ICurve c = ICurve $ prependPoint p c
p <++ Combine b i j = Combine b (p <++ i) j
p <++ IEmpty = point p
(++>) :: Image -> Point -> Image
ICurve cs ++> p = ICurve $ appendPoint cs p
IEmpty ++> p = point p
Combine b i j ++> p = Combine b i (j ++> p)
(+.+) :: Image -> Image -> Image
ICurve (Curves cs1 s) +.+ ICurve (Curves cs2 _) = ICurve $ Curves (cs1 ++ cs2) s
i +.+ IEmpty = i
IEmpty +.+ i = i
Combine f i j +.+ c = Combine f i (j +.+ c)
c +.+ Combine f i j = Combine f (c +.+ i) j
line :: Point -> Point -> Image
line p q = curve_ (interpolate p q)
point :: Point -> Image
point p = curve_ (const p)
circle :: Point -> Scalar -> Image
circle p r = circleSegment p r 0 (2 * pi)
circleSegment :: Point -> Scalar -> Scalar -> Scalar -> Image
circleSegment c r a b | b < a = reverseImage $ circleSegment c r b a
circleSegment (Vec x y) r a b =
curve a b (\α -> Vec (x + r * cos α) (y + r * sin α))
lineStrip :: [Point] -> Image
lineStrip [] = error "lineStrip: []"
lineStrip [p] = point p
lineStrip [p, q] = line p q
lineStrip [p, q, r] = p <++ line q r
lineStrip ps = lineStrip qs +++ lineStrip rs
where
(qs, rs) = splitAt (div (length ps) 2) ps
poly :: [Point] -> Image
poly (p:ps) = lineStrip ([p] ++ ps ++ [p])
poly [] = error "poly: []"
differentiate :: Image -> Image
differentiate = mapCurve differentiateCurve
mapImage :: (Scalar -> Point -> Point) -> Image -> Image
mapImage h = mapCurve pp
where
pp (Curve f g st n) = Curve f (\t -> h t . g t) st n
transformImage :: (forall a. Transformable a => Scalar -> a -> a) -> Image -> Image
transformImage h = mapCurve pp
where
pp (Curve f g st n) = Curve (\t -> h t (f t)) g st n
zipImage :: (Scalar -> Point -> Point -> Point) -> Image -> Image -> Image
zipImage f (ICurve c) (ICurve c') = ICurve (zipCurves f c c')
zipImage f IEmpty IEmpty = IEmpty
zipImage f (Combine g a b) (Combine _ c d) =
Combine g (zipImage f a c) (zipImage f b d)
bSpline :: [Point] -> Image
bSpline ps = foldl1 (+++) $ map seg (takeWhile ((>=4).length) $ map (take 4) (tails ps))
where
m = map (map (/ 6)) [[1, 3, 3, 1], [3, 6, 0, 4], [3, 3, 3, 1], [1, 0, 0, 0]]
coefs t = map diag $ mmul [t^3, t^2, t, 1] m
mmul v m = map (vmul v) m
vmul u v = sum $ zipWith (*) u v
seg ps = curve_ f
where
f t = vmul (coefs t) ps
closedBSpline :: [Point] -> Image
closedBSpline ps = bSpline $ ps ++ take 3 ps
bSpline' (p:ps) = bSpline $ p:p:p:ps ++ replicate 2 (last (p:ps))
bSpline' [] = error "bSpline': empty list"
bezierSegment :: [Point] -> Image
bezierSegment [] = error "bezierSegment: empty list"
bezierSegment [p] = point p
bezierSegment ps = zipImage (\t p q -> interpolate p q t) (bezierSegment (init ps)) (bezierSegment (tail ps))
bezier :: [Point] -> Image
bezier ps | n < 4 || mod n 3 /= 1 = error "bezier: needs 3k + 1 points (k > 0)"
where n = length ps
bezier ps = foldr1 (+++) (map bezierSegment $ quads ps)
where
quads [p] = []
quads (p0:p1:p2:p3:ps) = [p0, p1, p2, p3] : quads (p3:ps)