module Graphics.Fig
( ReplaceDef (..)
, emptyDef
, applyReplaceDef
, parse
, pretty
, module Graphics.Fig.Syntax
) where
import Graphics.Fig.Printer (pretty)
import Graphics.Fig.Parser (parse)
import Graphics.Fig.Syntax
import Control.Monad
emptyDef :: ReplaceDef
applyReplaceDef
:: ReplaceDef
-> Fig
-> Fig
data ReplaceDef =
ReplaceDef
{ headerOrientation :: Orientation -> Orientation
, headerJustification :: Justification -> Justification
, headerUnits :: Units -> Units
, headerPapersize :: PaperSize -> PaperSize
, headerMagnification :: Double -> Double
, headerMultiplePage :: MultiplePage -> MultiplePage
, headerTransparentColor :: Transparent -> Transparent
, headerResolution :: Integer -> Integer
, textColor :: ColorSpec -> ColorSpec
, textFontSize :: Double -> Double
, textFont :: Font -> Font
, textFontFlags :: FontFlags -> FontFlags
, picFlipped :: Flipped -> Flipped
, picFile :: FilePath -> FilePath
, arrowType :: ArrowType -> ArrowType
, arrowStyle :: ArrowStyle -> ArrowStyle
, arrowThickness :: Double -> Double
, arrowWidth :: Double -> Double
, arrowHeight :: Double -> Double
, areaFill :: AreaFill -> AreaFill
, areaFillColor :: ColorSpec -> ColorSpec
, lineStyle :: LineStyle -> LineStyle
, lineThickness :: Integer -> Integer
, linePenColor :: ColorSpec -> ColorSpec
, lineStyleVal :: Double -> Double
, lineCapStyle :: CapStyle -> CapStyle
, lineJoinStyle :: JoinStyle -> JoinStyle
}
emptyDef =
ReplaceDef
id id id id id id id id id id id id id id
id id id id id id id id id id id id id
applyReplaceDef funs = mapFig headerF colorF objF
where
headerF header =
header
{ header_orientation =
headerOrientation funs (header_orientation header)
, header_justification =
headerJustification funs (header_justification header)
, header_units = headerUnits funs (header_units header)
, header_papersize =
headerPapersize funs (header_papersize header)
, header_magnification =
headerMagnification funs (header_magnification header)
, header_multiple_page =
headerMultiplePage funs (header_multiple_page header)
, header_transparent_color =
headerTransparentColor funs (header_transparent_color header)
, header_resolution = headerResolution funs (header_resolution header)
}
colorF = id
objF = objF' . mapObject commonF arrF picF
objF' obj =
case obj of
Arc line fw bw ->
Arc
line
{ arc_cap_style =
lineCapStyle funs (arc_cap_style line)
}
fw
bw
Polyline line fw bw pic pts ->
Polyline
line
{ polyline_join_style =
lineJoinStyle funs (polyline_join_style line)
, polyline_cap_style =
lineCapStyle funs (polyline_cap_style line)
}
fw
bw
pic
pts
Spline line fw bw pts ctrl ->
Spline
line
{ spline_cap_style =
lineCapStyle funs (spline_cap_style line)
}
fw
bw
pts
ctrl
line @ Text {} ->
line
{ text_color = textColor funs (text_color line)
, text_font = textFont funs (text_font line)
, text_font_size =
textFontSize funs (text_font_size line)
, text_font_flags =
textFontFlags funs (text_font_flags line)
}
_ -> obj
commonF common =
common
{ line_style = lineStyle funs (line_style common)
, line_thickness = lineThickness funs (line_thickness common)
, pen_color = linePenColor funs (pen_color common)
, fill_color = areaFillColor funs (fill_color common)
, area_fill = areaFill funs (area_fill common)
, style_val = lineStyleVal funs (style_val common)
}
arrF (Arrow ty st th wi he) =
Arrow
(arrowType funs ty)
(arrowStyle funs st)
(arrowThickness funs th)
(arrowWidth funs wi)
(arrowHeight funs he)
picF (Pic flipped file) =
Pic (picFlipped funs flipped) (picFile funs file)
commented f (Comment cs obj) = Comment cs (f obj)
mapFig headerF colorF objF (Fig header cls objs) =
Fig
(headerF header)
(map (commented colorF) cls)
(map (commented objF) objs)
mapObject commonF arrF picF = object
where
object obj =
case obj of
Arc line fw bw ->
Arc
line { arc_common = commonF (arc_common line) }
(arrow fw)
(arrow bw)
Polyline line fw bw pic pts ->
Polyline
line { polyline_common = commonF (polyline_common line) }
(arrow fw)
(arrow bw)
(liftM picF pic)
pts
Spline line fw bw pts ctrl ->
Spline
line { spline_common = commonF (spline_common line) }
(arrow fw)
(arrow bw)
pts
ctrl
Compound line objs ->
Compound line (objects objs)
line @ Ellipse {} ->
line { ellipse_common = commonF (ellipse_common line) }
_ -> obj
arrow = liftM arrF
objects objs = map (commented object) objs