adding player sprite and handling

shell.nix

@@ -79,7 +79,7 @@ let
 
   f = { mkDerivation, astar, base, containers, linear
       , matrix, OpenGL, random, sdl2, stdenv, stm, text, unordered-containers
-      , vector
+      , vector, JuicyPixels, JuicyPixels-extra, bytestring
       }:
       mkDerivation {
         pname = "tracer-game";
@@ -90,7 +90,8 @@ let
         enableExecutableProfiling = true;
         executableHaskellDepends = [
           affectionNeko astar base containers ecstasyNeko linear matrix nanovgNeko
-          OpenGL random sdl2 stm text unordered-containers vector
+          OpenGL random sdl2 stm text unordered-containers vector JuicyPixels
+          JuicyPixels-extra bytestring
         ];
         license = stdenv.lib.licenses.gpl3;
       };

src/Init.hs

@@ -10,9 +10,13 @@ import qualified SDL
 import qualified Graphics.Rendering.OpenGL as GL
 
 import NanoVG hiding (V2(..), V3(..))
+import NanoVG.Internal.Image (ImageFlags(..))
 
 import Linear
 
+import Codec.Picture as CP
+import Codec.Picture.Extra
+
 import Control.Monad (when)
 import Control.Monad.IO.Class (liftIO)
 
@@ -22,6 +26,7 @@ import qualified Data.Set as S
 import qualified Data.Map.Strict as M
 import Data.Ecstasy
 import Data.Maybe
+import Data.ByteString.Lazy (toStrict)
 
 import System.Exit (exitFailure)
 
@@ -72,12 +77,14 @@ load = do
   when (any isNothing mimgs) $ do
     logIO Error "Failed to load image assets"
     exitFailure
+  playerImgs <- loadPlayerSprite "assets/intruder.png" 64 74 nvg
+    (zipWith (\a b -> (a, [b])) [0..] [ImgIntrE .. ImgIntrNE])
   let imgs = zipWith (\a b -> (a, fromJust b)) [ImgWallAsc ..] mimgs
   return UserData
     { state       = Menu
     , subsystems  = subs
     , assetImages = M.fromList
-      imgs
+      (imgs ++ playerImgs)
     , assetFonts  = M.fromList
       [ (FontBedstead, "bedstead")
       ]
@@ -86,3 +93,31 @@ load = do
     , worldState  = ws
     , stateData   = None
     }
+
+loadPlayerSprite
+  :: FilePath         -- Path to spritemap
+  -> Int              -- width of single sprite
+  -> Int              -- height of single sprite
+  -> Context          -- Nanovg context
+  -> [(Int, [ImgId])] -- [(picture row, Image IDs)]
+  -> IO [(ImgId, NanoVG.Image)]
+loadPlayerSprite fp w h nvg rids = do
+  eimg <- readImage fp
+  case eimg of
+    Left err -> do
+      logIO Error err
+      exitFailure
+    Right dimg -> do
+      let img = convertRGBA8 dimg
+      ret <- mapM (\(row, ids) -> do
+        mapM (\(num, id) -> do
+          let cr = crop (num * w) (row * h) w h img
+          mresimg <- createImageMem nvg (ImagePremultiplied) (toStrict $ encodePng cr)
+          case mresimg of
+            Nothing     -> do
+              logIO Error ("Failed to load: " ++ fp ++ " " ++ show id)
+              exitFailure
+            Just resimg -> return (id, resimg)
+          ) (zip [0..] ids)
+        ) rids
+      return $ concat ret

src/NPC.hs

@@ -3,6 +3,7 @@ module NPC where
 import Affection as A
 
 import qualified Data.Matrix as M
+import Data.Map.Strict as Map hiding (filter, null)
 import Data.Ecstasy as E
 
 import Control.Monad.IO.Class (MonadIO(..))
@@ -26,18 +27,19 @@ import Types.Map
 import Types.ReachPoint
 
 drawNPCs
-  :: Context
+  :: Map ImgId Image
+  -> Context
   -> UserData
-  -> [V2 Double]
+  -> [(V2 Double, Direction)]
   -> Double
   -> Double
   -> Int
   -> Int
   -> Maybe ImgId
   -> IO ()
