module FMP.Picture (
      (|-|), (|||), (|=|),     (||||), ( # ),
      (.&.), (...), (.-.),     (....), (.--.),
      IsPicture(..),     IsPath(..), IsArea(..),
      HasPicture(..),   HasName(..), HasDXY(..), HasExtent(..),
      HasLabel(..), HasPattern(..),
      HasPen(..),  HasArrowHead(..), HasStartEndCut(..),
      HasStartEndDir(..), HasJoin(..),
      HasShadow(..),    HasLayer(..), HasConcat(..), IsHideable(..),
      joinCat, joinFree, joinBounded, joinStraight, joinTense,
      joinTension, joinTensions, joinControl, joinControls,
      tension, tensionAtLeast,
      buildCycle, transformPath,
      mm, pt, dd, bp, cm, pc, cc, inch,
      up, down, left, right,
      fullcircle, halfcircle, quartercircle, unitsquare,
      enumPics, image,
      Picture(..), Layer(..), Transformation(..), BitDepth(..),
      row, column, rowSepBy, columnSepBy, vspace, hspace, space,
      fill, clip, draw, at, label, overlay, overlay', ooalign, HasDefine(..),
      text, tex, math, empty, setTrueBoundingBox,
      scale, rotate, transform , affine, shifted,
      rotated, reflectedX, reflectedY, reflectX, reflectY,
      scaledX, scaledY, scaled, skewedX, skewX, skewedY, skewY,
      line, curve, arrow, cycle', lastNameIsDir,
      defaultArrowHead, arrowHeadBig, arrowHeadSize,
      setArrowHeadStyle, getArrowHeadStyle, ahFilled, ahLine,
      Attrib(..), stdAttrib,
      FrameAttrib(..), stdFrameAttrib,
      PathElemDescr(..), stdPathElemDescr,
      Path(..), PathLabel(..), ArrowHead(..), ArrowHeadStyle(..), CutPic(..),
      pathLength, forEachPath,
      Dir'(..), BasicJoin(..), Tension(..),
      Area(..), AreaDescr(..), stdAreaDescr,
      getDefault,
      Frame(..), AbsOrRel(..), ExtentAttrib(..), stdExtentAttrib,
      dot, bullet,
      box, triangle, triAngle, rbox, oval, circle
      ) where

import Data.List
import FMP.Types
import FMP.Color

infixl 0 #
infixr 1 .&.,...,.-.,....,.--.
infixr 1 &
infixl 5 |-|, |=|
infixl 6 |||, ||||

( # )                         :: a -> (a -> b) -> b
a # f                         =  f a

class HasConcat a where
      (&)                     :: a -> a -> a

class FromList a where
      fromList                :: [a] -> a

instance FromList Equation where
      fromList                =  equations

instance FromList a => HasConcat [a] where
      a & b                   =  fromList a:b

class (Show a) => IsPicture a where
      toPicture               :: a -> Picture
      toPictureList           :: [a] -> Picture
      toPicture a             =  text (show a)
      toPictureList ps        =  row (map toPicture ps)

class HasPicture a where
      fromPicture             :: (IsPicture b) => b -> a

class HasName a where
      setName                 :: IsName b => b -> a -> a
      getNames                :: a -> [Name]

class HasDXY a where
      setDX                   :: Numeric -> a -> a
      getDX                   :: a -> Maybe Numeric
      setDY                   :: Numeric -> a -> a
      getDY                   :: a -> Maybe Numeric

class HasExtent a where
      setWidth                :: Numeric -> a -> a
      removeWidth             :: a -> a
      getWidth                :: a -> Maybe Numeric
      setHeight               :: Numeric -> a -> a
      removeHeight            :: a -> a
      getHeight               :: a -> Maybe Numeric

class HasLabel a where
      setLabel                :: IsPicture b => Double -> Dir -> b -> a -> a
      removeLabel             :: a -> a

class HasPattern a where
      setPattern              :: Pattern -> a -> a
      setDefaultPattern       :: a -> a
      getPattern              :: a -> Pattern

class HasPen a where
      setPen                  :: Pen -> a -> a
      setDefaultPen           :: a -> a
      getPen                  :: a -> Pen

class HasArrowHead a where
      setArrowHead            :: ArrowHead -> a -> a
      removeArrowHead         :: a -> a
      getArrowHead            :: a -> Maybe ArrowHead
      setStartArrowHead       :: ArrowHead -> a -> a
      removeStartArrowHead    :: a -> a
      getStartArrowHead       :: a -> Maybe ArrowHead

class HasStartEndCut a where
      setStartCut             :: IsName b => b -> a -> a
      removeStartCut          :: a -> a
      setEndCut               :: IsName b => b -> a -> a
      removeEndCut            :: a -> a

class HasStartEndDir a where
      setStartAngle           :: Numeric -> a -> a
      setEndAngle             :: Numeric -> a -> a
      setStartCurl            :: Numeric -> a -> a
      setEndCurl              :: Numeric -> a -> a
      setStartVector          :: Point -> a -> a
      setEndVector            :: Point -> a -> a
      removeStartDir          :: a -> a
      removeEndDir            :: a -> a

class HasJoin a where
      setJoin                 :: BasicJoin -> a -> a
      getJoin                 :: a -> BasicJoin

class HasDefine a where
      define                  :: [Equation] -> a -> a

class IsHideable a where
      hide                    :: a -> a

class HasShadow a where
      setShadow               :: (Numeric, Numeric) -> a -> a
      clearShadow             :: a -> a
      getShadow               :: a -> Maybe (Numeric, Numeric)

data Layer                    =  Front | Back
                                 deriving (Eq, Show, Read)

class HasLayer a where
      setBack                 :: a -> a
      setFront                :: a -> a
      getLayer                :: a -> Layer

------------------- Picture ---------------------

data Transformation           =  Transformation Numeric Numeric Numeric Numeric
                                               Numeric Numeric
                                 deriving (Eq, Show, Read)

data Picture                  =  Attributes   Attrib  Picture

                              |  Overlay      [Equation] (Maybe Int) [Picture]
                              |  Define       [Equation] Picture

                              |  Frame        FrameAttrib [Equation]  Path    Picture

                              |  Draw         [Path]  Picture
                              |  Fill         [Area]  Picture
                              |  Clip         Path    Picture

                              |  Empty        Numeric Numeric
                              |  Tex          String
                              |  Text         String

                              |  BitLine      Point   BitDepth        String

                              |  PTransform   Transformation  Picture

                              |  TrueBox      Picture
                                 deriving (Eq, Show, Read)

data BitDepth                 =  Depth1 | Depth8 | Depth24
                                 deriving (Eq, Show, Read)

instance IsPicture Picture where
      toPicture               =  id

instance IsPicture Char where
      toPicture c             =  text [c]
      toPictureList           =  tex

instance IsPicture Int where
      toPicture               =  tex . show

instance IsPicture Integer where
      toPicture               =  tex . show

instance IsPicture Numeric where
      toPicture (Numeric n)   =  tex (show n)
      toPicture a             =  tex (show a)

instance IsPicture a => IsPicture [a]  where
      toPicture               =  toPictureList

instance IsPicture () where
      toPicture ()            =  empty

instance (IsPicture a, IsPicture b) => IsPicture (a, b)  where
      toPicture (a, b)        =  row [toPicture a, toPicture b]

instance (IsPicture a, IsPicture b, IsPicture c) => IsPicture (a, b, c)  where
      toPicture (a, b, c)     =  row [toPicture a, toPicture b, toPicture c]

instance IsPicture Path where
      toPicture p             =  setTrueBoundingBox (draw [p] empty)
      toPictureList ps        =  setTrueBoundingBox (draw ps empty)

instance IsPicture Area where
      toPicture a             =  setTrueBoundingBox (fill [a] empty)
      toPictureList as        =  setTrueBoundingBox (fill as empty)

instance HasRelax Picture where
      relax                   =  empty

instance HasColor Picture where
      setColor c (Attributes as p)
                              =  Attributes as{ aColor = c } p
      setColor c p            =  Attributes stdAttrib{ aColor = c } p
      setDefaultColor         =  setColor DefaultColor
      getColor (Attributes as _)
                              =  aColor as
      getColor _              =  DefaultColor

instance HasBGColor Picture where
      setBGColor c (Attributes as p)
                              =  Attributes as{ aBGColor = c } p
      setBGColor c p          =  Attributes stdAttrib{ aBGColor = c } p
      setDefaultBGColor       =  setBGColor DefaultColor
      getBGColor (Attributes as _)
                              =  aBGColor as
      getBGColor _            =  DefaultColor


instance HasName Picture where
      setName s (Attributes as p)
                              =  Attributes as{ aNames = toName s:aNames as } p
      setName s p             =  Attributes stdAttrib{ aNames = [toName s] } p
      getNames (Attributes as _)
                              =  aNames as
      getNames _              =  []

instance HasDefault Color where
      default'                =  DefaultColor

-----------------------------------------------------------------


mm, pt, dd, bp, cm, pc, cc, inch:: Numeric
mm                            =  2.83464
pt                            =  0.99626
dd                            =  1.06601
bp                            =  1
cm                            =  28.34645
pc                            =  11.95517
cc                            =  12.79213
inch                          =  72

up , down, left, right        :: Point
up                            =  vec( 0, 1)
down                          =  vec( 0,-1)
left                          =  vec(-1, 0)
right                         =  vec( 1, 0)


fullcircle, halfcircle        :: Path
fullcircle                    =  right ... down ... left ... up ... cycle'
halfcircle                    =  right ... down ... left
                              #  setStartVector down
                              #  setEndVector up

quartercircle, unitsquare     :: Path
quartercircle                 =  right ... down
                              #  setStartVector down
                              #  setEndVector left
unitsquare                    =  vec(0,0).-.vec(1,0).-.vec(1,1).-.vec(0,1).-.cycle'

(|-|)                         :: (IsPicture a, IsPicture b) => a -> b -> Picture
p1 |-| p2                     =  column [toPicture p1, toPicture p2]

(|||)                         :: (IsPicture a, IsPicture b) => a -> b -> Picture
p1 ||| p2                     =  row [toPicture p1, toPicture p2]

(|=|)                         :: (IsPicture a, IsPicture b) => a -> b -> Picture
p1 |=| p2                     =  columnSepBy 8 [toPicture p1, toPicture p2]

(||||)                        :: (IsPicture a, IsPicture b) => a -> b -> Picture
p1 |||| p2                    =  rowSepBy 8 [toPicture p1, toPicture p2]

row                           :: IsPicture a => [a] -> Picture
row                           =  rowSepBy 0

column                        :: IsPicture a => [a] -> Picture
column                        =  columnSepBy 0

rowSepBy                      :: IsPicture a => Numeric -> [a] -> Picture
rowSepBy hSep ps              =  overlay [ ref (i <+ E) + vec(hSep,0) .= ref (i+1 <+ W)
                                         | i <- [0..length ps - 2] ]
                                         ps

columnSepBy                   :: IsPicture a => Numeric -> [a] -> Picture
columnSepBy vSep ps           =  overlay [ ref (i <+ S) - vec(0, vSep) .= ref (i+1 <+ N)
                                         | i <- [0..length ps - 2] ]
                                         ps

enumPics                      :: (HasName a) => [a] -> [a]
enumPics ps                   =  [ setName (n::Int) p| (p, n) <- zip ps [0..] ]

fill                          :: (IsPicture a,IsArea b) => [b] -> a -> Picture
fill as p                     =  Fill (map toArea as) (toPicture p)

clip                          :: IsPicture a => Path -> a -> Picture
clip path p                   =  Clip path (toPicture p)

draw                          :: IsPicture a => [Path] -> a -> Picture
draw ps p                     =  Draw  (map toPath ps) (toPicture p)

at                            :: (IsPicture a, IsPicture b)
                              => Dir -> a -> b -> Picture
at d l p                      =  overlay' [ ref ((0::Int) <+ C)
                                              .= ref ((1::Int) <+ d)]
                                      (Just 1) [toPicture l, toPicture p]

label                         :: (IsPicture a, IsPicture b)
                              => Dir -> a -> b -> Picture
label d l p                   =  overlay' [ ref ((0::Int) <+ (-d))
                                              .= ref ((1::Int) <+ d)]
                                      (Just 1) [toPicture l, toPicture p]

