<|start_filename|>src/Graphics/Rasterific/Outline.hs<|end_filename|>
-- | This module provide helper functions to create outline
-- of  shapes.
module Graphics.Rasterific.Outline
    ( StrokeWidth
    , strokize
    , S.dashedStrokize 
    , S.approximatePathLength
    ) where

import Graphics.Rasterific.Types
import qualified Graphics.Rasterific.StrokeInternal as S

-- | This function will create the outline of a given geometry
-- given a path. You can then stroke it.
--
-- > stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0) $
-- >     strokize 40 JoinRound (CapRound, CapRound) $
-- >         CubicBezier (V2  40 160) (V2 40   40)
-- >                     (V2 160  40) (V2 160 160)
--
-- <<docimages/strokize_path.png>>
--
strokize :: Geometry geom
         => StrokeWidth -- ^ Stroke width
         -> Join        -- ^ Which kind of join will be used
         -> (Cap, Cap)  -- ^ Start and end capping.
         -> geom        -- ^ List of elements to strokize
         -> [Primitive]
strokize w j c = listOfContainer . S.strokize w j c



<|start_filename|>src/Graphics/Rasterific/QuadraticFormula.hs<|end_filename|>
module Graphics.Rasterific.QuadraticFormula( QuadraticFormula( .. )
                                           , discriminant
                                           , formulaRoots
                                           ) where

-- | Represent an equation `a * x^2 + b * x + c = 0`
data QuadraticFormula a = QuadraticFormula
    { _coeffA :: !a -- ^ Coefficient for the square part (x^2)
    , _coeffB :: !a -- ^ Coefficient the linear part (x)
    , _coeffC :: !a -- ^ Constant
    }