-drawNPCs ctx ud npcposs prow pcol row col img = do
-  let fnpcposs = filter
-        (\(V2 nr nc) ->
+drawNPCs ai ctx ud npcposrots prow pcol row col img = do
+  let fnpcposrots = filter
+        (\((V2 nr nc, dir)) ->
           let x = realToFrac $ 640 + ((nc - pcol) + (nr - prow)) * 32
               y = realToFrac $ 360 + ((nr - prow) - (nc - pcol)) * 16
           in  ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) &&
@@ -48,18 +50,23 @@ drawNPCs ctx ud npcposs prow pcol row col img = do
             all (\m -> pcol < (fromIntegral (floor pcol :: Int)) + m) maxcs)) &&
             (floor nr == row && floor nc == col)
           )
-        npcposs
+        npcposrots
   mapM_
-    (\(V2 nr nc) -> do
+    (\((V2 nr nc, dir)) -> do
       let x = realToFrac $ 640 + ((nc - pcol) + (nr - prow)) * 32
           y = realToFrac $ 360 + ((nr - prow) - (nc - pcol)) * 16
       beginPath ctx
-      circle ctx x y 5
-      closePath ctx
-      fillColor ctx (rgba 255 0 0 255)
+      paint <- imagePattern ctx (x - 32) (y - 58) 64 74 0
+        (ai Map.! (dirToImgId dir)) 1
+      rect ctx (x - realToFrac (tileWidth / 2)) (y - 58)
+        (realToFrac tileWidth) 74
+      fillPaint ctx paint
+      -- circle ctx x y 5
+      -- closePath ctx
+      -- fillColor ctx (rgba 255 0 0 255)
       fill ctx
       )
-    fnpcposs
+    fnpcposrots
   where
     tileWidth = 64 :: Double
     tileHeight = 32 :: Double

src/Test.hs

@@ -63,6 +63,7 @@ loadMap = do
       { pos = Just (V2 20.5 20.5)
       , vel = Just (V2 0 0)
       , player = Just ()
+      , rot = Just SE
       }
     void $ mapM_ (\npcpos@(V2 nr nc) -> do
       -- ttl <- liftIO $ randomRIO (5, 30)
@@ -72,7 +73,8 @@ loadMap = do
       createEntity $ newEntity
         { pos      = Just (V2 (nr + 0.5) (nc + 0.5))
         , vel      = Just (V2 0 0)
-        , velFact = Just fact
+        , velFact  = Just fact
+        , rot      = Just SE
         , npcState = Just (NPCStanding 0 future)
         }
       ) npcposs
@@ -128,20 +130,23 @@ drawMap :: Affection UserData ()
 drawMap = do
   ud <- getAffection
   dt <- getDelta
-  (_, (playerPos, npcposs)) <- liftIO $ yieldSystemT (worldState ud) $ do
-    pc <- efor allEnts $ do
+  (_, (playerPos, playerRot, npcposrots)) <- liftIO $ yieldSystemT (worldState ud) $ do
+    (pc, dir) <- fmap head $ efor allEnts $ do
       with player
       with pos
+      with rot
       pos' <- query pos
-      pure pos'
+      rot' <- query rot
+      pure (pos', rot')
   -- (_, npcposs) <- yieldSystemT (worldState ud) $ do
-    npcs <- efor allEnts $ do
+    npcsrots <- efor allEnts $ do
       with npcState
       with pos
       pos' <- query pos
-      pure pos'
-    return (pc, npcs)
-  let V2 pr pc = head playerPos
+      rot' <- query rot
+      pure (pos', rot')
+    return (pc, dir, npcsrots)
+  let V2 pr pc = playerPos
       mat = imgMat (stateData ud)
       ctx = nano ud
       cols = fromIntegral (ncols mat)
@@ -167,9 +172,8 @@ drawMap = do
     fill ctx
     mapM_ (\(i, ls) -> mapM_
       (\(j, t) -> do
-        drawTile
-          (assetImages ud) ctx pr pc i j t
-        drawNPCs ctx ud npcposs pr pc i j t
+        drawTile (assetImages ud) ctx pr pc i j t (dirToImgId playerRot)
+        drawNPCs (assetImages ud) ctx ud npcposrots pr pc i j t
         )
         (reverse $ zip [1..] ls))
       (zip [1..] (toLists mat))
@@ -182,6 +186,14 @@ drawMap = do
 
 updateMap :: Double -> Affection UserData ()
 updateMap dt = do
+  let direction vel'@(V2 vr _) rot' = if sqrt (vel' `dot` vel') > 0
+        then toEnum (
+          let xuu = floor
+                ((((acos ((vel' `dot` V2 0 1) / sqrt (vel' `dot` vel'))) /
+                  pi) + 0.25) * 4 )
+              xu = if vr < 0 then 7 - xuu else xuu
+          in  A.log A.Debug ("xu: " ++ show xu) xu)
+        else rot'
   ud <- getAffection
   (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
     emap allEnts $ do
@@ -189,21 +201,26 @@ updateMap dt = do
       with vel
       with velFact
       with pos
+      with rot
       pos'@(V2 pr pc) <- query pos
       vel' <- query vel
+      rot' <- query rot
       fact' <- query velFact
       let npos@(V2 nr nc) = pos' + fmap (* (dt * fact')) vel'
           dpos = npos - pos'
           ent = unchanged
             { pos = Set $ npos
+            , rot = Set $ direction vel' rot'
             }
       return ent
     emap allEnts $ do
       with player
       with vel
       with pos
+      with rot
       pos'@(V2 pr pc) <- query pos
-      vel' <- query vel
+      vel'@(V2 vr vc) <- query vel
+      rot' <- query rot
       let npos@(V2 nr nc) = pos' + fmap (* dt) vel'
           dpos@(V2 dpr dpc) = npos - pos'
           len = sqrt (dpos `dot` dpos)
@@ -250,6 +267,8 @@ updateMap dt = do
                   )
                 (A.log A.Verbose (show lll ++ " " ++ show len) lll)
               )
+            , rot = Set (A.log A.Debug ("dir: " ++ show (direction vel' rot'))
+              (direction vel' rot'))
             }
       return ent
     updateNPCs