instance HasDefine Picture where
      define eqs p            = Define eqs (toPicture p)

overlay                       :: IsPicture a => [Equation] -> [a] -> Picture
overlay eqs ps                =  overlay' eqs Nothing ps

overlay'                      :: IsPicture a => [Equation] -> Maybe Int -> [a]
                              -> Picture
overlay' eqs ibb ps           =  Overlay eqs ibb (map toPicture ps)


ooalign                       :: IsPicture a => [a] -> Picture
ooalign ps                    =  overlay [ ref (i <+ C) .= ref (i+1 <+ C)
                                         | i <- [0..length ps - 2] ]
                                         ps

text                          :: String -> Picture
text p                        =  Text p

tex                           :: String -> Picture
tex p                         =  Tex p

math                          :: String -> Picture
math p                        =  tex ("$" ++ p ++ "$")

empty                         :: Picture
empty                         =  space 0 0

vspace                        :: Numeric -> Picture
vspace n                      =  space 0 n

hspace                        :: Numeric -> Picture
hspace n                      =  space n 0

space                         :: Numeric -> Numeric -> Picture
space x y                     =  Empty x y

setTrueBoundingBox            :: IsPicture a => a -> Picture
setTrueBoundingBox            =  TrueBox . toPicture


------ Transformations ---------

scale                         :: IsPicture a => Numeric -> a -> Picture
scale n                       =  transform (scaled n)

rotate                        :: IsPicture a => Numeric -> a -> Picture
rotate a                      =  transform (rotated a)

skewX                         :: IsPicture a => Numeric -> a -> Picture
skewX a                       =  transform (skewedX a)

skewY                         :: IsPicture a => Numeric -> a -> Picture
skewY a                       =  transform (skewedY a)

reflectX                      :: IsPicture a => a -> Picture
reflectX                      =  transform reflectedX

reflectY                      :: IsPicture a => a -> Picture
reflectY                      =  transform reflectedY

transform                     :: IsPicture a => Transformation -> a -> Picture
transform m p                 =  PTransform m (toPicture p)

affine                        :: (Numeric,Numeric,Numeric,Numeric,Numeric,Numeric)
                              -> Transformation
affine (a,b,c,d,e,f)          =  Transformation a b c d e f

rotated                       :: Numeric -> Transformation
rotated a                     =  affine (cos a, -sin a, sin a, cos a, 0, 0)

