Skip to content

Commit eaec85e

Browse files
author
Julien Dehos
committed
misokoban wip
1 parent c1a7562 commit eaec85e

File tree

5 files changed

+93
-41
lines changed

5 files changed

+93
-41
lines changed

‎app.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,7 @@ executable app
3535
base,
3636
containers,
3737
jsaddle,
38+
lens,
3839
miso,
3940
vector
4041

‎src/Component.hs‎

Lines changed: 40 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@
44
module Component (mkComponent) where
55

66
import Data.IntSet qualified as IS
7-
import Language.Javascript.JSaddle (JSM, liftJSM, FromJSVal(..), ToJSVal(..))
7+
import Language.Javascript.JSaddle (liftJSM, FromJSVal(..), ToJSVal(..))
88
import Miso
99
import Miso.Canvas as Canvas
1010
import Miso.Lens
@@ -14,7 +14,7 @@ import Miso.Html.Property as P
1414
import Miso.CSS as CSS
1515

1616
import Model
17-
import World
17+
import Game
1818

1919
-------------------------------------------------------------------------------
2020
-- params
@@ -44,25 +44,29 @@ updateModel ActionSayHelloWorld =
4444

4545
updateModel (ActionKey keys)
4646
| IS.member 37 keys = do
47-
modelPos %= over _1 (subtract 1)
48-
io_ $ consoleLog "left"
47+
modelGame %= playMove MoveUp
48+
modelNbMoves += 1
4949
| IS.member 38 keys = do
50-
modelPos %= over _2 (subtract 1)
51-
io_ $ consoleLog "up"
50+
modelGame %= playMove MoveLeft
51+
modelNbMoves += 1
5252
| IS.member 39 keys = do
53-
modelPos %= over _1 (+1)
54-
io_ $ consoleLog "right"
53+
modelGame %= playMove MoveDown
54+
modelNbMoves += 1
5555
| IS.member 40 keys = do
56-
modelPos %= over _2 (+1)
57-
io_ $ consoleLog "down"
56+
modelGame %= playMove MoveRight
57+
modelNbMoves += 1
5858
| otherwise = pure ()
5959

6060
-------------------------------------------------------------------------------
6161
-- resources
6262
-------------------------------------------------------------------------------
6363

