haskelloids in menu

src/Commons.hs

@@ -14,17 +14,19 @@ import Control.Monad.IO.Class (liftIO)
 
 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
 
 toR :: Double -> Double
 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
     nnx
       | nx > 800    = nx - (800 + width)
@@ -41,7 +43,7 @@ newHaskelloids img = liftIO $ mapM (\_ -> do
   posy <- randomRIO (0, 600)
   velx <- randomRIO (-10, 10)
   vely <- randomRIO (-10, 10)
-  rot <- randomRIO (0, 2*pi)
+  rot <- randomRIO (-180, 180)
   pitch <- randomRIO (-pi, pi)
   div <- randomRIO (1, 2)
   return $ Haskelloid
@@ -54,14 +56,59 @@ newHaskelloids img = liftIO $ mapM (\_ -> do
   ) [1..10]
 
 updateHaskelloid :: Double -> Haskelloid -> Haskelloid
-updateHaskelloid sec has =
+updateHaskelloid dsec 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
     }
+  where
+    sec = realToFrac dsec
 
 clamp :: Ord a => a -> a -> a -> a
 clamp a' low up
   | a' < low = low
   | a' > up = up
   | 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

src/Menu.hs

@@ -34,7 +34,7 @@ loadMenu = do
   liftIO $ logIO A.Debug "Loading Menu"
   ud <- getAffection
   mhaskImage <- liftIO $
-    createImage (nano ud) (FileName "assets/haskelloid.svg") 0
+    createImage (nano ud) (FileName "assets/haskelloid.png") 0
   when (isNothing mhaskImage) $
     liftIO $ logIO Error "Failed to load asset haskelloid"
   hs <- newHaskelloids (fromJust mhaskImage)
@@ -76,37 +76,6 @@ updateMenu sec = do
 drawMenu :: Affection UserData ()
 drawMenu = do
   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

src/Types.hs

@@ -24,17 +24,17 @@ data UserData = UserData
   }
 
 data Ship = Ship
-  { sPos :: V2 Double
+  { sPos :: V2 Float
-  , sVel :: V2 Double
+  , sVel :: V2 Float
-  , sRot :: Double
+  , sRot :: Float
   , sImg :: Image
   }
 
 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
   , hImg :: Image
   } deriving (Eq)