reflectedX                    :: Transformation
reflectedX                    =  affine (1, 0, 0, -1, 0, 0)

reflectedY                    :: Transformation
reflectedY                    =  affine (-1, 0, 0, 1, 0, 0)

shifted                       :: (Numeric,Numeric) -> Transformation
shifted (x, y)                =  affine (1, 0, 0, 1, x, y)

scaledX                       :: Numeric -> Transformation
scaledX a                     =  affine (a, 0, 0, 1, 0, 0)

scaledY                       :: Numeric -> Transformation
scaledY a                     =  affine (1, 0, 0, a, 0, 0)

scaled                        :: Numeric -> Transformation
scaled a                      =  affine (a, 0, 0, a, 0, 0)

skewedX                       :: Numeric -> Transformation
skewedX a                     =  affine (1, a, 0, 1, 0, 0)

skewedY                       :: Numeric -> Transformation
skewedY a                     =  affine (1, 0, a, 1, 0, 0)

instance HasConcat Transformation where
      (Transformation a1 b1 c1 d1 e1 f1) & (Transformation a2 b2 c2 d2 e2 f2)
                              =  Transformation       (a1*a2 + c1*b2)
                                                      (b1*a2 + d1*b2)
                                                      (a1*c2 + c1*d2)
                                                      (b1*c2 + d1*d2)
                                                      (e1+e2) (f1+f2)

----- Paths -----

line                          :: (IsPath a, IsPath b) => a -> b -> Path
line p1 p2                    =  p1 .-. p2

curve                         :: (IsPath a, IsPath b) => a -> b -> Path
curve p1 p2                   =  p1 ... p2

arrow                         :: (IsPath b, IsPath a) => a -> b -> Path
arrow a b                     =  curve a b
                                 # setArrowHead default'

cycle'                        :: Path
cycle'                        =  PathCycle

------Arrows -----------------

instance HasDefault ArrowHead where
      default'                = defaultArrowHead

defaultArrowHead              :: ArrowHead
defaultArrowHead              =  ArrowHead Nothing Nothing AHFilled

arrowHeadBig                  :: ArrowHead
arrowHeadBig                  =  ArrowHead (Just 8) Nothing AHFilled

arrowHeadSize                 :: Double -> Double -> ArrowHead
arrowHeadSize a b             =  ArrowHead (Just a) (Just b) AHFilled

-----------------------

data Attrib                   =  Attrib{      aNames          :: [Name],
                                              aColor          :: Color,
                                              aBGColor        :: Color}
                                 deriving (Eq, Read)

instance Show Attrib where            -- Bug workaround fuer Hugs' Show
      showsPrec p (Attrib aNames aColor aBGColor)
                              =  showParen ( p >= 10 )
                                      (showString "Attrib{".
                                      showString "aNames=".
                                      showsPrec 10 aNames.
                                      showString ", ".
                                      showString "aColor=".
                                      showsPrec 10 aColor.
                                      showString ", ".
                                      showString "aBGColor=".
                                      showsPrec 10 aBGColor.
                                      showString "}")
      showList []             =  showString "[]"
      showList (x:xs)         =  showChar '[' . shows x . showl xs
              where
              showl []        =  showChar ']'
              showl (x:xs)    =  showString ", "
                                 . shows x
                                 . shows xs

stdAttrib                      :: Attrib
stdAttrib                     =  Attrib{      aNames          = [],
                                              aColor          = DefaultColor,
                                              aBGColor        = DefaultColor}

data FrameAttrib              =  FrameAttrib{ faNames         :: [Name],
                                              faColor,
                                              faBGColor       :: Color,
                                              faPen           :: Pen,
                                              faPattern       :: Pattern,
                                              faShadow        :: Maybe (Numeric, Numeric),
                                              faVisible       :: Bool}
                                 deriving (Eq, Read)

instance Show FrameAttrib where       -- Bug workaround fuer Hugs' Show
      showsPrec p (FrameAttrib faNames faColor faBGColor faPen faPattern faShadow
                      faVisible)
                              =  showParen ( p >= 10 )
                                      (showString "FrameAttrib{".
                                      showString "faNames=".
                                      showsPrec 10 faNames.
                                      showString ", ".
                                      showString "faColor=".
                                      showsPrec 10 faColor.
                                      showString ", ".
                                      showString "faBGColor=".
                                      showsPrec 10 faBGColor.
                                      showString ", ".
                                      showString "faPen=".
                                      showsPrec 10 faPen.
                                      showString ", ".
                                      showString "faPattern=".
                                      showsPrec 10 faPattern.
                                      showString ", ".
                                      showString "faShadow=".
                                      showsPrec 10 faShadow.
                                      showString ", ".
                                      showString "faVisible=".
                                      showsPrec 10 faVisible.
                                      showString "}")
      showList []             =  showString "[]"
      showList (x:xs)         =  showChar '[' . shows x . showl xs
              where
              showl []        =  showChar ']'
              showl (x:xs)    =  showString ", "
                                 . shows x
                                 . shows xs

stdFrameAttrib                :: FrameAttrib
stdFrameAttrib                =  FrameAttrib{ faNames         = [],
                                              faColor         = DefaultColor,
                                              faBGColor       = DefaultColor,
                                              faPen           = DefaultPen,
                                              faPattern       = DefaultPattern,
                                              faShadow        = Just (0,0),
                                              faVisible       = True}

instance HasPen FrameAttrib where
      setPen pen fa           =  fa{ faPen = pen }
      setDefaultPen           =  setPen DefaultPen
      getPen                  =  faPen

instance HasPattern FrameAttrib where
      setPattern pat fa       =  fa{ faPattern = pat }
      setDefaultPattern       =  setPattern DefaultPattern
      getPattern              =  faPattern

instance HasShadow FrameAttrib where
      setShadow a fa          =  fa{ faShadow = Just a }
      clearShadow fa          =  fa{ faShadow = Just (0,0) }
      getShadow               =  faShadow

instance HasColor FrameAttrib where
      setColor a fa           =  fa{ faColor = a }
      setDefaultColor         =  setColor DefaultColor
      getColor fa             =  faColor fa

instance HasBGColor FrameAttrib where
      setBGColor a fa         =  fa{ faBGColor = a }
      setDefaultBGColor       =  setBGColor DefaultColor
      getBGColor fa           =  faBGColor fa

instance HasName FrameAttrib where
      setName n fa            =  fa{ faNames = toName n:faNames fa }
      getNames fa             =  faNames fa

instance IsHideable FrameAttrib where
      hide fa                 =  fa{ faVisible = False }


-------------------- Pfade --------------


data PathElemDescr            =  PathElemDescr {
                                              peColor         :: Color,
                                              pePen           :: Pen,
                                              peArrowHead     :: Maybe ArrowHead,
                                              peSArrowHead    :: Maybe ArrowHead,
                                              pePattern       :: Pattern,
                                              peVisible       :: Bool,
                                              peStartCut,
                                              peEndCut        :: Maybe CutPic,
                                              peStartDir,
                                              peEndDir        :: Dir',
                                              peJoin          :: BasicJoin,
                                              peLabels        :: [PathLabel] }
                                 deriving (Eq, Read)

