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
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
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)
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
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
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
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 }
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
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 (ilen1) 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
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
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
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 Nref S) .= 0.5*tan (90a/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 Nref 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 Nref S),
0.5*xpart (ref Eref 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'