instance Functor QuadraticFormula where
    {-# INLINE fmap #-}
    fmap f (QuadraticFormula a b c) =
        QuadraticFormula (f a) (f b) (f c)

instance Applicative QuadraticFormula where
  pure a = QuadraticFormula a a a
  {-# INLINE pure #-}

  QuadraticFormula a b c <*> QuadraticFormula d e f =
      QuadraticFormula (a d) (b e) (c f)
  {-# INLINE (<*>) #-}

-- | Discriminant equation, if the result is:
--
--  * Below 0, then the formula doesn't have any solution
--
--  * Equal to 0, then the formula has an unique root.
--
--  * Above 0, the formula has two solutions
--
discriminant :: Num a => QuadraticFormula a -> a
discriminant (QuadraticFormula a b c) = b * b - 4 * a *c

-- | Extract all the roots of the formula ie. where the
-- unknown gives a result of 0
formulaRoots :: (Ord a, Floating a) => QuadraticFormula a -> [a]
formulaRoots formula@(QuadraticFormula a b _)
  | disc < 0 = []
  | disc == 0 = [positiveResult]
  | otherwise = [positiveResult, negativeResult]
  where
    disc = discriminant formula
    squarePart = sqrt disc
    positiveResult = (negate b + squarePart) / (2 * a)
    negativeResult = (negate b - squarePart) / (2 * a)



<|start_filename|>exec-src/snowflake.hs<|end_filename|>
import Control.Monad( replicateM )
import Data.Monoid( (<>) )
import qualified Data.Vector as V
import Codec.Picture
    ( Image
    , PixelRGBA8( .. )
    , writePng
    )
import Graphics.Rasterific
    ( Drawing
    , Bezier( .. )
    , V2( .. )
    , Point
    , fill
    , withTransformation
    , withTexture
    , renderDrawing
    )
import Graphics.Rasterific.Transformations
    ( Transformation
    , translate
    , scale
    , rotate
    )

import Graphics.Rasterific.Texture( uniformTexture )
import System.Random( randomRIO )
import Criterion( whnf, bench )
import Criterion.Main( defaultMain )

snowflakeColor :: PixelRGBA8
snowflakeColor = PixelRGBA8 255 229 255 178

snowflake :: [Bezier]
snowflake =
   let b x1 y1 x2 y2 x3 y3 = Bezier (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) in
   [b 16.8063 (-26.3434) 17.7989 (-25.3508) 16.8009 (-22.7501),
    b 16.8009 (-22.7501) 16.3070 (-21.4629) 16.5456 (-21.1093),
    b 16.5456 (-21.1093) 16.6644 (-20.9332) 16.9645 (-20.9931),
    b 16.9645 (-20.9931) 17.2654 (-21.0532) 17.7455 (-21.3499),
    b 17.7455 (-21.3499) 18.6092 (-21.8837) 19.1487 (-21.5293),
    b 19.1487 (-21.5293) 19.6882 (-21.1749) 19.6882 (-20.0737),
    b 19.6882 (-20.0737) 19.6882 (-17.5969) 16.1479 (-16.4732),
    b 16.1479 (-16.4732) 14.0548 (-15.8089) 13.8003 (-15.2770),
    b 13.8003 (-15.2770) 13.6623 (-14.9887) 13.9414 (-14.6446),
    b 13.9414 (-14.6446) 14.2041 (-14.3207) 14.9025 (-13.8707),
    b 14.9025 (-13.8707) 16.3494 (-12.9382) 16.3133 (-12.3628),
    b 16.3133 (-12.3628) 16.2771 (-11.7875) 14.7068 (-10.7566),
    b 14.7068 (-10.7566) 12.2161 (-9.1216) 10.3181 (-9.0962),
    b 10.3181 (-9.0962) 8.4202 (-9.0707) 7.4644 (-6.5800),
    b 7.4644 (-6.5800) 7.0056 (-5.3844) 7.6667 (-4.7020),
    b 7.6667 (-4.7020) 8.2718 (-4.0775) 9.5712 (-4.0812),
    b 9.5712 (-4.0812) 12.6401 (-4.0898) 14.7238 (-6.6005),
    b 14.7238 (-6.6005) 15.9127 (-8.0330) 16.8479 (-8.1677),
    b 16.8479 (-8.1677) 17.7831 (-8.3023) 19.0783 (-7.2274),
    b 19.0783 (-7.2274) 20.3558 (-6.1671) 21.3969 (-6.2071),
    b 21.3969 (-6.2071) 22.4379 (-6.2471) 23.8394 (-7.4103),
    b 23.8394 (-7.4103) 24.8668 (-8.2629) 25.5985 (-8.5665),
    b 25.5985 (-8.5665) 25.9438 (-8.7099) 26.1336 (-8.6820),
    b 26.1336 (-8.6820) 26.2297 (-8.6679) 26.2793 (-8.6092),
    b 26.2793 (-8.6092) 26.3301 (-8.5490) 26.3301 (-8.4438),
    b 26.3301 (-8.4438) 26.3301 (-5.0516) 28.9388 (-3.5917),
    b 28.9388 (-3.5917) 31.2406 (-2.3035) 31.1691 (-0.4840),
    b 31.1691 (-0.4840) 31.0976 1.3355 28.5951 5.1548,
    b 28.5951 5.1548 26.7219 8.0136 25.8517 8.2511,
    b 25.8517 8.2511 24.9814 8.4887 22.9886 6.6852,
    b 22.9886 6.6852 21.0119 4.8963 20.3861 4.9237,
    b 20.3861 4.9237 19.7603 4.9510 19.0285 6.8582,
    b 19.0285 6.8582 18.2849 8.7960 17.6638 8.8069,
    b 17.6638 8.8069 17.0427 8.8178 14.9565 6.9298,
    b 14.9565 6.9298 11.9546 4.2131 8.9762 4.2131,
    b 8.9762 4.2131 7.1317 4.2131 6.9583 4.6873,
    b 6.9583 4.6873 6.7848 5.1614 8.0649 6.7038,
    b 8.0649 6.7038 10.1320 9.1945 12.3214 9.1945,
    b 12.3214 9.1945 14.7027 9.1945 15.6210 11.1190,
    b 15.6210 11.1190 16.0194 11.9541 15.8094 12.7617,
    b 15.8094 12.7617 15.5824 13.6348 14.7001 14.1801,
    b 14.7001 14.1801 14.1325 14.5309 13.9378 14.8353,
    b 13.9378 14.8353 13.7389 15.1460 13.9115 15.4341,
    b 13.9115 15.4341 14.2467 15.9936 16.1479 16.5970,
    b 16.1479 16.5970 18.7443 17.4211 19.5750 19.1195,
    b 19.5750 19.1195 19.9313 19.8481 19.6103 20.3129,
    b 19.6103 20.3129 19.2615 20.8179 18.2122 20.8179,
    b 18.2122 20.8179 17.6034 20.8179 17.2376 21.6705,
    b 17.2376 21.6705 16.8717 22.5231 16.9669 23.7204,
    b 16.9669 23.7204 17.1008 25.4064 15.8033 26.0897,
    b 15.8033 26.0897 14.5057 26.7730 10.7752 26.9810,
    b 10.7752 26.9810 6.0003 27.2472 5.2937 26.6088,
    b 5.2937 26.6088 4.5872 25.9703 5.2663 22.0029,
    b 5.2663 22.0029 5.6431 19.8017 5.6598 18.8439,
    b 5.6598 18.8439 5.6678 18.3914 5.5838 18.3574,
    b 5.5838 18.3574 5.5413 18.3400 5.4768 18.4343,
    b 5.4768 18.4343 5.4106 18.5310 5.3234 18.7423,
    b 5.3234 18.7423 4.7144 20.2184 4.0071 20.6781,
    b 4.0071 20.6781 3.3408 21.1112 2.7449 20.5553,
    b 2.7449 20.5553 1.4230 19.3223 1.4230 15.1042,
    b 1.4230 15.1042 1.4230 9.3905 (-0.2375) 8.3643,
    b (-0.2375) 8.3643 (-0.9317) 7.9353 (-1.3335) 8.1224,
    b (-1.3335) 8.1224 (-1.7565) 8.3193 (-1.9463) 9.2332,
    b (-1.9463) 9.2332 (-2.3005) 10.9392 (-1.9242) 16.4867,
    b (-1.9242) 16.4867 (-1.7256) 19.4124 (-2.2139) 20.1385,
    b (-2.2139) 20.1385 (-2.7021) 20.8646 (-4.4236) 20.2040,
    b (-4.4236) 20.2040 (-5.3338) 19.8547 (-5.8063) 19.8228,
    b (-5.8063) 19.8228 (-6.3221) 19.7879 (-6.5134) 20.1092,
    b (-6.5134) 20.1092 (-6.8561) 20.6848 (-6.2197) 23.2205,
    b (-6.2197) 23.2205 (-5.4941) 26.1115 (-6.2628) 26.6654,
    b (-6.2628) 26.6654 (-7.0315) 27.2192 (-11.4315) 26.9754,
    b (-11.4315) 26.9754 (-14.6467) 26.7972 (-16.1596) 26.1096,
    b (-16.1596) 26.1096 (-17.6725) 25.4220 (-17.6725) 24.1388,
    b (-17.6725) 24.1388 (-17.6725) 21.6481 (-20.1399) 20.1010,
    b (-20.1399) 20.1010 (-20.9108) 19.6177 (-21.1498) 19.2429,
    b (-21.1498) 19.2429 (-21.4069) 18.8398 (-21.1359) 18.4415,
    b (-21.1359) 18.4415 (-20.6423) 17.7160 (-17.6492) 16.4398,
    b (-17.6492) 16.4398 (-15.6040) 15.5678 (-14.7573) 14.9247,
    b (-14.7573) 14.9247 (-14.3575) 14.6212 (-14.3520) 14.4467,
    b (-14.3520) 14.4467 (-14.3492) 14.3583 (-14.4510) 14.3090,
    b (-14.4510) 14.3090 (-14.5554) 14.2584 (-14.7667) 14.2508,
    b (-14.7667) 14.2508 (-16.0660) 14.2039 (-16.5691) 13.6374,
    b (-16.5691) 13.6374 (-17.0373) 13.1100 (-16.7011) 12.2910,
    b (-16.7011) 12.2910 (-15.9365) 10.4285 (-12.6911) 9.1945,
    b (-12.6911) 9.1945 (-8.5399) 7.6163 (-8.5399) 5.9147,
    b (-8.5399) 5.9147 (-8.5399) 4.9917 (-9.2468) 4.5611,
    b (-9.2468) 4.5611 (-9.9051) 4.1601 (-10.9785) 4.2876,
    b (-10.9785) 4.2876 (-13.4170) 4.5773 (-15.1818) 6.7038,
    b (-15.1818) 6.7038 (-17.2242) 9.1648 (-18.6937) 9.0888,
    b (-18.6937) 9.0888 (-19.3865) 9.0531 (-19.7678) 8.3917,
    b (-19.7678) 8.3917 (-20.1632) 7.7061 (-20.1632) 6.4465,
    b (-20.1632) 6.4465 (-20.1632) 5.4062 (-20.2449) 5.0202,
    b (-20.2449) 5.0202 (-20.2958) 4.7792 (-20.3888) 4.6657,
    b (-20.3888) 4.6657 (-20.4850) 4.5484 (-20.6388) 4.5510,
    b (-20.6388) 4.5510 (-21.1144) 4.5592 (-23.2585) 6.4995,
    b (-23.2585) 6.4995 (-25.4562) 8.4884 (-26.3237) 8.2555,
    b (-26.3237) 8.2555 (-27.1911) 8.0226 (-29.2418) 4.8929,
    b (-29.2418) 4.8929 (-32.8702) (-0.6449) (-27.2854) (-8.9222),
    b (-27.2854) (-8.9222) (-27.1923) (-9.0603) (-26.8440) (-8.9490),
    b (-26.8440) (-8.9490) (-26.5078) (-8.8416) (-25.9821) (-8.5181),
    b (-25.9821) (-8.5181) (-24.8684) (-7.8328) (-23.4944) (-6.5892),
    b (-23.4944) (-6.5892) (-21.2502) (-4.5582) (-20.7067) (-4.5148),
    b (-20.7067) (-4.5148) (-20.5369) (-4.5012) (-20.4282) (-4.6082),
    b (-20.4282) (-4.6082) (-20.3227) (-4.7121) (-20.2629) (-4.9421),
    b (-20.2629) (-4.9421) (-20.1632) (-5.3259) (-20.1632) (-6.3227),
    b (-20.1632) (-6.3227) (-20.1632) (-7.5823) (-19.7678) (-8.2679),
    b (-19.7678) (-8.2679) (-19.3865) (-8.9293) (-18.6937) (-8.9650),
    b (-18.6937) (-8.9650) (-17.2242) (-9.0410) (-15.1818) (-6.5800),
    b (-15.1818) (-6.5800) (-13.1147) (-4.0893) (-9.5819) (-4.1446),
    b (-9.5819) (-4.1446) (-8.0423) (-4.1686) (-7.6019) (-4.2262),
    b (-7.6019) (-4.2262) (-7.2663) (-4.2701) (-7.1145) (-4.3531),
    b (-7.1145) (-4.3531) (-6.9551) (-4.4401) (-6.9655) (-4.5868),
    b (-6.9655) (-4.5868) (-6.9938) (-4.9877) (-9.8075) (-7.3346),
    b (-9.8075) (-7.3346) (-13.5659) (-10.4694) (-15.6191) (-11.3041),
    b (-15.6191) (-11.3041) (-16.7771) (-11.7748) (-16.7006) (-12.3216),
    b (-16.7006) (-12.3216) (-16.6241) (-12.8683) (-15.2684) (-13.8117),
    b (-15.2684) (-13.8117) (-14.5195) (-14.3327) (-14.2754) (-14.6893),
    b (-14.2754) (-14.6893) (-14.0134) (-15.0721) (-14.2475) (-15.3790),
    b (-14.2475) (-15.3790) (-14.6746) (-15.9388) (-17.4163) (-16.6270),
    b (-17.4163) (-16.6270) (-20.4849) (-17.3971) (-21.2071) (-19.6020),
    b (-21.2071) (-19.6020) (-21.5026) (-20.5042) (-20.9491) (-20.9641),
    b (-20.9491) (-20.9641) (-20.3358) (-21.4736) (-18.9057) (-21.1743),
    b (-18.9057) (-21.1743) (-18.2157) (-21.0299) (-17.7889) (-21.7606),
    b (-17.7889) (-21.7606) (-17.3621) (-22.4913) (-17.4528) (-23.6617),
    b (-17.4528) (-23.6617) (-17.5781) (-25.2795) (-16.2840) (-25.9644),
    b (-16.2840) (-25.9644) (-14.9899) (-26.6492) (-11.4315) (-26.8483),
    b (-11.4315) (-26.8483) (-7.0311) (-27.0944) (-6.2625) (-26.5413),
    b (-6.2625) (-26.5413) (-5.4940) (-25.9880) (-6.2197) (-23.0967),
    b (-6.2197) (-23.0967) (-6.8550) (-20.5656) (-6.5137) (-19.9873),
    b (-6.5137) (-19.9873) (-6.3235) (-19.6650) (-5.8107) (-19.6981),
    b (-5.8107) (-19.6981) (-5.3404) (-19.7284) (-4.4364) (-20.0753),
    b (-4.4364) (-20.0753) (-3.5146) (-20.4290) (-3.0272) (-20.4124),
    b (-3.0272) (-20.4124) (-2.4901) (-20.3941) (-2.2523) (-19.9329),
    b (-2.2523) (-19.9329) (-1.8302) (-19.1144) (-2.1761) (-15.6924),
    b (-2.1761) (-15.6924) (-2.7282) (-10.2301) (-0.6526) (-9.5121),
    b (-0.6526) (-9.5121) (-0.1235) (-9.3290) 0.2656 (-9.5565),
    b 0.2656 (-9.5565) 0.6565 (-9.7850) 0.9131 (-10.4319),
    b 0.9131 (-10.4319) 1.4230 (-11.7170) 1.4230 (-14.7440),
    b 1.4230 (-14.7440) 1.4230 (-19.1388) 2.7236 (-20.4008),
    b 2.7236 (-20.4008) 3.3172 (-20.9767) 4.0093 (-20.5495),
    b 4.0093 (-20.5495) 4.7393 (-20.0988) 5.4162 (-18.6185),
    b 5.4162 (-18.6185) 5.5129 (-18.4072) 5.5876 (-18.3117),
    b 5.5876 (-18.3117) 5.6605 (-18.2187) 5.7104 (-18.2384),
    b 5.7104 (-18.2384) 5.8087 (-18.2773) 5.8096 (-18.7378),
    b 5.8096 (-18.7378) 5.8115 (-19.7142) 5.4227 (-21.9394),
    b 5.4227 (-21.9394) 4.7390 (-25.8532) 5.3881 (-26.5946),
    b 5.3881 (-26.5946) 6.0371 (-27.3360) 10.1469 (-27.3360),
    b 10.1469 (-27.3360) 15.8137 (-27.3360) 16.8063 (-26.3434)]

data Box = Box
  { _position :: !Point
  , _dy       :: !Float
  , _scale    :: !Float
  , _angle    :: !Float
  , _dangle   :: !Float
  }

randomBox :: Float -> Float -> IO Box
randomBox w h = Box
    <$> pos
    <*> randomRIO (0.5 , 2.2)
    <*> randomRIO (0.2 , 1.7)
    <*> randomRIO (0.0 , 4.0)
    <*> randomRIO (- 0.1 , 0.1)
  where
    pos = V2 
      <$> randomRIO (0.0 , w)
      <*> randomRIO (0.0 , h)

toTransform :: Float -> Float -> Float -> Box -> Transformation
toTransform ww wh zoom box =
  translate (V2 (ww / 2) (wh / 2)) <>
  scale zoom zoom <>
  translate (V2 (-ww / 2) (-wh / 2)) <>
  translate (_position box) <>
  rotate (_angle box) <>
  scale (_scale box) (_scale box)

renderFlake :: Float -> Float -> Float -> Box -> Drawing PixelRGBA8 ()
renderFlake w h zoom box  =
 withTexture (uniformTexture snowflakeColor) . 
   withTransformation (toTransform w h zoom box) $
     fill snowflake

renderFlakes :: Foldable f => Float -> Float -> Float -> f Box -> Image PixelRGBA8
renderFlakes width height zoom boxes =
  renderDrawing (floor width) (floor height) background $
    foldMap (renderFlake width height zoom) boxes
    where
      background = PixelRGBA8 0 0 0 255
      -- background = PixelRGBA8 255 255 255 255

benchFlakes :: Foldable f => Float -> Float -> Float -> f Box -> Image PixelRGBA8
benchFlakes width height zoom boxes =
  renderDrawing (floor width) (floor height) background $
    foldMap (renderFlake width height zoom) boxes
    where
      background = PixelRGBA8 0 0 0 255

main :: IO ()
main = do
  let width = 800
      height = 600
      zoom = 1
  boxes <- V.fromListN 500 <$> replicateM 1000 (randomBox width height)
  writePng "flakes.png" $
    renderFlakes width height zoom boxes
  -- benching
  defaultMain [bench "flake draw" $ whnf (benchFlakes width height zoom) boxes]



<|start_filename|>src/Graphics/Rasterific/Lenses.hs<|end_filename|>
{-# LANGUAGE RankNTypes #-}
-- | This module provide lenses compatible with the `lens`
-- module but without the dependency to it.
module Graphics.Rasterific.Lenses
    ( -- * Line lenses
      lineX0
    , lineX1
    , linePoints

      -- * Quadratic bezier curve
    , bezX0
    , bezX1
    , bezX2
    , bezierPoints

      -- * Cubic bezier lenses
    , cbezX0
    , cbezX1
    , cbezX2
    , cbezX3
    , cubicBezierPoints

      -- * Primitive lenses
    , primitivePoints

      -- * Path oriented lenses
    , pathCommandPoints
    , pathPoints

      -- * Type definition to match Lens
    , Lens
    , Lens'
    , Traversal
    , Traversal'
    ) where

import Graphics.Rasterific.Types

-- | Does it look familiar? yes it's the official
-- Lens type.
type Lens s t a b =
    forall f. Functor f => (a -> f b) -> s -> f t

-- | Try to match the Lens' type alias.
type Lens' s a = Lens s s a a

-- | Traversal type, matched to the one of the lens
-- package.
type Traversal s t a b =
    forall f. Applicative f => (a -> f b) -> s -> f t

type Traversal' s a = Traversal s s a a

-- | Create a full lens out of setter and getter
lens :: (s -> a)
     -> (s -> b -> t)
     -> Lens s t a b
{-# INLINE lens #-}
lens accessor setter = \f src ->
  fmap (setter src) $ f (accessor src)

-- | Traverse all the points of a line.
linePoints :: Traversal' Line Point
linePoints f (Line p0 p1) = Line <$> f p0 <*> f p1

-- | Line origin point.
lineX0 :: Lens' Line Point
lineX0 = lens _lineX0 setter where
  setter a b = a { _lineX0 = b }

-- | Line end point.
lineX1 :: Lens' Line Point
lineX1 = lens _lineX1 setter where
  setter a b = a { _lineX1 = b }

-- | Quadratic bezier starting point.
bezX0 :: Lens' Bezier Point
bezX0 = lens _bezierX0 setter where
  setter a b = a { _bezierX0 = b }

-- | bezier control point.
bezX1 :: Lens' Bezier Point
bezX1 = lens _bezierX1 setter where
  setter a b = a { _bezierX1 = b }

-- | bezier end point.
bezX2 :: Lens' Bezier Point
bezX2 = lens _bezierX2 setter where
  setter a b = a { _bezierX2 = b }

-- | Traversal of all the bezier's points.
bezierPoints :: Traversal' Bezier Point
bezierPoints f (Bezier p0 p1 p2) =
  Bezier <$> f p0 <*> f p1 <*> f p2

-- | Cubic bezier first point
cbezX0 :: Lens' CubicBezier Point
cbezX0 = lens _cBezierX0 setter where
  setter a b = a { _cBezierX0 = b }

-- | Cubic bezier first control point.
cbezX1 :: Lens' CubicBezier Point
cbezX1 = lens _cBezierX1 setter where
  setter a b = a { _cBezierX1 = b }

-- | Cubic bezier second control point.
cbezX2 :: Lens' CubicBezier Point
cbezX2 = lens _cBezierX2 setter where
  setter a b = a { _cBezierX2 = b }

-- | Cubic bezier last point.
cbezX3 :: Lens' CubicBezier Point
cbezX3 = lens _cBezierX2 setter where
  setter a b = a { _cBezierX3 = b }

-- | Traversal of all the points of the cubic bezier.
cubicBezierPoints :: Traversal' CubicBezier Point
cubicBezierPoints f (CubicBezier p0 p1 p2 p3) =
  CubicBezier <$> f p0 <*> f p1 <*> f p2 <*> f p3

-- | Traverse all the points defined in the primitive.
primitivePoints :: Traversal' Primitive Point
primitivePoints f (LinePrim l) = LinePrim <$> linePoints f l
primitivePoints f (BezierPrim b) = BezierPrim <$> bezierPoints f b
primitivePoints f (CubicBezierPrim c) =
    CubicBezierPrim <$> cubicBezierPoints f c

-- | Traversal of all the points of a path
pathCommandPoints :: Traversal' PathCommand Point
pathCommandPoints f (PathLineTo p) = PathLineTo <$> f p
pathCommandPoints f (PathQuadraticBezierCurveTo p1 p2) =
    PathQuadraticBezierCurveTo <$> f p1 <*> f p2
pathCommandPoints f (PathCubicBezierCurveTo p1 p2 p3) =
    PathCubicBezierCurveTo <$> f p1 <*> f p2 <*> f p3

-- | Traversal of all the points in a path.
pathPoints :: Traversal' Path Point
pathPoints f (Path p0 yn comms) =
  Path <$> f p0 <*> pure yn <*> traverse (pathCommandPoints f) comms



<|start_filename|>src/Graphics/Rasterific/Rasterize.hs<|end_filename|>
{-# LANGUAGE BangPatterns #-}
module Graphics.Rasterific.Rasterize
    ( CoverageSpan( .. )
    , rasterize
    , toOpaqueCoverage
    , clip
    ) where

import Control.Monad.ST( runST )
import Data.Fixed( mod' )
import Data.Monoid( Endo( Endo, appEndo ) )
import Graphics.Rasterific.Types
import Graphics.Rasterific.QuadraticBezier
import Graphics.Rasterific.CubicBezier
import Graphics.Rasterific.Line
import qualified Data.Vector as V
import qualified Data.Vector.Algorithms.Intro as VS

data CoverageSpan = CoverageSpan
    { _coverageX      :: {-# UNPACK #-} !Float
    , _coverageY      :: {-# UNPACK #-} !Float
    , _coverageVal    :: {-# UNPACK #-} !Float
    , _coverageLength :: {-# UNPACK #-} !Float
    }
    deriving Show

toOpaqueCoverage :: CoverageSpan -> CoverageSpan
{-# INLINE toOpaqueCoverage #-}
toOpaqueCoverage coverage = coverage { _coverageVal = 1 }

combineEdgeSamples :: (Float -> Float) -> V.Vector EdgeSample
                   -> [CoverageSpan]
{-# INLINE combineEdgeSamples #-}
combineEdgeSamples prepareCoverage vec = go 0 0 0 0 0
  where
    !maxi = V.length vec
    go !ix !x !y !a !_h | ix >= maxi = [CoverageSpan x y (prepareCoverage a) 1]
    go !ix !x !y !a !h = sub (vec `V.unsafeIndex` ix) where
      sub (EdgeSample x' y' a' h')
        | y == y' && x == x' = go (ix + 1) x' y' (a + a') (h + h')
        | y == y' = p1 : p2 : go (ix + 1) x' y' (h + a') (h + h')
        | otherwise =
           CoverageSpan x y (prepareCoverage a) 1 : go (ix + 1) x' y' a' h'
             where p1 = CoverageSpan x y (prepareCoverage a) 1
                   p2 = CoverageSpan (x + 1) y (prepareCoverage h) (x' - x - 1)

-- | Clip the geometry to a rectangle.
clip :: Point     -- ^ Minimum point (corner upper left)
     -> Point     -- ^ Maximum point (corner bottom right)
     -> Primitive -- ^ Primitive to be clipped
     -> Container Primitive
clip mini maxi (LinePrim l) = clipLine mini maxi l
clip mini maxi (BezierPrim b) = clipBezier mini maxi b
clip mini maxi (CubicBezierPrim c) = clipCubicBezier mini maxi c

decompose :: Primitive -> Producer EdgeSample
decompose (LinePrim l) = decomposeLine l
decompose (BezierPrim b) = decomposeBeziers b
decompose (CubicBezierPrim c) =
    {-decomposeCubicBezierForwardDifference c-}
    decomposeCubicBeziers c

xyCompare :: EdgeSample -> EdgeSample -> Ordering
{-# INLINE xyCompare #-}
xyCompare !(EdgeSample { _sampleY = ay, _sampleX = ax })
          !(EdgeSample { _sampleY = by, _sampleX = bx }) =
  case compare ay by of
    EQ -> compare ax bx
    c -> c

sortEdgeSamples :: [EdgeSample] -> V.Vector EdgeSample
sortEdgeSamples samples = runST $ do
    -- Resist the urge to make this a storable vector,
    -- it is actually a pessimisation.
    mutableVector <- V.unsafeThaw $ V.fromList samples
    VS.sortBy xyCompare mutableVector
    V.unsafeFreeze mutableVector

rasterize :: FillMethod -> Container Primitive -> [CoverageSpan]
rasterize method = 
  case method of
    FillWinding -> combineEdgeSamples combineWinding 
                        . sortEdgeSamples
                        . (($ []) . appEndo)
                        . foldMap (Endo . decompose)
    FillEvenOdd -> combineEdgeSamples combineEvenOdd
                        . sortEdgeSamples
                        . (($ []) . appEndo)
                        . foldMap (Endo . decompose)
  where combineWinding = min 1 . abs
        combineEvenOdd cov = abs $ abs (cov - 1) `mod'` 2 - 1



<|start_filename|>src/Graphics/Rasterific/MiniLens.hs<|end_filename|>
{-# LANGUAGE RankNTypes #-}
module Graphics.Rasterific.MiniLens
    ( -- * Types
      Lens
    , Lens'
    , Traversal
    , Traversal'
    , lens

      -- * Getter
    , (.^)
    , view
    , use

      -- * Setter
    , (.~)
    , (.=)
    , (%=)
    , (+=)
    , set

      -- * Helper
    , (&)
    ) where

import Control.Monad.Identity
import Control.Applicative
import Control.Monad.State        as State
import Data.Function( (&) )

infixl 8 .^
infixr 4 .~
infix  4 .=,%=,+=

-- | Does it look familiar? yes it's the official
-- Lens type.
type Lens s t a b =
    forall f. Functor f => (a -> f b) -> s -> f t

-- | Try to match the Lens' type alias.
type Lens' s a = Lens s s a a

-- | Traversal type, matched to the one of the lens
-- package.
type Traversal s t a b =
    forall f. Applicative f => (a -> f b) -> s -> f t

type Traversal' s a = Traversal s s a a

-- | Create a full lens out of setter and getter
lens :: (s -> a)
     -> (s -> b -> t)
     -> Lens s t a b
{-# INLINE lens #-}
lens accessor setter = \f src ->
  fmap (setter src) $ f (accessor src)

view :: s -> Lens s t a b -> a
{-# INLINE view #-}
view v l = getConst (l Const v)

(.^) :: s -> Lens s t a b -> a
{-# INLINE (.^) #-}
(.^) = view

set :: Lens' s a -> a -> s -> s
{-# INLINE set #-}
set l new v = runIdentity $ l (\_ -> Identity new) v

(.~) :: Lens' s a -> a -> s -> s
{-# INLINE (.~) #-}
(.~) = set

(.=) :: MonadState s m => Lens' s a -> a -> m ()
{-# INLINE (.=) #-}
(.=) l v = State.modify (l .~ v)

(%=) :: MonadState s m => Lens' s a -> (a -> a) -> m ()
{-# INLINE (%=) #-}
(%=) l f = State.modify $ \s -> s & l .~ f (s .^ l)

(+=) :: (Num a, MonadState s m) => Lens' s a -> a -> m ()
{-# INLINE (+=) #-}
(+=) l n = l %= (+ n)

use :: MonadState s m => Lens s t a b -> m a
{-# INLINE use #-}
use l = State.gets (.^ l)



<|start_filename|>src/Graphics/Rasterific/BiSampleable.hs<|end_filename|>
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
-- | Module to describe bi-sampleable types
module Graphics.Rasterific.BiSampleable
    ( BiSampleable( .. )
    , bilinearInterpolation
    , sampledImageShader
    ) where

import Data.Fixed( mod' )
import Codec.Picture
    ( Image( .. )
    , Pixel8
    , Pixel( .. )
    , PixelRGBA8( .. ) )

import Graphics.Rasterific.Linear
import Graphics.Rasterific.Types
import Graphics.Rasterific.Compositor
import Graphics.Rasterific.Command
import Graphics.Rasterific.PatchTypes
import Graphics.Rasterific.Transformations

-- | Interpolate a 2D point in a given type
class BiSampleable sampled px | sampled -> px where
  -- | The interpolation function
  interpolate :: sampled -> Float -> Float -> px

-- | Basic bilinear interpolator
instance  (Pixel px, Modulable (PixelBaseComponent px))
    => BiSampleable (ParametricValues px) px where
  {-# INLINE interpolate #-}
  interpolate = bilinearPixelInterpolation

-- | Bicubic interpolator
instance ( InterpolablePixel px
         , Num (Holder px Float)
         ) => BiSampleable (CubicCoefficient px) px where
  {-# INLINE interpolate #-}
  interpolate = bicubicInterpolation

-- | Bilinear interpolation of an image
instance BiSampleable (ImageMesh PixelRGBA8) PixelRGBA8 where
  {-# INLINE interpolate #-}
  interpolate imesh xb yb = sampledImageShader (_meshImage imesh) SamplerPad x y
    where (V2 x y) = applyTransformation (_meshTransform imesh) (V2 xb yb)

-- | Use another image as a texture for the filling.
-- Contrary to `imageTexture`, this function perform a bilinear
-- filtering on the texture.
--
sampledImageShader :: forall px. RenderablePixel px
                   => Image px -> SamplerRepeat -> ShaderFunction px
{-# SPECIALIZE
     sampledImageShader :: Image Pixel8 -> SamplerRepeat
                        -> ShaderFunction Pixel8 #-}
{-# SPECIALIZE
     sampledImageShader :: Image PixelRGBA8 -> SamplerRepeat
                        -> ShaderFunction PixelRGBA8 #-}
sampledImageShader img _ _ _
  | imageWidth img == 0 || imageHeight img == 0 = emptyPx
sampledImageShader img sampling x y =
  (at px  py `interpX` at pxn py)
             `interpY`
  (at px pyn `interpX` at pxn pyn)
  where
   coordSampler SamplerPad maxi v = min (maxi - 1) . max 0 $ floor v
   coordSampler SamplerReflect maxi v =
      floor $ abs (abs (v - maxif - 1) `mod'` (2 * maxif) - maxif - 1)
        where maxif = fromIntegral maxi
   coordSampler SamplerRepeat maxi v = floor v `mod` maxi

   w = fromIntegral $ imageWidth img
   h = fromIntegral $ imageHeight img

   clampedX = coordSampler sampling w
   clampedY = coordSampler sampling h

   px = clampedX x
   pxn = clampedX $ x + 1
   py = clampedY y
   pyn = clampedY $ y + 1

   dx, dy :: Float
   !dx = x - fromIntegral (floor x :: Int)
   !dy = y - fromIntegral (floor y :: Int)

   at :: Int -> Int -> px
   at !xx !yy =
        unsafePixelAt rawData $ (yy * w + xx) * compCount

   (covX, icovX) = clampCoverage dx
   (covY, icovY) = clampCoverage dy

   interpX = mixWith (const $ alphaOver covX icovX)
   interpY = mixWith (const $ alphaOver covY icovY)

   compCount = componentCount (undefined :: px)
   rawData = imageData img

bilinearPixelInterpolation :: (Pixel px, Modulable (PixelBaseComponent px))
                           => ParametricValues px -> Float -> Float -> px
{-# SPECIALIZE INLINE
    bilinearPixelInterpolation :: ParametricValues PixelRGBA8 -> Float -> Float -> PixelRGBA8
  #-}
bilinearPixelInterpolation (ParametricValues { .. }) !dx !dy = 
  mixWith (const $ alphaOver covY icovY)
        (mixWith (const $ alphaOver covX icovX) _northValue _eastValue)
        (mixWith (const $ alphaOver covX icovX) _westValue _southValue)
  where
   (!covX, !icovX) = clampCoverage dx
   (!covY, !icovY) = clampCoverage dy

bilinearInterpolation :: InterpolablePixel px
                      => ParametricValues px -> Float -> Float -> px
{-# INLINE bilinearInterpolation #-}
bilinearInterpolation ParametricValues { .. } u v = fromFloatPixel $ lerp v uBottom uTop where
  -- The arguments are flipped, because the lerp function from Linear is...
  -- inversed in u v
  !uTop = lerp u (toFloatPixel _eastValue) (toFloatPixel _northValue)
  !uBottom = lerp u (toFloatPixel _southValue) (toFloatPixel _westValue)


bicubicInterpolation :: forall px . (InterpolablePixel px, Num (Holder px Float))
                     => CubicCoefficient px -> Float -> Float -> px
bicubicInterpolation params x y =
  fromFloatPixel . fmap clamp $ af ^+^ bf ^+^ cf ^+^ df
  where
    ParametricValues a b c d = getCubicCoefficients params
    maxi = maxRepresentable (Proxy :: Proxy px)
    clamp = max 0 . min maxi
    xv, vy, vyy, vyyy :: V4 Float
    xv = V4 1 x (x*x) (x*x*x)
    vy = xv ^* y
    vyy = vy ^* y
    vyyy = vyy ^* y

    v1 ^^*^ v2 = (^*) <$> v1 <*> v2

    V4 af bf cf df = (a ^^*^ xv) ^+^ (b ^^*^ vy) ^+^ (c ^^*^ vyy) ^+^ (d ^^*^ vyyy)



<|start_filename|>src/Graphics/Rasterific/Linear.hs<|end_filename|>
-- | This module is a reduction of the `Linear` package
-- from <NAME> to match just the need of Rasterific.
--
-- If the flag `embed_linear` is disabled, this module is
-- just a reexport from the real linear package.
--
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
module Graphics.Rasterific.Linear
    ( V1( .. )
    , V2( .. )
    , V3( .. )
    , V4( .. )
    , R1( .. )
    , R2( .. )
    , Additive( .. )
    , Epsilon( .. )
    , Metric( .. )
    , (^*)
    , (^/)
    , normalize
    ) where

#ifdef EXTERNAL_LINEAR
-- We just reexport
import Linear
#else

import Graphics.Rasterific.MiniLens

infixl 6 ^+^, ^-^
infixl 7 ^*, ^/

-- | A 2-dimensional vector
--
-- >>> pure 1 :: V2 Int
-- V2 1 1
--
-- >>> V2 1 2 + V2 3 4
-- V2 4 6
--
-- >>> V2 1 2 * V2 3 4
-- V2 3 8
--
-- >>> sum (V2 1 2)
-- 3
data V2 a = V2 !a !a
    deriving (Eq, Show)

-- | A 3-dimensional vector
data V3 a = V3 !a !a !a
    deriving (Eq, Show)

-- | A 4-dimensional vector
data V4 a = V4 !a !a !a !a
    deriving (Eq, Show)

class R1 t where
  _x :: Lens' (t a) a

class R2 t where
  _y :: Lens' (t a) a

instance R1 V1 where
  _x = lens (\(V1 a) -> a) (\_ -> V1)

instance R1 V2 where
  _x = lens (\(V2 x _) -> x) (\(V2 _ y) x -> V2 x y)

instance R2 V2 where
  _y = lens (\(V2 _ y) -> y) (\(V2 x _) y -> V2 x y)

instance R1 V3 where
  _x = lens (\(V3 x _ _) -> x) (\(V3 _ y z) x -> V3 x y z)

instance R2 V3 where
  _y = lens (\(V3 _ y _) -> y) (\(V3 x _ z) y -> V3 x y z)

instance R1 V4 where
  _x = lens (\(V4 x _ _ _) -> x) (\(V4 _ y z w) x -> V4 x y z w)

instance R2 V4 where
  _y = lens (\(V4 _ y _ _) -> y) (\(V4 x _ z w) y -> V4 x y z w)

-- | A 1-dimensional vector
newtype V1 a = V1 a
    deriving (Eq, Show, Num)

instance Functor V1 where
    {-# INLINE fmap #-}
    fmap f (V1 a) = V1 $ f a

instance Functor V2 where
    {-# INLINE fmap #-}
    fmap f (V2 a b) = V2 (f a) (f b)

instance Functor V3 where
    {-# INLINE fmap #-}
    fmap f (V3 a b c) = V3 (f a) (f b) (f c)

instance Functor V4 where
    {-# INLINE fmap #-}
    fmap f (V4 a b c d) = V4 (f a) (f b) (f c) (f d)

instance Foldable V3 where
  foldMap f (V3 a b c) = f a `mappend` f b `mappend` f c
  {-# INLINE foldMap #-}

instance Traversable V3 where
  traverse f (V3 a b c) = V3 <$> f a <*> f b <*> f c
  {-# INLINE traverse #-}

instance Foldable V2 where
  foldMap f (V2 a b) = f a `mappend` f b
  {-# INLINE foldMap #-}

instance Traversable V2 where
  traverse f (V2 a b) = V2 <$> f a <*> f b
  {-# INLINE traverse #-}

instance Foldable V4 where
  foldMap f (V4 a b c d) = f a `mappend` f b `mappend` f c `mappend` f d
  {-# INLINE foldMap #-}

instance Traversable V4 where
  traverse f (V4 a b c d) = V4 <$> f a <*> f b <*> f c <*> f d
  {-# INLINE traverse #-}

instance Foldable V1 where
  foldMap f (V1 a) = f a
  {-# INLINE foldMap #-}

instance Traversable V1 where
  traverse f (V1 a) = V1 <$> f a
  {-# INLINE traverse #-}

instance Num a => Num (V2 a) where
  (V2 a b) + (V2 a' b') = V2 (a + a') (b + b')
  {-# INLINE (+) #-}
  (V2 a b) - (V2 a' b') = V2 (a - a') (b - b')
  {-# INLINE (-) #-}
  (V2 a b) * (V2 a' b') = V2 (a * a') (b * b')
  {-# INLINE (*) #-}
  negate (V2 a b) = V2 (negate a) (negate b)
  {-# INLINE negate #-}
  abs (V2 a b) = V2 (abs a) (abs b)
  {-# INLINE abs #-}
  signum (V2 a b) = V2 (signum a) (signum b)
  {-# INLINE signum #-}
  fromInteger = pure . fromInteger
  {-# INLINE fromInteger #-}

instance Num a => Num (V3 a) where
  (V3 a b c) + (V3 a' b' c') = V3 (a + a') (b + b') (c + c')
  {-# INLINE (+) #-}
  (V3 a b c) - (V3 a' b' c') = V3 (a - a') (b - b') (c - c')
  {-# INLINE (-) #-}
  (V3 a b c) * (V3 a' b' c') = V3 (a * a') (b * b') (c * c')
  {-# INLINE (*) #-}
  negate (V3 a b c) = V3 (negate a) (negate b) (negate c)
  {-# INLINE negate #-}
  abs (V3 a b c) = V3 (abs a) (abs b) (abs c)
  {-# INLINE abs #-}
  signum (V3 a b c) = V3 (signum a) (signum b) (signum c)
  {-# INLINE signum #-}
  fromInteger = pure . fromInteger
  {-# INLINE fromInteger #-}

instance Num a => Num (V4 a) where
  (V4 a b c d) + (V4 a' b' c' d') = V4 (a + a') (b + b') (c + c') (d + d')
  {-# INLINE (+) #-}
  (V4 a b c d) - (V4 a' b' c' d') = V4 (a - a') (b - b') (c - c') (d - d')
  {-# INLINE (-) #-}
  (V4 a b c d) * (V4 a' b' c' d') = V4 (a * a') (b * b') (c * c') (d * d')
  {-# INLINE (*) #-}
  negate (V4 a b c d) = V4 (negate a) (negate b) (negate c) (negate d)
  {-# INLINE negate #-}
  abs (V4 a b c d) = V4 (abs a) (abs b) (abs c) (abs d)
  {-# INLINE abs #-}
  signum (V4 a b c d) = V4 (signum a) (signum b) (signum c) (signum d)
  {-# INLINE signum #-}
  fromInteger = pure . fromInteger
  {-# INLINE fromInteger #-}

instance Applicative V4 where
    {-# INLINE pure #-}
    pure a = V4 a a a a
    {-# INLINE (<*>) #-}
    (V4 f1 f2 f3 f4) <*> (V4 a b c d) = V4 (f1 a) (f2 b) (f3 c) (f4 d)

instance Applicative V3 where
    {-# INLINE pure #-}
    pure a = V3 a a a
    {-# INLINE (<*>) #-}
    (V3 f1 f2 f3) <*> (V3 a b c) = V3 (f1 a) (f2 b) (f3 c)

instance Applicative V2 where
    {-# INLINE pure #-}
    pure a = V2 a a
    {-# INLINE (<*>) #-}
    (V2 f1 f2) <*> (V2 a b) = V2 (f1 a) (f2 b)

instance Applicative V1 where
    {-# INLINE pure #-}
    pure = V1 
    {-# INLINE (<*>) #-}
    (V1 f) <*> (V1 v) = V1 $ f v

-- | A vector is an additive group with additional structure.
class Functor f => Additive f where
  -- | The zero vector
  zero :: Num a => f a
  -- | Compute the sum of two vectors
  --
  -- >>> V2 1 2 ^+^ V2 3 4
  -- V2 4 6
  (^+^) :: Num a => f a -> f a -> f a

  -- | Compute the difference between two vectors
  --
  -- >>> V2 4 5 - V2 3 1
  -- V2 1 4
  (^-^) :: Num a => f a -> f a -> f a

  -- | Linearly interpolate between two vectors.
  lerp :: Num a => a -> f a -> f a -> f a

-- | Provides a fairly subjective test to see if a quantity is near zero.
--
-- >>> nearZero (1e-11 :: Double)
-- False
--
-- >>> nearZero (1e-17 :: Double)
-- True
--
-- >>> nearZero (1e-5 :: Float)
-- False
--
-- >>> nearZero (1e-7 :: Float)
-- True
class Num a => Epsilon a where
  -- | Determine if a quantity is near zero.
  nearZero :: a -> Bool

-- | @'abs' a '<=' 1e-6@
instance Epsilon Float where
  nearZero a = abs a <= 1e-6
  {-# INLINE nearZero #-}

-- | @'abs' a '<=' 1e-12@
instance Epsilon Double where
  nearZero a = abs a <= 1e-12
  {-# INLINE nearZero #-}

instance Epsilon a => Epsilon (V4 a) where
  nearZero = nearZero . quadrance
  {-# INLINE nearZero #-}

instance Epsilon a => Epsilon (V3 a) where
  nearZero = nearZero . quadrance
  {-# INLINE nearZero #-}

instance Epsilon a => Epsilon (V2 a) where
  nearZero = nearZero . quadrance
  {-# INLINE nearZero #-}

instance Epsilon a => Epsilon (V1 a) where
  nearZero (V1 a) = nearZero a
  {-# INLINE nearZero #-}

instance Additive V4 where
    zero = V4 0 0 0 0
    {-# INLINE zero #-}

    (V4 a b c d) ^+^ (V4 a' b' c' d') = V4 (a + a') (b + b') (c + c') (d + d')
    {-# INLINE (^+^) #-}

    (V4 a b c d) ^-^ (V4 a' b' c' d') = V4 (a - a') (b - b') (c + c') (d + d')
    {-# INLINE (^-^) #-}
    lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha)
    {-# INLINE lerp #-}

instance Additive V3 where
    zero = V3 0 0 0
    {-# INLINE zero #-}

    (V3 a b c) ^+^ (V3 a' b' c') = V3 (a + a') (b + b') (c + c')
    {-# INLINE (^+^) #-}

    (V3 a b c) ^-^ (V3 a' b' c') = V3 (a - a') (b - b') (c + c')
    {-# INLINE (^-^) #-}

    lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha)
    {-# INLINE lerp #-}

instance Additive V2 where
    zero = V2 0 0
    {-# INLINE zero #-}

    (V2 a b) ^+^ (V2 a' b') = V2 (a + a') (b + b')
    {-# INLINE (^+^) #-}

    (V2 a b) ^-^ (V2 a' b') = V2 (a - a') (b - b')
    {-# INLINE (^-^) #-}

    lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha)
    {-# INLINE lerp #-}

instance Additive V1 where
    zero = V1 0
    {-# INLINE zero #-}

    (V1 a) ^+^ (V1 a') = V1 (a + a')
    {-# INLINE (^+^) #-}

    (V1 a) ^-^ (V1 a') = V1 (a - a')
    {-# INLINE (^-^) #-}

    lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha)
    {-# INLINE lerp #-}

-- | Free and sparse inner product/metric spaces.
class Additive f => Metric f where
  -- | Compute the inner product of two vectors or (equivalently)
  -- convert a vector @f a@ into a covector @f a -> a@.
  --
  -- >>> V2 1 2 `dot` V2 3 4
  -- 11
  dot :: Num a => f a -> f a -> a

  -- | Compute the squared norm. The name quadrance arises from
  -- <NAME>'s rational trigonometry.
  quadrance :: Num a => f a -> a
  {-# INLINE quadrance #-}
  quadrance v = dot v v

  -- | Compute the quadrance of the difference
  qd :: Num a => f a -> f a -> a
  {-# INLINE qd #-}
  qd f g = quadrance (f ^-^ g)

  -- | Compute the distance between two vectors in a metric space
  distance :: Floating a => f a -> f a -> a
  {-# INLINE distance #-}
  distance f g = norm (f ^-^ g)

  -- | Compute the norm of a vector in a metric space
  norm :: Floating a => f a -> a
  {-# INLINE norm #-}
  norm v = sqrt (quadrance v)

  -- | Convert a non-zero vector to unit vector.
  signorm :: Floating a => f a -> f a
  signorm v = fmap (/ m) v where
    m = norm v

instance Metric V4 where
    dot (V4 a b c d) (V4 a' b' c' d') = a * a' + b * b' + c * c' + d * d'
    {-# INLINE dot #-}

    quadrance (V4 a b c d) = a * a + b * b + c * c + d * d
    {-# INLINE quadrance #-}

    norm v = sqrt (quadrance v)
    {-# INLINE norm #-}

instance Metric V3 where
    dot (V3 a b c) (V3 a' b' c') = a * a' + b * b' + c * c'
    {-# INLINE dot #-}

    quadrance (V3 a b c) = a * a + b * b + c * c
    {-# INLINE quadrance #-}

    norm v = sqrt (quadrance v)
    {-# INLINE norm #-}

instance Metric V2 where
    dot (V2 a b) (V2 a' b') = a * a' + b * b'
    {-# INLINE dot #-}

    quadrance (V2 a b) = a * a + b * b
    {-# INLINE quadrance #-}

    norm v = sqrt (quadrance v)
    {-# INLINE norm #-}

-- | Compute the right scalar product
--
-- >>> V2 3 4 ^* 2
-- V2 6 8
(^*) :: (Functor f, Num a) => f a -> a -> f a
{-# INLINE (^*) #-}
(^*) f n = fmap (* n) f

-- | Compute division by a scalar on the right.
(^/) :: (Functor f, Floating a) => f a -> a -> f a
{-# INLINE (^/) #-}
(^/) f n = fmap (/ n) f

-- | Normalize a 'Metric' functor to have unit 'norm'. This function
-- does not change the functor if its 'norm' is 0 or 1.
normalize :: (Floating a, Metric f, Epsilon a) => f a -> f a
{-# INLINE normalize #-}
normalize v = if nearZero l || nearZero (1-l) then v
             else fmap (/ sqrt l) v
  where l = quadrance v

#endif



<|start_filename|>src/Graphics/Rasterific/Types.hs<|end_filename|>
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances #-}
-- | Gather all the types used in the rasterization engine.
module Graphics.Rasterific.Types
    ( -- * Geometry description
      Vector
    , Point
    , Line( .. )
    , Bezier( .. )
    , CubicBezier( .. )
    , Primitive( .. )

    , Primitivable( .. )
    , Geometry( .. )

    , Producer
    , Container
    , containerOfList
    , listOfContainer
    , containerOfFunction
    , PathCommand( .. )
    , Path( .. )
    , Transformable( .. )
    , PointFoldable( .. )

      -- * Rasterization control types
    , Cap( .. )
    , Join( .. )
    , FillMethod( .. )
    , SamplerRepeat( .. )
    , DashPattern
    , StrokeWidth

      -- * Internal type
    , EdgeSample( .. )
    , pathToPrimitives

      -- * Little geometry helpers
    , firstTangeantOf
    , lastTangeantOf
    , firstPointOf
    , lastPointOf
    , resplit

      -- * RankNType helper
    , Proxy( Proxy )
    ) where

import Data.DList( DList, fromList )

import Control.Monad.Identity( runIdentity )
import Data.Foldable( foldl', toList )
import qualified Data.Foldable as F
import Graphics.Rasterific.Linear( V2( .. ), (^-^), nearZero )
import Graphics.Rasterific.Operators
import Foreign.Ptr( castPtr )
import Foreign.Storable( Storable( sizeOf
                       , alignment
                       , peek
                       , poke
                       , peekElemOff
                       , pokeElemOff ) )

-- | Represent a vector
type Vector = V2 Float

-- | Type alias just to get more meaningful
-- type signatures
type StrokeWidth = Float

-- | Dash pattern to use
type DashPattern = [Float]

data Proxy p = Proxy

-- | Describe how we will "finish" the stroking
-- that don't loop.
data Cap
    -- | Create a straight caping on the stroke.
    -- Cap value should be positive and represent
    -- the distance from the end of curve to the actual cap
    --
    --  * cap straight with param 0 : <<docimages/cap_straight.png>>
    --
    --  * cap straight with param 1 : <<docimages/cap_straight_1.png>>
    --
  = CapStraight Float

    -- | Create a rounded caping on the stroke.
    -- <<docimages/cap_round.png>>
  | CapRound
  deriving (Eq, Show)

-- | Describe how to display the join of broken lines
-- while stroking.
data Join
    -- | Make a curved join.
    -- <<docimages/join_round.png>>
  = JoinRound
    -- | Make a mitter join. Value must be positive or null.
    -- Seems to make sense in [0;1] only
    --
    --  * Miter join with 0 : <<docimages/join_miter.png>>
    --
    --  * Miter join with 5 : <<docimages/join_miter_5.png>>
    --
  | JoinMiter Float
  deriving (Eq, Show)

-- | Tell how to fill complex shapes when there is self 
-- intersections. If the filling mode is not specified,
-- then it's the `FillWinding` method which is used.
--
-- The examples used are produced with the following
-- function:
--
--
-- > fillingSample :: FillMethod -> Drawing px ()
-- > fillingSample fillMethod = fillWithMethod fillMethod geometry where
-- >   geometry = transform (applyTransformation $ scale 0.35 0.4
-- >                                            <> translate (V2 (-80) (-180)))
-- >      [ Path (V2 484 499) True
-- >          [ PathCubicBezierCurveTo (V2 681 452) (V2 639 312) (V2 541 314)
-- >          , PathCubicBezierCurveTo (V2 327 337) (V2 224 562) (V2 484 499)
-- >          ]
-- >      , Path (V2 136 377) True
-- >          [ PathCubicBezierCurveTo (V2 244 253) (V2 424 420) (V2 357 489)
-- >          , PathCubicBezierCurveTo (V2 302 582) (V2 47 481) (V2 136 377)
-- >          ]
-- >      , Path (V2 340 265) True
-- >          [ PathCubicBezierCurveTo (V2 64 371) (V2 128 748) (V2 343 536)
-- >          , PathCubicBezierCurveTo (V2 668 216) (V2 17 273) (V2 367 575)
-- >          , PathCubicBezierCurveTo (V2 589 727) (V2 615 159) (V2 340 265)
-- >          ]
-- >      ]
data FillMethod
  -- | Also known as nonzero rule.
  -- To determine if a point falls inside the curve, you draw 
  -- an imaginary line through that point. Next you will count
  -- how many times that line crosses the curve before it reaches
  -- that point. For every clockwise rotation, you subtract 1 and
  -- for every counter-clockwise rotation you add 1.
  --
  -- <<docimages/fill_winding.png>>
  = FillWinding

  -- | This rule determines the insideness of a point on 
  -- the canvas by drawing a ray from that point to infinity
  -- in any direction and counting the number of path segments
  -- from the given shape that the ray crosses. If this number
  -- is odd, the point is inside; if even, the point is outside.
  --
  -- <<docimages/fill_evenodd.png>>
  | FillEvenOdd
  deriving (Eq, Enum, Show)

-- | Describe the behaviour of samplers and texturers
-- when they are out of the bounds of image and/or gradient.
data SamplerRepeat
    -- | Will clamp (ie. repeat the last pixel) when
    -- out of bound
    -- <<docimages/sampler_pad.png>>
  = SamplerPad
    -- | Will loop on it's definition domain
    -- <<docimages/sampler_repeat.png>>
  | SamplerRepeat
    -- | Will loop inverting axises
    -- <<docimages/sampler_reflect.png>>
  | SamplerReflect
  deriving (Eq, Enum, Show)

-- | Represent a raster line
data EdgeSample = EdgeSample
  { _sampleX     :: {-# UNPACK #-} !Float -- ^ Horizontal position
  , _sampleY     :: {-# UNPACK #-} !Float -- ^ Vertical position
  , _sampleAlpha :: {-# UNPACK #-} !Float -- ^ Alpha
  , _sampleH     :: {-# UNPACK #-} !Float -- ^ Height
  }
  deriving Show

-- | Just to get faster sorting
instance Storable EdgeSample where
   sizeOf _ = 4 * sizeOf (0 :: Float)
   alignment = sizeOf

   {-# INLINE peek #-}
   peek ptr = do
     let q = castPtr ptr
     sx <- peekElemOff q 0
     sy <- peekElemOff q 1
     sa <- peekElemOff q 2
     sh <- peekElemOff q 3
     return $ EdgeSample sx sy sa sh
      
   {-# INLINE poke #-}
   poke ptr (EdgeSample sx sy sa sh) = do
     let q = castPtr ptr
     pokeElemOff q 0 sx
     pokeElemOff q 1 sy
     pokeElemOff q 2 sa
     pokeElemOff q 3 sh

-- | This typeclass is there to help transform the geometry,
-- by applying a transformation on every point of a geometric
-- element.
class Transformable a where
    -- | Apply a transformation function for every
    --  point in the element.
    transform :: (Point -> Point) -> a -> a
    transform f = runIdentity . transformM (return . f)

    -- | Transform but monadic
    transformM :: Monad m => (Point -> m Point) -> a -> m a

-- | Typeclass helper gathering all the points of a given
-- geometry.
class PointFoldable a where
    -- | Fold an accumulator on all the points of
    -- the primitive.
    foldPoints :: (b -> Point -> b) -> b -> a -> b

-- | Just apply the function
instance Transformable Point where
    {-# INLINE transform #-}
    transform f = f
    {-# INLINE transformM #-}
    transformM f = f

-- | Just apply the function
instance PointFoldable Point where
    {-# INLINE foldPoints #-}
    foldPoints f = f

-- | Describe a simple 2D line between two points.
--
-- > fill [ Line (V2 10 10) (V2 190 10)
-- >      , Line (V2 190 10) (V2 95 170)
-- >      , Line (V2 95 170) (V2 10 10)]
--
-- <<docimages/simple_line.png>>
--
data Line = Line
  { _lineX0 :: {-# UNPACK #-} !Point -- ^ Origin point
  , _lineX1 :: {-# UNPACK #-} !Point -- ^ End point
  }
  deriving Eq

instance Show Line where
  show (Line a b) =
      "Line (" ++ show a ++ ") ("
               ++ show b ++ ")"

instance Transformable Line where
    {-# INLINE transformM #-}
    transformM f (Line a b) = Line <$> f a <*> f b

instance PointFoldable Line where
    {-# INLINE foldPoints #-}
    foldPoints f acc (Line a b) = f (f acc b) a

-- | Describe a quadratic bezier spline, described
-- using 3 points.
--
-- > fill [Bezier (V2 10 10) (V2 200 50) (V2 200 100)
-- >      ,Bezier (V2 200 100) (V2 150 200) (V2 120 175)
-- >      ,Bezier (V2 120 175) (V2 30 100) (V2 10 10)]
--
-- <<docimages/quadratic_bezier.png>>
--
data Bezier = Bezier
  { -- | Origin points, the spline will pass through it.
    _bezierX0 :: {-# UNPACK #-} !Point
    -- | Control point, the spline won't pass on it.
  , _bezierX1 :: {-# UNPACK #-} !Point
    -- | End point, the spline will pass through it.
  , _bezierX2 :: {-# UNPACK #-} !Point
  }
  deriving Eq

instance Show Bezier where
    show (Bezier a b c) =
        "Bezier (" ++ show a ++ ") ("
                   ++ show b ++ ") ("
                   ++ show c ++ ")"

instance Transformable Bezier where
    {-# INLINE transform #-}
    transform f (Bezier a b c) = Bezier (f a) (f b) $ f c
    {-# INLINE transformM #-}
    transformM f (Bezier a b c) = Bezier <$> f a <*> f b <*> f c

instance PointFoldable Bezier where
    {-# INLINE foldPoints #-}
    foldPoints f acc (Bezier a b c) =
        foldl' f acc [a, b, c]

-- | Describe a cubic bezier spline, described
-- using 4 points.
--
-- > stroke 4 JoinRound (CapRound, CapRound) $
-- >    CubicBezier (V2 0 10) (V2 205 250) (V2 (-10) 250) (V2 160 35)
--
-- <<docimages/cubic_bezier.png>>
--
data CubicBezier = CubicBezier
  { -- | Origin point, the spline will pass through it.
    _cBezierX0 :: {-# UNPACK #-} !Point
    -- | First control point of the cubic bezier curve.
  , _cBezierX1 :: {-# UNPACK #-} !Point
    -- | Second control point of the cubic bezier curve.
  , _cBezierX2 :: {-# UNPACK #-} !Point
    -- | End point of the cubic bezier curve
  , _cBezierX3 :: {-# UNPACK #-} !Point
  }
  deriving Eq

instance Show CubicBezier where
  show (CubicBezier a b c d) =
     "CubicBezier (" ++ show a ++ ") ("
                ++ show b ++ ") ("
                ++ show c ++ ") ("
                ++ show d ++ ")"

instance Transformable CubicBezier where
    {-# INLINE transform #-}
    transform f (CubicBezier a b c d) =
       CubicBezier (f a) (f b) (f c) $ f d
    transformM f (CubicBezier a b c d) =
       CubicBezier <$> f a <*> f b <*> f c <*> f d

instance PointFoldable CubicBezier where
    {-# INLINE foldPoints #-}
    foldPoints f acc (CubicBezier a b c d) =
        foldl' f acc [a, b, c, d]

-- | This datatype gather all the renderable primitives,
-- they are kept separated otherwise to allow specialization
-- on some specific algorithms. You can mix the different
-- primitives in a single call :
--
-- > fill [ toPrim $ CubicBezier (V2 50 20) (V2 90 60)
-- >                             (V2  5 100) (V2 50 140)
-- >      , toPrim $ Line (V2 50 140) (V2 120 80)
-- >      , toPrim $ Line (V2 120 80) (V2 50 20) ]
--
-- <<docimages/primitive_mixed.png>>
--
data Primitive
  = LinePrim !Line      -- ^ Primitive used for lines
  | BezierPrim !Bezier  -- ^ Primitive used for quadratic beziers curves
  | CubicBezierPrim !CubicBezier -- ^ Primitive used for cubic bezier curve
  deriving (Eq, Show)

-- | Generalizing constructors of the `Primitive` type to work
-- generically.
class Primitivable a where
  toPrim :: a -> Primitive

-- | @toPrim = id@
instance Primitivable Primitive where toPrim = id

-- | @toPrim = LinePrim@
instance Primitivable Line where toPrim = LinePrim

-- | @toPrim = BezierPrim@
instance Primitivable Bezier where toPrim = BezierPrim

-- | @toPrim = CubicBezierPrim@
instance Primitivable CubicBezier where toPrim = CubicBezierPrim

-- | All the rasterization works on lists of primitives,
-- in order to ease the use of the library, the Geometry
-- type class provides conversion facility, which help
-- generalising the geometry definition and avoid applying
-- Primitive constructor.
--
-- Also streamline the Path conversion.
class Geometry a where
  -- | Convert an element to a list of primitives
  -- to be rendered.
  toPrimitives :: a -> [Primitive]

  -- | Helper method to avoid overlaping instances.
  -- You shouldn't use it directly.
  listToPrims :: (Foldable f) => f a -> [Primitive]
  {-# INLINE listToPrims #-}
  listToPrims = F.concatMap toPrimitives . F.toList

instance Geometry Path where
  {-# INLINE toPrimitives #-}
  toPrimitives = pathToPrimitives

instance Geometry Primitive where
  toPrimitives e = [e]
  {-# INLINE listToPrims #-}
  listToPrims = F.toList -- Open question, is it optimised as `id`?

instance Geometry Line where
  {-# INLINE toPrimitives #-}
  toPrimitives e = [toPrim e]

instance Geometry Bezier where
  {-# INLINE toPrimitives #-}
  toPrimitives e = [toPrim e]

instance Geometry CubicBezier where
  {-# INLINE toPrimitives #-}
  toPrimitives e = [toPrim e]

-- | Generalize the geometry to any foldable container,
-- so you can throw any container to the the 'fill' or
-- 'stroke' function.
instance (Foldable f, Geometry a) => Geometry (f a) where
  {-# INLINE toPrimitives #-}
  toPrimitives = listToPrims


instance Transformable Primitive where
    {-# INLINE transform #-}
    transform f (LinePrim l) = LinePrim $ transform f l
    transform f (BezierPrim b) = BezierPrim $ transform f b
    transform f (CubicBezierPrim c) = CubicBezierPrim $ transform f c

    transformM f (LinePrim l) = LinePrim <$> transformM f l
    transformM f (BezierPrim b) = BezierPrim <$> transformM f b
    transformM f (CubicBezierPrim c) = CubicBezierPrim <$> transformM f c

instance PointFoldable Primitive where
    {-# INLINE foldPoints #-}
    foldPoints f acc = go
      where go (LinePrim l) = foldPoints f acc l
            go (BezierPrim b) = foldPoints f acc b
            go (CubicBezierPrim c) = foldPoints f acc c

instance {-# OVERLAPPABLE #-} (Traversable f, Transformable a)
      => Transformable (f a) where
    transform f = fmap (transform f)
    transformM f = mapM (transformM f)

instance {-# OVERLAPPABLE #-} (Foldable f, PointFoldable a)
      => PointFoldable (f a) where
    foldPoints f = foldl' (foldPoints f)

type Producer a = [a] -> [a]

type Container a = DList a

containerOfFunction :: ([a] -> [a]) -> Container a
containerOfFunction f = fromList $ f []

containerOfList :: [a] -> Container a
containerOfList = fromList

listOfContainer :: Container a -> [a]
listOfContainer = toList

-- | Describe a path in a way similar to many graphical
-- packages, using a "pen" position in memory and reusing
-- it for the next "move"
-- For example the example from Primitive could be rewritten:
--
-- > fill $ Path (V2 50 20) True
-- >    [ PathCubicBezierCurveTo (V2 90 60) (V2  5 100) (V2 50 140)
-- >    , PathLineTo (V2 120 80) ]
--
-- <<docimages/path_example.png>>
--
data Path = Path
    { -- | Origin of the point, equivalent to the
      -- first "move" command.
      _pathOriginPoint :: Point
      -- | Tell if we must close the path.
    , _pathClose       :: Bool
      -- | List of commands in the path
    , _pathCommand     :: [PathCommand]
    }
    deriving (Eq, Show)

instance Transformable Path where
    {-# INLINE transform #-}
    transform f (Path orig close rest) =
        Path (f orig) close (transform f rest)

    transformM f (Path orig close rest) =
        Path <$> f orig <*> pure close <*> transformM f rest


instance PointFoldable Path where
    {-# INLINE foldPoints #-}
    foldPoints f acc (Path o _ rest) =
        foldPoints f (f acc o) rest

-- | Actions to create a path
data PathCommand
    = -- | Draw a line from the current point to another point
      PathLineTo Point
      -- | Draw a quadratic bezier curve from the current point
      -- through the control point to the end point.
    | PathQuadraticBezierCurveTo Point Point

      -- | Draw a cubic bezier curve using 2 control points.
    | PathCubicBezierCurveTo Point Point Point
    deriving (Eq, Show)

instance Transformable PathCommand where
    transform f (PathLineTo p) = PathLineTo $ f p
    transform f (PathQuadraticBezierCurveTo p1 p2) =
        PathQuadraticBezierCurveTo (f p1) $ f p2
    transform f (PathCubicBezierCurveTo p1 p2 p3) =
        PathCubicBezierCurveTo (f p1) (f p2) $ f p3

    transformM f (PathLineTo p) = PathLineTo <$> f p
    transformM f (PathQuadraticBezierCurveTo p1 p2) =
        PathQuadraticBezierCurveTo <$> f p1 <*> f p2
    transformM f (PathCubicBezierCurveTo p1 p2 p3) =
        PathCubicBezierCurveTo <$> f p1 <*> f p2 <*> f p3

instance PointFoldable PathCommand where
    foldPoints f acc (PathLineTo p) = f acc p
    foldPoints f acc (PathQuadraticBezierCurveTo p1 p2) =
        f (f acc p1) p2
    foldPoints f acc (PathCubicBezierCurveTo p1 p2 p3) =
        foldl' f acc [p1, p2, p3]

-- | Transform a path description into a list of renderable
-- primitives.
pathToPrimitives :: Path -> [Primitive]
pathToPrimitives (Path origin needClosing commands) = go origin commands
  where
    go prev [] | prev /= origin && needClosing = [LinePrim $ Line prev origin]
    go _ [] = []
    go prev (PathLineTo to : xs) =
        LinePrim (Line prev to) : go to xs
    go prev (PathQuadraticBezierCurveTo c1 to : xs) =
        BezierPrim (Bezier prev c1 to) : go to xs
    go prev (PathCubicBezierCurveTo c1 c2 to : xs) =
        CubicBezierPrim (CubicBezier prev c1 c2 to) : go to xs

-- | Gives the orientation vector for the start of the
-- primitive.
firstTangeantOf :: Primitive -> Vector
firstTangeantOf p = case p of
  LinePrim (Line p0 p1) -> p1 ^-^ p0
  BezierPrim (Bezier p0 p1 p2) ->
      (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1)
  CubicBezierPrim (CubicBezier p0 p1 p2 _) -> 
       (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1)
 where
   ifBigEnough a b | nearZero a = b
                   | otherwise = a

-- | Gives the orientation vector at the end of the
-- primitive.
lastTangeantOf :: Primitive -> Vector
lastTangeantOf p = case p of
  LinePrim (Line p0 p1) -> p1 ^-^ p0
  BezierPrim (Bezier _ p1 p2) -> p2 ^-^ p1
  CubicBezierPrim (CubicBezier _ _ p2 p3) -> p3 ^-^ p2

-- | Extract the first point of the primitive.
firstPointOf :: Primitive -> Point
firstPointOf p = case p of
  LinePrim (Line p0 _) -> p0
  BezierPrim (Bezier p0 _ _) -> p0
  CubicBezierPrim (CubicBezier p0 _ _ _) -> p0

-- | Return the last point of a given primitive.
lastPointOf :: Primitive -> Point
lastPointOf p = case p of
  LinePrim (Line _ p0) -> p0
  BezierPrim (Bezier _ _ p0) -> p0
  CubicBezierPrim (CubicBezier _ _ _ p0) -> p0

resplit :: [Primitive] -> [[Primitive]]
resplit = uncurry (:) . go where
  go [] = ([], [])
  go (x:xs@(y:_)) | lastPointOf x `isDistingableFrom` firstPointOf y =
      ([x], after:rest) where (after, rest) = go xs
  go (x:xs) = (x:curr, rest) where (curr, rest) = go xs



<|start_filename|>exec-src/coon_rendering.hs<|end_filename|>
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
import Control.Monad.Trans.State.Strict
import Control.Monad( forM_ )
import Control.Monad.ST( ST, runST )
import Graphics.Rasterific hiding ( fill
                                  , dashedStrokeWithOffset
                                  , dashedStroke
                                  , fillWithMethod, stroke)
import Graphics.Rasterific.Texture
import Graphics.Rasterific.Linear( (^+^), (^*) )
import Graphics.Rasterific.Immediate
import Graphics.Rasterific.Patch
import Graphics.Rasterific.MeshPatch
import Graphics.Rasterific

import Criterion
import Criterion.Main
import Codec.Picture.ColorQuant
import Codec.Picture.Types
import Codec.Picture

import qualified Data.Vector as V

background, blue, black, yellow, red, green, orange, white :: PixelRGBA8
background = PixelRGBA8 128 128 128 255
blue = PixelRGBA8 0 020 150 255
red = PixelRGBA8 255 0 0 255
green =  PixelRGBA8 0 255 0 255
black = PixelRGBA8 0 0 0 255
{-grey = PixelRGBA8 128 128 128 255-}
orange = PixelRGBA8 255 0xA5 0 255
yellow = PixelRGBA8 255 255 0 255
{-brightblue = PixelRGBA8 0 255 255 255-}
white = PixelRGBA8 255 255 255 255

biColor, triColor :: Gradient PixelRGBA8
biColor = [ (0.0, black) , (1.0, yellow) ]
triColor = [ (0.0, blue), (0.5, white) , (1.0, red) ]

frontColor, accentColor, accent2Color :: PixelRGBA8
frontColor = PixelRGBA8 0 0x86 0xc1 255
accentColor = PixelRGBA8 0xff 0xf4 0xc1 255
accent2Color = PixelRGBA8 0xFF 0x53 0x73 255


drawImm :: FilePath -> Int -> Int -> (forall s. DrawContext (ST s) PixelRGBA8 ()) -> IO ()
drawImm path w h d = do
  putStrLn $ "Rendering " ++ path
  writePng path $ runST $ runDrawContext w h white d

drawPatchDebug :: FilePath -> Int -> Int -> CoonPatch (ParametricValues PixelRGBA8) -> IO ()
drawPatchDebug path w h p = do
  putStrLn $ "Rendering " ++ path
  writePng path $ runST $ runDrawContext w h white $ do
    rasterizeCoonPatch p
    mapM_ fillOrder $ drawOrdersOfDrawing w h 96 white $ debugDrawCoonPatch defaultDebug p

drawTensorDebug :: DebugOption -> FilePath -> Int -> Int -> TensorPatch (ParametricValues PixelRGBA8) -> IO ()
drawTensorDebug opt path w h p = do
  putStrLn $ "Rendering " ++ path
  writePng path $ runST $ runDrawContext w h white $ do
    rasterizeTensorPatch p
    mapM_ fillOrder $ drawOrdersOfDrawing w h 96 white $ debugDrawTensorPatch opt p

drawPure :: FilePath -> Int -> Int -> Drawing PixelRGBA8 () -> IO ()
drawPure path w h act = do
  putStrLn $ "Rendering " ++ path
  writePng path $ renderDrawing w h white $ 
    withTexture (uniformTexture black) act

coonTest :: IO ()
coonTest = do
  drawing "coon_img/single_patch.png" defaultDebug 400 440 patch [patch]
  drawing "coon_img/single_patch_subdiv.png" defaultDebug 400 410 patch [n, e, w, s]
  putStrLn "coon_img/subdiv.gif"
  case imgAtSubdiv of
    Left _ -> return ()
    Right f -> f
  where
    draw path p = do
      putStrLn $ "Rendering " ++ path
      writePng path . renderDrawing 800 800 (PixelRGBA8 255 255 255 255) $
          withTexture (uniformTexture (PixelRGBA8 0 0 0 255)) p

    drawing :: FilePath -> DebugOption -> Int -> Int
            -> CoonPatch (ParametricValues PixelRGBA8)
            -> [CoonPatch (ParametricValues a)]
            -> IO ()
    drawing path opt w h rootPatch patches = do
      putStrLn $ "Rendering " ++ path
      writePng path $ runST $ runDrawContext w h white $ do
        rasterizeCoonPatch rootPatch
        forM_ patches $ \p ->
          mapM_ fillOrder $ drawOrdersOfDrawing w h 96 white $
            debugDrawCoonPatch defaultDebug p { _coonValues = colors }

    Subdivided n e w s = subdividePatch patch { _coonValues = parametricBase }

    imgAtSubdiv = writeGifImages "coon_img/subdiv.gif" LoopingForever images
      where
        images = toGifPart . renderLevel <$> [0 .. 8]
        renderLevel i =
          runST $ runDrawContext 400 400 white $ renderCoonPatchAtDeepness i patch 
        toGifPart img = (pal, 200, i)
          where (i, pal) = palettize defaultPaletteOptions $ pixelMap dropTransparency img

    colors = ParametricValues
      { _northValue = frontColor
      , _eastValue = accentColor
      , _southValue = accent2Color
      , _westValue = frontColor
      }

    patch :: CoonPatch (ParametricValues PixelRGBA8)
    patch = transform (\p -> p ^* 0.5 ^+^ V2 0 20) CoonPatch
      { _north = CubicBezier (V2 52 67) (V2 198 (-55)) (V2 580 104) (V2 713 113)
      , _east = CubicBezier (V2 713 113) (V2 775 369) (V2 437 392) (V2 670 674)
      , _south = CubicBezier (V2 670 674) (V2 471 690) (V2 294 762) (V2 72 722)
      , _west = CubicBezier (V2 73 722) (V2 9 490) (V2 56 284) (V2 52 67)
      , _coonValues = colors
      }

coonTensorTest :: IO ()
coonTensorTest = do
  drawImm "coon_img/compare_tensor.png" 400 400 $ rasterizeTensorPatch tensorPatch
  drawTensorDebug opt "coon_img/compare_tensor_debug.png" 400 400 tensorPatch
  drawImm "coon_img/compare_coon.png" 400 400 $ rasterizeCoonPatch coonPatch
  drawImm "coon_img/tensor_ffd.png" 400 400 $ rasterizeTensorPatch tensorPatch
  where
    opt = defaultDebug { _drawOutline = False }
    [ c00, c01, c02, c03
      , c10, c11, c12, c13
      , c20, c21, c22, c23
      , c30, c31, c32, c33
      ] = fmap (\p -> (p ^+^ (V2 0 (-852.36))) * 2)
        {-
          [(V2 13.21 869.2), (V2 49.67 838.5), (V2 145.1 878.4), (V2 178.2 880.7)
          ,(V2 13.98 923.5), (V2 90 950),     (V2 117 950),      (V2 193.9 944.6)
          ,(V2 2.253 974.9), (V2 90 1000),    (V2 117 1000),     (V2 109.2 950.4)
          ,(V2 18.21  1033), (V2 73.48 1043), (V2 117.7 1025),   (V2 167.5 1021)
          ] -- -} 
       -- {- 
          [(V2 13.21 869.2), (V2 49.67 838.5), (V2 145.1 878.4), (V2 178.2 880.7)
          ,(V2 13.98 923.5), (V2 140 990),     (V2 147 1000),      (V2 193.9 944.6)
          ,(V2 2.253 974.9), (V2 140 1000),    (V2 147 1005),     (V2 109.2 950.4)
          ,(V2 18.21  1033), (V2 73.48 1043), (V2 117.7 1025),   (V2 167.5 1021)
          ] -- -}

    coonPatch = CoonPatch
        { _north = CubicBezier c00 c01 c02 c03
        , _east  = CubicBezier c03 c13 c23 c33
        , _south = CubicBezier c33 c32 c31 c30
        , _west  = CubicBezier c30 c20 c10 c00
        , _coonValues = colors
        }

    tensorPatch = TensorPatch
      { _curve0 = CubicBezier c00 c01 c02 c03
      , _curve1 = CubicBezier c10 c11 c12 c13
      , _curve2 = CubicBezier c20 c21 c22 c23
      , _curve3 = CubicBezier c30 c31 c32 c33
      , _tensorValues = colors
      }

    colors = ParametricValues blue red red red

tensorSplit :: IO ()
tensorSplit = do
  drawImm "coon_img/split_tensor_orig.png" 400 400 $ rasterizeTensorPatch $ tensorPatch
  drawTensorDebug defaultDebug "coon_img/split_tensor_orig_debug.png" 400 400 tensorPatch
  drawTensorSubdivDebug "coon_img/split_tensor_orig_subH.png" 400 400 tensorPatch [patchWest, patchEast]
  drawTensorSubdivDebug "coon_img/split_tensor_orig_subHVR.png" 400 400 tensorPatch [patchWest, patchNorthEast, patchSouthEast]
  where
    drawTensorSubdivDebug path w h p ps = do
        putStrLn $ "Rendering " ++ path
        writePng path $ runST $ runDrawContext w h white $ do
            rasterizeTensorPatch p
            mapM_ fillOrder $ drawOrdersOfDrawing w h 96 white $ mapM_ (debugDrawTensorPatch opt) ps

    opt = defaultDebug
    [ c00, c01, c02, c03
     , c10, c11, c12, c13
     , c20, c21, c22, c23
     , c30, c31, c32, c33
     ] = fmap (\p -> (p ^+^ (V2 30 (-802.36))) ^* 1.5)
        [(V2 13.21 869.2), (V2 49.67 838.5), (V2 145.1 878.4), (V2 178.2 880.7)
        ,(V2 13.98 923.5), (V2 120 950),     (V2 147 950),      (V2 193.9 944.6)
        ,(V2 2.253 974.9), (V2 120 1000),    (V2 147 1000),     (V2 220.2 950.4)
        ,(V2 18.21  1033), (V2 73.48 1043), (V2 117.7 1025),   (V2 167.5 1021)
        ]

    tensorPatch = TensorPatch
      { _curve0 = CubicBezier c00 c01 c02 c03
      , _curve1 = CubicBezier c10 c11 c12 c13
      , _curve2 = CubicBezier c20 c21 c22 c23
      , _curve3 = CubicBezier c30 c31 c32 c33
      , _tensorValues = colors
      }

    (patchWest, patchEast) = horizontalTensorSubdivide tensorPatch { _tensorValues = parametricBase }
    (patchNorthEast, patchSouthEast) = horizontalTensorSubdivide $ transposePatch patchEast
    colors = ParametricValues frontColor accentColor accent2Color frontColor

coonTestColorStop :: IO ()
coonTestColorStop = do
  drawImm "coon_render_color.png" 800 800 $ rasterizeCoonPatch patch
  drawPatchDebug "coon_render_color_debug.png" 800 800 patch
  where
    cc a b c d e f = PathCubicBezierCurveTo (V2 a b) (V2 c d) (V2 e f)
    [CubicBezierPrim c1, CubicBezierPrim c2, CubicBezierPrim c3, CubicBezierPrim c4] =
        toPrimitives . transform (\p -> (p ^+^ (V2 0 (-852.36))) * 4) $ Path (V2 13.21 869.2) False
          [cc 49.67 838.5 145.1 878.4 178.2 (880.7 :: Float)
          ,cc 193.9 944.6 109.2 950.4 167.5 1021
          ,cc 117.7 1025 73.48 1043 18.21 1033
          ,cc 2.253 974.9 13.98 923.5 13.21 869.2
          ]
    patch = CoonPatch c1 c2 c3 c4 
              (ParametricValues (PixelRGBA8 255 20 0 255)
                          red
                          red
                          red)

toCoon :: V2 Float -> ParametricValues px -> [[V2 Float]] -> CoonPatch (ParametricValues px)
toCoon st values = build . go st where
  build [n, e, s, w] = CoonPatch n e s w values
  build _ = error "toCoon"

  go _ [] = []
  go p [lst] = case toAbsolute p lst of
    [c1, c2] -> [CubicBezier p c1 c2 st]
    _ -> error "Mouh"
  go p (x : xs) = case toAbsolute p x of
    [c1, c2, c3] -> CubicBezier p c1 c2 c3 : go c3 xs
    _ -> error "Mouh"

  toAbsolute p = fmap (p ^+^)

drawVertex :: Point -> Drawing PixelRGBA8 ()
drawVertex p = stroke 2 JoinRound (CapRound, CapRound) $ circle p 4

drawBetweenPoint :: Point -> Point -> Drawing PixelRGBA8 ()
drawBetweenPoint p1 p2 =
  stroke 1.5 JoinRound (CapRound, CapRound) $ line p1 p2

jitPoints :: Transformable a => Float -> a -> a
jitPoints force e = evalState (transformM jit e) jitter where
  jitter = cycle $ (^* force) <$> [ V2 1 0.5, V2 0.5 1 , V2 (-0.5) (-1)
                                  , V2 (-1) (-0.5), V2 2 (-1.5), V2 (-1) 1]
  jit p = do
    v:rest <- get
    put rest
    return $ p ^+^ v

simpleGrid :: DebugOption
simpleGrid = defaultDebug
    { _drawControlMesh = False
    , _drawBaseVertices = False
    , _drawControVertices = False
    }

grid :: IO ()
grid = do
    drawPure "coon_img/grid.png" 460 300 $ drawing simpleGrid limesh
    drawPure "coon_img/grid_bez.png" 460 300 $ drawing simpleGrid moved
    drawPure "coon_img/grid_bez_color.png" 460 300 $ drawing simpleColor moved
    drawImm  "coon_img/gradient_mesh_first.png" 460 300 $ renderCoonMesh moved
    drawImm  "coon_img/gradient_mesh_first_bicubic.png" 460 300 $ renderCoonMeshBicubic moved
  where
    height = 3
    width = 4
    colorConstants = [frontColor, accentColor, frontColor, accent2Color, accentColor]
    colors = V.fromListN ((width + 1) * (height + 1))
           $ cycle $ colorConstants ++ tail colorConstants
    limesh = generateLinearGrid width height (V2 30 40) (V2 90 70) colors
    moved = jitPoints 12 limesh

    varPatchIndices = [(x, y) | y <- [0 .. height - 1], x <- [0 .. width - 1]]

    simpleColor = simpleGrid
        { _colorVertices    = True
        , _drawBaseVertices = True
        , _drawControVertices = False
        }

    drawing opt mesh =
      forM_ varPatchIndices $ \(x, y) -> do
          debugDrawCoonPatch opt $ coonPatchAt mesh x y

imgGrid :: IO ()
imgGrid = do
  Right img <- fmap convertRGBA8 <$> readImage "exec-src/maki_fab.JPG"
  let limesh = generateImageMesh 3 3 (V2 10 10) img
      moved = jitPoints 21 limesh
      w = 502
      h = 333
  drawImm "coon_img/maki_base.png" w h $ renderImageMesh limesh
  drawImm "coon_img/maki_base_grid.png" w h $ do
    renderImageMesh limesh
    mapM_ fillOrder $
      drawOrdersOfDrawing  w h 90 (PixelRGBA8 0 0 0 0) $ do
        mapM_ (debugDrawCoonPatch simpleGrid) . coonPatchesOf $ const frontColor <$> limesh
  drawImm "coon_img/maki_moved.png" w h $ renderImageMesh moved
  drawImm "coon_img/maki_moved_with_grid.png" w h $ do
    renderImageMesh moved
    mapM_ fillOrder $
      drawOrdersOfDrawing  w h 90 (PixelRGBA8 0 0 0 0) $ do
        mapM_ (debugDrawCoonPatch simpleGrid) . coonPatchesOf $ const frontColor <$> moved

debugCubic :: IO ()
debugCubic = do
    drawImm "coon_img/gradient_mesh_bilinear_debug.png" 500 500 $ renderCoonMesh mesh
    drawImm "coon_img/gradient_mesh_bicubic_debug.png" 500 500 $ renderCoonMeshBicubic mesh
    drawImm "coon_img/gradient_mesh_bilinear_debug2.png" 500 500 $ renderCoonMesh mesh2
    drawImm "coon_img/gradient_mesh_bicubic_debug2.png" 500 500 $ renderCoonMeshBicubic mesh2
    drawImm "coon_img/gradient_mesh_bilinear_debug3.png" 1000 1000 $ renderCoonMesh mesh3
    drawImm "coon_img/gradient_mesh_bicubic_debug3.png" 1000 1000 $ renderCoonMeshBicubic mesh3
  where
    px r g b = PixelRGBA8 r g b 255
    mesh =
      generateLinearGrid 4 4 (V2 10 10) (V2 100 100) colors

    mesh2 =
      generateLinearGrid 3 3 (V2 10 10) (V2 100 100) colors

    mesh3 =
      generateLinearGrid 9 9 (V2 10 10) (V2 100 100) . V.fromListN (10 * 10) $ cycle colorBase
  
    colors2 = V.fromListN (4 * 4)
      [ px 255 179  47
      , px 255 242  34
      , px  61 227 206
      , px  90 255   0

      , px 255 242  34
      , px  61 227 206
      , px 103 157 255
      , px 255 179  47

      , px 255  74  74
      , px  90 255   0
      , px 255 179  47
      , px  61 227 206

      , px 103 157 255
      , px  61 227 206
      , px 255 242  34
      , px 103 157 255
      ]

    colors = V.fromListN (5 * 5) colorBase

    colorBase =
      [ px 205 255 41
      , px 255 196 0
      , px 255 103 0
      , px 255 103 0
      , px 0   176 255
  
      , px 241 7   0
      , px 127 0   0
      , px 0   76  255
      , px 41  255 205
      , px 255 196 0
  
      , px 0   76  255
      , px 255 103 0
      , px 0   76  255
      , px 124 255 121
      , px 255 103 0
  
      , px 0   76  255
      , px 241 7   0
      , px 0   176 255
      , px 255 103 0
      , px 0   76  255
  
      , px 241 7   0
      , px 0   0   241
      , px 241 7   0
      , px 41  255 205
      , px 41  255 205
      ]

coonTestWild :: IO ()
coonTestWild = do
  drawImm "coon_render_wild.png" 800 800 $ rasterizeCoonPatch patch
  drawPatchDebug "coon_render_wild_debug.png" 800 800 patch
  where
    patch = toCoon (V2 50 130 ^* 2)
        (ParametricValues red yellow orange green) $
        fmap (^* 2) <$>
        [ [V2 150  0, V2 300 (-100), V2 120 (-100)]
        , [V2 0  100, V2  40   200 , V2  40  220]
        , [V2 (-250) (-100), V2 50 60, V2 (-160) 0]
        , [V2 (-20) (-80), V2 20 (-40)]
        ]

profile :: IO ()
profile = do
  writePng "M.png" $ (runST $ runDrawContext 400 400 white $ rasterizeTensorPatch tensorPatch)
  where
    [ c00, c01, c02, c03
      , c10, c11, c12, c13
      , c20, c21, c22, c23
      , c30, c31, c32, c33
      ] = fmap (\p -> (p ^+^ (V2 0 (-852.36))) * 2)
        {-
          [(V2 13.21 869.2), (V2 49.67 838.5), (V2 145.1 878.4), (V2 178.2 880.7)
          ,(V2 13.98 923.5), (V2 90 950),     (V2 117 950),      (V2 193.9 944.6)
          ,(V2 2.253 974.9), (V2 90 1000),    (V2 117 1000),     (V2 109.2 950.4)
          ,(V2 18.21  1033), (V2 73.48 1043), (V2 117.7 1025),   (V2 167.5 1021)
          ] -- -} 
       -- {- 
          [(V2 13.21 869.2), (V2 49.67 838.5), (V2 145.1 878.4), (V2 178.2 880.7)
          ,(V2 13.98 923.5), (V2 140 990),     (V2 147 1000),      (V2 193.9 944.6)
          ,(V2 2.253 974.9), (V2 140 1000),    (V2 147 1005),     (V2 109.2 950.4)
          ,(V2 18.21  1033), (V2 73.48 1043), (V2 117.7 1025),   (V2 167.5 1021)
          ] -- -}

    tensorPatch = TensorPatch
      { _curve0 = CubicBezier c00 c01 c02 c03
      , _curve1 = CubicBezier c10 c11 c12 c13
      , _curve2 = CubicBezier c20 c21 c22 c23
      , _curve3 = CubicBezier c30 c31 c32 c33
      , _tensorValues = colors
      }

    colors = ParametricValues blue red red red

doBench :: IO ()
doBench = do
 writePng "subdiv_render.png" $ runST $ runDrawContext 400 400 white $ renderTensorPatch tensorPatch
 writePng "ffd_render.png" $ runST $ runDrawContext 400 400 white $ rasterizeTensorPatch tensorPatch
 defaultMain
   [ bench "Subdiv" $ whnf 
       (\v -> runST $ runDrawContext 400 400 white $ renderTensorPatch v) tensorPatch
   , bench "FFD" $ whnf 
       (\v -> runST $ runDrawContext 400 400 white $ rasterizeTensorPatch v) tensorPatch
   ]
  where
    [ c00, c01, c02, c03
      , c10, c11, c12, c13
      , c20, c21, c22, c23
      , c30, c31, c32, c33
      ] = fmap (\p -> (p ^+^ (V2 0 (-852.36))) * 2)
        {-
          [(V2 13.21 869.2), (V2 49.67 838.5), (V2 145.1 878.4), (V2 178.2 880.7)
          ,(V2 13.98 923.5), (V2 90 950),     (V2 117 950),      (V2 193.9 944.6)
          ,(V2 2.253 974.9), (V2 90 1000),    (V2 117 1000),     (V2 109.2 950.4)
          ,(V2 18.21  1033), (V2 73.48 1043), (V2 117.7 1025),   (V2 167.5 1021)
          ] -- -} 
       -- {- 
          [(V2 13.21 869.2), (V2 49.67 838.5), (V2 145.1 878.4), (V2 178.2 880.7)
          ,(V2 13.98 923.5), (V2 140 990),     (V2 147 1000),      (V2 193.9 944.6)
          ,(V2 2.253 974.9), (V2 140 1000),    (V2 147 1005),     (V2 109.2 950.4)
          ,(V2 18.21  1033), (V2 73.48 1043), (V2 117.7 1025),   (V2 167.5 1021)
          ] -- -}

    tensorPatch = TensorPatch
      { _curve0 = CubicBezier c00 c01 c02 c03
      , _curve1 = CubicBezier c10 c11 c12 c13
      , _curve2 = CubicBezier c20 c21 c22 c23
      , _curve3 = CubicBezier c30 c31 c32 c33
      , _tensorValues = colors
      }

    colors = ParametricValues blue red red red

main :: IO ()
main = do
  grid
  imgGrid
  debugCubic
  coonTest
  coonTestColorStop 
  coonTestWild 
  coonTensorTest
  tensorSplit
  profile
  doBench 



<|start_filename|>src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs<|end_filename|>
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
module Graphics.Rasterific.CubicBezier.FastForwardDifference
    ( ForwardDifferenceCoefficient( .. )
    , bezierToForwardDifferenceCoeff
    , rasterizerCubicBezier
    , rasterizeTensorPatch
    , rasterizeCoonPatch
    , estimateFDStepCount
    ) where

import Control.Monad.Primitive( PrimMonad )
import Control.Monad.State( lift, get )
import Control.Monad.ST( ST )
import Data.Bits( unsafeShiftL )

import Codec.Picture( PixelRGBA8 )
import Codec.Picture.Types( MutableImage( .. ) )

import Graphics.Rasterific.Compositor
import Graphics.Rasterific.Command
import Graphics.Rasterific.Types
import Graphics.Rasterific.Linear
import Graphics.Rasterific.BiSampleable
import Graphics.Rasterific.PatchTypes
import Graphics.Rasterific.Shading

data ForwardDifferenceCoefficient = ForwardDifferenceCoefficient
    { _fdA :: {-# UNPACK #-} !Float
    , _fdB :: {-# UNPACK #-} !Float
    , _fdC :: {-# UNPACK #-} !Float
    }

-- | Given a cubic curve, return the initial step size and
-- the coefficient for the forward difference.
-- Initial step is assumed to be "1"
bezierToForwardDifferenceCoeff
    :: CubicBezier
    -> V2 ForwardDifferenceCoefficient
bezierToForwardDifferenceCoeff (CubicBezier x y z w) = V2 xCoeffs yCoeffs
  where
    xCoeffs = ForwardDifferenceCoefficient { _fdA = ax, _fdB = bx, _fdC = cx }
    yCoeffs = ForwardDifferenceCoefficient { _fdA = ay, _fdB = by, _fdC = cy }

    V2 ax ay = w ^-^ x
    V2 bx by = (w ^-^ z ^* 2 ^+^ y) ^* 6
    V2 cx cy = (w ^-^ z ^* 3 ^+^ y ^* 3 ^-^ x) ^* 6

halveFDCoefficients :: ForwardDifferenceCoefficient -> ForwardDifferenceCoefficient
halveFDCoefficients (ForwardDifferenceCoefficient a b c) =
    ForwardDifferenceCoefficient { _fdA = a', _fdB = b', _fdC = c' }
  where
    c' = c * 0.125
    b' = b * 0.25 - c'
    a' = (a - b') * 0.5

updateForwardDifferencing :: ForwardDifferenceCoefficient -> ForwardDifferenceCoefficient
updateForwardDifferencing (ForwardDifferenceCoefficient a b c) =
  ForwardDifferenceCoefficient (a + b) (b + c) c

updatePointsAndCoeff :: (Applicative f', Applicative f, Additive f)
                     => f' (f Float) -> f' (f ForwardDifferenceCoefficient)
                     -> (f' (f Float), f' (f ForwardDifferenceCoefficient))
updatePointsAndCoeff pts coeffs =
    (advancePoint <$> pts <*> coeffs, fmap updateForwardDifferencing <$> coeffs)
  where
    fstOf (ForwardDifferenceCoefficient a _ _) = a
    advancePoint v c = v ^+^ (fstOf <$> c)


estimateFDStepCount :: CubicBezier -> Int
estimateFDStepCount (CubicBezier p0 p1 p2 p3) =
  toInt $ maximum [p0 `qd` p1, p2 `qd` p3, (p0 `qd` p2) / 4, (p1 `qd` p3) / 4]
  where
    toInt = scale . frexp . max 1 . (18 *)
    scale (_, r) = (r + 1) `div` 2


fixIter :: Int -> (a -> a) -> a -> a
fixIter count f = go count
  where
    go 0 a = a
    go n a = go (n-1) $ f a

isPointInImage :: MutableImage s a -> Point -> Bool
isPointInImage MutableImage { mutableImageWidth = w, mutableImageHeight = h } (V2 x y) =
   0 <= x && x < fromIntegral w && 0 <= y && y < fromIntegral h

isCubicBezierOutsideImage :: MutableImage s a -> CubicBezier -> Bool
isCubicBezierOutsideImage img (CubicBezier a b c d) =
  not $ isIn a || isIn b || isIn c || isIn d
  where isIn = isPointInImage img

isCubicBezierInImage :: MutableImage s a -> CubicBezier -> Bool
isCubicBezierInImage img (CubicBezier a b c d) =
    isIn a && isIn b && isIn c && isIn d
  where isIn = isPointInImage img

-- | Rasterize a cubic bezier curve using the Fast Forward Diffrence
-- algorithm.
rasterizerCubicBezier :: (PrimMonad m, ModulablePixel px, BiSampleable src px)
                      => src -> CubicBezier
                      -> Float -> Float
                      -> Float -> Float
                      -> DrawContext m px ()
{-# SPECIALIZE INLINE
  rasterizerCubicBezier :: (ParametricValues PixelRGBA8) -> CubicBezier
                        -> Float -> Float
                        -> Float -> Float
                        -> DrawContext (ST s) PixelRGBA8 () #-}
rasterizerCubicBezier source bez uStart vStart uEnd vEnd = do
  canvas <- get
  let !baseFfd = bezierToForwardDifferenceCoeff bez
      !shiftCount = estimateFDStepCount bez
      maxStepCount :: Int
      maxStepCount = 1 `unsafeShiftL` shiftCount
      !(V2 (ForwardDifferenceCoefficient ax' bx' cx)
           (ForwardDifferenceCoefficient ay' by' cy)) =
               fixIter shiftCount halveFDCoefficients <$> baseFfd

      !(V2 _du dv) = (V2 uEnd vEnd ^-^ V2 uStart vStart) ^/ fromIntegral maxStepCount
      !(V2 xStart yStart) = _cBezierX0 bez
      
      go !currentStep _ _ _ _ _ _ _ | currentStep >= maxStepCount = return ()
      go !currentStep !ax !bx !ay !by !x !y !v = do
        let !color = interpolate source uStart v
        plotOpaquePixel canvas color (floor x) (floor y)
        go (currentStep + 1)
            (ax + bx) (bx + cx)
            (ay + by) (by + cy)
            (x  + ax) (y  + ay)
            (v  + dv)

      goUnsafe !currentStep _ _ _ _ _ _ _ | currentStep >= maxStepCount = return ()
      goUnsafe !currentStep !ax !bx !ay !by !x !y !v = do
        let !color = interpolate source uStart v
        unsafePlotOpaquePixel canvas color (floor x) (floor y)
        goUnsafe (currentStep + 1)
            (ax + bx) (bx + cx)
            (ay + by) (by + cy)
            (x  + ax) (y  + ay)
            (v  + dv)

  if isCubicBezierOutsideImage canvas bez then
    return ()
  else if isCubicBezierInImage canvas bez then
    lift $ goUnsafe 0 ax' bx' ay' by' xStart yStart vStart
  else
    lift $ go 0 ax' bx' ay' by' xStart yStart vStart

-- | Rasterize a coon patch using the Fast Forward Diffrence algorithm,
-- likely to be faster than the subdivision one.
rasterizeCoonPatch :: (PrimMonad m, ModulablePixel px, BiSampleable src px)
                    => CoonPatch src -> DrawContext m px ()
{-# SPECIALIZE rasterizeCoonPatch :: CoonPatch (ParametricValues PixelRGBA8)
                                  -> DrawContext (ST s) PixelRGBA8 () #-}
rasterizeCoonPatch = rasterizeTensorPatch . toTensorPatch

-- | Rasterize a tensor patch using the Fast Forward Diffrence algorithm,
-- likely to be faster than the subdivision one.
rasterizeTensorPatch :: (PrimMonad m, ModulablePixel px, BiSampleable src px)
                     => TensorPatch src -> DrawContext m px ()
{-# SPECIALIZE rasterizeTensorPatch :: TensorPatch (ParametricValues PixelRGBA8)
                                    -> DrawContext (ST s) PixelRGBA8 () #-}
rasterizeTensorPatch TensorPatch { .. } =
    go maxStepCount basePoints ffCoeff 0
  where
    !curves = V4 _curve0 _curve1 _curve2 _curve3
    !shiftStep = maximum $ estimateFDStepCount <$> [_curve0, _curve1, _curve2, _curve3]
    
    !basePoints = _cBezierX0 <$> curves
    !ffCoeff =
      fmap (fixIter shiftStep halveFDCoefficients) . bezierToForwardDifferenceCoeff <$> curves
    
    maxStepCount :: Int
    !maxStepCount = 1 `unsafeShiftL` shiftStep

    !du = 1 / fromIntegral maxStepCount
    
    toBezier (V4 a b c d) = CubicBezier a b c d
    
    go 0 _pts _coeffs _uvStart = return ()
    go i !pts !coeffs !ut = do
      let (newPoints, newCoeff) = updatePointsAndCoeff pts coeffs
      rasterizerCubicBezier _tensorValues (toBezier pts) ut 0 ut 1
      go (i - 1) newPoints newCoeff (ut + du)

frexp :: Float -> (Float, Int)
frexp x
   | isNaN x = error "NaN given to frexp"
   | isInfinite x = error "infinity given to frexp"
   | otherwise  = go x 0
  where
    go s e
      | s >= 1.0 = go (s / 2) (e + 1)
      | s < 0.5 = go (s * 2) (e - 1)
      | otherwise = (s, e)



<|start_filename|>Makefile<|end_filename|>

build:
	cabal build

doc:
	cabal haddock

depinstall:
	cabal install -j4 --only-dependencies

run:
	dist/build/test/test
	
test:
	dist/build/test/test

lint:
	hlint lint src



<|start_filename|>src/Graphics/Rasterific/ComplexPrimitive.hs<|end_filename|>
-- | Provide definition for some higher level objects (only slightly)
module Graphics.Rasterific.ComplexPrimitive( rectangle
                                           , roundedRectangle
                                           , circle
                                           , ellipse
                                           ) where

import Control.Applicative( empty, (<|>) )
import Control.Exception( throw, ArithException( .. ) )

import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^*) )
import Graphics.Rasterific.Line
import Graphics.Rasterific.CubicBezier
import Graphics.Rasterific.Types

isCoordValid :: RealFloat a => a -> Maybe ArithException
isCoordValid v
  | isInfinite v = pure Overflow
  | isNaN v || isDenormalized v = pure Denormal
  | otherwise = empty

isPointValid :: RealFloat a => V2 a -> Maybe ArithException
isPointValid (V2 x y) = isCoordValid x <|> isCoordValid y

-- | Generate a list of primitive representing a circle.
--
-- > fill $ circle (V2 100 100) 75
--
-- <<docimages/fill_circle.png>>
--
circle :: Point -- ^ Circle center in pixels
       -> Float -- ^ Circle radius in pixels
       -> [Primitive]
circle p r
  | Just ex <- isCoordValid r <|> isPointValid p = throw ex
circle center radius =
    CubicBezierPrim . transform mv <$> cubicBezierCircle
  where
    mv p = (p ^* radius) ^+^ center

-- | Generate a list of primitive representing an ellipse.
--
-- > fill $ ellipse (V2 100 100) 75 30
--
-- <<docimages/fill_ellipse.png>>
--
ellipse :: Point -> Float -> Float -> [Primitive]
ellipse c rx ry
  | Just ex <- isCoordValid rx <|> isCoordValid ry <|> isPointValid c = throw ex
ellipse center rx ry =
    CubicBezierPrim . transform mv <$> cubicBezierCircle
  where
    mv (V2 x y) = V2 (x * rx) (y * ry) ^+^ center

-- | Generate a list of primitive representing a
-- rectangle
--
-- > fill $ rectangle (V2 30 30) 150 100
--
-- <<docimages/fill_rect.png>>
--
rectangle :: Point -- ^ Corner upper left
          -> Float -- ^ Width in pixel
          -> Float -- ^ Height in pixel
          -> [Primitive]
rectangle p w h
  | Just ex <- isCoordValid w <|> isCoordValid h <|> isPointValid p = throw ex
rectangle p@(V2 px py) w h =
  LinePrim <$> lineFromPath
    [ p, V2 (px + w) py, V2 (px + w) (py + h), V2 px (py + h), p ]

-- | Generate a list of primitive representing a rectangle
-- with rounded corner.
--
-- > fill $ roundedRectangle (V2 10 10) 150 150 20 10
--
-- <<docimages/fill_roundedRectangle.png>>
--
roundedRectangle :: Point -- ^ Corner upper left
                 -> Float -- ^ Width in pixel
                 -> Float -- ^ Height in pixel.
                 -> Float -- ^ Radius along the x axis of the rounded corner. In pixel.
                 -> Float -- ^ Radius along the y axis of the rounded corner. In pixel.
                 -> [Primitive]
roundedRectangle p w h rx ry
  | Just ex <- isCoordValid w
        <|> isCoordValid h
        <|> isCoordValid rx
        <|> isCoordValid ry
        <|> isPointValid p = throw ex
roundedRectangle (V2 px py) w h rx ry =
    [ CubicBezierPrim . transform (^+^ V2 xFar yNear) $ cornerTopR
    , LinePrim $ Line (V2 xFar py) (V2 xNear py)
    , CubicBezierPrim . transform (^+^ V2 (px + rx) (py + ry)) $ cornerTopL
    , LinePrim $ Line (V2 px yNear) (V2 px yFar)
    , CubicBezierPrim . transform (^+^ V2 (px + rx) yFar) $ cornerBottomL
    , LinePrim $ Line (V2 xNear (py + h)) (V2 xFar (py + h))
    , CubicBezierPrim . transform (^+^ V2 xFar yFar) $ cornerBottomR
    , LinePrim $ Line (V2 (px + w) yFar) (V2 (px + w) yNear)
    ]
  where
   xNear = px + rx
   xFar = px + w - rx

   yNear = py + ry
   yFar = py + h - ry

   (cornerBottomR :
    cornerTopR     :
    cornerTopL  :
    cornerBottomL:_) = transform (\(V2 x y) -> V2 (x * rx) (y * ry)) <$> cubicBezierCircle