instance Show PathElemDescr where     -- Bug workaround fuer Hugs' Show
      showsPrec p (PathElemDescr peColor pePen peArrowHead peSArrowHead pePattern
                      peVisible peStartCut peEndCut peStartDir peEndDir
                      peJoin peLabels)
                              =  showParen ( p >= 10 )
                                      (showString "PathElemDescr{".
                                      showString "peColor=".
                                      showsPrec 10 peColor.
                                      showString ", ".
                                      showString "pePen=".
                                      showsPrec 10 pePen.
                                      showString ", ".
                                      showString "peArrowHead=".
                                      showsPrec 10 peArrowHead.
                                      showString ", ".
                                      showString "peSArrowHead=".
                                      showsPrec 10 peSArrowHead.
                                      showString ", ".
                                      showString "pePattern=".
                                      showsPrec 10 pePattern.
                                      showString ", ".
                                      showString "peVisible=".
                                      showsPrec 10 peVisible.
                                      showString ", ".
                                      showString "peStartCut=".
                                      showsPrec 10 peStartCut.
                                      showString ", ".
                                      showString "peEndCut=".
                                      showsPrec 10 peEndCut.
                                      showString ", ".
                                      showString "peStartDir=".
                                      showsPrec 10 peStartDir.
                                      showString ", ".
                                      showString "peEndDir=".
                                      showsPrec 10 peEndDir.
                                      showString ", ".
                                      showString "peJoin=".
                                      showsPrec 10 peJoin.
                                      showString ", ".
                                      showString "peLabels=".
                                      showsPrec 10 peLabels.
                                      showString "}")
      showList []             =  showString "[]"
      showList (x:xs)         =  showChar '[' . shows x . showl xs
              where
              showl []        =  showChar ']'
              showl (x:xs)    =  showString ", "
                                 . shows x
                                 . shows xs

stdPathElemDescr              :: PathElemDescr
stdPathElemDescr              =  PathElemDescr {
                                              peColor         = DefaultColor,
                                              pePen           = DefaultPen,
                                              peArrowHead     = Nothing,
                                              peSArrowHead    = Nothing,
                                              pePattern       = DefaultPattern,
                                              peVisible       = True,
                                              peStartCut      = Nothing,
                                              peEndCut        = Nothing,
                                              peStartDir      = DirEmpty,
                                              peEndDir        = DirEmpty,
                                              peJoin          = BJStraight,
                                              peLabels        = []
                                              }

data CutPic                   =  CutPicTrans  CutPic  [Int]
                              |  CutPic       Name
                              |  CutPic'      String
                                 deriving (Eq, Show, Read)

cutPic                        :: Name -> CutPic
cutPic                        =  CutPic

data PathLabel                =  PathLabel    Picture Double  Dir
                                 deriving (Eq, Show, Read)

--------------------------

data ArrowHead                =  DefaultArrowHead
                              |  ArrowHead    (Maybe Double)  (Maybe Double)
                                              ArrowHeadStyle
                                 deriving (Eq, Show, Read)

data ArrowHeadStyle           =  AHFilled
                              |  AHLine
                                 deriving (Eq, Show, Read)

ahFilled, ahLine              :: ArrowHeadStyle
ahFilled                      =  AHFilled
ahLine                        =  AHLine

setArrowHeadStyle             :: ArrowHeadStyle -> ArrowHead -> ArrowHead
setArrowHeadStyle s (ArrowHead a b _)
                              =  ArrowHead a b s
setArrowHeadStyle s DefaultArrowHead
                              =  ArrowHead Nothing Nothing s

getArrowHeadStyle             :: ArrowHead -> ArrowHeadStyle
getArrowHeadStyle (ArrowHead _ _ s)
                              =  s
getArrowHeadStyle DefaultArrowHead
                              =  AHFilled

--------------------------

image                         :: BitDepth -> [String] -> Picture
image Depth1 bls              = setTrueBoundingBox(overlay' [] (Just 0)
                                      [BitLine (vec(0,y)) Depth1 bl
                                      | (bl,y) <- zip bls [0,-0.12..]])
image Depth8 bls              = setTrueBoundingBox(overlay' [] (Just 0)
                                      [BitLine (vec(0,y)) Depth8 bl
                                      | (bl,y) <- zip bls [0,-0.12..]])
image Depth24 bls             = setTrueBoundingBox(overlay' [] (Just 0)
                                      [BitLine (vec(0,y)) Depth24 bl
                                      | (bl,y) <- zip bls [0,-0.36..]])


--------------------------

instance HasLabel PathElemDescr where
      setLabel i d l ped      =  ped{peLabels         = PathLabel (toPicture l) i d
                                                      : peLabels ped}
      removeLabel ped         =  ped{peLabels         = []}

instance HasColor PathElemDescr where
      setColor c ped          =  ped{ peColor         = c }
      setDefaultColor         =  setColor DefaultColor
      getColor ped            =  peColor ped

instance HasPattern PathElemDescr where
      setPattern pat ped      =  ped{pePattern        = pat}
      setDefaultPattern       =  setPattern DefaultPattern
      getPattern ped          =  pePattern ped

instance HasPen PathElemDescr where
      setPen pen ped          =  ped{pePen            = pen}
      setDefaultPen           =  setPen DefaultPen
      getPen ped              =  pePen ped

instance IsHideable PathElemDescr where
      hide ped                =  ped{peVisible        = False}

instance HasArrowHead PathElemDescr where
      setArrowHead ar ped     =  ped{peArrowHead      = Just ar}
      removeArrowHead ped     =  ped{peArrowHead      = Nothing}
      getArrowHead ped        =  peArrowHead ped
      setStartArrowHead ar ped
                              =  ped{peSArrowHead     = Just ar}
      removeStartArrowHead ped
                              =  ped{peSArrowHead     = Nothing}
      getStartArrowHead ped   =  peSArrowHead ped

instance HasStartEndCut PathElemDescr where
      setStartCut s ped       =  ped{peStartCut       = Just (cutPic $ toName s)}
      removeStartCut ped      =  ped{peStartCut       = Nothing}
      setEndCut s ped         =  ped{peEndCut         = Just (cutPic $ toName s)}
      removeEndCut ped        =  ped{peEndCut         = Nothing}

instance HasJoin PathElemDescr where
      setJoin bj ped          =  ped{ peJoin = bj }
      getJoin ped             =  peJoin ped

instance HasStartEndDir PathElemDescr where
      setStartAngle    a ped  =  ped{ peStartDir      = DirDir a}
      setEndAngle      a ped  =  ped{ peEndDir        = DirDir a}
      setStartCurl     a ped  =  ped{ peStartDir      = DirCurl a}
      setEndCurl       a ped  =  ped{ peEndDir        = DirCurl a}
      setStartVector   a ped  =  ped{ peStartDir      = DirVector a}
      setEndVector     a ped  =  ped{ peEndDir        = DirVector a}
      removeStartDir     ped  =  ped{ peStartDir      = DirEmpty}
      removeEndDir       ped  =  ped{ peEndDir        = DirEmpty}

----


pathLength                    :: Num a => Path -> a
pathLength (PathJoin p1 _ p2) =  pathLength p1 + 1 + pathLength p2
pathLength _                  =  0


forEachPath                   :: (PathElemDescr -> PathElemDescr)
                              -> Path -> Path
forEachPath f (PathJoin p1 ped p2)
                              =  PathJoin     (forEachPath f p1)
                                              (f ped)
                                              (forEachPath f p2)
forEachPath f (PathDefine eqs p)
                              =  PathDefine eqs (forEachPath f p)
