added NaiveTokenModel

Author: hellwolf

packages/spec-haskell/pkgs/semantic-money/semantic-money.cabal

@@ -29,6 +29,7 @@ library
     -- other-extensions:
     build-depends:
         base >=4.16.0.0 && <5,
+        containers >= 0.8,
         data-default
 
 test-suite semantic-money-test-suite

packages/spec-haskell/pkgs/semantic-money/src/Money/Theory/MonetaryTypes.hs

@@ -8,7 +8,7 @@ module Money.Theory.MonetaryTypes
       , mt_v_mul_u, mt_v_div_u, mt_v_mul_u_qr_u
       , mt_fr_mul_u, mt_fr_div_u, mt_fr_mul_u_qr_u
       )
-    , MonetaryTypes'tv, MonetaryTypes'tvr, MonetaryTypes'tvru
+    , MonetaryTypes'tv, MonetaryTypes'tr, MonetaryTypes'tvr, MonetaryTypes'tvru
     ) where
 -- base
 import           Data.Kind (Type)
@@ -73,5 +73,6 @@ class ( Eq (MT_TIME mt), Ord (MT_TIME mt), Num (MT_TIME mt)
     type family MT_UNIT  mt = (u :: Type) | u -> mt
 
 type MonetaryTypes'tv mt t v = (MonetaryTypes mt, t ~ MT_TIME mt, v ~ MT_VALUE mt)
-type MonetaryTypes'tvr mt t v fr = (MonetaryTypes'tv mt t v, fr ~ MT_FLOWRATE mt)
+type MonetaryTypes'tr mt t fr = (MonetaryTypes mt, t ~ MT_TIME mt, fr ~ MT_FLOWRATE mt)
+type MonetaryTypes'tvr mt t v fr = (MonetaryTypes'tv mt t v, MonetaryTypes'tr mt t fr)
 type MonetaryTypes'tvru mt t v fr u = (MonetaryTypes'tvr mt t v fr, u ~ MT_UNIT mt)

packages/spec-haskell/pkgs/semantic-money/src/Money/Theory/SemanticMoney.hs

@@ -3,7 +3,7 @@ module Money.Theory.SemanticMoney
     ( -- * Semantic Money Classes & Primitives
         MonetaryUnit (settle, settledAt, flowRate, rtb)
     , IndexedValue (shift1, flow1)
-    , shift2b, flow2a, flow2b, align2a, align2b
+    , shift2a, shift2b, flow2a, flow2b, align2a, align2b
       -- * Semantic Money Instances
     , BasicParticle (..)
     , PDP_Index (..), PDP_Member (..), PDP_MemberMU, pdp_UpdateMember2

packages/spec-haskell/pkgs/semantic-money/src/Money/Theory/TokenModel.hs

@@ -1,4 +1,7 @@
+{-# LANGUAGE LambdaCase #-}
 module Money.Theory.TokenModel where
+-- containers
+import qualified Data.IntMap                as IntMap
 --
 import           Money.Theory.SemanticMoney
 
@@ -7,8 +10,46 @@ data TokenEvent mt acc where
     TransferEvent :: forall mt acc {t} {v}.
         MonetaryTypes'tv mt t v =>
         t -> acc -> acc -> v -> TokenEvent mt acc
-    -- UpdateFlowEvent :: forall mt acc {t} {v} {u}.
-    --     MonetaryTypes'tvu mt t v u =>
-    --     t -> acc -> acc -> v -> TokenEvent mt acc
+    UpdateFlowEvent :: forall mt acc {t} {fr}.
+        MonetaryTypes'tr mt t fr =>
+        t -> acc -> acc -> fr -> TokenEvent mt acc
 
-data TokenModel mt acc
+type Account = Int
+
+------------------------------------------------------------------------------------------------------------------------
+-- NaiveTokenModel
+------------------------------------------------------------------------------------------------------------------------
+
+data NaiveTokenModel mt acc = MkNaiveTokenModel
+    { accounts :: IntMap.IntMap (BasicParticle mt) -- ^ accounts indexed by Int
+    , pools    :: IntMap.IntMap (PDP_Index mt (BasicParticle mt)) -- ^ pools indexed by Int
+    }
+
+naiveProcessOneEvent ::
+    MonetaryTypes mt =>
+    NaiveTokenModel mt Account ->
+    TokenEvent mt Account ->
+    NaiveTokenModel mt Account
+naiveProcessOneEvent (MkNaiveTokenModel accs pools) = \case
+    TransferEvent t from to amount -> go2 from to (shift2a amount t)
+    UpdateFlowEvent t from to rate -> go2 from to (flow2a rate t)
+    where go2 from to op =
+              let sender = IntMap.findWithDefault mempty from accs
+                  receiver = IntMap.findWithDefault mempty from accs
+                  (sender', receiver') = op (sender, receiver)
+                  accs' = IntMap.insert from sender'
+                          $ IntMap.insert to receiver'
+                          $ accs
+              in MkNaiveTokenModel accs' pools
+
+naiveProcessEvents ::
+    MonetaryTypes mt =>
+    [TokenEvent mt Account] ->
+    NaiveTokenModel mt Account
+naiveProcessEvents = foldl' naiveProcessOneEvent (MkNaiveTokenModel IntMap.empty IntMap.empty)
+
+naiveSystemSnapshot ::
+    MonetaryTypes'tv mt t v =>
+    NaiveTokenModel mt Account ->
+    IntMap.IntMap (t -> v)
+naiveSystemSnapshot = (rtb <$>) . accounts