packages feed

curves 1.0.0 → 1.1.0

raw patch · 16 files changed

+301/−140 lines, 16 files

Files

Graphics/Curves.hs view
@@ -13,16 +13,16 @@     -- ** Curves   , point, line, lineStrip, poly, circle, circleSegment     -- ** Advanced curves-  , curve, curve'+  , curve, curve_, curve'   , bSpline, bSpline', closedBSpline   , bezier, bezierSegment     -- ** Operating on curves   , reverseImage   , (+++), (+.+), (<++), (++>)-  , differentiate, mapImage, zipImage+  , differentiate, mapImage, zipImage, transformImage   , curveLength     -- ** Advanced image manipulation-  , freezeImageSize, freezeImageOrientation, freezeImage+  , freezeImageSize, freezeImageOrientation, freezeImage, freezeImageStyle   , unfreezeImage     -- ** Combining images   , BlendFunc@@ -31,7 +31,7 @@   , (<>)   , (><), (<->)     -- ** Query functions-  , imageBounds+  , imageBounds, sampleImage     -- * Image attributes     -- | Image attributes control things like the colour and width of curves.   , module Graphics.Curves.Attribute@@ -39,6 +39,8 @@     -- * Rendering   , autoFit, autoStretch   , renderImage+    -- * Other+  , version   )   where @@ -47,11 +49,14 @@ import Graphics.Curves.Curve import Graphics.Curves.Image import Graphics.Curves.Colour-import Graphics.Curves.Render+import Graphics.Curves.Render hiding (sampleImage) import Graphics.Curves.Compile import Graphics.Curves.Attribute import Graphics.Curves.Style +import Data.Version (showVersion)+import qualified Paths_curves as Paths+ -- | Scale the an image to fit inside the the box given by the two points --   (bottom-left and top-right corners). autoFit :: Point -> Point -> Image -> Image@@ -119,6 +124,21 @@     getBounds k' i = scale (1/k) $ bboxToSegment $ bounds $ compileImage $ scale k i       where k = diag k' +sampleImage :: Image -> Scalar -> [[Point]]+sampleImage IEmpty t                 = []+sampleImage (Combine _ i j) t        = sampleImage i t ++ sampleImage j t+sampleImage (ICurve (Curves cs _)) t = [map (sampleCurve t) cs]+  where+    sampleCurve t (Curve f g _ _) = g t (f t)++-- | Freeze the line style of an image. This means that the pixel parameters+--   (distance along the curve and pixel position) are given as they are at+--   this moment, and won't be affected by later transformations.+freezeImageStyle :: Image -> Image+freezeImageStyle i = mapCurve (freezeLineStyle res) i+  where res = vuncurry min (p1 - p0) / 100+        Seg p0 p1 = imageBounds i+ -- ImageElement -----------------------------------------------------------  class Transformable a => ImageElement a where@@ -132,4 +152,7 @@  instance ImageElement Vec where   toImage = point++version :: String+version = showVersion Paths.version
Graphics/Curves/Attribute.hs view
@@ -10,13 +10,15 @@     -- | Modify an attribute   | forall f b. HasAttribute f a => f b :~ (b -> b) +infix 0 :=, :~+ -- | The type constructor @f@ is such that @f b@ is the type of names of --   attributes of @a@ of type @b@. class HasAttribute f a where   modifyAttribute :: f b -> (b -> b) -> a -> a+  setAttribute    :: f b -> b -> a -> a -setAttribute :: HasAttribute f a => f b -> b -> a -> a-setAttribute t x = modifyAttribute t (const x)+  setAttribute t x = modifyAttribute t (const x)  infixl 7 `with` -- | Apply a sequence of attribute assignments to an object (applied
Graphics/Curves/BoundingBox.hs view
@@ -7,6 +7,7 @@ import Data.Function -- import Data.List import Data.Foldable hiding (concatMap)+import Data.Maybe import Test.QuickCheck  import Graphics.Curves.Math@@ -104,18 +105,16 @@     -- could be optimized (looking at bounding boxes of l and r),     -- but not a bottle-neck -  distanceAtMost d t p = fst <$> distanceAtMost' d t p+  distanceAtMost d t p =+    case distanceAtMost' d t p of+      [] -> Nothing+      xs -> Just $ minimum $ map fst xs -distanceAtMost' :: DistanceToPoint a => Scalar -> BBTree a -> Point -> Maybe (Scalar, a)-distanceAtMost' d (Leaf x)     p = (,) <$> distanceAtMost d x p <*> pure x-distanceAtMost' d (Node b l r) p =-  distanceAtMost d b p *>-  case (distanceAtMost' d l p, distanceAtMost' d r p) of-    (Nothing, d) -> d-    (d, Nothing) -> d-    (l@(Just (dl, x)), r@(Just (dr, y)))-      | dl < dr   -> l-      | otherwise -> r+distanceAtMost' :: DistanceToPoint a => Scalar -> BBTree a -> Point -> [(Scalar, a)]+distanceAtMost' d (Leaf x)     p = [ (d, x) | Just d <- [distanceAtMost d x p] ]+distanceAtMost' d (Node b l r) p+  | isNothing $ distanceAtMost d b p = []+  | otherwise = distanceAtMost' d l p ++ distanceAtMost' d r p  buildBBTree :: HasBoundingBox a => [a] -> BBTree a buildBBTree []  = error "buildBBTree []"
Graphics/Curves/Colour.hs view
@@ -1,17 +1,40 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} {-| RGBA colour values. -} module Graphics.Curves.Colour where +import Control.Applicative+import Data.Foldable hiding (foldr)+import Data.Traversable+ import Graphics.Curves.Math  -- | RGBA values in the range 0.0 to 1.0.-data Colour = Colour { getRed, getGreen, getBlue, getAlpha :: !Scalar }-  deriving (Eq, Ord)+type Colour = Colour' Scalar -instance Show Colour where+-- | RGBA values parameterised on the colour value type.+data Colour' a = Colour { getRed, getGreen, getBlue, getAlpha :: !a }+  deriving (Eq, Ord, Functor, Foldable, Traversable)++instance Applicative Colour' where+  pure x = Colour x x x x+  Colour fr fg fb fa <*> Colour r g b a = Colour (fr r) (fg g) (fb b) (fa a)++instance Show a => Show (Colour' a) where   showsPrec p (Colour r g b a) =     showParen (p > 9) $       showString "Colour" . foldr (\x f -> showString " " . shows x . f) id [r, g, b, a]++truncColour :: (Ord a, Num a) => Colour' a -> Colour' a+truncColour = fmap (max 0 . min 1)++instance (Ord a, Num a) => Num (Colour' a) where+  a + b       = truncColour $ (+) <$> a <*> b+  a - b       = truncColour $ (-) <$> a <*> b+  a * b       = truncColour $ (*) <$> a <*> b+  abs         = fmap abs+  signum      = fmap signum+  fromInteger = pure . fromInteger  -- | > opacity a c = setAlpha (a * getAlpha c) c opacity :: Scalar -> Colour -> Colour
Graphics/Curves/Compile.hs view
@@ -18,7 +18,7 @@  type Segments = BBTree (AnnotatedSegment LineStyle) -data FillStyle = FillStyle Colour Scalar LineStyle+data FillStyle = FillStyle FillColour Scalar Basis LineStyle data LineStyle = LineStyle Colour Scalar Scalar  instance Monoid LineStyle where@@ -35,10 +35,10 @@   bounds (Segments fs b) = relaxBoundingBox (max fw lw) $ bounds b     where       fw = case fs of-             FillStyle c w _ | not $ isTransparent c -> w/2-             _ -> 0+             FillStyle (SolidFill c) _ _ _ | isTransparent c -> 0+             FillStyle _ w _ _ -> w / 2       lw = case fs of-             FillStyle _ _ (LineStyle c w b) | not $ isTransparent c -> w + b+             FillStyle _ _ _ (LineStyle c w b) | not $ isTransparent c -> w + b              _ -> 0   bounds (CIUnion _ b _ _) = b   bounds CIEmpty           = Empty@@ -46,17 +46,13 @@ compileImage :: Image -> CompiledImage compileImage = compileImage' 1 -setLineStyle :: CurveStyle -> AnnotatedSegment (Scalar, Scalar) -> AnnotatedSegment LineStyle-setLineStyle s seg = fmap mkLineStyle seg-  where-    mkLineStyle (d, r) = LineStyle (lineColour s d r) (lineWidth s d r) (lineBlur s d r)- compileImage' :: Scalar -> Image -> CompiledImage compileImage' res (ICurve c) = Segments fs ss   where-    s  = curveStyle c-    fs = FillStyle (fillColour s) (fillBlur s) (foldMap annotation ss)-    ss = setLineStyle (curveStyle c) <$> curveToSegments res c+    s  = curveFillStyle c+    fs = FillStyle (fillColour s) (fillBlur s) (textureBasis s) (foldMap annotation ss)+    ss = fmap (\(_, _, s) -> toLineStyle s) <$> curveToSegments res c+    toLineStyle s = LineStyle (lineColour s) (lineWidth s) (lineBlur s) compileImage' res IEmpty = CIEmpty compileImage' res (Combine blend a b) =   CIUnion blend (bounds (ca, cb)) ca cb
Graphics/Curves/Curve.hs view
@@ -3,7 +3,7 @@              UndecidableInstances #-} module Graphics.Curves.Curve where -import Control.Arrow ((***), (&&&))+import Control.Arrow ((***), (&&&), first, second)  import Graphics.Curves.Math import Graphics.Curves.Colour@@ -12,23 +12,34 @@  import Debug.Trace -data Curves = Curves { curvePaths :: [Curve]-                     , curveStyle :: CurveStyle }+data Curves = Curves { curvePaths     :: [Curve]+                     , curveFillStyle :: CurveFillStyle }  data Curve = forall a. Transformable a =>-             Curve { curveFunction :: Scalar -> a-                   , curveRender   :: Scalar -> a -> Point-                   , curveDensity  :: Int   -- ^ Number of subcurves that have been joined into this one+             Curve { curveFunction  :: Scalar -> a+                   , curveRender    :: Scalar -> a -> Point+                   , curveLineStyle :: Scalar -> Scalar -> Point -> CurveLineStyle+                   , curveDensity   :: Int   -- ^ Number of subcurves that have been joined into this one                    } -data CurveStyle = CurveStyle-      { lineWidth  :: Scalar -> Scalar -> Scalar-      , lineBlur   :: Scalar -> Scalar -> Scalar-      , lineColour :: Scalar -> Scalar -> Colour-      , fillColour :: Colour-      , fillBlur   :: Scalar-      }+data CurveLineStyle = CurveLineStyle+  { lineWidth    :: Scalar+  , lineBlur     :: Scalar+  , lineColour   :: Colour+  } +data CurveFillStyle = CurveFillStyle+  { fillColour   :: FillColour+  , textureBasis :: Basis+  , fillBlur     :: Scalar+  }++data FillColour = SolidFill Colour | TextureFill (Point -> Point -> Colour)++getFillColour :: FillColour -> Point -> Point -> Colour+getFillColour (SolidFill c)   _ _ = c+getFillColour (TextureFill t) p r = t p r+ -- | Style attributes of a curve. The line width is with width in pixels of the -- solid part of the curve. Outside the line width the curve fades to -- full transparency in a band whose width is determined by the line blur@@ -36,49 +47,90 @@ -- pixels) and relative distance from the start of the curve. -- -- A set of closed curves combined with 'Graphics.Curves.+++'--- can be filled using a fill colour ('transparent' for no fill). A point is--- deemed inside the curves if a ray starting at the point intersects with the--- curves an odd number of times. The fill blur is the width of the band around--- the curve edge in which the fill colour fades to full transparency.  Setting--- the fill colour of a non-closed curve results in unspecified behaviour.+-- can be filled using a fill colour ('transparent' for no fill) or a texture.+-- A texture is a function that computes a colour value given the position of the+-- point being filled, both in absolute pixels and relative to the texture+-- basis. The texture basis is 'defaultBasis' by default and is transformed+-- with the image. Typically you would use the absolute position for+-- rasterisation and the relative position for textures.+--+-- A point is deemed inside the curves if a ray starting at the point+-- intersects with the curves an odd number of times. The fill blur is the+-- width of the band around the curve edge in which the fill colour fades to+-- full transparency.  Setting the fill colour of a non-closed curve results in+-- unspecified behaviour. data CurveAttribute :: * -> * where   LineWidth     :: CurveAttribute Scalar   LineBlur      :: CurveAttribute Scalar   LineColour    :: CurveAttribute Colour-  VarLineWidth  :: CurveAttribute (Scalar -> Scalar -> Scalar)-  VarLineBlur   :: CurveAttribute (Scalar -> Scalar -> Scalar)-  VarLineColour :: CurveAttribute (Scalar -> Scalar -> Colour)+  VarLineWidth  :: CurveAttribute (Scalar -> Scalar -> Point -> Scalar)+  VarLineBlur   :: CurveAttribute (Scalar -> Scalar -> Point -> Scalar)+  VarLineColour :: CurveAttribute (Scalar -> Scalar -> Point -> Colour)   FillBlur      :: CurveAttribute Scalar   FillColour    :: CurveAttribute Colour+  Texture       :: CurveAttribute (Point -> Point -> Colour)+  TextureBasis  :: CurveAttribute Basis -instance HasAttribute CurveAttribute CurveStyle where-  modifyAttribute LineWidth     f s = s { lineWidth  = \d r -> f (lineWidth s d r) }-  modifyAttribute LineBlur      f s = s { lineBlur   = \d r -> f (lineBlur s d r) }-  modifyAttribute LineColour    f s = s { lineColour = \d r -> f (lineColour s d r) }-  modifyAttribute VarLineWidth  f s = s { lineWidth  = f $ lineWidth s }-  modifyAttribute VarLineBlur   f s = s { lineBlur   = f $ lineBlur s }-  modifyAttribute VarLineColour f s = s { lineColour = f $ lineColour s }-  modifyAttribute FillColour    f s = s { fillColour = f $ fillColour s }-  modifyAttribute FillBlur      f s = s { fillBlur   = f $ fillBlur s }+instance HasAttribute CurveAttribute Curves where+  modifyAttribute a f =+    case a of+      LineWidth     -> onLine_ $ \s -> s { lineWidth  = f (lineWidth s) }+      LineBlur      -> onLine_ $ \s -> s { lineBlur   = f (lineBlur s) }+      LineColour    -> onLine_ $ \s -> s { lineColour = f (lineColour s) }+      VarLineWidth  -> onLine  $ \h d r p -> (h d r p) { lineWidth  = f (\d r p -> lineWidth  (h d r p)) d r p }+      VarLineBlur   -> onLine  $ \h d r p -> (h d r p) { lineBlur   = f (\d r p -> lineBlur   (h d r p)) d r p }+      VarLineColour -> onLine  $ \h d r p -> (h d r p) { lineColour = f (\d r p -> lineColour (h d r p)) d r p }+      FillBlur      -> onFill  $ \s -> s { fillBlur     = f $ fillBlur s }+      TextureBasis  -> onFill  $ \s -> s { textureBasis = f $ textureBasis s }+      FillColour    -> onFill  $ \s ->+        s { fillColour = case fillColour s of+                           SolidFill c   -> SolidFill (f c)+                           TextureFill t -> TextureFill $ \p r -> f (t p r)+          }+      Texture       -> onFill  $ \s -> s { fillColour = TextureFill $ f (tex s) }+        where tex s = case fillColour s of+                        SolidFill c   -> \_ _ -> c+                        TextureFill t -> t+    where+      onFill :: (CurveFillStyle -> CurveFillStyle) -> Curves -> Curves+      onFill f (Curves cs fill) = Curves cs (f fill) -instance HasAttribute a CurveStyle => HasAttribute a Curves where-  modifyAttribute attr f (Curves cs s) = Curves cs (modifyAttribute attr f s)+      onLine_ :: (CurveLineStyle -> CurveLineStyle) -> Curves -> Curves+      onLine_ f = onLine (\old d r p -> f (old d r p)) -defaultCurveStyle =-  CurveStyle { lineWidth  = \_ _ -> 0.0-             , lineBlur   = \_ _ -> 1.2-             , lineColour = \_ _ -> black-             , fillColour = transparent-             , fillBlur   = sqrt 2 }+      onLine :: ((Scalar -> Scalar -> Point -> CurveLineStyle) -> (Scalar -> Scalar -> Point -> CurveLineStyle)) -> Curves -> Curves+      onLine f (Curves cs fill) = Curves (map onCurve cs) fill+        where+          onCurve c@(Curve g h old n) = Curve g h (\d r p -> f old d r p) n +  setAttribute FillColour c (Curves cs fill) = Curves cs fill{ fillColour = SolidFill c }  -- allows turning a Texture into a Solid+  setAttribute a x s = modifyAttribute a (const x) s++defaultCurveLineStyle =+  CurveLineStyle+    { lineWidth    = 0.0+    , lineBlur     = 1.2+    , lineColour   = black+    }++defaultCurveFillStyle =+  CurveFillStyle+    { fillColour   = SolidFill transparent+    , fillBlur     = sqrt 2+    , textureBasis = defaultBasis+    }+ instance Transformable Curve where-  transform h (Curve f g n) = Curve (transform h f) g n+  transform h (Curve f g st n) = Curve (transform h f) g st n  instance Transformable Curves where-  transform f (Curves cs s) = Curves (transform f cs) s+  transform f (Curves cs s) = Curves (transform f cs) (transform f s) +instance Transformable CurveFillStyle where+  transform f s = s { textureBasis = transform f $ textureBasis s }+ reverseCurve :: Curve -> Curve-reverseCurve (Curve f g n) = Curve f' g' n+reverseCurve (Curve f g st n) = Curve f' g' st n  -- doesn't reverse style!   where     f' t = f (1 - t)     g' t p = g (1 - t) p@@ -87,7 +139,7 @@  -- | Freeze dimension to pixels. freezeCurve :: Freezing -> Point -> Curve -> Curve-freezeCurve fr p0 (Curve f g n) = Curve (const basis) g' n+freezeCurve fr p0 (Curve f g st n) = Curve (const basis) g' st n   where     fsize = freezeSize fr     fdir  = freezeOrientation fr@@ -103,17 +155,18 @@           | fsize         = (norm (px - o), norm (py - o))  bindCurve :: Transformable a => (Scalar -> a) -> (Scalar -> a -> Curve) -> Curve-bindCurve f g = Curve f g' 1  -- not quite the right density+bindCurve f g = Curve f g' style 1  -- not quite the right density   where-    g' t x = case g t x of Curve i j _ -> j t (i t)+    g' t x    = case g t x of Curve i j _ _ -> j t (i t)+    style d r = case g r (f r) of Curve _ _ st _ -> st d r  -- is this right?  joinCurve :: Curves -> Curves -> Curves joinCurve (Curves cs s) (Curves (c:cs2) _) =   Curves (init cs ++ [joinCurve' (last cs) c] ++ cs2) s  joinCurve' :: Curve -> Curve -> Curve-joinCurve' (Curve f f' n) (Curve g g' m) =-    Curve h h' (n + m)+joinCurve' (Curve f f' st n) (Curve g g' _ m) =+    Curve h h' st (n + m)   where     mid = fromIntegral n / fromIntegral (n + m)     lo t = t / mid@@ -129,7 +182,7 @@ appendPoint (Curves cs s) p = Curves (init cs ++ [appendPoint' (last cs) p]) s  appendPoint' :: Curve -> Point -> Curve-appendPoint' (Curve f g n) p = Curve f' g' (n + 1)+appendPoint' (Curve f g st n) p = Curve f' g' st (n + 1)   where     mid   = fromIntegral n / fromIntegral (n + 1)     lo t  = t / mid@@ -144,7 +197,7 @@ prependPoint p (Curves (c:cs) s) = Curves (prependPoint' p c : cs) s  prependPoint' :: Point -> Curve -> Curve-prependPoint' p (Curve f g n) = Curve f' g' (n + 1)+prependPoint' p (Curve f g st n) = Curve f' g' st (n + 1)   where     mid     = 1 / fromIntegral (n + 1)     lo t    = t / mid@@ -156,28 +209,30 @@     g' t (Right p)     = g (hi t) p  differentiateCurve :: Curve -> Curve-differentiateCurve (Curve f g n) = Curve (const f) g' n+differentiateCurve (Curve f g st n) = Curve f' g' st n   where-    eps  = 0.01-    eps2 = eps ^ 2-    minus a b = max (a - b) 0-    plus  a b = min (a + b) 1-    g' t f = norm (p1 - p0)+    δ = 1.0e-5+    f' t = Seg (h t) (h t + v)       where         h t = g t (f t)-        p   = h t-        farEnough q = squareDistance p q > eps2-        (t0, p0) = maybe (0, h 0) id $ findThreshold (\e -> h (t - e)) farEnough 1.0e-6 0 t-        (t1, p1) = maybe (1, h 1) id $ findThreshold (\e -> h (t + e)) farEnough 1.0e-6 0 (1 - t)+        v = (h t1 - h t0) / diag (t1 - t0)+        t1 = min (t + δ) 1+        t0 = max (t - δ) 0+    g' _ (Seg p0 p1) = p1 - p0  zipCurves :: (Scalar -> Point -> Point -> Point) -> Curves -> Curves -> Curves zipCurves f (Curves cs1 s) (Curves cs2 _) = Curves (zipWith (zipCurve f) cs1 cs2) s  zipCurve :: (Scalar -> Point -> Point -> Point) -> Curve -> Curve -> Curve-zipCurve h (Curve f1 g1 n) (Curve f2 g2 m) = Curve (f1 &&& f2) g' (max n m)+zipCurve h (Curve f1 g1 st1 n) (Curve f2 g2 _ m) = Curve (f1 &&& f2) g' st1 (max n m)   where     g' t (x, y) = h t (g1 t x) (g2 t y) +freezeLineStyle :: Scalar -> Curve -> Curve+freezeLineStyle res c@(Curve f g s n) = Curve f g s' n+  where+    s' _ t _ = s (curveLengthUpTo res c t) t (g t (f t))+ data AnnotatedSegment a = AnnSeg { annotation :: a                                  , theSegment :: Segment }   deriving (Functor)@@ -190,27 +245,43 @@   distance         = distance . theSegment   squareDistance   = squareDistance . theSegment --- Each segment is annotated with the distance from the start of the curve.-curveToSegments :: Scalar -> Curves -> BBTree (AnnotatedSegment (Scalar, Scalar))+-- Each segment is annotated with the distance from the start of the curve and the line style+curveToSegments :: Scalar -> Curves -> BBTree (AnnotatedSegment (Scalar, Scalar, CurveLineStyle)) curveToSegments r (Curves cs _) = buildBBTree $ concatMap (toSegments r) cs +-- | The length of the curve up to the given parameter value (between 0 and 1)+curveLengthUpTo :: Scalar -> Curve -> Scalar -> Scalar+curveLengthUpTo res _ t | t < 0 || t > 1 = error $ "curveLengthUpTo: " ++ show t ++ " not between 0 and 1"+curveLengthUpTo res _ 0 = 0+curveLengthUpTo res (Curve f g st n) t = curveLength' res (Curve f' g' st n)+  where+    f' = f . (/ t)+    g' = g . (/ t)+ curveLength' :: Scalar -> Curve -> Scalar curveLength' r c = d + segmentLength s-  where AnnSeg (d, _) s = last $ toSegments r c+  where AnnSeg (d, _, _) s = last $ toSegments r c -toSegments :: Scalar -> Curve -> [AnnotatedSegment (Scalar, Scalar)]-toSegments r (Curve f g _) =-    annotate $ map (uncurry Seg . (snd *** snd)) $ concatMap (uncurry subdivide) ss+toSegments :: Scalar -> Curve -> [AnnotatedSegment (Scalar, Scalar, CurveLineStyle)]+toSegments r (Curve f g style _) =+    annotate $ map mkSeg $ concatMap (uncurry subdivide) ss   where     h t = g t (f t)     res = r^2     pairs xs = zip xs (tail xs) +    mkSeg ((_, p0), (_, p1)) = Seg p0 p1+     annotate ss = annotate' total 0 ss       where         total = sum $ map segmentLength ss -    annotate' tot !d (s:ss) = AnnSeg (d, d/tot) s : annotate' tot (d + segmentLength s) ss+    addDist d r style = (d, r, style)++    annotate' tot !d (s@(Seg p0 p1):ss) = AnnSeg (d, t, style d t p) s : annotate' tot (d + segmentLength s) ss+      where p = (p0 + p1) / 2+            t = d / tot+     annotate' _ _ [] = []      ss = pairs $ do
Graphics/Curves/Geometry.hs view
@@ -38,10 +38,10 @@ triangleAA a α β = triangleA a (a * sin β / sin (α + β)) α  -- | Draw an n-sided regular polygon centered at the origin and one corner at---   (1, 0).+--   'unitY'. regularPoly :: Int -> Image regularPoly n | n < 3 = error "regularPoly: n < 3"-regularPoly n = poly [ rotate (2 * pi * fromIntegral i / fromIntegral n) unitX | i <- [0..n - 1] ]+regularPoly n = poly [ rotate (2 * pi * fromIntegral i / fromIntegral n) unitY | i <- [0..n - 1] ]  -- | Draw an angle arc for the counter clockwise angle BAC. angleArc :: Scalar -- ^ Radius of the arc in pixels@@ -49,7 +49,7 @@          -> Point  -- ^ B          -> Point  -- ^ C          -> Image-angleArc w p0 p1 p2 = curve' f g 0 1+angleArc w p0 p1 p2 = curve' 0 1 f g   where     f _ = (p0, p1, p2)     g t (p0, p1, p2) = p0 + diag w * rotate (t * α) (norm (p1 - p0))@@ -68,7 +68,7 @@  -- | Draw a line segment with an arrow head. arrow :: Point -> Point -> Image-arrow from to = curve' f g 0 2 <> line from to+arrow from to = curve' 0 2 f g <> line from to   where     f = const $ Seg from to     g t (Seg from to) =
Graphics/Curves/Graph.hs view
@@ -61,7 +61,7 @@   where     fx0 = Vec x0 0     fx1 = Vec x1 0-    g = curve (\x -> Vec x (f x)) x0 x1+    g = curve x0 x1 $ \x -> Vec x (f x)     Seg p q = imageBounds g     w = getX (q - p)     h = getY (q - p)
Graphics/Curves/Image.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances,+             RankNTypes #-} module Graphics.Curves.Image   ( module Graphics.Curves.Image   , (<>) )@@ -79,16 +80,20 @@ (<->) :: Image -> Image -> Image a <-> b = combine diffBlend a b --- | A simple curve whose points are given by the function argument. The second---   and third arguments specify the range of the function. The function must---   be continuous on this interval.+-- | A simple curve whose points are given by the function argument. The first+--   two arguments specify the range of the function. The function must be+--   continuous on this interval. -- --   For example, a straight line between points @p@ and @q@ can be implemented as -----   @curve ('interpolate' p q) 0 1@-curve :: (Scalar -> Point) -> Scalar -> Scalar -> Image-curve f = curve' f (const id)+--   @curve 0 1 ('interpolate' p q)@+curve :: Scalar -> Scalar -> (Scalar -> Point) -> Image+curve t0 t1 f = curve' t0 t1 f (const id) +-- | @curve_ = 'curve' 0 1@+curve_ :: (Scalar -> Point) -> Image+curve_ = curve 0 1+ -- | The most general form of curve. The curve function is split in two, one --   function from the parameter to an arbitrary 'Transformable' object, and a --   second function from this object (and the parameter value) to a point on@@ -101,13 +106,14 @@ --   which uses a line 'Segment' as the intermediate type and computes the --   arrow head in the second function, to ensure that the arrow head has the --   same dimensions regardless of how the arrow is scaled.-curve' :: Transformable a => (Scalar -> a) -> (Scalar -> a -> Point) -> Scalar -> Scalar -> Image-curve' f g t0 t1 = ICurve $ Curves [Curve (f . tr) (g . tr) 1] defaultCurveStyle+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) --- | Compute the length of the curves of an image.  The first argument is the---   precision (small is more precise).+-- | Compute the length of the curves of an image by approximating it by a+--   series of straight-line segments, each no longer than specified by the+--   first argument. curveLength :: Scalar -> Image -> Scalar curveLength _ IEmpty                 = 0 curveLength r (ICurve (Curves cs _)) = sum $ map (curveLength' r) cs@@ -162,7 +168,7 @@ unfreezeImage :: Image -> Image unfreezeImage = mapCurve unfreeze   where-    unfreeze (Curve f g n) = Curve (\t -> g t (f t)) (const id) n+    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)@@ -212,11 +218,11 @@  -- | A straight line between two points. line :: Point -> Point -> Image-line p q = curve (interpolate p q) 0 1+line p q = curve_ (interpolate p q)  -- | A single point. point :: Point -> Image-point p = curve (const p) 0 1+point p = curve_ (const p)  -- | A circle given by its center and radius. circle :: Point -> Scalar -> Image@@ -231,7 +237,7 @@ 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 (\α -> Vec (x + r * cos α) (y + r * sin α)) a b+  curve a b (\α -> Vec (x + r * cos α) (y + r * sin α))  -- | A connected sequence of straight lines. The list must have at least two --   elements.@@ -262,8 +268,15 @@ mapImage :: (Scalar -> Point -> Point) -> Image -> Image mapImage h = mapCurve pp   where-    pp (Curve f g n) = Curve f (\t -> h t . g t) n+    pp (Curve f g st n) = Curve f (\t -> h t . g t) st n +-- | Apply a transformation to an image. Unlike 'mapImage' the transformation+--   is applied immediately.+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+ -- | Zipping two images. Both images must have the same number of curves --   'combine'd in the same order. As with 'mapImage' the zipping takes place --   after all transformations.@@ -285,7 +298,7 @@     mmul v m = map (vmul v) m     vmul u v = sum $ zipWith (*) u v -    seg ps = curve f 0 1+    seg ps = curve_ f       where         f t = vmul (coefs t) ps
Graphics/Curves/Math.hs view
@@ -16,7 +16,7 @@   , leftOf, intersectSegment, intersectLine   , intersectLineSegment     -- * Basis-  , Basis(..), defaultBasis+  , Basis(..), defaultBasis, toBasis, fromBasis     -- * Distances   , DistanceToPoint(..)     -- * Transformations@@ -289,6 +289,20 @@  instance Transformable Basis where   transform f (Basis o x y) = Basis (transform f o) (transform f x) (transform f y)++-- | Translate a point from the 'defaultBasis' to the given basis.+toBasis :: Basis -> Point -> Point+toBasis (Basis o x y) p = Vec s t+  where+    u = x - o+    v = y - o+    perp u v = dot u (rot90 v)+    s = (perp p v - perp o v) / perp u v+    t = (perp p u - perp o u) / perp v u++-- | Translate a point in the given basis to the 'defaultBasis'.+fromBasis :: Basis -> Point -> Point+fromBasis (Basis o x y) (Vec s t) = o + diag s * (x - o) + diag t * (y - o)  -- Searching --------------------------------------------------------------
Graphics/Curves/Render.hs view
@@ -4,7 +4,9 @@ import Control.Applicative import Control.Monad import Data.Maybe+import Data.List import qualified Data.ByteString.Lazy as B+import Data.Function  import qualified Codec.Picture as Codec import qualified Codec.Picture.Png as Codec@@ -21,7 +23,7 @@ -- Rendering --------------------------------------------------------------  sampleSegments :: FillStyle -> Segments -> Point -> Maybe Colour-sampleSegments (FillStyle fillColour fillBlur (LineStyle lineColour lineWidth lineBlur)) s p@(Vec x y) =+sampleSegments (FillStyle varFillColour fillBlur texBasis (LineStyle lineColour lineWidth lineBlur)) s p@(Vec x y) =   case isLine of     Nothing -> edge <|> fill       where@@ -34,9 +36,10 @@           return $ opacity o fillColour     Just (α, c) -> Just $ opacity (getAlpha c) $ addFill (getAlpha c) $ setAlpha α c   where+    fillColour = getFillColour varFillColour p (toBasis texBasis p)     isZero x = round (255 * x) == 0     isLine = do-      (d, seg) <- distanceAtMost' (lineWidth/2 + lineBlur) s p+      (d, seg) <- closestSeg (lineWidth/2 + lineBlur) s p       let LineStyle c w b = annotation seg           inner = w/2           outer = inner + b@@ -47,6 +50,13 @@       guard $ not $ isZero (getAlpha c)       return (α, c) +    closestSeg d s p =+      case distanceAtMost' (lineWidth/2 + lineBlur) s p of+        []    -> Nothing+        cands -> Just $ minimumBy (compare `on` dist) cands+      where+        dist (d, AnnSeg (LineStyle _ w b) _) = (d - w/2) / b+     hasFill = not $ isZero $ getAlpha fillColour     addFill α' c = maybe c (blend c . opacity (1/α')) fill     fill | hasFill && odd (length ps) = Just fillColour@@ -84,7 +94,7 @@     bg = opaque bg0     sample p = toRGBA $ case sampleImage i p of       Nothing -> bg0-      Just c  -> blend c bg+      Just c  -> blend (truncColour c) bg  saveImage :: FilePath -> Codec.Image Codec.PixelRGBA8 -> IO () saveImage file img = B.writeFile file (Codec.encodePng img)
Graphics/Curves/SVG/Font.hs view
@@ -141,9 +141,10 @@ --   scaled to make upper case letters 1 unit high. drawString :: SVGFont -> String -> Image drawString font s =-  scale (diag $ 1 / fontCapHeight font) $-  mconcat [ translate (Vec 0 (-l * lineSep)) $ draw 0 Nothing s-          | (l, s) <- zip [0..] $ lines s ]+  scale (diag $ 1 / fontCapHeight font)+        (mconcat [ translate (Vec 0 (-l * lineSep)) $ draw 0 Nothing s+                 | (l, s) <- zip [0..] $ lines s ])+    `with` [ TextureBasis := defaultBasis ]   -- reset the texture basis   where     lineSep = fontAscent font - fontDescent font     draw p _ [] = mempty
Graphics/Curves/Style.hs view
@@ -29,7 +29,7 @@ --   is maximum width and the second the length of the tapering off part. brushStyle :: Scalar -> Scalar -> Style brushStyle w d =-  [VarLineWidth := \x r ->+  [VarLineWidth := \x r _ ->     let total = x/r in     if | r == 0        -> 0        | x < d         -> w * f (2 * x / d - 1)@@ -45,7 +45,7 @@ -- in the distance in pixels it takes to reach the second colour. gradient :: Colour -> Colour -> Scalar -> Style gradient c1 c2 a =-  [VarLineColour := \d _ ->+  [VarLineColour := \d _ _ ->     case modDouble d (2 * a) of       x | x <= a    -> blend (setAlpha (x / a) c2) c1         | otherwise -> blend (setAlpha ((2 * a - x) / a) c2) c1@@ -57,13 +57,13 @@ dashedOpen :: Scalar -> Scalar -> Style dashedOpen a b =   dashed a b ++-  [VarLineColour :~ \old d r ->-    if | r == 0    -> old d r+  [VarLineColour :~ \old d r p ->+    if | r == 0    -> old d r p        | otherwise ->         let total = d/r             n     = round (total / (a + b))             k     = total / (fromIntegral n * (a + b) + a)-        in old (d / k) r+        in old (d / k) r p   ]  -- | A dashed line style. The first argument is the approximate length (in@@ -73,22 +73,22 @@ dashedClosed :: Scalar -> Scalar -> Style dashedClosed a b =   dashed a b ++-  [VarLineColour :~ \old d r ->-    if | r == 0    -> old d r+  [VarLineColour :~ \old d r p ->+    if | r == 0    -> old d r p        | otherwise ->         let total = d/r             n     = round (total / (a + b))             k     = total / (fromIntegral n * (a + b))-        in old (d / k) r+        in old (d / k) r p   ]  -- | A dashed line style. The first argument is the lengths (in pixels) of the --   dashes and the second argument of the gaps. dashed :: Scalar -> Scalar -> Style dashed a b =-  [VarLineColour :~ \old d r ->+  [VarLineColour :~ \old d r p ->     case modDouble d (a + b) of-      x | x <= a    -> old d r+      x | x <= a    -> old d r p         | otherwise -> transparent   ]
Graphics/Curves/Tests.hs view
@@ -85,3 +85,12 @@       intersectBoundingBox l1 (bounds l2)   ) +goodBasis x y =+  not $ or [ eqV x 0+           , eqV y 0+           , dot x (rot90 y) ≈ 0 ]++prop_toBasis o x y p =+  goodBasis x y ==> eqV p (fromBasis b $ toBasis b p)+  where+    b = Basis o x y
Graphics/Curves/Text.hs view
@@ -305,5 +305,5 @@ -- | Draw a string centered at a given point. The second argument specifies the --   font height in pixels, invariant under scaling. label :: Point -> Scalar -> String -> Image-label p h s = translate p $ freezeImage 0 $ scale (diag $ h/2) $ translate (Vec 0 (-1)) $ stringImage' CenterAlign 0.1 s+label p h s = translate p $ freezeImageSize 0 $ scale (diag $ h/2) $ translate (Vec 0 (-1)) $ stringImage' CenterAlign 0.5 s
curves.cabal view
@@ -1,5 +1,5 @@ Name:               curves-Version:            1.0.0+Version:            1.1.0 Category:           Graphics License:            MIT License-file:       LICENSE