forEachPath f (PathTransform t p)
                              =  PathTransform t (forEachPath f p)
forEachPath _ a               =  a


pathSetStart                  :: (PathElemDescr -> PathElemDescr) -> Path -> Path
pathSetStart f (PathJoin PathCycle ped p)
                              =  PathJoin PathCycle (f ped) p
pathSetStart f (PathJoin (PathPoint p) ped p2)
                              =  PathJoin (PathPoint p) (f ped) p2
pathSetStart f (PathJoin (PathEndDir d p) ped p2)
                              =  PathJoin (PathEndDir d p) (f ped) p2
pathSetStart f (PathJoin p1 ped p2)
                              =  PathJoin (pathSetStart f p1) ped p2
pathSetStart f (PathDefine eqs p)
                              =  PathDefine eqs (pathSetStart f p)
pathSetStart f (PathTransform t p)
                              =  PathTransform t (pathSetStart f p)
pathSetStart _ p              =  p

pathSetEnd                    :: (PathElemDescr -> PathElemDescr) -> Path -> Path
pathSetEnd f (PathJoin p ped PathCycle)
                              =  PathJoin p (f ped) PathCycle
pathSetEnd f (PathJoin p1 ped  (PathPoint p))
                              =  PathJoin p1 (f ped) (PathPoint p)
pathSetEnd f (PathJoin p1 ped  (PathEndDir d p))
                              =  PathJoin p1 (f ped) (PathEndDir d p)
pathSetEnd f (PathJoin p1 ped p2)
                              =  PathJoin p1 ped (pathSetEnd f p2)
pathSetEnd f (PathDefine eqs p )
                              =  PathDefine eqs (pathSetEnd f p)
pathSetEnd f (PathTransform t p)
                              =  PathTransform t (pathSetEnd f p)
pathSetEnd _ p                =  p

pathGetStart                  :: (PathElemDescr -> a) -> Path -> a
pathGetStart f (PathJoin PathCycle ped _)
                              =  f ped
pathGetStart f (PathJoin (PathPoint _) ped _)
                              =  f ped
pathGetStart f (PathJoin (PathEndDir _ _) ped _)
                              =  f ped
pathGetStart f (PathJoin p1 _ _)
                              =  pathGetStart f p1
pathGetStart f (PathDefine _ p)
                              =  pathGetStart f p
pathGetStart f (PathTransform _ p)
                              =  pathGetStart f p
pathGetStart f _              =  f stdPathElemDescr

pathGetEnd                    :: (PathElemDescr -> a) -> Path -> a
pathGetEnd f (PathJoin _ ped PathCycle)
                              =  f ped
pathGetEnd f (PathJoin _ ped (PathPoint _))
                              =  f ped
pathGetEnd f (PathJoin _ ped (PathEndDir _ _))
                              =  f ped
pathGetEnd f (PathJoin _ _ p2)=  pathGetEnd f p2
pathGetEnd f (PathDefine _ p )
                              =  pathGetEnd f p
pathGetEnd f (PathTransform _ p)
                              =  pathGetEnd f p
pathGetEnd f _                =  f stdPathElemDescr


instance HasLabel Path where
      setLabel i d l (PathJoin p1 ped p2)
              | i <=1         =  PathJoin p1 (setLabel i d l ped) p2
              | i > len1      =  setLabel (i-len1) d l p2
              | otherwise     =  setLabel i d l p1
                      where
                      len1    =  pathLength p1
      setLabel i d l (PathDefine eqs p)
                              =  PathDefine eqs (setLabel i d l p)
      setLabel i d l (PathTransform t p)
                              =  PathTransform t (setLabel i d l p)
      setLabel _ _ _ p        =  p
      removeLabel             =  forEachPath removeLabel


instance HasColor Path where
      setColor c p            =  forEachPath (setColor c) p
      setDefaultColor         =  setColor DefaultColor
      getColor (PathJoin _ ped _)
                              =  getColor ped
      getColor _              =  DefaultColor

instance HasPattern Path where
      setPattern pat          =  forEachPath (setPattern pat)
      setDefaultPattern       =  setPattern DefaultPattern
      getPattern (PathJoin _ ped _)
                              =  getPattern ped
      getPattern _            =  DefaultPattern

instance HasPen Path where
      setPen pen              =  forEachPath (setPen pen)
      setDefaultPen           =  setPen DefaultPen
      getPen (PathJoin _ ped _ )
                              =  getPen ped
      getPen _                =  DefaultPen

instance IsHideable Path where
      hide                    =  forEachPath hide

instance HasArrowHead Path where
      setArrowHead ar         =  pathSetEnd (setArrowHead ar)
      removeArrowHead         =  pathSetEnd removeArrowHead
      getArrowHead            =  pathGetEnd peArrowHead
      setStartArrowHead ar    =  pathSetStart (setStartArrowHead ar)
      removeStartArrowHead    =  pathSetStart removeStartArrowHead
      getStartArrowHead       =  pathGetStart peSArrowHead

instance HasStartEndDir Path where
      setStartAngle d (PathEndDir p _)
                              =  PathEndDir p (DirDir d)
      setStartAngle d (PathPoint p)
                              =  PathEndDir p (DirDir d)
      setStartAngle d p       =  pathSetStart (setStartAngle d) p

      setEndAngle d (PathEndDir p _)
                              =  PathEndDir p (DirDir d)
      setEndAngle d (PathPoint p)
                              =  PathEndDir p (DirDir d)
      setEndAngle a p         =  pathSetEnd (setEndAngle a) p


      setStartCurl a (PathEndDir p _)
                              =  PathEndDir p (DirCurl a)
      setStartCurl a (PathPoint p)
                              =  PathEndDir p (DirCurl a)
      setStartCurl a p        =  pathSetStart (setStartCurl a) p

      setEndCurl a (PathEndDir p _)
                              =  PathEndDir p (DirCurl a)
      setEndCurl a (PathPoint p)
                              =  PathEndDir p (DirCurl a)
      setEndCurl a p          =  pathSetEnd (setEndCurl a) p


      setStartVector a (PathEndDir p _)
                              =  PathEndDir p (DirVector a)
      setStartVector a (PathPoint p)
                              =  PathEndDir p (DirVector a)
      setStartVector a p      =  pathSetStart (setStartVector a) p

      setEndVector a (PathEndDir p _)
                              =  PathEndDir p (DirVector a)
      setEndVector a (PathPoint p)
                              =  PathEndDir p (DirVector a)
      setEndVector a p        =  pathSetEnd (setEndVector a) p

      removeStartDir (PathEndDir p _)
                              =  PathPoint p
      removeStartDir p        =  pathSetStart removeStartDir p
      removeEndDir (PathEndDir p _)
                              =  PathPoint p
      removeEndDir p          =  pathSetEnd (removeEndDir) p

instance HasJoin Path where
      setJoin bj p            =  forEachPath (setJoin bj) p
      getJoin (PathJoin _ ped _)
                              =  peJoin ped
      getJoin _               =  BJStraight

instance HasStartEndCut Path where
      setStartCut s           =  pathSetStart (setStartCut $ toName s)
      setEndCut s             =  pathSetEnd (setEndCut $ toName s)
      removeStartCut          =  pathSetStart removeStartCut
      removeEndCut            =  pathSetEnd removeEndCut

-------------------- Pfade ------------------

