never executed always true always false
1 -- All extensions should be enabled explicitly due to doctest in this module.
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE FlexibleContexts #-}
5 {-# LANGUAGE FlexibleInstances #-}
6 {-# LANGUAGE FunctionalDependencies #-}
7 {-# LANGUAGE GADTs #-}
8 {-# LANGUAGE ImportQualifiedPost #-}
9 {-# LANGUAGE NamedFieldPuns #-}
10 {-# LANGUAGE OverloadedStrings #-}
11 {-# LANGUAGE TypeFamilies #-}
12 {-# LANGUAGE UndecidableInstances #-}
13
14 {- |
15 Module : NITTA.Intermediate.Types
16 Description : Types for an algorithm intermediate representation
17 Copyright : (c) Aleksandr Penskoi, 2019
18 License : BSD3
19 Maintainer : aleksandr.penskoi@gmail.com
20 Stability : experimental
21 -}
22 module NITTA.Intermediate.Types (
23 -- * Function interface
24 I (..),
25 O (..),
26 X (..),
27
28 -- * Function description
29 F (..),
30 FView (..),
31 packF,
32 castF,
33 functionType,
34 Function (..),
35 Lock (..),
36 Locks (..),
37 inputsLockOutputs,
38 WithFunctions (..),
39 Label (..),
40
41 -- * Functional simulation
42 FunctionSimulation (..),
43 CycleCntx (..),
44 Cntx (..),
45 log2md,
46 log2json,
47 log2csv,
48 cntxReceivedBySlice,
49 getCntx,
50 updateCntx,
51
52 -- * Patch
53 Patch (..),
54 Changeset (..),
55 reverseDiff,
56 module NITTA.Intermediate.Value,
57 module NITTA.Intermediate.Variable,
58 ) where
59
60 import Data.Aeson
61 import Data.Aeson.Encode.Pretty
62 import Data.Bifunctor
63 import Data.Csv qualified as Csv
64 import Data.Default
65 import Data.HashMap.Strict qualified as HM
66 import Data.List (sort, sortOn, transpose)
67 import Data.Map.Strict qualified as M
68 import Data.Maybe
69 import Data.Set qualified as S hiding (split)
70 import Data.String.ToString
71 import Data.String.Utils qualified as S
72 import Data.Text qualified as T
73 import Data.Tuple
74 import Data.Typeable
75 import GHC.Generics
76 import NITTA.Intermediate.Value
77 import NITTA.Intermediate.Variable
78 import NITTA.UIBackend.ViewHelperCls
79 import NITTA.Utils.Base
80 import Text.PrettyPrint.Boxes hiding ((<>))
81
82 -- | Input variable.
83 newtype I v = I v
84 deriving (Eq, Ord)
85
86 instance ToString v => Show (I v) where show (I v) = toString v
87
88 instance Eq v => Patch (I v) (v, v) where
89 patch (v, v') i@(I v0)
90 | v0 == v = I v'
91 | otherwise = i
92
93 instance Variables (I v) v where
94 variables (I v) = S.singleton v
95
96 -- | Output variable set.
97 newtype O v = O (S.Set v)
98 deriving (Eq, Ord)
99
100 instance Ord v => Patch (O v) (v, v) where
101 patch (v, v') (O vs) = O $ S.fromList $ map (\e -> if e == v then v' else e) $ S.elems vs
102
103 instance ToString v => Show (O v) where
104 show (O vs)
105 | S.null vs = "_"
106 | otherwise = S.join " = " $ vsToStringList vs
107
108 instance Variables (O v) v where
109 variables (O vs) = vs
110
111 -- | Value of variable (constant or initial value).
112 newtype X x = X x
113 deriving (Show, Eq)
114
115 -----------------------------------------------------------
116
117 {- | Casuality of variable processing sequence in term of locks.
118
119 For example:
120 > c := a + b
121 > [ Lock{ locked=c, lockBy=a }, Lock{ locked=c, lockBy=b } ]
122 -}
123 class Var v => Locks x v | x -> v where
124 locks :: x -> [Lock v]
125
126 -- | Variable casuality.
127 data Lock v = Lock
128 { locked :: v
129 , lockBy :: v
130 }
131 deriving (Eq, Ord, Generic)
132
133 instance ToString v => Show (Lock v) where
134 show Lock{locked, lockBy} =
135 "Lock{locked=" <> toString locked <> ", lockBy=" <> toString lockBy <> "}"
136
137 instance ToJSON v => ToJSON (Lock v)
138
139 -- | All input variables locks all output variables.
140 inputsLockOutputs f =
141 [ Lock{locked = y, lockBy = x}
142 | x <- S.elems $ inputs f
143 , y <- S.elems $ outputs f
144 ]
145
146 -----------------------------------------------------------
147
148 -- | Type class for application algorithm functions.
149 class Function f v | f -> v where
150 -- | Get all input variables.
151 inputs :: f -> S.Set v
152 inputs _ = S.empty
153
154 -- | Get all output variables.
155 outputs :: f -> S.Set v
156 outputs _ = S.empty
157
158 -- | Sometimes, one function can cause internal process unit lock for another function.
159
160 -- TODO: remove or move, because its depends from PU type
161 isInternalLockPossible :: f -> Bool
162 isInternalLockPossible _ = False
163
164 -- | Type class for making fine label for Functions.
165 class Label a where
166 label :: a -> String
167
168 instance Label String where
169 label s = s
170
171 instance Label T.Text where
172 label = toString
173
174 -- | Type class of something, which is related to functions.
175 class WithFunctions a f | a -> f where
176 -- | Get a list of associated functions.
177 functions :: a -> [f]
178
179 -- | Box forall functions.
180 data F v x where
181 F ::
182 ( Function f v
183 , Patch f (v, v)
184 , Locks f v
185 , Show f
186 , Label f
187 , FunctionSimulation f v x
188 , Typeable f
189 , Eq f
190 ) =>
191 { fun :: f
192 , funHistory :: [F v x]
193 } ->
194 F v x
195
196 packF f = F{fun = f, funHistory = []}
197
198 functionType :: F v x -> TypeRep
199 functionType F{fun} = typeOf fun
200
201 instance Eq (F v x) where
202 F{fun = a} == F{fun = b}
203 | typeOf a == typeOf b = a == fromJust (cast b)
204 | otherwise = False
205
206 instance Function (F v x) v where
207 isInternalLockPossible F{fun} = isInternalLockPossible fun
208 inputs F{fun} = inputs fun
209 outputs F{fun} = outputs fun
210
211 instance FunctionSimulation (F v x) v x where
212 simulate cntx F{fun} = simulate cntx fun
213
214 instance Label (F v x) where
215 label F{fun} = label fun
216
217 instance Var v => Locks (F v x) v where
218 locks F{fun} = locks fun
219
220 instance Ord (F v x) where
221 F{fun = a} `compare` F{fun = b} = show a `compare` show b
222
223 instance Patch (F v x) (v, v) where
224 patch diff fun0@F{fun, funHistory} =
225 F
226 { fun = patch diff fun
227 , funHistory = fun0 : funHistory
228 }
229
230 instance Ord v => Patch (F v x) (Changeset v) where
231 patch Changeset{changeI, changeO} f0 =
232 let changeI' =
233 mapMaybe
234 ( \v -> case changeI M.!? v of
235 Just v' -> Just (v, v')
236 Nothing -> Nothing
237 )
238 $ S.elems
239 $ inputs f0
240 changeO' =
241 concat
242 $ mapMaybe
243 ( \v -> case changeO M.!? v of
244 Just vs -> Just [(v, v') | v' <- S.elems vs]
245 Nothing -> Nothing
246 )
247 $ S.elems
248 $ outputs f0
249 in foldl (\f diff -> patch diff f) f0 $ changeI' ++ changeO'
250
251 instance Patch b v => Patch [b] v where
252 patch diff fs = map (patch diff) fs
253
254 instance Show (F v x) where
255 show F{fun} = show fun
256
257 instance Var v => Variables (F v x) v where
258 variables F{fun} = inputs fun `S.union` outputs fun
259
260 -- | Helper for extraction function from existential container 'F'.
261 castF :: (Typeable f, Typeable v, Typeable x) => F v x -> Maybe (f v x)
262 castF F{fun} = cast fun
263
264 -- | Helper for JSON serialization
265 data FView = FView
266 { fvFun :: T.Text
267 , fvHistory :: [T.Text]
268 }
269 deriving (Generic, Show)
270
271 instance Viewable (F v x) FView where
272 view F{fun, funHistory} =
273 FView
274 { fvFun = showText fun
275 , fvHistory = map showText funHistory
276 }
277
278 instance ToJSON FView
279
280 -----------------------------------------------------------
281
282 -- | The type class for function simulation.
283 class FunctionSimulation f v x | f -> v x where
284 -- FIXME: CycleCntx - problem, because its prevent Receive simulation with
285 -- data drop (how implement that?).
286
287 -- | Receive a computational context and return changes (list of varible names and its new values).
288 simulate :: CycleCntx v x -> f -> [(v, x)]
289
290 newtype CycleCntx v x = CycleCntx {cycleCntx :: HM.HashMap v x}
291 deriving (Generic)
292
293 instance (ToString v, Show x) => Show (CycleCntx v x) where
294 show CycleCntx{cycleCntx} =
295 "{" <> S.join ", " (map (\(v, x) -> toString v <> ": " <> show x) $ HM.toList cycleCntx) <> "}"
296
297 instance Default (CycleCntx v x) where
298 def = CycleCntx HM.empty
299
300 data Cntx v x = Cntx
301 { cntxProcess :: [CycleCntx v x]
302 -- ^ all variables on each process cycle
303 , cntxReceived :: M.Map v [x]
304 -- ^ sequences of all received values, one value per process cycle
305 , cntxCycleNumber :: Int
306 }
307
308 instance Show x => Show (Cntx String x) where
309 show Cntx{cntxProcess} = log2md $ map (HM.map show . cycleCntx) cntxProcess
310
311 log2list cntxProcess0 =
312 let cntxProcess = map (HM.fromList . map (first toString) . HM.toList) cntxProcess0
313 header = sort $ HM.keys $ head cntxProcess
314 body = map row cntxProcess
315 row cntx = map snd $ zip header $ sortedValues cntx
316 in map (uncurry (:)) $ zip header (transpose body)
317 where
318 sortedValues cntx = map snd $ sortOn fst $ HM.toList cntx
319
320 {- |
321 >>> let records = map HM.fromList [[("x1"::String,"1.2"::String), ("x2","3.4")], [("x1","3.4"), ("x2","2.3")]]
322 >>> putStr $ log2md records
323 | Cycle | x1 | x2 |
324 |:-------|:-----|:-----|
325 | 1 | 1.2 | 3.4 |
326 | 2 | 3.4 | 2.3 |
327 -}
328 log2md records =
329 let n = length records
330 cntx2listCycle = ("Cycle" : map show [1 .. n]) : log2list records
331 maxLength t = length $ foldr1 (\x y -> if length x >= length y then x else y) t
332 formatCell x@(x1 : x2 : xs) = x1 : ("|:" ++ replicate (maxLength x) '-') : x2 : xs
333 formatCell x = error $ "formatCell: unexpected sequence:" <> show x
334 cycleFormattedTable = map (formatCell . map ("| " ++)) cntx2listCycle ++ [replicate (n + 2) "|"]
335 in render
336 ( hsep 0 left $
337 map (vcat left . map text) cycleFormattedTable
338 )
339
340 {- |
341 >>> import qualified Data.ByteString.Lazy.Char8 as BS
342 >>> let records = map HM.fromList [[("x1"::String,"1.2"::String), ("x2","3.4")], [("x1","3.4"), ("x2","2.3")]]
343 >>> BS.putStr $ log2json records
344 [
345 {
346 "x1": 1.2,
347 "x2": 3.4
348 },
349 {
350 "x1": 3.4,
351 "x2": 2.3
352 }
353 ]
354 -}
355 log2json records =
356 let listHashMap = transpose $ map varAndValues $ log2list records
357 in encodePretty $ map HM.fromList listHashMap
358 where
359 varAndValues (k : vs) = map (\v -> (k, read v :: Double)) vs
360 varAndValues x = error $ "varAndValues: unexpected sequence:" <> show x
361
362 {- |
363 >>> import qualified Data.ByteString.Lazy.Char8 as BS
364 >>> let records = map HM.fromList [[("x1"::String,"1.2"::String), ("x2","3.4")], [("x1","3.4"), ("x2","2.3")]]
365 >>> BS.putStr $ log2csv records
366 x1,x2
367 1.2,3.4
368 3.4,2.3
369 -}
370 log2csv records = Csv.encode $ transpose $ log2list records
371
372 instance Default (Cntx v x) where
373 def =
374 Cntx
375 { cntxProcess = def
376 , cntxReceived = def
377 , cntxCycleNumber = 5
378 }
379
380 -- | Make sequence of received values '[ Map v x ]'
381 cntxReceivedBySlice :: Ord v => Cntx v x -> [M.Map v x]
382 cntxReceivedBySlice Cntx{cntxReceived} = cntxReceivedBySlice' $ M.assocs cntxReceived
383
384 cntxReceivedBySlice' received
385 | not $ any (null . snd) received =
386 let slice = M.fromList [(v, x) | (v, x : _) <- received]
387 received' = [(v, xs) | (v, _ : xs) <- received]
388 in slice : cntxReceivedBySlice' received'
389 | otherwise = repeat M.empty
390
391 getCntx (CycleCntx cntx) v = case HM.lookup v cntx of
392 Just x -> x
393 Nothing -> error $ "variable not defined: " <> toString v
394
395 updateCntx cycleCntx [] = Right cycleCntx
396 updateCntx (CycleCntx cntx) ((v, x) : vxs)
397 | HM.member v cntx = Left $ "variable value already defined: " <> toString v
398 | otherwise = updateCntx (CycleCntx $ HM.insert v x cntx) vxs
399
400 -----------------------------------------------------------
401
402 -- | Patch class allows replacing one variable by another. Especially for algorithm refactor.
403 class Patch f diff where
404 patch :: diff -> f -> f
405
406 {- | Change set for patch.
407
408 >>> Changeset (M.fromList [("a", "b"), ("c", "d")]) (M.fromList [("e", S.fromList ["f", "g"])]) :: Changeset String
409 Changeset{changeI=[(a, b), (c, d)], changeO=[(e, [f, g])]}
410 -}
411 data Changeset v = Changeset
412 { changeI :: M.Map v v
413 -- ^ change set for input variables (one to one)
414 , changeO :: M.Map v (S.Set v)
415 -- ^ change set for output variables. Many to many relations:
416 --
417 -- > fromList [(a, {x}), (b, {x})] -- several output variables to one
418 -- > fromList [(c, {y, z})] -- one output variable to many
419 }
420 deriving (Eq)
421
422 instance Var v => Show (Changeset v) where
423 show Changeset{changeI, changeO} =
424 let changeI' = S.join ", " $ map (\(a, b) -> "(" <> toString a <> ", " <> toString b <> ")") $ M.assocs changeI
425 changeO' = S.join ", " $ map (\(a, bs) -> "(" <> toString a <> ", [" <> S.join ", " (vsToStringList bs) <> "])") $ M.assocs changeO
426 in "Changeset{changeI=[" <> changeI' <> "], changeO=[" <> changeO' <> "]}"
427
428 instance Default (Changeset v) where
429 def = Changeset def def
430
431 -- | Reverse changeset for patch a process unit options / decision.
432 reverseDiff Changeset{changeI, changeO} =
433 Changeset
434 { changeI = M.fromList $ map swap $ M.assocs changeI
435 , changeO =
436 foldl
437 ( \st (k, v) ->
438 let box' = case st M.!? k of
439 Just box -> box `S.union` S.singleton v
440 Nothing -> S.singleton v
441 in M.insert k box' st
442 )
443 def
444 [ (b, a)
445 | (a, bs) <- M.assocs changeO
446 , b <- S.elems bs
447 ]
448 }