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