haskelloids in menu

This commit is contained in:
nek0 2017-12-19 08:18:57 +01:00
parent 990f1a7daf
commit 66499d07e4
3 changed files with 65 additions and 49 deletions

View file

@ -14,17 +14,19 @@ import Control.Monad.IO.Class (liftIO)
import System.Random (randomRIO) import System.Random (randomRIO)
import NanoVG hiding (V2(..)) import NanoVG as N hiding (V2(..))
import Linear import Linear as L hiding (rotate)
import Foreign.C.Types (CFloat(..))
import Types import Types
toR :: Double -> Double toR :: Double -> Double
toR deg = deg * pi / 180 toR deg = deg * pi / 180
wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t) wrapAround :: (Ord t, Num t) => V2 t -> t -> V2 t
wrapAround (nx, ny) width = (nnx, nny) wrapAround (V2 nx ny) width = (V2 nnx nny)
where where
nnx nnx
| nx > 800 = nx - (800 + width) | nx > 800 = nx - (800 + width)
@ -41,7 +43,7 @@ newHaskelloids img = liftIO $ mapM (\_ -> do
posy <- randomRIO (0, 600) posy <- randomRIO (0, 600)
velx <- randomRIO (-10, 10) velx <- randomRIO (-10, 10)
vely <- randomRIO (-10, 10) vely <- randomRIO (-10, 10)
rot <- randomRIO (0, 2*pi) rot <- randomRIO (-180, 180)
pitch <- randomRIO (-pi, pi) pitch <- randomRIO (-pi, pi)
div <- randomRIO (1, 2) div <- randomRIO (1, 2)
return $ Haskelloid return $ Haskelloid
@ -54,14 +56,59 @@ newHaskelloids img = liftIO $ mapM (\_ -> do
) [1..10] ) [1..10]
updateHaskelloid :: Double -> Haskelloid -> Haskelloid updateHaskelloid :: Double -> Haskelloid -> Haskelloid
updateHaskelloid sec has = updateHaskelloid dsec has =
has has
{ hPos = hPos has + hVel has * V2 sec sec { hPos = wrapAround (hPos has + hVel has * V2 sec sec) (100 / fromIntegral (hDiv has))
, hRot = hRot has + hPitch has * sec , hRot = hRot has + hPitch has * sec
} }
where
sec = realToFrac dsec
clamp :: Ord a => a -> a -> a -> a clamp :: Ord a => a -> a -> a -> a
clamp a' low up clamp a' low up
| a' < low = low | a' < low = low
| a' > up = up | a' > up = up
| otherwise = a' | otherwise = a'
drawImage :: Context -> Image -> V2 Float -> V2 Float -> Float -> Float -> IO ()
drawImage ctx img pos dim rot alpha = do
let (V2 x y) = fmap CFloat pos
(V2 w h) = fmap CFloat dim
save ctx
translate ctx x y
rotate ctx (degToRad $ CFloat rot)
sPaint <- imagePattern ctx 0 0 w h 0 img (CFloat alpha)
beginPath ctx
rect ctx 0 0 w h
fillPaint ctx sPaint
fill ctx
resetTransform ctx
restore ctx
drawSpinner :: Context -> Float -> Float -> Float -> Float -> IO ()
drawSpinner ctx x y cr ct = do
let a0 = 0+t*6
a1 = pi + t*6
r0 = r
r1 = r*0.75
(cx, cy) = (CFloat x, CFloat y)
r = CFloat cr
t = CFloat ct
save ctx
beginPath ctx
arc ctx cx cy r0 a0 a1 CW
arc ctx cx cy r1 a1 a0 CCW
closePath ctx
let ax = cx+cos a0 * (r0+r1)*0.5
ay = cy+sin a0 * (r0+r1)*0.5
bx = cx+cos a1 * (r0+r1)*0.5
by = cy+sin a1 * (r0+r1)*0.5
paint <- linearGradient ctx ax ay bx by (rgba 255 255 255 0) (rgba 255 255 255 128)
fillPaint ctx paint
fill ctx
restore ctx
drawHaskelloid :: Haskelloid -> Affection UserData ()
drawHaskelloid (Haskelloid pos _ rot _ div img) = do
ctx <- nano <$> getAffection
liftIO $ drawImage ctx img pos (fmap (/ fromIntegral div) (V2 100 100)) rot 255

View file

@ -34,7 +34,7 @@ loadMenu = do
liftIO $ logIO A.Debug "Loading Menu" liftIO $ logIO A.Debug "Loading Menu"
ud <- getAffection ud <- getAffection
mhaskImage <- liftIO $ mhaskImage <- liftIO $
createImage (nano ud) (FileName "assets/haskelloid.svg") 0 createImage (nano ud) (FileName "assets/haskelloid.png") 0
when (isNothing mhaskImage) $ when (isNothing mhaskImage) $
liftIO $ logIO Error "Failed to load asset haskelloid" liftIO $ logIO Error "Failed to load asset haskelloid"
hs <- newHaskelloids (fromJust mhaskImage) hs <- newHaskelloids (fromJust mhaskImage)
@ -76,37 +76,6 @@ updateMenu sec = do
drawMenu :: Affection UserData () drawMenu :: Affection UserData ()
drawMenu = do drawMenu = do
ud <- getAffection ud <- getAffection
let V2 sx sy = fmap (CFloat . realToFrac) (sPos $ ship ud) mapM_ drawHaskelloid (haskelloids ud)
liftIO $ do -- t <- getElapsedTime
save (nano ud) -- liftIO $ drawSpinner (nano ud) 100 100 100 t
sPaint <- imagePattern (nano ud) 400 300 20 20 0 (sImg $ ship ud) 255
beginPath (nano ud)
rect (nano ud) 400 300 20 20
fillPaint (nano ud) sPaint
fill (nano ud)
restore (nano ud)
dt <- getElapsedTime
liftIO $
drawSpinner (nano ud) 100 100 100 (CFloat $ realToFrac dt)
drawSpinner :: Context -> CFloat -> CFloat -> CFloat -> CFloat -> IO ()
drawSpinner vg cx cy r t = do
let a0 = 0+t*6
a1 = pi + t*6
r0 = r
r1 = r*0.75
save vg
beginPath vg
arc vg cx cy r0 a0 a1 CW
arc vg cx cy r1 a1 a0 CCW
closePath vg
let ax = cx+cos a0 * (r0+r1)*0.5
ay = cy+sin a0 * (r0+r1)*0.5
bx = cx+cos a1 * (r0+r1)*0.5
by = cy+sin a1 * (r0+r1)*0.5
paint <- linearGradient vg ax ay bx by (rgba 255 255 255 0) (rgba 255 255 255 128)
fillPaint vg paint
fill vg
restore vg

View file

@ -24,17 +24,17 @@ data UserData = UserData
} }
data Ship = Ship data Ship = Ship
{ sPos :: V2 Double { sPos :: V2 Float
, sVel :: V2 Double , sVel :: V2 Float
, sRot :: Double , sRot :: Float
, sImg :: Image , sImg :: Image
} }
data Haskelloid = Haskelloid data Haskelloid = Haskelloid
{ hPos :: V2 Double { hPos :: V2 Float
, hVel :: V2 Double , hVel :: V2 Float
, hRot :: Double , hRot :: Float
, hPitch :: Double , hPitch :: Float
, hDiv :: Int , hDiv :: Int
, hImg :: Image , hImg :: Image
} deriving (Eq) } deriving (Eq)