module Graphics.Craftwerk.Core.Style (
StyleProperties(..)
, LineCap(..)
, LineJoin(..)
, ArrowTip(..)
, emptyStyle
, newStyle
, defaultStyle
, setLineWidth
, fillOnly
, strokeOnly
, yes
, no
, rgb
, width
, verythin
, thin
, semithick
, thick
, verythick
, ultrathick
, limit
, phase
, getProperty
, mergeProperties
, arrow
, (<=>)
, (===)
, (==>)
, (<==)
) where
import Graphics.Craftwerk.Core.Color
import Data.Maybe
data ArrowDummy = ArrowDummy deriving Show
data ArrowTip = TipNone | TipDefault deriving (Show,Eq)
type ArrowTips = (ArrowTip, ArrowTip)
data LineCap = CapRect | CapButt | CapRound deriving (Show,Eq)
data LineJoin = JoinRound | JoinBevel | JoinMiter deriving (Show,Eq)
data StyleProperties =
StyleProperties { lineWidth :: Maybe Double
, lineColor :: Maybe FigureColor
, fillColor :: Maybe FigureColor
, fill :: Maybe Bool
, stroke :: Maybe Bool
, clip :: Maybe Bool
, closePath :: Maybe Bool
, dashes :: Maybe [Double]
, dashPhase :: Maybe Double
, lineCap :: Maybe LineCap
, lineJoin :: Maybe LineJoin
, miterLimit :: Maybe Double
, arrowTips :: Maybe ArrowTips
} deriving (Show, Eq)
emptyStyle :: StyleProperties
emptyStyle = StyleProperties
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
newStyle :: StyleProperties
newStyle = emptyStyle
defaultStyle :: StyleProperties
defaultStyle =
StyleProperties { lineWidth = Just 1.0
, lineColor = Just black
, fillColor = Just white
, stroke = Just True
, fill = Just False
, clip = Just False
, closePath = Just False
, dashes = Just [] :: Maybe [Double]
, dashPhase = Just 0.0
, lineCap = Just CapButt
, lineJoin = Just JoinMiter
, miterLimit = Just 10.0
, arrowTips = Just (TipNone, TipNone)
}
setLineWidth :: Maybe Double -> StyleProperties
setLineWidth a = newStyle { lineWidth = a }
fillOnly :: StyleProperties
fillOnly = newStyle { fill = yes, stroke = no }
strokeOnly :: StyleProperties
strokeOnly = newStyle { fill = no, stroke = yes}
yes :: Maybe Bool
yes = Just True
no :: Maybe Bool
no = Just False
rgb :: Double -> Double -> Double -> Maybe FigureColor
rgb r g b = Just $ sRGB r g b
width :: Double -> Maybe Double
width = Just
verythin :: Maybe Double
verythin = width 0.2
thin :: Maybe Double
thin = width 0.4
semithick :: Maybe Double
semithick = width 0.6
thick :: Maybe Double
thick = width 0.8
verythick :: Maybe Double
verythick = width 1.2
ultrathick :: Maybe Double
ultrathick = width 1.6
limit :: Double -> Maybe Double
limit = width
phase :: Double -> Maybe Double
phase = width
getProperty :: StyleProperties -> (StyleProperties -> Maybe a) -> a
getProperty s f = fromMaybe (fromJust $ f defaultStyle) (f s)
mergeProperty :: StyleProperties ->
StyleProperties ->
(StyleProperties -> Maybe a) ->
Maybe a
mergeProperty s t f = case f t of
Nothing -> f s
x -> x
mergeProperties :: StyleProperties ->
StyleProperties ->
StyleProperties
mergeProperties s t =
StyleProperties { lineWidth = mergeProperty s t lineWidth
, lineColor = mergeProperty s t lineColor
, fillColor = mergeProperty s t fillColor
, fill = mergeProperty s t fill
, stroke = mergeProperty s t stroke
, clip = mergeProperty s t clip
, closePath = mergeProperty s t closePath
, dashes = mergeProperty s t dashes
, dashPhase = mergeProperty s t dashPhase
, lineCap = mergeProperty s t lineCap
, lineJoin = mergeProperty s t lineJoin
, miterLimit = mergeProperty s t miterLimit
, arrowTips = mergeProperty s t arrowTips
}
arrow :: (ArrowDummy -> ArrowTips) -> Maybe ArrowTips
arrow f = Just (f ArrowDummy)
(<=>) :: ArrowDummy -> ArrowTips
(<=>) _ = (TipDefault, TipDefault)
(===) :: ArrowDummy -> ArrowTips
(===) _ = (TipNone, TipNone)
(==>) :: ArrowDummy -> ArrowTips
(==>) _ = (TipNone, TipDefault)
(<==) :: ArrowDummy -> ArrowTips
(<==) _ = (TipDefault, TipNone)