module FMP.Core (
mp
) where
import FMP.Types
import FMP.Syntax
import FMP.Symbols
import FMP.Term
import FMP.Color
import FMP.Syntax
import FMP.Picture
import FMP.Resolve
type MPArg = (Int, Symbols)
type MPResult = (Int, Symbols, MetaPost, MetaPost)
drawBC :: Attrib -> Int -> MetaPost
drawBC a n = case aBGColor a of
DefaultColor -> relax
Graduate c1 c2 a n'
-> MPGraduate (mpColor c1) (mpColor c2)
(MPBPath (Id (suff n))) n' a
a -> MPFill (MPBPath (Id (suff n)))
(mpColor a)
MPDefaultPen
drawFrameBC :: Symbols -> FrameAttrib -> Int -> MetaPost
drawFrameBC d fa n = case bgColor of
DefaultColor -> mpShadow
Graduate c1 c2 a n'
-> MPGraduate (mpColor c1)
(mpColor c2)
(MPBPath (Id (suff n))) n' a
_ -> mpShadow
& MPFill (MPBPath (Id (suff n)))
(mpColor bgColor)
MPDefaultPen
where
bgColor = faBGColor fa
(sx,sy) = getDefault (faShadow fa) (0, 0)
mpShadow = if sx==0 && sy == 0
then relax
else MPFill (MPShiftedP
(pair sx' sy')
(MPBPath (Id (suff n))))
(mpColor black)
MPDefaultPen
sx' = maybe 0 mpNumeric (resolveNumeric (n, d) sx)
sy' = maybe 0 mpNumeric (resolveNumeric (n, d) sy)
drawBorder :: FrameAttrib -> Int -> MetaPost
drawBorder fa n = if faVisible fa
then case fgColor of
Graduate c1 c2 a n'
-> MPGraduatePath MPNormal
(mpColor c1) (mpColor c2)
(MPBPath (Id (suff n)))
(mpPattern pattern) (mpPen pen)
n' a
_ -> MPDraw MPNormal (MPBPath (Id (suff n)))
(mpPattern pattern) (mpColor fgColor)
(mpPen pen)
else relax
where
fgColor = faColor fa
pen = faPen fa
pattern = faPattern fa
mp :: Picture -> MPArg -> MPResult
mp (Attributes as p) (n, symDown)
= (n', symNames (aNames as) n symUp', l',
case aColor as of
DefaultColor -> drawBC as n & z'
Graduate c1 c2 a num
-> MPImage rememberPic z' & drawBC as n
& MPGraduatePic (mpColor c1) (mpColor c2)
(Id rememberPic) num a
c -> MPImage rememberPic z' & drawBC as n
& MPDrawPic (mpColor c) (Id rememberPic))
where
(n', symUp', l', z') = mp p (n, symDown)
rememberPic = "r"++show n
mp (Overlay _ _ []) ns = mp (Empty 0 0) ns
mp (Overlay eqs bbox ps) (n, symDown)
= (n', newSym & symUp',
l' & mpEquations (maybes2List eqs') & newBBox bbox,
z')
where
(n':ns',symSons',l',z') = foldr (\j i-> mergeResult (mp j (params i)) i)
([n+1], [], relax, relax) ps
mergeResult (n, sym, l, z) (ns', syms', l', z')
= (n:ns', sym:syms', l & l', z & z')
params (n:_,_,_,_) = (n, symUp' & symDown)
params ([],_,_,_) = (n, symUp' & symDown)
mapping = zip3 [0..] ns' symSons'
symUp' = symUnions symSons'
symLocalNames = symUnion3
(symUnions [ addPDef (SymPName (toName n) m 0)
relax
| (n, m, _) <- mapping ])
(symUnions [ symHier n m sym
| (n, m, sym) <- mapping ])
symUp'
newSym = snd (symEquations (n, 0, relax) eqs)
eqs' = map (resolveEquation (n, sym)) eqs
where sym = newSym & symLocalNames & symDown
newBBox Nothing = MPBoxit (suff n) relax
& MPEquals [tdot (suff n) SW,
pair (Min [XPart (tdot (suff n) W)| n <- ns'])
(Min [YPart (tdot (suff n) S)| n <- ns'])]
& MPEquals [tdot (suff n) NE,
pair (Max [XPart (tdot (suff n) E)| n <- ns'])
(Max [YPart(tdot (suff n) N)| n <- ns'])]
& MPFixSize [suff n]
newBBox (Just b) = let nBBox = head ([ n | (m,n,_) <- mapping, m==b]++[0])
in MPCloneit (suff n) (suff nBBox)
mp (Define eqs p) (n, symDown)
= (n', symUp',
mpEquations (maybes2List eqs') & l'
& MPCloneit (suff n) (suff (n+1)), z')
where
(n', symUp', l', z') = mp p (n+1, newSym & symDown)
newSym = snd (symEquations (n, 0, relax) eqs)
eqs' = map (resolveEquation (n, sym)) eqs
where sym = newSym & symUp' & symDown
mp (Frame fa eqs path p) (n, symDown)
= (n', symNames (faNames fa) n symUp',
l' & MPShapeit (suff n) & mpEquations eqs' & assignPath,
drawFrameBC sym fa n & z' & drawBorder fa n)
where
(n', symUp', l', z') = mp p (n+1, relax)
sym = newSym & symUp' & symDown
newSym = snd (symEquations (n, 0, relax) eqs)
eqs' = maybes2List (map (resolveEquation (n, sym)) eqs)
assignPath = case resolvePath (n, 0, sym) path of
Nothing -> relax
Just (_, p')-> MPAssign (Id (suff n++".p"))
(Id $ show $ show $ emit $ mpPath p')
mp (Draw ls p) (n, symDown) = (n'', symUp'' & symUp',
l' & l'' & MPCloneit (suff n) (suff (n+1)),
z' & z'')
where
nThis = n
(n', symUp', l', z') = mp p (n+1, symDown)
(n'', _, symUp'', l'', z'') = paths ls n' 0
sym = symUp' & symUnion3 relax relax symDown
paths [] n m = (n, m, relax, relax, relax)
paths (l:ls) n m = (n'',m'', symUp2' & symUp2'', l' & l'', z' & z'')
where
(n', m',symUp2',l',z') = constructPath sym l n nThis m
(n'',m'',symUp2'',l'',z'')= paths ls n' m'
mp (Fill ars p) (n, symDown) = if preFill == relax
then (n',
symUp',
l' & l'' & MPCloneit (suff n) (suff (n+1)),
z' & postFill)
else (n',
symTrans symUp' n,
defShift & l' & l'' & MPSubBox n z',
preFill & MPDrawUnBoxed [suff n] & postFill)
where
(n', symUp', l', z') = mp p (n+1, symDown)
defShift = MPDef (tr n) (Shifted Identity
(LLCorner (Pic (suff n)) shiftRefPoint n))
sym = if and [getLayer a == Front | a <- ars]
then symUp' & symUnion3 relax relax symDown
else symTrans symUp' n & symUnion3 relax relax symDown
(_,l'',preFill,postFill)= fillCommands 0 ars
fillCommands :: Int -> [Area] -> (Int, MetaPost, MetaPost, MetaPost)
fillCommands m [] = (m, relax, relax, relax)
fillCommands m (Area ad ps:ars)
= if arLayer ad == Back
then ( m'', l' & l'', fill & pre, post )
else ( m'', l' & l'', pre, fill & post )
where
(m', l',fill) = fillCommand m ad ps
(m'', l'', pre, post)= fillCommands m' ars
fillCommand :: Int -> AreaDescr -> Path -> (Int, MetaPost, MetaPost)
fillCommand m ad ps = case resolvePath (n, m, sym) ps of
Just (m', PathJoin (PathPoint p) _ PathCycle)
-> ( m', relax,
MPDraw MPNormal
(MPPathTerm (mpPoint p))
MPDefaultPattern
(mpColor (arColor ad))
(mpPen (arPen ad)))
Just (m', path')
-> case (arColor ad) of
Graduate c1 c2 a n'
-> ( m', mpEquations (getEqs path'),
MPGraduate (mpColor c1) (mpColor c2)
(mpPath path') n' a)
c-> ( m', mpEquations (getEqs path'),
MPFill (mpPath path') (mpColor c)
(mpPen (arPen ad)))
Nothing -> ( m, relax, relax)
mp (Clip path p) (n, symDown)
= (n',
symTrans symUp' n,
defShift & eqs & l' & MPSubBox n z',
MPAssign (Id ("p"++show n)) CurrentPicture
& MPClearIt
& MPDrawUnBoxed [suff n]
& clipCommand
& MPAssign (Id ("q"++show n)) CurrentPicture
& MPClearIt
& MPAssign CurrentPicture (Id ("p"++show n))
& MPDrawPic MPDefaultColor (Id ("q"++show n)))
where
(n', symUp', l', z') = mp p (n+1, relax)
sym = symTrans symUp' n & symUnion3 relax relax symDown
defShift = MPDef (tr n) (Shifted Identity (LLCorner (Pic (suff n))
shiftRefPoint n))
path' = resolvePath (n, 0, sym) path
eqs = case path' of
Just (_, path'')-> mpEquations (getEqs path'')
Nothing -> relax
clipCommand = case path' of
Just (_, path'') -> MPClip (mpPath path'')
Nothing -> relax
mp (Empty w h) (n, symDown) = (n+1, relax,
MPBoxit (suff n) relax
& width (getDefault (resolveNumeric (n, symDown) w) 0)
& hight (getDefault (resolveNumeric (n, symDown) h) 0),
MPDrawUnBoxed [suff n])
where width w = MPEquals [tdot (suff n) E,
tdot (suff n) W + pair (mpNumeric w) 0]
hight h = MPEquals [tdot (suff n) N,
tdot (suff n) S + pair 0 (mpNumeric h)]
mp (Tex s) (n, _) = (n+1, relax,
MPBoxit (suff n) (MPTex s)
& MPEquals [Id (suff n++".dx"), txtDX]
& MPEquals [Id (suff n++".dy"), txtDY],
MPDrawUnBoxed [suff n])
mp (Text s) (n, _) = (n+1,
relax,
MPBoxit (suff n) (MPText s)
& MPEquals [Id (suff n++".dx"), txtDX]
& MPEquals [Id (suff n++".dy"), txtDY],
MPDrawUnBoxed [suff n])
mp (PTransform (Transformation xx xy yx yy dx dy) p) (n, symDown)
= (n', symTrans symUp' n,
defShift & l' & MPSubBox n (
z' & MPDefineTrans trn
(MPTransform (mpNumeric xx) (mpNumeric xy)
(mpNumeric yx) (mpNumeric yy)
(mpNumeric dx) (mpNumeric dy))
& MPAssign CurrentPicture
(Transformed CurrentPicture (Id trn))),
MPDrawUnBoxed [suff n])
where
(n', symUp', l', z') = mp p (n+1, symDown)
trn = "tr"++show n
defShift = MPDef (tr n)
(Shifted (Transformed Identity (Id trn))
(LLCorner (Pic (suff n)) shiftRefPoint n))
mp (TrueBox p) (n, symDown) = (n', symTrans symUp' n,
defShift & l' & MPSubBox n z',
MPDrawUnBoxed [suff n])
where
(n', symUp', l', z') = mp p (n+1, symDown)
defShift = MPDef (tr n) (Shifted Identity (LLCorner (Pic (suff n))
shiftRefPoint n))
mp (BitLine o d bs) (n, symDown)
= (n,
relax,
relax,
MPBitLine ( mpNumeric (xpart o'),
mpNumeric (ypart o') ) (depth d) bs)
where
o' = getDefault (resolvePoint (n, symDown) o) 0
depth Depth1 = 1
depth Depth8 = 8
depth Depth24 = 24
constructPath :: Symbols -> Path -> Int -> Int -> Int
-> (Int,Int,Symbols,MetaPost,MetaPost)
constructPath d p n nThis m = (n',
maybe m fst (resolvePath (nThis, m, d) p),
d',
maybe relax (\(_,p)->mpEquations (getEqs p) & l')
(resolvePath (nThis, m, d) p),
maybe relax (\(_,p)->MPAssignPath "tempPath"
(mpPath p)
& snd (drawPath d p 0 relax)
& z')
(resolvePath (nThis, m, d) p))
where
(n', d', l', z') = mpLabels' p n d (MPPathTerm (Id "tempPath"))
getEqs :: Path -> [Equation]
getEqs (PathJoin p1 _ p2) = equations (getEqs p1):getEqs p2
getEqs (PathBuildCycle p1 p2) = equations (getEqs p1):getEqs p2
getEqs (PathDefine eqs p) = equations (eqs):getEqs p
getEqs _ = []
mpPath :: Path -> MPPath
mpPath p = MPPathNorm (mpPath' p Nothing)
mpPath' :: Path -> Maybe (PathElemDescr,MPPathSub) -> MPPathSub
mpPath' PathCycle _ = MPCycle
mpPath' (PathPoint p) (Just (j, c))
= MPPathSub (mpPoint p) (MPPathJoin
(mpDir (peStartDir j))
(mpJoin (peJoin j))
(mpDir (peEndDir j))) c
mpPath' (PathPoint p) Nothing
= MPPathEnd (mpPoint p)
mpPath' (PathEndDir p d) _ = MPPathEndDir (mpPoint p) (mpDir d)
mpPath' (PathJoin p1 ped p2) end
= mpPath' p1 (Just (ped, (mpPath' p2 end)))
mpPath' (PathBuildCycle p1 p2) _
= MPPathBuildCycle [ mpPath p1, mpPath p2 ]
mpPath' (PathTransform (Transformation a b c d e f) p) end
= (MPPathTransform (MPTransform (mpNumeric a)
(mpNumeric b) (mpNumeric c)
(mpNumeric d) (mpNumeric e)
(mpNumeric f))
(mpPath' p end) )
mpPath' (PathDefine _ p) end = mpPath' p end
drawPath :: Symbols -> Path -> Double -> MetaPost
-> (Double,MetaPost)
drawPath def (PathJoin p1 ped p2) n pr
= (n2', p1')
where
drawSegment = case color of
Graduate c1 c2 a q
-> MPGraduatePath
(mpPathArrow arrow)
(mpColor c1) (mpColor c2)
(path p)
(mpPattern pat) (mpPen pen) q a
_ -> MPDraw
(mpPathArrow arrow)
(path p)
(mpPattern pat)
(mpColor color)
(mpPen pen)
(n1', p1') = if peVisible ped
then drawPath def p1 n ( drawSegment
& p2'
& backArrrowHead )
else drawPath def p1 n p2'
(n2', p2') = if (peJoin ped == BJCat)
then drawPath def p2 n1' pr
else drawPath def p2 (n1'+1) pr
arrow = getDefault (peArrowHead ped) DefaultArrowHead
arrowS = getDefault (peSArrowHead ped) DefaultArrowHead
backArrrowHead = if arrowS == DefaultArrowHead
then relax
else MPDrawAHead
(mpPathRArrow arrowS)
(path p)
(mpColor color)
(mpPen pen)
color = peColor ped
pat = pePattern ped
pen = pePen ped
p = MPSubPath (Const n1') (Const(n1'+1))
(MPPathTerm (Id "tempPath"))
path p = case peEndCut ped of
Nothing -> path' p
Just cb -> MPCutafter (path' p)
(MPBPath (mpCutPic cb))
path' p = case peStartCut ped of
Nothing -> p
Just ca -> MPCutbefore p
(MPBPath (mpCutPic ca))
drawPath def (PathTransform _ p) n pr
= drawPath def p n pr
drawPath _ (PathBuildCycle _ _) _ _
= (0, MPDraw MPNormal
(MPPathTerm (Id "tempPath"))
MPDefaultPattern
MPDefaultColor
MPDefaultPen)
drawPath def (PathDefine _ p) n pr
= drawPath def p n pr
drawPath _ _ n mp = (n, mp)
mpDir :: Dir' -> MPPathDir
mpDir DirEmpty = MPDefaultPathDir
mpDir (DirCurl a) = MPPathDirCurl (mpNumeric a)
mpDir (DirDir a) = MPPathDir (mpNumeric a)
mpDir (DirVector a) = MPPathDirPair (mpNumeric (xpart a))
(mpNumeric (ypart a))
mpJoin :: BasicJoin -> MPPathBasicJoin
mpJoin BJStraight = MPPathBasicJoinStraight
mpJoin BJTense = MPPathBasicJoinTense
mpJoin BJFree = MPPathBasicJoin2
mpJoin BJBounded = MPPathBasicJoin3
mpJoin BJCat = MPPathBasicJoinCat
mpJoin (BJTension a) = MPPathBasicJoinTension1 (mpTension a)
mpJoin (BJTension2 a b) = MPPathBasicJoinTension2 (mpTension a) (mpTension b)
mpJoin (BJControls a) = MPPathBasicJoinControls1 (mpPoint a)
mpJoin (BJControls2 a b) = MPPathBasicJoinControls2 (mpPoint a) (mpPoint b)
mpTension :: Tension -> MPPathBasicJoinTension
mpTension (Tension a) = MPPathBasicJoinTension (mpNumeric a)
mpTension (TensionAtLeast a) = MPPathBasicJoinAtLeast (mpNumeric a)
mpLabels :: Int -> [PathLabel] -> Symbols -> MPPath -> MPResult
mpLabels n [] _ _ = (n, relax, relax, relax)
mpLabels n (PathLabel p i o:lls) sym p'
= (n'',
d & d',
l & l',
z' & MPEquals [Id (suff n ++ (emitDir o)),
Id ("point " ++ showFF i ""
++ "*length(" ++ show (emit p')
++ ") of (" ++ show (emit p') ++ ")")]
& z)
where
(n' ,d ,l ,z) = mp p (n, sym)
(n'', d', l', z') = mpLabels n' lls sym p'
mpLabels' :: Path -> Int -> Symbols -> MPPath -> MPResult
mpLabels' (PathJoin p1 ped p2) n sym p'
= (n''',
symUnions [d', d, d''],
l & l' & l'',
z' & z & z'')
where
(n' , d, l, z) = mpLabels n (peLabels ped) sym p'
(n'' , d', l', z') = mpLabels' p1 n' sym p'
(n''', d'', l'', z'') = mpLabels' p2 n'' sym p'
mpLabels' (PathDefine _ p) n sym p'
= mpLabels' p n sym p'
mpLabels' _ n _ _ = (n, relax, relax, relax)