tracer/src/Init.hs

173 lines
5.8 KiB
Haskell
Raw Normal View History

2018-02-07 00:18:16 +00:00
{-# LANGUAGE ForeignFunctionInterface #-}
module Init where
import Affection as A
import SDL (($=))
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import NanoVG hiding (V2(..), V3(..))
2018-05-20 22:40:40 +00:00
import NanoVG.Internal.Image (ImageFlags(..))
2018-02-07 00:18:16 +00:00
2018-05-30 14:20:58 +00:00
import Linear hiding (E(..))
2018-02-07 00:18:16 +00:00
2018-05-20 22:40:40 +00:00
import Codec.Picture as CP
import Codec.Picture.Extra
2018-02-25 09:30:13 +00:00
import Control.Monad (when)
2018-02-07 00:18:16 +00:00
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM
import qualified Data.Set as S
import qualified Data.Map.Strict as M
import Data.Ecstasy
2018-02-25 09:30:13 +00:00
import Data.Maybe
2018-05-20 22:40:40 +00:00
import Data.ByteString.Lazy (toStrict)
2018-02-25 09:30:13 +00:00
import System.Exit (exitFailure)
2018-02-07 00:18:16 +00:00
import Foreign.C.Types (CInt(..))
import Types
2018-02-15 18:42:07 +00:00
import Floorplan
import Debug.Trace
2018-02-07 00:18:16 +00:00
foreign import ccall unsafe "glewInit"
glewInit :: IO CInt
load :: IO UserData
load = do
subs <- Subsystems
<$> (Window <$> newTVarIO [])
<*> (Mouse <$> newTVarIO [])
2018-06-07 22:29:46 +00:00
_ <- glewInit
nvg <- createGL3 (S.fromList [Antialias, StencilStrokes])
_ <- createFont nvg "bedstead"
(FileName "assets/font/Bedstead-Semicondensed.ttf")
2018-05-17 11:06:13 +00:00
(ws, _) <- yieldSystemT (0, defStorage) (return ())
2018-02-27 19:35:08 +00:00
mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0
mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") 0
mwallcornern <- createImage nvg (FileName "assets/walls/wall_corner_n.png") 0
mwallcornere <- createImage nvg (FileName "assets/walls/wall_corner_e.png") 0
mwallcorners <- createImage nvg (FileName "assets/walls/wall_corner_s.png") 0
mwallcornerw <- createImage nvg (FileName "assets/walls/wall_corner_w.png") 0
mwalltne <- createImage nvg (FileName "assets/walls/wall_t_ne.png") 0
mwalltse <- createImage nvg (FileName "assets/walls/wall_t_se.png") 0
mwalltsw <- createImage nvg (FileName "assets/walls/wall_t_sw.png") 0
mwalltnw <- createImage nvg (FileName "assets/walls/wall_t_nw.png") 0
mwallcross <- createImage nvg (FileName "assets/walls/wall_cross.png") 0
2018-03-03 16:03:17 +00:00
mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") 0
2018-03-31 21:22:10 +00:00
mmisctable1 <- createImage nvg (FileName "assets/misc/table1.png") 0
mmisctable2 <- createImage nvg (FileName "assets/misc/table2.png") 0
2018-04-11 18:01:41 +00:00
mmisctable3 <- createImage nvg (FileName "assets/misc/table3.png") 0
mmisctable4 <- createImage nvg (FileName "assets/misc/table4.png") 0
2018-03-31 21:22:10 +00:00
mmisctableC <- createImage nvg (FileName "assets/misc/tableCorner.png") 0
2018-03-03 16:03:17 +00:00
let mimgs = [ mwallasc, mwalldesc,
2018-06-07 22:29:46 +00:00
mwallcornern, mwallcornere, mwallcorners, mwallcornerw,
2018-03-03 16:03:17 +00:00
mwalltne, mwalltse, mwalltsw, mwalltnw, mwallcross,
2018-03-31 21:22:10 +00:00
mmiscbox1,
2018-04-11 18:01:41 +00:00
mmisctable1, mmisctable2, mmisctable3, mmisctable4, mmisctableC
2018-03-03 16:03:17 +00:00
]
when (any isNothing mimgs) $ do
2018-03-31 21:22:10 +00:00
logIO Error "Failed to load image assets"
2018-02-25 09:30:13 +00:00
exitFailure
2018-05-30 14:20:58 +00:00
-- playerImgs <- loadPlayerSprite "assets/intruder.png" 64 74 nvg
-- (zipWith (\a b -> (a, [b])) [0..] $ [ImgIntrE .. ImgIntrN] ++ [ImgIntrNE])
2018-03-03 16:03:17 +00:00
let imgs = zipWith (\a b -> (a, fromJust b)) [ImgWallAsc ..] mimgs
2018-05-30 14:20:58 +00:00
directions = [E .. N] ++ [NE]
2018-05-30 20:15:49 +00:00
standIds = map (AnimId 0 "standing") directions
walkIds = map (AnimId 0 "walking") directions
standConfigs = map
2018-05-30 14:20:58 +00:00
(\i -> AnimationConfig (0, i * 74) (64, 74) 1 0 APLoop)
2018-05-30 20:15:49 +00:00
[0 .. length standIds - 1]
walkConfigs = map
2018-05-31 01:07:41 +00:00
(\i -> AnimationConfig (64, i * 74) (64, 74) 6 1.5 APLoop)
2018-05-30 20:15:49 +00:00
[0 .. length walkIds - 1]
playerStanding <- loadAnimationSprites "assets/intruder.png" nvg
(zip standIds standConfigs)
playerWalking <- loadAnimationSprites "assets/intruder.png" nvg
(zip walkIds walkConfigs)
2018-02-07 00:18:16 +00:00
return UserData
2018-05-30 14:20:58 +00:00
{ state = Menu
, subsystems = subs
, assetImages = M.fromList imgs
2018-05-30 20:15:49 +00:00
, assetAnimations = M.fromList
(playerStanding ++ playerWalking)
2018-05-30 14:20:58 +00:00
, assetFonts = M.fromList
2018-03-01 22:33:08 +00:00
[ (FontBedstead, "bedstead")
]
2018-05-30 14:20:58 +00:00
, nano = nvg
, uuid = []
, worldState = ws
, stateData = None
2018-02-07 00:18:16 +00:00
}
2018-05-20 22:40:40 +00:00
2018-05-30 14:20:58 +00:00
loadAnimationSprites
:: FilePath -- Path to Sprite map
-> Context -- NanoVG context
-> [(AnimId, AnimationConfig)]
-> IO [(AnimId, Animation)]
loadAnimationSprites fp nvg idconfs = do
eimg <- readImage fp
case eimg of
Left err -> do
logIO Error err
exitFailure
Right dimg -> do
let img = convertRGBA8 dimg
mapM
(\(id, (AnimationConfig (xoffs, yoffs) (w, h) count dur pb)) -> do
let crs = map
(\i -> crop (xoffs + (i * w)) yoffs w h img)
[0 .. (count - 1)]
mresimgs <- mapM
(\cr ->
createImageMem nvg (ImagePremultiplied) (toStrict $ encodePng cr))
crs
imgs <- if any isNothing mresimgs
then do
logIO Error ("failed to load: " ++ fp ++ " " ++ show id)
exitFailure
else
return $ catMaybes mresimgs
return $
( id
, Animation dur imgs pb
)
) idconfs
2018-05-20 22:40:40 +00:00
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
2018-05-30 14:20:58 +00:00
mresimg <-
createImageMem nvg (ImagePremultiplied) (toStrict $ encodePng cr)
2018-05-20 22:40:40 +00:00
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