module FMP.Resolve (
resolvePoint, resolvePath, resolveNumeric, resolveEquation,
maybes2List,
symEquations,
insertNumeric
) where
import FMP.Types
import FMP.Picture
import FMP.Syntax
import FMP.Symbols
import Control.Monad ( mplus )
maybes2List :: [Maybe a] -> [a]
maybes2List [] = []
maybes2List (Just a :ls) = a:maybes2List ls
maybes2List (Nothing:ls) = maybes2List ls
flattenName :: Name -> Name
flattenName (Hier a b) = flattenName' (Hier a b) Nothing
flattenName (Global (Hier a b) )
= flattenName' (Hier a b) Nothing
flattenName a = a
flattenName' :: Name -> Maybe Name -> Name
flattenName' (Hier (Hier a b) c) Nothing
= flattenName' a (Just (flattenName' b (Just c)))
flattenName' (Hier (Hier a b) c) (Just e)
= flattenName' a (Just (flattenName' b (Just (c <+ e))))
flattenName' a Nothing = a
flattenName' a (Just e) = a <+ e
resolvePoint :: (Int, Symbols) -> Point -> Maybe Point
resolvePoint ns (PointVar (Global name))
= resolvePoint ns (PointVar name)
resolvePoint (n, _) (PointVar (NameInt m))
= Just (PointVarArray' n m)
resolvePoint (n, _) (PointVar (NameDir d))
= Just (PointPic' n d)
resolvePoint (n, _) (PointVar (Hier (NameStr "last") (NameDir d)))
= Just (PointPic' (n+1) d)
resolvePoint (_, s) (PointVar name)
= resolvePointName (symPnts s) (flattenName name)
resolvePoint ns (PointTrans' p ts)
= maybe' (\p->PointTrans' p ts) (resolvePoint ns p)
resolvePoint ns (PointVec (nx, ny))
= maybe2 (\a b -> PointVec (a, b))
(resolveNumeric ns nx, resolveNumeric ns ny)
resolvePoint ns (PointPPP c p1 p2)
= maybe2 (PointPPP c)
(resolvePoint ns p1, resolvePoint ns p2)
resolvePoint ns (PointMediate a p1 p2)
= maybe3 PointMediate (resolveNumeric ns a,
resolvePoint ns p1,
resolvePoint ns p2)
resolvePoint ns (PointNMul a p )
= maybe2 PointNMul (resolveNumeric ns a, resolvePoint ns p)
resolvePoint ns (PointNeg p) = maybe' PointNeg (resolvePoint ns p)
resolvePoint ns (PointDirection p)
= maybe' PointDirection (resolveNumeric ns p)
resolvePoint ns (PointCond b t e)
= maybe3 PointCond ( resolveBoolean ns b,
resolvePoint ns t,
resolvePoint ns e)
resolvePoint _ p = Just p
resolvePointName :: SymPoint -> Name -> Maybe Point
resolvePointName (SymPUnion d1 d2) name
= resolvePointName d1 name
`mplus` resolvePointName d2 name
resolvePointName (SymPUnion3 d1 d2 d3) name
= resolvePointName d1 name
`mplus` resolvePointName d2 name
`mplus` resolvePointName d3 name
resolvePointName (SymPHier name' n _) (Hier name (NameInt m))
= if name == name'
then Just (PointVarArray' n m)
else Nothing
resolvePointName (SymPName name' n _) (Hier name (NameDir d))
= if name == name'
then Just (PointPic' n d)
else Nothing
resolvePointName (SymPHier name' _ ds) (Hier name p)
= if name == name'
then resolvePointName ds p
else Nothing
resolvePointName (SymPName name' n m) name
= if name == name'
then Just (PointVar' n m)
else Nothing
resolvePointName (SymPTrans d k) name
= maybe' (f k) (resolvePointName d name)
where
f k (PointTrans' p2 ks) = PointTrans' p2 (k:ks)
f k p = PointTrans' p [k]
resolvePointName _ _ = Nothing
resolveNumeric2 :: SymNum -> Name -> Maybe Numeric
resolveNumeric2 (SymNUnion n1 n2) name
= resolveNumeric2 n1 name
`mplus` resolveNumeric2 n2 name
resolveNumeric2 (SymNUnion3 n1 n2 n3) name
= resolveNumeric2 n1 name
`mplus` resolveNumeric2 n2 name
`mplus` resolveNumeric2 n3 name
resolveNumeric2 (SymNHier name' n _) (Hier name (NameInt m))
= if name == name'
then Just (NumericArray' n m)
else Nothing
resolveNumeric2 (SymNHier name' _ ds) (Hier name n)
= if name == name'
then resolveNumeric2 ds n
else Nothing
resolveNumeric2 (SymNName name' n m) name
= if name == name'
then Just (NumericVar' n m)
else Nothing
resolveNumeric2 _ _ = Nothing
maybe' :: (a -> b) -> Maybe a -> Maybe b
maybe' f (Just a) = Just (f a)
maybe' _ _ = Nothing
maybe2 :: (a -> b -> c) -> (Maybe a,Maybe b) -> Maybe c
maybe2 f (Just a, Just b) = Just (f a b)
maybe2 _ (_, _) = Nothing
maybe3 :: (a -> b -> c -> d) -> (Maybe a,Maybe b,Maybe c) -> Maybe d
maybe3 f (Just a, Just b, Just c)
= Just (f a b c)
maybe3 _ (_, _, _) = Nothing
resolveNumeric :: (Int, Symbols) -> Numeric -> Maybe Numeric
resolveNumeric (n,_) (NumericVar (NameInt m))
= Just (NumericArray' n m)
resolveNumeric (_,s) (NumericVar name)
= resolveNumeric2 (symNums s) (flattenName name)
resolveNumeric ns (NumericNNN c n1 n2)
= maybe2 (NumericNNN c)
(resolveNumeric ns n1,
resolveNumeric ns n2)
resolveNumeric ns (NumericPN c p)
= maybe' (NumericPN c) (resolvePoint ns p)
resolveNumeric ns (NumericNN c a)
= maybe' (NumericNN c) (resolveNumeric ns a)
resolveNumeric ns (NumericNsN c as)
= if elem Nothing as'
then Nothing
else Just (NumericNsN c (maybes2List as'))
where
as' = map (resolveNumeric ns) as
resolveNumeric ns (NumericDist p1 p2)
= maybe2 NumericDist ( resolvePoint ns p1,
resolvePoint ns p2)
resolveNumeric ns (NumericMediate n1 n2 n3)
= maybe3 NumericMediate ( resolveNumeric ns n1,
resolveNumeric ns n2,
resolveNumeric ns n3)
resolveNumeric ns (NumericCond b t e)
= maybe3 NumericCond ( resolveBoolean ns b,
resolveNumeric ns t,
resolveNumeric ns e)
resolveNumeric _ a = Just a
resolvePath :: (Int, Int, Symbols) -> Path -> Maybe (Int, Path)
resolvePath (_, m, _) PathCycle
= Just (m, PathCycle)
resolvePath (n, m, s) (PathPoint p)
= maybe' (\a->(m, PathPoint a)) (resolvePoint (n, s) p)
resolvePath (n, m, s) (PathEndDir p d)
= maybe' (\a->(m, PathEndDir a (resolveDir (n, s) d)))
(resolvePoint (n, s) p)
resolvePath (n, m, s) (PathJoin p1 ped p2)
= case resolvePath (n, m, s) p1 of
Just (_, p1')
-> case resolvePath (n, m, s) p2 of
Just (m2', p2')
-> Just (m2',PathJoin p1'
(resolvePathElemDescr (n, s) ped)
p2')
_ -> Nothing
_ -> Nothing
resolvePath (n, m, s) (PathBuildCycle p1 p2)
= case resolvePath (n, m, s) p1 of
Just (_, p1')
-> case resolvePath (n, m, s) p2 of
Just (m2', p2')
-> Just (m2', PathBuildCycle p1' p2')
_ -> Nothing
_ -> Nothing
resolvePath (n, m, s) (PathDefine eqs p)
= case resolvePath (n, m', s1 & s) p of
Just (m',p')
-> Just (m', PathDefine eqs' p')
_ -> Nothing
where
eqs' = maybes2List (map (resolveEquation (n, s1 & s)) eqs)
(m', s1) = symEquations (n, m, relax) eqs
resolvePath nms (PathTransform t p)
= case resolvePath nms p of
Just (m',p')
-> Just (m', PathTransform t p')
_ -> Nothing
resolvePathElemDescr :: (Int, Symbols) -> PathElemDescr -> PathElemDescr
resolvePathElemDescr ns@(n, s) ped
= ped {peStartCut = getCut (peStartCut ped),
peEndCut = getCut (peEndCut ped),
pePen = resolvePen ns (pePen ped),
peStartDir = resolveDir ns (peStartDir ped),
peEndDir = resolveDir ns (peEndDir ped)}
where
getCut Nothing = Nothing
getCut (Just cut) = resolveCut (n,symPnts s) cut
resolveDir :: (Int, Symbols) -> Dir' -> Dir'
resolveDir ns (DirCurl a) = maybe DirEmpty DirCurl (resolveNumeric ns a)
resolveDir ns (DirDir a) = maybe DirEmpty DirDir (resolveNumeric ns a)
resolveDir ns (DirVector a) = maybe DirEmpty DirVector (resolvePoint ns a)
resolveDir _ a = a
resolveCut :: (Int, SymPoint) -> CutPic -> Maybe CutPic
resolveCut (n,_) (CutPic (NameDir _))
= return (CutPic' (suff n))
resolveCut (n,SymPUnion p1 p2) c
= resolveCut (n, p1) c
`mplus` resolveCut (n, p2) c
resolveCut (n,SymPUnion3 p1 p2 p3 ) c
= resolveCut (n, p1) c
`mplus` resolveCut (n, p2) c
`mplus` resolveCut (n, p3) c
resolveCut (n,SymPHier name' _ ds) (CutPic (Hier name name2))
= if name == name'
then resolveCut (n, ds) (CutPic name2)
else Nothing
resolveCut (_,SymPName name' n _) (CutPic name)
= if name == name'
then return (CutPic' (suff n))
else Nothing
resolveCut (n,SymPTrans d k) c= maybe' (f k) (resolveCut (n, d) c)
where
f k (CutPicTrans p2 ks) = CutPicTrans p2 (k:ks)
f k p = CutPicTrans p [k]
resolveCut _ _ = Nothing
resolveJoin :: (Int, Symbols) -> BasicJoin -> BasicJoin
resolveJoin ns (BJTension a) = maybe BJBounded BJTension (resolveTension ns a)
resolveJoin ns (BJTension2 a b )
= case (resolveTension ns a, resolveTension ns b) of
(Nothing, Nothing) -> BJBounded
(Just a', Nothing) -> BJTension a'
(Nothing, Just a') -> BJTension a'
(Just a', Just b') -> BJTension2 a' b'
resolveJoin ns (BJControls a) = maybe BJBounded BJControls (resolvePoint ns a)
resolveJoin ns (BJControls2 a b)
= case (resolvePoint ns a, resolvePoint ns b) of
(Nothing, Nothing) -> BJBounded
(Just a', Nothing) -> BJControls a'
(Nothing, Just a') -> BJControls a'
(Just a', Just b') -> BJControls2 a' b'
resolveJoin _ a = a
resolveTension :: (Int, Symbols) -> Tension -> Maybe Tension
resolveTension ns (Tension a) = maybe' Tension (resolveNumeric ns a)
resolveTension ns (TensionAtLeast a)
= maybe' TensionAtLeast (resolveNumeric ns a)
resolvePen :: (Int, Symbols) -> Pen -> Pen
resolvePen ns (PenCircle (x, y ) a)
= PenCircle (getDefault (resolveNumeric ns x) 1,
getDefault (resolveNumeric ns y) 1)
(getDefault (resolveNumeric ns a) 0)
resolvePen ns (PenSquare (x, y ) a)
= PenSquare (getDefault (resolveNumeric ns x) 1,
getDefault (resolveNumeric ns y) 1)
(getDefault (resolveNumeric ns a) 0)
resolvePen _ a = a
resolveEquation :: (Int, Symbols) -> Equation -> Maybe Equation
resolveEquation ns (PEquations ps)
= case ps' of
[] -> Nothing
[_] -> Nothing
a -> Just (PEquations a)
where
ps' = maybes2List (map (resolvePoint ns) ps)
resolveEquation ns (NEquations nums)
= case nums'' of
[] -> Nothing
[_] -> Nothing
a -> Just (NEquations a)
where
nums' = map (resolveNumeric ns) nums
nums'' = maybes2List nums'
resolveEquation ns (EquationCond b e1 e2)
= maybe3 EquationCond (resolveBoolean ns b,
resolveEquation ns e1,
resolveEquation ns e2)
resolveEquation ns (Equations es)
= if null es'
then Nothing
else Just (Equations es')
where
es' = maybes2List (map (resolveEquation ns) es)
resolveBoolean :: (Int, Symbols) -> Boolean -> Maybe Boolean
resolveBoolean _ (Boolean a) = Just (Boolean a)
resolveBoolean ns (BoolNum a c b)
= maybe2 (\a b -> BoolNum a c b)
(resolveNumeric ns a, resolveNumeric ns b)
resolveBoolean ns (BoolPnt a c b)
= maybe2 (\a b -> BoolPnt a c b)
(resolvePoint ns a, resolvePoint ns b)
resolveBoolean ns (BoolOr a b)= maybe2 BoolOr (resolveBoolean ns a, resolveBoolean ns b)
resolveBoolean ns (BoolAnd a b )
= maybe2 BoolAnd (resolveBoolean ns a, resolveBoolean ns b)
resolveBoolean ns (BoolNot a) = maybe' BoolNot (resolveBoolean ns a)
symEquations :: (Int, Int, Symbols) -> [Equation] -> (Int, Symbols)
symEquations (_, m, s) [] = (m, s)
symEquations (n, m, s) (eq : eqs)
= symEquations (n, m', s') eqs
where
(m', s') = symEquation (n, m, s) eq
symEquation :: (Int, Int, Symbols) -> Equation -> (Int, Symbols)
symEquation (n, m, s) (PEquations ps)
= symPoints (n, m, s) ps
where
symPoints (_, m, s) [] = (m, s)
symPoints (n, m, s) (p : ps)
= symPoints (n, m', s') ps
where
(m', s') = symPoint (n, m, s) p
symEquation (n, m, s) (NEquations ns)
= symNumerics (n, m, s) ns
where
symNumerics (_, m, s) []
= (m, s)
symNumerics (n, m, s) (num:ns)
= symNumerics (n, m', s') ns
where
(m', s') = symNumeric (n, m, s) num
symEquation (n, m, s) (EquationCond b e1 e2)
= symEquation (n, m'', s'') e2
where
(m', s') = symBoolean (n, m, s) b
(m'', s'') = symEquation (n, m', s') e1
symEquation (n, m, s) (Equations es)
= symEquations (n, m, s) es
symPoint :: (Int, Int, Symbols) -> Point -> (Int, Symbols)
symPoint (_, m, s) (PointVar (Global _))
= (m, s)
symPoint nms (PointVar name)
= insertPntName nms name
symPoint (n, m, s) (PointPPP _ a b)
= symPoint (n, m', s') b
where (m', s') = symPoint (n, m, s) a
symPoint (n, m, s) (PointVec (a, b))
= symNumeric (n, m', s') b
where (m', s') = symNumeric (n, m, s) a
symPoint (n, m, s) (PointMediate a b c)
= symPoint (n, m'', s'') c
where (m', s') = symNumeric (n, m, s) a
(m'', s'') = symPoint (n, m', s') b
symPoint (n, m, s) (PointNMul a b)
= symPoint (n, m', s') b
where (m', s') = symNumeric (n, m, s) a
symPoint nms(PointDirection a)
= symNumeric nms a
symPoint nms (PointNeg a) = symPoint nms a
symPoint (n, m, s) (PointCond b t e)
= symPoint (n, m'', s'') e
where (m', s') = symBoolean (n, m, s) b
(m'', s'') = symPoint (n, m', s') t
symPoint (_, m, s) _ = (m, s)
symNumeric :: (Int,Int,Symbols) -> Numeric -> (Int,Symbols)
symNumeric (_, m, s) (NumericVar (Global _))
= (m, s)
symNumeric (n, m, s) (NumericVar name)
= insertNumeric (n, m, s) name
symNumeric (n, m, s) (NumericNN _ a)
= symNumeric (n, m, s) a
symNumeric (n, m, s) (NumericPN _ a)
= symPoint (n, m, s) a
symNumeric (n, m, s) (NumericNNN _ a b)
= symNumeric (n, m', s') b
where
(m', s') = symNumeric (n, m, s) a
symNumeric (n, m, s) (NumericDist a b)
= symPoint (n, m', s') b
where
(m', s') = symPoint (n, m, s) a
symNumeric (n, m, s) (NumericMediate a b c)
= symNumeric (n, m'', s'') c
where
(m', s') = symNumeric (n, m, s) a
(m'', s'') = symNumeric (n, m', s') b
symNumeric (n, m, s) (NumericNsN _ as)
= symNumerics (n, m, s) as
where
symNumerics (_,m ,s) [] = (m, s)
symNumerics (n,m ,s) (a:as)
= symNumerics (n, m', s') as
where
(m',s') = symNumeric (n, m, s) a
symNumeric (n, m, s) (NumericCond b t e)
= symNumeric (n, m'', s'') e
where
(m', s') = symBoolean (n, m, s) b
(m'', s'') = symNumeric (n, m', s') t
symNumeric (_, m, s) _= (m, s)
symBoolean :: (Int,Int,Symbols) -> Boolean -> (Int,Symbols)
symBoolean (n, m, s) (BoolNum a _ b)
= symNumeric (n, m', s') b
where
(m', s') = symNumeric (n, m, s) a
symBoolean (n, m, s) (BoolPnt a _ b)
= symPoint (n, m', s') b
where
(m', s') = symPoint (n, m, s) a
symBoolean (n, m, s) (BoolOr a b)
= symBoolean (n, m', s') b
where
(m', s') = symBoolean (n, m, s) a
symBoolean (n, m, s) (BoolAnd a b)
= symBoolean (n, m', s') b
where
(m', s') = symBoolean (n, m, s) a
symBoolean (n, m, s) (BoolNot a)
= symBoolean (n, m, s) a
symBoolean (_, m, _) _ = (m, relax)
insertNumeric :: (Int,Int,Symbols) -> Name -> (Int,Symbols)
insertNumeric (n, m, s) name = if resolveNumeric (n,s) (NumericVar name)
== Nothing
then (m+1, addNDef (SymNName name n m) s)
else (m, s)
insertPntName :: (Int,Int,Symbols) -> Name -> (Int,Symbols)
insertPntName (n, m, s) name = if not (lastNameIsDir name)
&& resolvePoint (n,s) (PointVar name) == Nothing
then (m+1, addPDef (SymPName name n m) s)
else (m, s)