never executed always true always false
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE PartialTypeSignatures #-}
4 {-# LANGUAGE NoMonomorphismRestriction #-}
5
6 {- |
7 Module : NITTA.Frontends.XMILE.Frontend
8 Description : XMILE frontend prototype
9 Copyright : (c) Artur Gogiyan, 2022
10 License : BSD3
11 Maintainer : artur.gogiyan@gmail.com
12 Stability : experimental
13 -}
14 module NITTA.Frontends.XMILE.Frontend (
15 translateXMILE,
16 FrontendResult (..),
17 TraceVar (..),
18 ) where
19
20 import Control.Monad.State
21 import Data.HashMap.Strict qualified as HM
22 import Data.List qualified as L
23 import Data.Maybe (fromMaybe)
24 import Data.String
25 import Data.Text qualified as T
26 import NITTA.Frontends.Common
27 import NITTA.Frontends.XMILE.DocumentParser as XMILE
28 import NITTA.Frontends.XMILE.MathParser
29 import NITTA.Intermediate.DataFlow
30 import NITTA.Intermediate.Functions qualified as F
31 import NITTA.Utils.Base
32
33 data XMILEAlgBuilder v x = XMILEAlgBuilder
34 { algDataFlowGraph :: DataFlowGraph v x
35 , algTraceVars :: [TraceVar]
36 , algUsagesCount :: HM.HashMap T.Text Int
37 , algDefaultValues :: HM.HashMap T.Text Double
38 , algNextFreeNameIndex :: HM.HashMap T.Text Int
39 , algNextArgIndex :: Int
40 }
41 deriving (Show)
42
43 deltaTimeVarName = T.pack "time_delta"
44
45 translateXMILE src =
46 let xmContent = XMILE.parseDocument $ T.unpack src
47 builder = processXMILEGraph xmContent
48 frTrace = algTraceVars' builder
49 in FrontendResult{frDataFlow = algDataFlowGraph builder, frTrace, frPrettyLog = prettyLog frTrace}
50 where
51 algTraceVars' :: XMILEAlgBuilder T.Text Int -> [TraceVar]
52 algTraceVars' = algTraceVars
53
54 processXMILEGraph xmContent = flip execState emptyBuilder $ do
55 getDefaultValuesAndUsages xmContent
56 createDataFlowGraph xmContent
57 where
58 emptyBuilder =
59 XMILEAlgBuilder
60 { algDataFlowGraph = DFCluster []
61 , algTraceVars = []
62 , algNextFreeNameIndex = HM.empty
63 , algDefaultValues = HM.empty
64 , algUsagesCount = HM.empty
65 , algNextArgIndex = 0
66 }
67
68 createDataFlowGraph xmContent = do
69 modify
70 ( \st@XMILEAlgBuilder{algUsagesCount} ->
71 st{algNextFreeNameIndex = foldl (\hm key -> HM.insert key 0 hm) HM.empty $ HM.keys algUsagesCount}
72 )
73 mapM_ processStock $ xcStocks xmContent
74 mapM_ processAux $ xcAuxs xmContent
75 mapM_ processFlow $ xcFlows xmContent
76 addTimeIncrement
77 where
78 addTimeIncrement = do
79 modify
80 ( \st@XMILEAlgBuilder{algUsagesCount} ->
81 st
82 { algUsagesCount =
83 HM.insert
84 deltaTimeVarName
85 ((algUsagesCount HM.! deltaTimeVarName) + 1)
86 algUsagesCount
87 }
88 )
89 dtUniqueName <- getUniqueName deltaTimeVarName
90 dtAllGraphNodes <- getAllOutGraphNodes deltaTimeVarName
91 XMILEAlgBuilder{algDataFlowGraph} <- get
92 let dt = xssDt $ xcSimSpecs xmContent
93 startTime = xssStart $ xcSimSpecs xmContent
94 graph =
95 L.foldl'
96 (flip addFuncToDataFlowGraph)
97 algDataFlowGraph
98 [ F.constant (read $ show dt) (map fromText dtAllGraphNodes)
99 , F.loop (read $ show startTime) (fromString "time_inc") [fromString "time"]
100 , F.add (fromString "time") (fromText dtUniqueName) [fromString "time_inc"]
101 ]
102 modify
103 ( \st@XMILEAlgBuilder{algTraceVars} ->
104 st
105 { algDataFlowGraph = graph
106 , algTraceVars = TraceVar{tvFmt = Nothing, tvVar = "time"} : algTraceVars
107 }
108 )
109
110 processStock XMILE.Stock{xsName, xsOutflow, xsInflow} = do
111 outputs <- getAllOutGraphNodes xsName
112 case (xsOutflow, xsInflow) of
113 (Nothing, Nothing) -> do
114 input <- getUniqueName xsName
115 addStockLoop input outputs
116 (Nothing, Just inflow) -> do
117 stockUniqueName <- getUniqueName xsName
118 tmpName <- processStockFlow inflow F.add (fromString "In") stockUniqueName
119 addStockLoop tmpName outputs
120 (Just outflow, Nothing) -> do
121 stockUniqueName <- getUniqueName xsName
122 tmpName <- processStockFlow outflow F.sub (fromString "Out") stockUniqueName
123 addStockLoop tmpName outputs
124 (Just outflow, Just inflow) -> do
125 stockUniqueName <- getUniqueName xsName
126 tmpNameOut <- processStockFlow outflow F.sub (fromString "Out") stockUniqueName
127 tmpNameIn <- processStockFlow inflow F.add (fromString "In") tmpNameOut
128 addStockLoop tmpNameIn outputs
129 where
130 processStockFlow flowName func ending stockName = do
131 let tmpName = xsName <> "_" <> ending
132 dt = xssDt $ xcSimSpecs xmContent
133 flowUniqueName <- skaleToDeltaTime dt
134 modify
135 ( \st@XMILEAlgBuilder{algDataFlowGraph} ->
136 st
137 { algDataFlowGraph =
138 addFuncToDataFlowGraph
139 (func (fromText stockName) (fromText flowUniqueName) [fromText tmpName])
140 algDataFlowGraph
141 }
142 )
143 return tmpName
144 where
145 skaleToDeltaTime 1 = getUniqueName flowName
146 skaleToDeltaTime _ = do
147 flowUniqueName <- getUniqueName flowName
148 dtUniqueName <- getUniqueName deltaTimeVarName
149 let skaledFlowName = stockName <> "_" <> flowName <> "_" <> ending
150 modify
151 ( \st@XMILEAlgBuilder{algDataFlowGraph} ->
152 st
153 { algDataFlowGraph =
154 addFuncToDataFlowGraph
155 (F.multiply (fromText dtUniqueName) (fromText flowUniqueName) [fromText skaledFlowName])
156 algDataFlowGraph
157 }
158 )
159 return skaledFlowName
160
161 addStockLoop stockName outputs = do
162 let traceVarName = TraceVar{tvFmt = Nothing, tvVar = T.takeWhile (/= '#') $ head outputs}
163 defaultValue <- getDefaultValue xsName
164 modify
165 ( \st@XMILEAlgBuilder{algDataFlowGraph, algTraceVars} ->
166 st
167 { algDataFlowGraph =
168 addFuncToDataFlowGraph
169 (F.loop (read $ show defaultValue) (fromText stockName) (map fromText outputs))
170 algDataFlowGraph
171 , algTraceVars = traceVarName : algTraceVars
172 }
173 )
174
175 processAux XMILE.Aux{xaName, xaEquation} =
176 case xaEquation of
177 (Val value) -> do
178 outputs <- getAllOutGraphNodes xaName
179 modify
180 ( \st@XMILEAlgBuilder{algDataFlowGraph} ->
181 st
182 { algDataFlowGraph =
183 addFuncToDataFlowGraph
184 (F.constant (read $ show value) (map fromText outputs))
185 algDataFlowGraph
186 }
187 )
188 expr -> error $ "non supported equation part: " <> show expr
189
190 processFlow XMILE.Flow{xfName, xfEquation} =
191 void (processFlowEquation xfEquation (0 :: Int) True)
192 where
193 processFlowEquation (Var name) index _ = do
194 n <- getUniqueName $ T.pack name
195 return (n, index)
196 processFlowEquation (Duo op leftExpr rightExpr) tempNameIndex isTopLevel = do
197 (leftNameText, tempNameIndex') <- processFlowEquation leftExpr tempNameIndex False
198 (rightNameText, tempNameIndex'') <- processFlowEquation rightExpr tempNameIndex' False
199 tmpNameText <- getTempName tempNameIndex'' xfName isTopLevel
200 let leftName = fromText leftNameText
201 rightName = fromText rightNameText
202 tmpName = map fromText tmpNameText
203
204 st@XMILEAlgBuilder{algDataFlowGraph = graph} <- get
205 case op of
206 Add -> put st{algDataFlowGraph = addFuncToDataFlowGraph (F.add leftName rightName tmpName) graph}
207 Sub -> put st{algDataFlowGraph = addFuncToDataFlowGraph (F.sub leftName rightName tmpName) graph}
208 Mul -> put st{algDataFlowGraph = addFuncToDataFlowGraph (F.multiply leftName rightName tmpName) graph}
209 Div -> put st{algDataFlowGraph = addFuncToDataFlowGraph (F.division leftName rightName tmpName []) graph}
210 return (head tmpName, tempNameIndex'' + 1)
211 where
212 getTempName _ name True = getAllOutGraphNodes name
213 getTempName index name _ = return [T.pack "_" <> showText index <> T.pack "#" <> name]
214 processFlowEquation _ _ _ = undefined
215
216 getUniqueName name = do
217 XMILEAlgBuilder{algNextFreeNameIndex} <- get
218 let index = fromMaybe (error $ "name not found : " <> T.unpack name) $ HM.lookup name algNextFreeNameIndex
219 modify (\st -> st{algNextFreeNameIndex = HM.insert name (index + 1) algNextFreeNameIndex})
220 return $ getGraphName name index
221
222 getAllOutGraphNodes name = do
223 XMILEAlgBuilder{algUsagesCount} <- get
224 let usages = fromMaybe (error $ "name not found : " <> T.unpack name) $ HM.lookup name algUsagesCount
225 return $ map (\num -> getGraphName name num) [0 .. usages]
226
227 getDefaultValue name = do
228 XMILEAlgBuilder{algDefaultValues} <- get
229 return $ fromMaybe (error $ "name not found :" <> T.unpack name) $ HM.lookup name algDefaultValues
230
231 getGraphName name index = name <> fromString ("#" <> show index)
232
233 getDefaultValuesAndUsages algBuilder =
234 mapM_ processStock $ xcStocks algBuilder
235 where
236 nameToEquationMap = flip execState HM.empty $ do
237 mapM_ (addToMap . (\a -> (xaName a, xaEquation a))) (xcAuxs algBuilder)
238 mapM_ (addToMap . (\a -> (xfName a, xfEquation a))) (xcFlows algBuilder)
239 mapM_ (addToMap . (\a -> (xsName a, xsEquation a))) (xcStocks algBuilder)
240 where
241 addToMap (name, eqn) = modify (\st -> HM.insert name eqn st)
242 processStock XMILE.Stock{xsEquation, xsName, xsInflow, xsOutflow} = do
243 XMILEAlgBuilder{algDefaultValues} <- get
244 let val = calculateDefaultValue algDefaultValues xsEquation
245 modify (\st -> st{algDefaultValues = HM.insert xsName val algDefaultValues})
246 processFlow xsInflow
247 processFlow xsOutflow
248 where
249 processFlow Nothing = return ()
250 processFlow (Just name) = do
251 addUsages name
252 addUsages xsName
253 addDtUsagesIfNeeded $ xssDt $ xcSimSpecs algBuilder
254 processEquation $ xfEquation $ findFlow name
255 where
256 addDtUsagesIfNeeded 1 = return ()
257 addDtUsagesIfNeeded _ = addUsages deltaTimeVarName
258
259 findFlow name =
260 fromMaybe
261 (error $ "cannot find expected flow flow with name " <> T.unpack name <> show (xcFlows algBuilder))
262 (L.find (\XMILE.Flow{xfName} -> xfName == name) $ xcFlows algBuilder)
263
264 processEquation (Val _) = return ()
265 processEquation (Duo _ expr expl) = do
266 processEquation expr
267 processEquation expl
268 processEquation (Var name) = do
269 addUsages $ T.pack name
270 addDefaultValueIfNeeded name nameToEquationMap
271
272 addUsages name = do
273 XMILEAlgBuilder{algUsagesCount} <- get
274 let val = maybe 0 (+ 1) $ HM.lookup name algUsagesCount
275 modify (\st -> st{algUsagesCount = HM.insert name val algUsagesCount})
276
277 addDefaultValueIfNeeded name nameToEquationMap = do
278 XMILEAlgBuilder{algDefaultValues} <- get
279 case HM.lookup (T.pack name) algDefaultValues of
280 Just _ -> return ()
281 Nothing ->
282 case HM.lookup (T.pack name) nameToEquationMap of
283 Just val ->
284 modify
285 ( \st ->
286 st
287 { algDefaultValues =
288 HM.insert
289 (T.pack name)
290 (calculateDefaultValue algDefaultValues val)
291 algDefaultValues
292 }
293 )
294 Nothing -> error $ "equation for name " <> name <> " not found."