@@ -271,8 +290,9 @@ drawTile
   -> Int
   -> Int
   -> Maybe ImgId
+  -> ImgId
   -> IO ()
-drawTile ai ctx pr pc row col img =
+drawTile ai ctx pr pc row col img playerImg =
   when ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) &&
     (realToFrac x < 1280 && realToFrac (y - (74 - realToFrac tileHeight)) < 720)) $
       do
@@ -330,9 +350,13 @@ drawTile ai ctx pr pc row col img =
     drawPlayer = do
       when (floor pr == row && floor pc == col) $ do
         beginPath ctx
-        circle ctx 640 360 5
-        closePath ctx
-        fillColor ctx (rgba 0 255 255 255)
+        paint <- imagePattern
+          ctx 608 302 64 74 0 (ai Map.! playerImg) 1
+        rect ctx 608 302 64 74
+        fillPaint ctx paint
+        -- circle ctx 640 360 5
+        -- closePath ctx
+        -- fillColor ctx (rgba 0 255 255 255)
         fill ctx
 
 checkBoundsCollision

src/Types/UserData.hs

@@ -62,6 +62,14 @@ data ImgId
   | ImgMiscTable3
   | ImgMiscTable4
   | ImgMiscTableCorner
+  | ImgIntrE
+  | ImgIntrSE
+  | ImgIntrS
+  | ImgIntrSW
+  | ImgIntrW
+  | ImgIntrNW
+  | ImgIntrN
+  | ImgIntrNE
   deriving (Show, Eq, Ord, Enum)
 
 isWall :: ImgId -> Bool
@@ -136,14 +144,25 @@ data FontId
   deriving (Show, Eq, Ord, Enum)
 
 data Direction
-  = N
-  | W
-  | S
+  = NE
   | E
-  | NW
-  | SW
-  | NE
   | SE
+  | S
+  | SW
+  | W
+  | NW
+  | N
+  deriving (Show, Eq, Ord, Enum)
+
+dirToImgId :: Direction -> ImgId
+dirToImgId E  = ImgIntrE
+dirToImgId SE = ImgIntrSE
+dirToImgId S  = ImgIntrS
+dirToImgId SW = ImgIntrSW
+dirToImgId W  = ImgIntrW
+dirToImgId NW = ImgIntrNW
+dirToImgId N  = ImgIntrN
+dirToImgId NE = ImgIntrNE
 
 data Entity f = Entity
   { pos      :: Component f 'Field (V2 Double)

tracer-game.cabal

@@ -49,6 +49,9 @@ executable tracer-game
                      , vector
                      , astar
                      , unordered-containers
+                     , JuicyPixels
+                     , JuicyPixels-extra
+                     , bytestring
   hs-source-dirs:      src
   ghc-options:         -Wall -threaded
   default-language:    Haskell2010