data Path                     =  PathBuildCycle       Path    Path
                              |  PathTransform        Transformation  Path
                              |  PathPoint            Point
                              |  PathCycle
                              |  PathJoin             Path    PathElemDescr   Path
                              |  PathEndDir           Point   Dir'
                              |  PathDefine           [Equation]      Path
                                 deriving (Eq, Show, Read)

data Dir'                     =  DirEmpty
                              |  DirCurl      Numeric
                              |  DirDir       Numeric
                              |  DirVector    Point
                                 deriving (Eq, Show, Read)

data BasicJoin                =  BJCat
                              |  BJFree
                              |  BJBounded
                              |  BJStraight
                              |  BJTense
                              |  BJTension    Tension
                              |  BJTension2   Tension Tension
                              |  BJControls   Point
                              |  BJControls2  Point   Point
                                 deriving (Eq, Show, Read)

data Tension                  =  Tension              Numeric
                              |  TensionAtLeast       Numeric
                                 deriving (Eq, Show, Read)

joinCat                       :: BasicJoin
joinCat                       =  BJCat

joinFree                      :: BasicJoin
joinFree                      =  BJFree

joinBounded                   :: BasicJoin
joinBounded                   =  BJBounded

joinStraight                  :: BasicJoin
joinStraight                  =  BJStraight

joinTense                     :: BasicJoin
joinTense                     =  BJTense

joinTension                   :: Tension -> BasicJoin
joinTension                   =  BJTension

joinTensions                  :: Tension -> Tension -> BasicJoin
joinTensions                  =  BJTension2

joinControl                   :: Point -> BasicJoin
joinControl                   =  BJControls

joinControls                  :: Point -> Point -> BasicJoin
joinControls                  =  BJControls2

tension                       :: Numeric -> Tension
tension                       =  Tension

tensionAtLeast                :: Numeric -> Tension
tensionAtLeast                =  TensionAtLeast

instance HasDefine Path where
      define eqs p            =  PathDefine eqs p

defaultCut                    :: (Name -> a -> a) -> Point -> (a -> a)
defaultCut f (PointVar name)
      | lastNameIsDir name    =  f  $ withoutDir name
      | otherwise             =  id
