Skip to content

Commit 88dfa1f

Browse files
dmjiodmjio
committed
Try IntMap
1 parent 88bf965 commit 88dfa1f

File tree

1 file changed

+91
-74
lines changed

1 file changed

+91
-74
lines changed

‎frameworks/keyed/miso/src/Main.hs

Lines changed: 91 additions & 74 deletions
Original file line numberDiff line numberDiff line change
@@ -1,31 +1,38 @@
1-
{-# LANGUAGE ScopedTypeVariables #-}
2-
{-# LANGUAGE BangPatterns #-}
1+
{-# LANGUAGE RecordWildCards #-}
2+
{-# LANGUAGE ScopedTypeVariables #-}
3+
{-# LANGUAGE BangPatterns #-}
34
{-# LANGUAGE OverloadedStrings #-}
4-
{-# LANGUAGE ExtendedDefaultRules #-}
5+
{-# LANGUAGE ExtendedDefaultRules #-}
56

67
module Main where
78

8-
import Data.Monoid ((<>))
9+
import Data.Monoid ((<>))
10+
11+
import Control.Arrow
12+
import Data.IntMap.Strict (IntMap)
13+
import qualified Data.IntMap.Strict as IM
14+
import qualified Data.Map as M
15+
import qualified Data.Vector as V
916

10-
import qualified Data.Map as M
11-
import qualified Data.Vector as V
12-
import qualified Data.Vector.Mutable as MV
1317
import Miso
14-
import Miso.String (MisoString)
15-
import qualified Miso.String as S
18+
import Miso.String (MisoString)
19+
import qualified Miso.String as S
1620
import System.Random
1721

1822
data Row = Row
19-
{ rowIdx :: !Int
23+
{ rowIdx :: !Int
2024
, rowTitle :: !MisoString
2125
} deriving (Eq)
2226

2327
data Model = Model
24-
{ rows :: !(V.Vector Row)
28+
{ rows :: !(IM.IntMap Row)
2529
, selectedId :: !(Maybe Int)
26-
, lastId :: !Int
30+
, lastId :: !Int
31+
, seed :: !StdGen
2732
} deriving (Eq)
2833

34+
instance Eq StdGen where _ == _ = True
35+
2936
data Action = Create !Int
3037
| Append !Int
3138
| Update !Int
@@ -95,84 +102,94 @@ nouns = V.fromList [ "table"
95102
]
96103

97104
main :: IO ()
98-
main = startApp App
99-
{ initialAction = NoOp
100-
, model = initialModel
101-
, update = updateModel
102-
, view = viewModel
103-
, events = M.singleton "click" True
104-
, subs = []
105-
, mountPoint = Nothing
106-
}
105+
main = do
106+
seed <- newStdGen
107+
startApp App
108+
{ initialAction = NoOp
109+
, model = initialModel seed
110+
, update = updateModel
111+
, view = viewModel
112+
, events = M.singleton "click" True
113+
, subs = []
114+
, mountPoint = Nothing
115+
}
107116

108-
initialModel :: Model
109-
initialModel = Model
110-
{ rows = V.empty
117+
initialModel :: StdGen -> Model
118+
initialModel seed = Model
119+
{ rows = mempty
111120
, selectedId = Nothing
112121
, lastId = 1
122+
, seed = seed
113123
}
114124

115-
updateModel :: Action -> Model -> Effect Action Model
125+
createRows :: Int -> Int -> StdGen -> (StdGen, IntMap Row)
126+
createRows n lastIdx seed = go seed mempty [0..n]
127+
where
128+
go seed intMap [] = (seed, intMap)
129+
go s0 intMap (x:xs) = do
130+
let (adjIdx, s1) = randomR (0, V.length adjectives - 1) s0
131+
(colorIdx, s2) = randomR (0, V.length colours - 1) s1
132+
(nounIdx, s3) = randomR (0, V.length nouns - 1) s2
133+
title = S.intercalate " "
134+
[ adjectives V.! adjIdx
135+
, colours V.! colorIdx
136+
, nouns V.! nounIdx
137+
]
138+
go s3 (IM.insert x (Row x title) intMap) xs
116139

140+
updateModel :: Action -> Model -> Effect Action Model
117141
updateModel (ChangeModel newModel) _ = noEff newModel
142+
updateModel (Create n) model@Model{..} = noEff $
143+
let
144+
(newSeed, intMap) = createRows 0 lastId seed
145+
in
146+
model { lastId = lastId + n
147+
, rows = intMap
148+
, seed = newSeed
149+
}
118150

119-
updateModel (Create n) model@Model{lastId=lastIdx} =
120-
model <# do
121-
newRows <- generateRows n lastIdx
122-
pure $ ChangeModel model { rows = newRows
123-
, lastId = lastIdx + n
124-
}
125-
126-
updateModel (Append n) model@Model{rows=existingRows, lastId=lastIdx} =
127-
model <# do
128-
newRows <- generateRows n (lastId model)
129-
pure $ ChangeModel model { rows=existingRows V.++ newRows
130-
, lastId=lastIdx + n
131-
}
151+
updateModel (Append n) model@Model{..} = noEff $ do
152+
let
153+
(newSeed, newRows) = createRows n lastId seed
154+
in
155+
model { lastId = lastId + n
156+
, rows = rows <> newRows
157+
, seed = newSeed
158+
}
132159

133-
updateModel Clear model = noEff model{ rows= V.empty }
160+
updateModel Clear model = noEff model { rows = mempty, lastId = 0 }
134161

135-
updateModel (Update n) model =
136-
noEff model{ rows = updatedRows }
137-
where
138-
updatedRows = V.imap updateR (rows model)
139-
updateR i row = if mod i 10 == 0
140-
then row{ rowTitle = rowTitle row <> " !!!" }
141-
else row
162+
updateModel (Update n) model@Model{..} = noEff $
163+
let
164+
newRows =
165+
flip IM.mapWithKey rows $ \key x ->
166+
if key `mod` 10 == 0
167+
then x { rowTitle = rowTitle x <> " !!!" }
168+
else x
169+
in
170+
model { rows = newRows }
142171

143-
updateModel Swap model =
144-
noEff newModel
172+
updateModel Swap model = noEff newModel
145173
where
146-
currentRows = rows model
147-
from = V.indexed
148-
newModel = if V.length currentRows > 998
149-
then model { rows = swappedRows }
150-
else model
151-
swappedRows = V.modify (\v -> MV.swap v 1 998) currentRows
174+
len = IM.size (rows model)
175+
newModel =
176+
if len > 998
177+
then model { rows = swappedRows }
178+
else model
179+
swappedRows =
180+
let
181+
oneValue = rows model IM.! 1
182+
nineNineEightValue = rows model IM.! 998
183+
in
184+
IM.insert 1 nineNineEightValue (IM.insert 998 oneValue (rows model))
152185

153-
updateModel (Select idx) model = noEff model{selectedId=Just idx}
186+
updateModel (Select idx) model = noEff model { selectedId = Just idx }
154187

155-
updateModel (Remove idx) model@Model{rows=currentRows} =
156-
noEff model { rows = firstPart V.++ V.drop 1 remainingPart }
157-
where
158-
(firstPart, remainingPart) = V.splitAt idx currentRows
188+
updateModel (Remove idx) model@Model{ rows = currentRows } =
189+
noEff model { rows = IM.delete idx currentRows }
159190

160191
updateModel NoOp model = noEff model
161192

162-
generateRows :: Int -> Int -> IO (V.Vector Row)
163-
generateRows n lastIdx = V.generateM n $ \x -> do
164-
adjIdx <- randomRIO (0, V.length adjectives - 1)
165-
colorIdx <- randomRIO (0, V.length colours - 1)
166-
nounIdx <- randomRIO (0, V.length nouns - 1)
167-
pure Row
168-
{ rowIdx=lastIdx + x
169-
, rowTitle= (adjectives V.! adjIdx)
170-
<> S.pack " "
171-
<> (colours V.! colorIdx)
172-
<> S.pack " "
173-
<> (nouns V.! nounIdx)
174-
}
175-
176193
viewModel :: Model -> View Action
177194
viewModel m = div_ [id_ "main"]
178195
[ div_
@@ -190,7 +207,7 @@ viewTable m@Model{selectedId=idx} =
190207
[
191208
tbody_
192209
[id_ "tbody"]
193-
(V.toList $ V.imap viewRow (rows m))
210+
(IM.elems $ IM.mapWithKey viewRow (rows m))
194211
]
195212
where
196213
viewRow i r@Row{rowIdx=rId} =

0 commit comments

Comments
 (0)