Skip to content

Commit

Permalink
accomodate units changes
Browse files Browse the repository at this point in the history
  • Loading branch information
@jeffreyrosenbluth
jeffreyrosenbluth committed Apr 14, 2014
1 parent 420399b commit 57f494d
Show file tree
Hide file tree
Showing 5 changed files with 74 additions and 173 deletions.
167 changes: 1 addition & 166 deletions src/Diagrams/Attributes.hs
View file
Expand Up @@ -29,20 +29,11 @@ module Diagrams.Attributes (

Color(..), SomeColor(..), someToAlpha

<<<<<<< HEAD
=======
-- ** Line color
, LineColor, getLineColor, mkLineColor, styleLineColor, lineColor, lineColorA, lc, lcA

-- ** Fill color
, FillColor, getFillColor, mkFillColor, styleFillColor, recommendFillColor, fillColor, fc, fcA

>>>>>>> master
-- ** Opacity
, Opacity, getOpacity, opacity

-- ** Converting colors
, colorToSRGBA, colorToRGBA
, colorToSRGBA, colorToRGBA, someToAlpha

-- * Line stuff
-- ** Cap style
Expand All @@ -54,30 +45,19 @@ module Diagrams.Attributes (
-- ** Miter limit
, LineMiterLimit(..), getLineMiterLimit, lineMiterLimit, lineMiterLimitA

-- * Compilation utilities
, splitFills

) where

import Control.Lens (Setter, sets)
import Data.Colour
import Data.Colour.RGBSpace (RGB (..))
import Data.Colour.SRGB (toSRGB)
import Data.Default.Class
<<<<<<< HEAD

import Data.Typeable

=======
import Data.Maybe (fromMaybe)
import Data.Monoid.Recommend
>>>>>>> master
import Data.Semigroup
import Data.Typeable

import Diagrams.Attributes.Compile
import Diagrams.Core
import Diagrams.Core.Style (setAttr)
import Diagrams.Core.Types (RTree)
import Diagrams.Located (unLoc)
import Diagrams.Path (Path, pathTrails)
Expand Down Expand Up @@ -112,116 +92,9 @@ class Color c where
data SomeColor = forall c. Color c => SomeColor c
deriving Typeable

<<<<<<< HEAD
=======
someToAlpha :: SomeColor -> AlphaColour Double
someToAlpha (SomeColor c) = toAlphaColour c

-- | The color with which lines (strokes) are drawn. Note that child
-- colors always override parent colors; that is, @'lineColor' c1
-- . 'lineColor' c2 $ d@ is equivalent to @'lineColor' c2 $ d@.
-- More precisely, the semigroup structure on line color attributes
-- is that of 'Last'.
newtype LineColor = LineColor (Last SomeColor)
deriving (Typeable, Semigroup)
instance AttributeClass LineColor

instance Default LineColor where
def = LineColor (Last (SomeColor (black :: Colour Double)))

getLineColor :: LineColor -> SomeColor
getLineColor (LineColor (Last c)) = c

mkLineColor :: Color c => c -> LineColor
mkLineColor = LineColor . Last . SomeColor

styleLineColor :: (Color c, Color c') => Setter (Style v) (Style v) c c'
styleLineColor = sets modifyLineColor
where
modifyLineColor f s
= flip setAttr s
. mkLineColor
. f
. fromAlphaColour . someToAlpha
. getLineColor
. fromMaybe def . getAttr
$ s

-- | Set the line (stroke) color. This function is polymorphic in the
-- color type (so it can be used with either 'Colour' or
-- 'AlphaColour'), but this can sometimes create problems for type
-- inference, so the 'lc' and 'lcA' variants are provided with more
-- concrete types.
lineColor :: (Color c, HasStyle a) => c -> a -> a
lineColor = applyAttr . mkLineColor

-- | Apply a 'lineColor' attribute.
lineColorA :: HasStyle a => LineColor -> a -> a
lineColorA = applyAttr

-- | A synonym for 'lineColor', specialized to @'Colour' Double@
-- (i.e. opaque colors).
lc :: HasStyle a => Colour Double -> a -> a
lc = lineColor

-- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@
-- (i.e. colors with transparency).
lcA :: HasStyle a => AlphaColour Double -> a -> a
lcA = lineColor

-- | The color with which shapes are filled. Note that child
-- colors always override parent colors; that is, @'fillColor' c1
-- . 'fillColor' c2 $ d@ is equivalent to @'lineColor' c2 $ d@.
-- More precisely, the semigroup structure on fill color attributes
-- is that of 'Last'.
newtype FillColor = FillColor (Recommend (Last SomeColor))
deriving (Typeable, Semigroup)
instance AttributeClass FillColor

instance Default FillColor where
def = FillColor (Recommend (Last (SomeColor (transparent :: AlphaColour Double))))

mkFillColor :: Color c => c -> FillColor
mkFillColor = FillColor . Commit . Last . SomeColor

styleFillColor :: (Color c, Color c') => Setter (Style v) (Style v) c c'
styleFillColor = sets modifyFillColor
where
modifyFillColor f s
= flip setAttr s
. mkFillColor
. f
. fromAlphaColour . someToAlpha
. getFillColor
. fromMaybe def . getAttr
$ s

-- | Set the fill color. This function is polymorphic in the color
-- type (so it can be used with either 'Colour' or 'AlphaColour'),
-- but this can sometimes create problems for type inference, so the
-- 'fc' and 'fcA' variants are provided with more concrete types.
fillColor :: (Color c, HasStyle a) => c -> a -> a
fillColor = applyAttr . mkFillColor

-- | Set a \"recommended\" fill color, to be used only if no explicit
-- calls to 'fillColor' (or 'fc', or 'fcA') are used.
recommendFillColor :: (Color c, HasStyle a) => c -> a -> a
recommendFillColor = applyAttr . FillColor . Recommend . Last . SomeColor

getFillColor :: FillColor -> SomeColor
getFillColor (FillColor c) = getLast . getRecommend $ c

-- | A synonym for 'fillColor', specialized to @'Colour' Double@
-- (i.e. opaque colors).
fc :: HasStyle a => Colour Double -> a -> a
fc = fillColor

-- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@
-- (i.e. colors with transparency).
fcA :: HasStyle a => AlphaColour Double -> a -> a
fcA = fillColor

>>>>>>> master
instance (Floating a, Real a) => Color (Colour a) where
toAlphaColour = opaque . colourConvert
fromAlphaColour = colourConvert . (`over` black)
Expand All @@ -234,27 +107,6 @@ instance Color SomeColor where
toAlphaColour (SomeColor c) = toAlphaColour c
fromAlphaColour c = SomeColor c

<<<<<<< HEAD
-- | Convert to an RGB space while preserving the alpha channel.
toRGBAUsingSpace :: Color c => RGBSpace Double -> c
-> (Double, Double, Double, Double)
toRGBAUsingSpace s col = (r,g,b,a)
where c' = toAlphaColour col
c = toRGBUsingSpace s (alphaToColour c')
a = alphaChannel c'
r = channelRed c
g = channelGreen c
b = channelBlue c
=======
instance Color LineColor where
toAlphaColour (LineColor c) = toAlphaColour . getLast $ c
fromAlphaColour = LineColor . Last . fromAlphaColour

instance Color FillColor where
toAlphaColour (FillColor c) = toAlphaColour . getLast . getRecommend $ c
fromAlphaColour = FillColor . Commit . Last . fromAlphaColour
>>>>>>> master

-- | Convert to sRGBA.
colorToSRGBA, colorToRGBA :: Color c => c -> (Double, Double, Double, Double)
colorToSRGBA col = (r, g, b, a)
Expand Down Expand Up @@ -364,21 +216,4 @@ lineMiterLimit = applyAttr . LineMiterLimit . Last
-- | Apply a 'LineMiterLimit' attribute.
lineMiterLimitA :: HasStyle a => LineMiterLimit -> a -> a
lineMiterLimitA = applyAttr
------------------------------------------------------------

data FillLoops v = FillLoops

instance Typeable v => SplitAttribute (FillLoops v) where
type AttrType (FillLoops v) = FillColor
type PrimType (FillLoops v) = Path v

primOK _ = all (isLoop . unLoc) . pathTrails

-- | Push fill attributes down until they are at the root of subtrees
-- containing only loops. This makes life much easier for backends,
-- which typically have a semantics where fill attributes are
-- applied to lines/non-closed paths as well as loops/closed paths,
-- whereas in the semantics of diagrams, fill attributes only apply
-- to loops.
splitFills :: forall b v a. Typeable v => RTree b v a -> RTree b v a
splitFills = splitAttr (FillLoops :: FillLoops v)
1 change: 1 addition & 0 deletions src/Diagrams/TwoD.hs
View file
Expand Up @@ -252,6 +252,7 @@ module Diagrams.TwoD
-- ** Colors
, fillColor, fc, fcA, recommendFillColor, getFillColor
, lineColor, lc, lcA, lineColorA, getLineColor

-- ** Width
, LineWidth, getLineWidth, lineWidth, lineWidthA
, lw, lwN, lwO, lwL, lwG
Expand Down
4 changes: 2 additions & 2 deletions src/Diagrams/TwoD/Adjust.hs
View file
Expand Up @@ -19,10 +19,10 @@ module Diagrams.TwoD.Adjust
, adjustDia2D
) where

import Diagrams.Attributes (lineCap, lineColorA, lineJoin,
import Diagrams.Attributes (lineCap, lineJoin,
lineMiterLimitA)
import Diagrams.Core
import Diagrams.TwoD.Attributes (lineWidthA)
import Diagrams.TwoD.Attributes (lineWidthA, lineTextureA, lineColorA)
import Diagrams.TwoD.Size (SizeSpec2D (..), center2D,
requiredScale, size2D)
import Diagrams.TwoD.Text (fontSizeA)
Expand Down
72 changes: 69 additions & 3 deletions src/Diagrams/TwoD/Attributes.hs
View file
@@ -1,6 +1,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

Expand Down Expand Up @@ -51,25 +53,38 @@ module Diagrams.TwoD.Attributes (

-- ** Line color
, LineColor, lineColor, getLineColor, lc, lcA, lineColorA
, mkLineColor, styleLineColor

-- ** Fill texture
, FillTexture(..), getFillTexture, fillTexture

-- ** Fill color
, FillColor, fillColor, getFillColor, fc, fcA, recommendFillColor
, mkFillColor, styleFillColor

-- * Compilation utilities
, splitFills

) where

import Diagrams.Core
import Diagrams.Attributes (Color(..), SomeColor(..))
import Diagrams.Core.Style (setAttr)
import Diagrams.Attributes
import Diagrams.Attributes.Compile
import Diagrams.TwoD.Types

import Diagrams.Core.Types (RTree)
import Diagrams.Located (unLoc)
import Diagrams.Path (Path, pathTrails)
import Diagrams.Trail (isLoop)

import Control.Lens ( makeLensesWith, generateSignatures, lensRules
, makePrisms, Lens', (&), (%~), (.~))
, makePrisms, Lens', (&), (%~), (.~), Setter, sets)

import Data.Colour hiding (AffineSpace)
import Data.Data
import Data.Default.Class
import Data.Maybe (fromMaybe)
import Data.Typeable

import Data.Monoid.Recommend
Expand Down Expand Up @@ -390,6 +405,21 @@ instance Color LineColor where
getLineColor :: LineColor -> SomeColor
getLineColor (LineColor (Last c)) = c

mkLineColor :: Color c => c -> LineColor
mkLineColor = LineColor . Last . SomeColor

styleLineColor :: (Color c, Color c') => Setter (Style v) (Style v) c c'
styleLineColor = sets modifyLineColor
where
modifyLineColor f s
= flip setAttr s
. mkLineColor
. f
. fromAlphaColour . someToAlpha
. getLineColor
. fromMaybe def . getAttr
$ s

-- | Set the line (stroke) color. This function is polymorphic in the
-- color type (so it can be used with either 'Colour' or
-- 'AlphaColour'), but this can sometimes create problems for type
Expand Down Expand Up @@ -466,6 +496,24 @@ instance AttributeClass FillColor
instance Color FillColor where
toAlphaColour (FillColor c) = toAlphaColour . getLast . getRecommend $ c

instance Default FillColor where
def = FillColor (Recommend (Last (SomeColor (transparent :: AlphaColour Double))))

mkFillColor :: Color c => c -> FillColor
mkFillColor = FillColor . Commit . Last . SomeColor

styleFillColor :: (Color c, Color c') => Setter (Style v) (Style v) c c'
styleFillColor = sets modifyFillColor
where
modifyFillColor f s
= flip setAttr s
. mkFillColor
. f
. fromAlphaColour . someToAlpha
. getFillColor
. fromMaybe def . getAttr
$ s

-- | Set the fill color. This function is polymorphic in the color
-- type (so it can be used with either 'Colour' or 'AlphaColour'),
-- but this can sometimes create problems for type inference, so the
Expand Down Expand Up @@ -500,4 +548,22 @@ fc = fillColor
-- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@
-- (i.e. colors with transparency). See comment after 'fillColor' about backends.
fcA :: (HasStyle a, V a ~ R2) => AlphaColour Double -> a -> a
fcA = fillColor
fcA = fillColor
------------------------------------------------------------

data FillLoops v = FillLoops

instance Typeable v => SplitAttribute (FillLoops v) where
type AttrType (FillLoops v) = FillColor
type PrimType (FillLoops v) = Path v

primOK _ = all (isLoop . unLoc) . pathTrails

-- | Push fill attributes down until they are at the root of subtrees
-- containing only loops. This makes life much easier for backends,
-- which typically have a semantics where fill attributes are
-- applied to lines/non-closed paths as well as loops/closed paths,
-- whereas in the semantics of diagrams, fill attributes only apply
-- to loops.
splitFills :: forall b v a. Typeable v => RTree b v a -> RTree b v a
splitFills = splitAttr (FillLoops :: FillLoops v)
3 changes: 1 addition & 2 deletions src/Diagrams/TwoD/Combinators.hs
View file
Expand Up @@ -46,15 +46,14 @@ import Data.VectorSpace
import Diagrams.Core

import Diagrams.Angle
import Diagrams.Attributes (fc)
import Diagrams.BoundingBox
import Diagrams.Combinators
import Diagrams.Coordinates
import Diagrams.Path
import Diagrams.Segment
import Diagrams.TrailLike
import Diagrams.TwoD.Align
import Diagrams.TwoD.Attributes (lineWidth)
import Diagrams.TwoD.Attributes (lineWidth, fc)
import Diagrams.TwoD.Path ()
import Diagrams.TwoD.Shapes
import Diagrams.TwoD.Transform (scaleX, scaleY)
Expand Down

0 comments on commit 57f494d

Please sign in to comment.