defaultCut f (PointTrans' p _)=  defaultCut f p                       ---
defaultCut _ _                =  id

defaultStartCut               :: HasStartEndCut a => Path -> (a -> a)
defaultStartCut (PathPoint p) =  defaultCut setStartCut p
defaultStartCut (PathEndDir p  _)
                              =  defaultCut setStartCut p
defaultStartCut (PathJoin _ _ p)
                              =  defaultStartCut p
defaultStartCut _             =  id

defaultEndCut                 :: HasStartEndCut a => Path -> (a -> a)
defaultEndCut (PathPoint p)   =  defaultCut setEndCut p
defaultEndCut (PathEndDir p _)=  defaultCut setEndCut p
defaultEndCut (PathJoin p _ _)=  defaultEndCut p
defaultEndCut _               =  id

lastNameIsDir                 :: Name -> Bool
lastNameIsDir (Hier _ name)   =  lastNameIsDir name
lastNameIsDir (NameDir _)     =  True
lastNameIsDir _               =  False

withoutDir                    :: Name -> Name
withoutDir (Hier name (NameDir _))
                              =  name
withoutDir (Hier n1 n2)       =  Hier n1 (withoutDir n2)
withoutDir name               =  name

class IsPath a where
      toPath                  :: a -> Path
      toPathList              :: [a] -> Path
      toPathList ps           =  foldl1 (.-.) (map toPath ps)

instance IsPath Path where
      toPath                  =  id

instance IsPath Point where
      toPath                  =  PathPoint

instance IsPath Name where
      toPath                  =  toPath . ref

instance IsPath a => IsPath [a] where
      toPath                  =  toPathList

instance IsPath Char where
      toPath                  =  toPath . ref
      toPathList              =  toPath . ref

instance (Real a, Real b) => IsPath (a, b) where
      toPath (a, b)           =  toPath (vec (fromRational $ toRational a,
                                              fromRational $ toRational b))

buildCycle                    :: Path -> Path -> Path
buildCycle                    =  PathBuildCycle

transformPath                 :: Transformation -> Path -> Path
transformPath                 =  PathTransform

instance HasConcat Path where
      (&)                     =  (.&.)

(.&.)                         :: (IsPath a, IsPath b) => a -> b -> Path
p1 .&. p2                     =  PathJoin (toPath p1)
                                          (stdPathElemDescr # setJoin BJCat)
                                          (toPath p2)

(...)                         :: (IsPath a, IsPath b) => a -> b -> Path
p1 ... p2                     =  PathJoin p1' (stdPathElemDescr
                                               # setJoin BJFree
                                               # defaultStartCut p1'
                                               # defaultEndCut p2') p2'
              where   p1'     =  toPath p1
                      p2'     =  toPath p2

(.-.)                         :: (IsPath a, IsPath b) => a -> b -> Path
p1 .-. p2                     =  PathJoin p1' (stdPathElemDescr
                                               # setJoin BJStraight
                                               # defaultStartCut p1'
                                               # defaultEndCut p2') p2'
              where   p1'     =  toPath p1
                      p2'     =  toPath p2

(.--.)                        :: (IsPath a, IsPath b) => a -> b -> Path
p1 .--. p2                    =  PathJoin p1' (stdPathElemDescr
                                               # setJoin  BJTense
                                               # defaultStartCut p1'
                                               # defaultEndCut p2') p2'
              where   p1'     =  toPath p1
                      p2'     =  toPath p2

(....)                        :: (IsPath a, IsPath b) => a -> b -> Path
p1 .... p2                    =  PathJoin p1' (stdPathElemDescr
                                               # setJoin  BJBounded
                                               # defaultStartCut p1'
                                               # defaultEndCut p2') p2'
              where   p1'     =  toPath p1
                      p2'     =  toPath p2



--------------------- Flaechen ------------------

data Area                     =  Area AreaDescr Path
                                 deriving (Eq, Show, Read)

data AreaDescr                =  AreaDescr {  arColor         :: Color,
                                              arLayer         :: Layer,
                                              arPen           :: Pen}
                                 deriving (Eq, Read)

instance Show AreaDescr where         -- Bug workaround fuer Hugs' Show
      showsPrec p (AreaDescr arColor arLayer arPen)
                              =  showParen ( p >= 10 )
                                      (showString "AreaDescr{".
                                      showString "arColor=".
                                      showsPrec 10 arColor.
                                      showString ", ".
                                      showString "arLayer=".
                                      showsPrec 10 arLayer.
                                      showString ", ".
                                      showString "arPen=".
                                      showsPrec 10 arPen.
                                      showString "}")

stdAreaDescr                  :: AreaDescr
stdAreaDescr                  =  AreaDescr {  arColor         = black,
                                              arLayer         = Front,
                                              arPen           = DefaultPen}

class IsArea a where
      toArea                  :: a -> Area

instance IsArea Area where
      toArea                  =  id

instance IsArea Path where
      toArea a                =  Area stdAreaDescr (ensureCycle a)

instance (IsPath a) => IsArea  [a] where
      toArea ps               =  Area stdAreaDescr (foldr (.-.) PathCycle ps)

instance HasDefine Area where
      define eqs (Area ad p)  =  Area ad (PathDefine eqs p)

instance HasColor Area where
      setColor c (Area ad ps) =  Area ad{ arColor = c } ps
      setDefaultColor a       =  setColor DefaultColor a
      getColor (Area ad _)    =  arColor ad

instance HasPen Area where
      setPen pen (Area ad ps) =  Area ad{ arPen = pen } ps
      setDefaultPen a         =  setPen DefaultPen a
      getPen (Area ad _)      =  arPen ad

instance HasLayer Area where
      setBack (Area ad ps)    =  Area ad{ arLayer = Back } ps
      setFront (Area ad ps)   =  Area ad{ arLayer = Front } ps
      getLayer (Area ad _)    =  arLayer ad


ensureCycle                   :: Path -> Path
ensureCycle(PathTransform t p)=  PathTransform t (ensureCycle p)
ensureCycle (PathPoint  p)    =  PathJoin (PathPoint p) stdPathElemDescr PathCycle
ensureCycle (PathJoin p1 ped p2)
                              =  PathJoin p1 ped (ensureCycle p2)
ensureCycle (PathEndDir p d)  =  PathJoin (PathEndDir p d) stdPathElemDescr PathCycle
ensureCycle (PathDefine eqs p)=  PathDefine eqs (ensureCycle p)
ensureCycle p                 =  p

getDefault                    :: Maybe a -> a -> a
getDefault (Just a) _         =  a
getDefault Nothing  b         =  b


------------------------------


data Frame                    =  Frame' FrameAttrib ExtentAttrib Path Picture
                                 deriving Show

data AbsOrRel                 =  AORAbs Numeric
                              |  AORRel Numeric
                              |  AORDefault
                                 deriving Show

data ExtentAttrib             =  ExtentAttrib{eaX, eaY        :: AbsOrRel,
                                              eaEqsDX         :: [Equation],
                                              eaEqsDY         :: [Equation],
                                              eaEqsWidth      :: [Equation],
                                              eaEqsHeight     :: [Equation],
                                              eaEqs           :: [Equation]}
                                 deriving Show

stdExtentAttrib               :: ExtentAttrib
stdExtentAttrib               =  ExtentAttrib{eaX             = AORDefault,
                                              eaY             = AORDefault,
                                              eaEqsDX         = [],
                                              eaEqsDY         = [],
                                              eaEqsWidth      = [],
                                              eaEqsHeight     = [],
                                              eaEqs           = [] }

instance HasRelax Frame where
      relax                   =  box empty # setWidth 0 # setHeight 0 # hide

instance HasColor Frame where
      setColor c (Frame' fa ea path p)
                              =  Frame' (setColor c fa) ea path p
      setDefaultColor f       =  setColor DefaultColor f
      getColor (Frame' fa _ _  _)
                              =  getColor fa

instance HasBGColor Frame where
      setBGColor c (Frame' fa ea path p)
                              =  Frame' (setBGColor c fa) ea path p
      setDefaultBGColor f     =  setBGColor DefaultColor f
      getBGColor (Frame' fa _  _ _)
                              =  getBGColor fa

instance HasPen Frame where
      setPen c (Frame' fa ea path p)
                              =  Frame' (setPen c fa) ea path p
      setDefaultPen f         =  setPen DefaultPen f
      getPen (Frame' fa _ _ _)=  getPen fa

instance HasShadow Frame where
      setShadow c (Frame' fa ea path p)
                              =  Frame' (setShadow c fa) ea path p
      clearShadow (Frame' fa ea path p)
                              =  Frame' (clearShadow fa) ea path p
      getShadow (Frame' fa _ _ _)
                              =  getShadow fa

instance HasPattern Frame where
      setPattern c (Frame' fa ea path p)
                              =  Frame' (setPattern c fa) ea path p
      setDefaultPattern f     =  setPattern DefaultPattern f
      getPattern (Frame' fa _  _ _)
                              =  getPattern fa

instance HasName Frame where
      setName n (Frame' fa ea path p)
                              =  Frame' (setName n fa) ea path p
      getNames (Frame' fa _ _  _)
                              =  getNames fa

instance HasDXY Frame where
      setDX dx (Frame' fa ea path p)
                              =  Frame' fa ea{ eaX = AORRel dx} path p
      setDY dy (Frame' fa ea path p)
                              =  Frame' fa ea{ eaY = AORRel dy} path p
      getDX (Frame' _ ea _ _)=  case eaX ea of
                                      AORRel dx       -> Just dx
                                      _               -> Nothing
      getDY (Frame' _ ea _ _)=  case eaY ea of
                                      AORRel dy       -> Just dy
                                      _               -> Nothing

instance HasExtent Frame where
      setWidth w (Frame' fa ea path p)
                              =  Frame' fa ea{ eaX = AORAbs w} path p
      setHeight h (Frame' fa ea path p)
                              =  Frame' fa ea{ eaY = AORAbs h} path p
      getWidth (Frame' _ ea _ _ )
                              =  case eaX ea of
                                      AORAbs w        -> Just w
                                      _               -> Nothing
      getHeight (Frame' _ ea  _ _)
                              =  case eaY ea of
                                      AORAbs h        -> Just h
                                      _               -> Nothing
      removeWidth (Frame' fa ea path p)
                              = Frame' fa ea{ eaX = AORDefault } path p
      removeHeight (Frame' fa ea path p)
                              = Frame' fa ea{ eaY = AORDefault } path p

instance IsHideable Frame where
      hide (Frame' fa ea path p)
                              =  Frame' (hide fa) ea path p

instance IsPicture Frame where
      toPicture (Frame' fa ea path p)
                              =  Frame fa eqs path p
              where eqs       =  equations (case eaX ea of
                                   AORRel dx  -> (var "dx" .= dx):eaEqsDX ea
                                   AORDefault -> (var "dx" .= 2):eaEqsDX ea
                                   AORAbs w   -> (var "width" .= w):eaEqsWidth ea)
                                 :equations (case eaY ea of
                                   AORRel dy  -> (var "dy" .= dy):eaEqsDY ea
                                   AORDefault -> (var "dy" .= 2):eaEqsDY ea
                                   AORAbs h   -> (var "height" .= h):(var "dy" .= 2):eaEqsHeight ea)
                                 :eaEqs ea

dot                           :: Frame
dot                           =  circle empty
                                 # setBGColor black
                                 # setDX 0.75

bullet                        :: Frame
bullet                        =  circle empty
                                 # setBGColor black
                                 # setDX 1.5

box                           :: IsPicture a => a -> Frame
box p                         =  Frame' stdFrameAttrib
                                        stdExtentAttrib{eaEqs         = eqs,
                                                        eaEqsDX       = eqsDX,
                                                        eaEqsDY       = eqsDY,
                                                        eaEqsWidth    = eqsWidth,
                                                        eaEqsHeight   = eqsHeight}
                                        path
                                        (toPicture p)
      where eqsDX             =  [ref E .= ref ("last" <+ E) + vec(var "dx",0),
                                  ref W .= ref ("last" <+ W) - vec(var "dx",0) ]
            eqsDY             =  [ref N .= ref ("last" <+ N) + vec(0,var "dy"),
                                  ref S .= ref ("last" <+ S) - vec(0,var "dy") ]
            eqsWidth          =  [ref E .= ref W + vec(var "width",0),
                                  ref C - ref W .= ref E - ref C ]
            eqsHeight         =  [ref N .= ref S + vec(0,var "height"),
                                  ref C - ref S .= ref N - ref C]
            eqs               =  [ref C .= ref ("last" <+ C),
                                  xpart (ref NE) .= xpart (ref SE),
                                  ypart (ref NW) .= ypart (ref NE),
                                  ref W .= med 0.5 (ref NW) (ref SW),
                                  ref S .= med 0.5 (ref SW) (ref SE),
                                  ref E .= med 0.5 (ref NE) (ref SE),
                                  ref N .= med 0.5 (ref NE) (ref NW) ]
            path              =  ref NE .-. ref SE .-. ref SW .-. ref NW .-. cycle'

triangle                      :: IsPicture a => a -> Frame
triangle                      =  triAngle 28

triAngle                      :: IsPicture a => Numeric -> a -> Frame
triAngle a p                  =  Frame' stdFrameAttrib
                                        stdExtentAttrib{eaEqs         = eqs,
                                                        eaEqsDX       = eqsDX,
                                                        eaEqsDY       = eqsDY,
                                                        eaEqsWidth    = eqsWidth,
                                                        eaEqsHeight   = eqsHeight}
                                        path
                                        (toPicture p)
      where
      eqsDX                   =  [ref SE .= ref ("last" <+ SE) + vec(var "dx",-var "dy"),
                                  ref S .= ref ("last" <+ S) - vec(0,var "dy") ]
      eqsDY                   =  [ypart (ref N-ref S) .= 0.5*tan (90-a/2)*xpart (ref SE - ref SW) ]
      eqsWidth                =  [xpart(ref SE) .= xpart(ref SW) + var "width",
                                  ref S .= ref ("last" <+ S) - vec(0,var "dy") ]
      eqsHeight               =  [ypart (ref N-ref S) .= var "height"]
      eqs                     =  [ref C .= ref N,
                                  ypart (ref SW) .= ypart (ref SE),
                                  ref S - ref SW .= ref SE - ref S,
                                  equal [ref NW, ref N, ref NE],
                                  xpart (ref S) .= xpart (ref N),
                                  ref W .= ref SW,
                                  ref E .= ref SE]
      path                    =  ref SW .-. ref SE .-. ref N .-. cycle'

rbox                          :: IsPicture a => Numeric -> a -> Frame
rbox r p                      =  Frame' stdFrameAttrib
                                        stdExtentAttrib{eaEqs         = eqs,
                                                        eaEqsDX       = eqsDX,
                                                        eaEqsDY       = eqsDY,
                                                        eaEqsWidth    = eqsWidth,
                                                        eaEqsHeight   = eqsHeight}
                                        path
                                        (toPicture p)
      where
      eqsDX                   =  [ref E .= ref ("last" <+ E) + vec(var "dx",0),
                                  ref W .= ref ("last" <+ W) - vec(var "dx",0) ]
      eqsDY                   =  [ref N .= ref ("last" <+ N) + vec(0,var "dy"),
                                  ref S .= ref ("last" <+ S) - vec(0,var "dy") ]
      eqsWidth                =  [ref E .= ref W + vec(var "width",0),
                                  ref C - ref W .= ref E - ref C ]
      eqsHeight               =  [ref N .= ref S + vec(0,var "height"),
                                  ref C - ref S .= ref N - ref C]
      eqs                     =  [ref C .= ref ("last" <+ C),
                                  xpart (ref NE) .= xpart (ref SE),
                                  ypart (ref NW) .= ypart (ref NE),
                                  ref W .= med 0.5 (ref NW) (ref SW),
                                  ref S .= med 0.5 (ref SW) (ref SE),
                                  ref E .= med 0.5 (ref NE) (ref SE),
                                  ref N .= med 0.5 (ref NE) (ref NW),
                                  var "r" .= minimum' [r, 0.5*ypart (ref N-ref S),
                                                       0.5*xpart (ref E-ref W)]]
      path                    =    ref SW + vec(var "r", 0) .--. ref SE - vec(var "r", 0)
                              ...  ref SE + vec(0,       var "r") .--. ref NE - vec(0,           var "r")
                              ...  ref NE - vec(var "r", 0).--. ref NW + vec(var "r", 0)
                              ...  ref NW - vec(0,       var "r").--. ref SW + vec(0,    var "r")
                              ...  cycle'

oval                          :: IsPicture a => a -> Frame
oval p                        =  Frame' stdFrameAttrib
                                        stdExtentAttrib{eaEqs         = eqs,
                                                        eaEqsDX       = eqsDX,
                                                        eaEqsDY       = eqsDY,
                                                        eaEqsWidth    = eqsWidth,
                                                        eaEqsHeight   = eqsHeight}
                                        path
                                        (toPicture p)
      where
      eqsDX                   =  [ref E .= ref ("last" <+ E) + vec(var "dx",0),
                                  ref W .= ref ("last" <+ W) - vec(var "dx",0) ]
      eqsDY                   =  [ref N .= ref ("last" <+ N) + vec(0,var "dy"),
                                  ref S .= ref ("last" <+ S) - vec(0,var "dy") ]
      eqsWidth                =  [ref E .= ref W + vec(var "width",0),
                                  ref C - ref W .= ref E - ref C ]
      eqsHeight               =  [ref N .= ref S + vec(0,var "height"),
                                  ref C - ref S .= ref N - ref C ]
      eqs                     =  [ref C .= ref ("last" <+ C),
                                  xpart (ref NE)  .= xpart (ref SE),
                                  ypart (ref NW)  .= ypart (ref NE),
                                  ref W .= med 0.5 (ref NW) (ref SW),
                                  ref S .= med 0.5 (ref SW) (ref SE),
                                  ref E .= med 0.5 (ref NE) (ref SE),
                                  ref N .= med 0.5 (ref NE) (ref NW)]
      path                    = ref N .... ref E ....  ref S .... ref W ....  cycle'

circle                        :: IsPicture a => a -> Frame
circle p                      =  Frame' stdFrameAttrib
                                        stdExtentAttrib{eaEqs         = eqs,
                                                        eaEqsDX       = eqsDX,
                                                        eaEqsDY       = eqsDY,
                                                        eaEqsWidth    = eqsWidth,
                                                        eaEqsHeight   = eqsHeight}
                                        path
                                        (toPicture p)
      where
      eqsDX                   =  [
              var "r"         .= 0.5*maximum'[xpart(ref ("last" <+ E)-ref ("last" <+ W)),
                                              ypart(ref ("last" <+ N)-ref ("last" <+ S))]
                                              +var "dx"]
      eqsDY                   =  []
      eqsWidth                =  [
              var "r"         .= 0.5*var "width"]
      eqsHeight               =  []
      eqs                     =  [ref C .= ref ("last" <+ C),
                                  ref N .= ref C + vec(0,var "r"),
                                  ref E .= ref C + vec(var "r",0),
                                  ref S .= ref C - vec(0,var "r"),
                                  ref W .= ref C - vec(var "r",0),
                                  xpart (ref NE)  .= xpart (ref SE),
                                  ypart (ref NW)  .= ypart (ref NE),
                                  ref W + vec(0.293*var"r",0) .= med 0.5 (ref NW) (ref SW),
                                  ref S + vec(0,0.293*var"r") .= med 0.5 (ref SW) (ref SE),
                                  ref E - vec(0.293*var"r",0) .= med 0.5 (ref NE) (ref SE),
                                  ref N - vec(0,0.293*var"r") .= med 0.5 (ref NW) (ref NE)]
      path                    =  ref N ... ref E ... ref S ... ref W ... cycle'