6464
data Resources = Resources
65-
{ _resEmpty :: Image
65+
{ _resBox1 :: Image
66+
, _resBox2 :: Image
67+
, _resEmpty :: Image
68+
, _resPlayer :: Image
69+
, _resTarget :: Image
6670
, _resWall :: Image
6771
}
6872

@@ -71,16 +75,13 @@ instance ToJSVal Resources where
7175

7276
instance FromJSVal Resources where
7377
fromJSVal v = do
74-
[empty', wall'] <- fromJSValUnchecked v
75-
pure $ Just $ Resources empty' wall'
78+
[b1, b2, e, p, t, w] <- fromJSValUnchecked v
79+
pure $ Just $ Resources b1 b2 e p t w
7680

7781
-------------------------------------------------------------------------------
7882
-- view
7983
-------------------------------------------------------------------------------
8084

81-
assetSizeD :: Double
82-
assetSizeD = fromIntegral assetSize
83-
8485
viewModel :: Model -> View Model Action
8586
viewModel m =
8687
div_ []
@@ -95,26 +96,40 @@ viewModel m =
9596

9697
initCanvas :: DOMRef -> Canvas Resources
9798
initCanvas _ = liftJSM $
98-
Resources <$> newImage (assetsUrl <> "empty.png")
99+
Resources <$> newImage (assetsUrl <> "box1.png")
100+
<*> newImage (assetsUrl <> "box2.png")
101+
<*> newImage (assetsUrl <> "empty.png")
102+
<*> newImage (assetsUrl <> "player.png")
103+
<*> newImage (assetsUrl <> "target.png")
99104
<*> newImage (assetsUrl <> "wall.png")
100105

101106
drawCanvas :: Model -> Resources -> Canvas ()
102107
drawCanvas Model{..} Resources{..} = do
103108
globalCompositeOperation DestinationOver
104109
clearRect (0, 0, 300, 300)
105-
let (i, j) = _modelPos
106-
drawImage (_resWall, fromIntegral (assetSize*i), fromIntegral (assetSize*j))
107-
fillStyle (Canvas.color CSS.red)
108-
fillRect (0, 0, 300, 300)
110+
111+
forGame _modelGame $ \ij c -> do
112+
let (x, y) = ij2xy ij
113+
case c of
114+
CellT -> drawImage (_resTarget, x, y)
115+
CellW -> drawImage (_resWall, x, y)
116+
_ -> drawImage (_resEmpty, x, y)
117+
118+
let (xp, yp) = _modelGame & _gameCurrentPos & ij2xy
119+
drawImage (_resPlayer, xp, yp)
120+
121+
ij2xy :: (Int, Int) -> (Double, Double)
122+
ij2xy (i, j) = (fromIntegral (assetSize*j), fromIntegral (assetSize*i))
109123

110124
-------------------------------------------------------------------------------
111125
-- component
112126
-------------------------------------------------------------------------------
113127

114128
mkComponent :: App Model Action
115129
mkComponent =
116-
(component mkModel updateModel viewModel)
117-
{ subs = [ keyboardSub ActionKey ]
118-
, logLevel = DebugAll
119-
}
130+
let initialMode = mkModel 1
131+
in (component initialMode updateModel viewModel)
132+
{ subs = [ keyboardSub ActionKey ]
133+
, logLevel = DebugAll
134+
}
120135

‎src/Game.hs‎

Lines changed: 46 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,59 @@
11

2-
module Game where
2+
module Game
3+
( World.assetSize
4+
, World.Cell(..)
5+
, Move(..)
6+
, Game(..)
7+
, mkGame
8+
, playMove
9+
, forGame
10+
) where
311

4-
import Miso.Lens
5-
import Miso.Lens.TH
12+
import Control.Lens
13+
import Data.Set qualified as S
14+
import Data.Vector qualified as V
615

16+
import GeneratedWorlds
717
import World
818

19+
data Move
20+
= MoveUp
21+
| MoveDown
22+
| MoveLeft
23+
| MoveRight
24+
925
data Game = Game
1026
{ _gameWorld :: World
27+
, _gameWorldIdx :: Int -- 1-indexed world, in allWorlds
1128
, _gameCurrentPos :: Position
1229
} deriving (Eq)
1330

1431
makeLenses ''Game
1532

33+
mkGame :: Int -> Game
34+
mkGame n = Game w (k + 1) (w ^. worldInitialPos)
35+
where
36+
k = n-1 `mod` length allWorlds
37+
w = allWorlds !! k
38+
39+
playMove :: Move -> Game -> Game
40+
playMove m g =
41+
case m of
42+
MoveUp -> g & gameCurrentPos . _1 -~ 1
43+
MoveDown -> g & gameCurrentPos . _1 +~ 1
44+
MoveLeft -> g & gameCurrentPos . _2 -~ 1
45+
MoveRight -> g & gameCurrentPos . _2 +~ 1
46+
47+
forGame :: (Monad m) => Game -> ((Int, Int) -> Cell -> m ()) -> m ()
48+
forGame g f =
49+
let nj = g ^. gameWorld . worldNiNj . _2
50+
b = g ^. gameWorld . worldBoard
51+
in V.iforM_ b $ \k c -> f (k2ij nj k) c
52+
53+
-------------------------------------------------------------------------------
54+
-- internal
55+
-------------------------------------------------------------------------------
56+
57+
k2ij :: Int -> Int -> (Int, Int)
58+
k2ij nj k = (k `div` nj, k`rem` nj)
1659

‎src/Model.hs‎

Lines changed: 5 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -6,15 +6,14 @@ import Miso.Lens
66
import Miso.Lens.TH
77

88
import Game
9-
-- import World
109

11-
newtype Model = Model
12-
{ _modelPos :: (Int, Int)
10+
data Model = Model
11+
{ _modelGame :: Game
12+
, _modelNbMoves :: Int
1313
} deriving (Eq)
1414

1515
makeLenses ''Model
1616

17-
mkModel :: Model
18-
mkModel = Model (0, 0)
19-
17+
mkModel :: Int -> Model
18+
mkModel n = Model (mkGame n) 0
2019

‎src/World.hs‎

Lines changed: 1 addition & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,9 @@
11

22
module World where
33

4+
import Control.Lens
45
import Data.Set qualified as S
56
import Data.Vector qualified as V
6-
import Miso.Lens
7-
import Miso.Lens.TH
87

98
-------------------------------------------------------------------------------
109
-- params
@@ -34,11 +33,6 @@ data World = World
3433

3534
makeLenses ''World
3635

37-
mkWorld :: (Int, Int) -> World
38-
mkWorld (ni, nj) = World (ni, nj) board S.empty (0, 0)
39-
where
40-
board = V.replicate (ni*nj) CellE
41-
4236
-------------------------------------------------------------------------------
4337
-- MyShow typeclass, for generating worlds source code from images
4438
-------------------------------------------------------------------------------

0 commit comments

Comments
 (0)