haskelloids/src/Commons.hs

123 lines
3 KiB
Haskell
Raw Normal View History

2017-01-03 16:34:37 +00:00
{-# LANGUAGE RecordWildCards #-}
2016-12-31 16:01:24 +00:00
module Commons where
import Affection
import qualified SDL
import qualified Data.Map as M
2017-01-03 16:34:37 +00:00
import Data.List (delete)
2017-12-16 10:55:30 +00:00
import Data.Maybe (catMaybes, isJust)
2016-12-31 16:01:24 +00:00
2017-12-16 10:55:30 +00:00
import Control.Monad (foldM, unless, when)
2017-12-16 18:06:36 +00:00
import Control.Monad.IO.Class (liftIO)
2016-12-31 16:01:24 +00:00
import System.Random (randomRIO)
2017-12-19 07:18:57 +00:00
import NanoVG as N hiding (V2(..))
2017-12-16 18:06:36 +00:00
2017-12-19 07:18:57 +00:00
import Linear as L hiding (rotate)
import Foreign.C.Types (CFloat(..))
2016-12-31 16:01:24 +00:00
import Types
toR :: Double -> Double
toR deg = deg * pi / 180
2017-12-19 16:30:44 +00:00
wrapAround :: (Fractional t, Ord t, Num t) => V2 t -> t -> V2 t
2017-12-19 07:18:57 +00:00
wrapAround (V2 nx ny) width = (V2 nnx nny)
2017-01-03 16:34:37 +00:00
where
2017-01-03 18:36:01 +00:00
nnx
2017-12-19 16:30:44 +00:00
| nx > 800 + half = nx - (800 + width)
| nx < -half = nx + 800 + width
| otherwise = nx
2017-01-03 18:36:01 +00:00
nny
2017-12-19 16:30:44 +00:00
| ny > 600 + half = ny - (600 + width)
| ny < -half = ny + 600 + width
| otherwise = ny
half = width / 2
2017-12-16 18:06:36 +00:00
2017-12-20 01:00:28 +00:00
newHaskelloids :: Affection UserData [Haskelloid]
newHaskelloids = do
img <- haskImage <$> getAffection
liftIO $ mapM (\_ -> do
posx <- randomRIO (0, 800)
posy <- randomRIO (0, 600)
velx <- randomRIO (-10, 10)
vely <- randomRIO (-10, 10)
rot <- randomRIO (-180, 180)
pitch <- randomRIO (-pi, pi)
div <- randomRIO (1, 2)
return $ Haskelloid
(V2 posx posy)
(V2 velx vely)
rot
pitch
div
img
) [1..10]
2017-12-16 18:06:36 +00:00
updateHaskelloid :: Double -> Haskelloid -> Haskelloid
2017-12-19 07:18:57 +00:00
updateHaskelloid dsec has =
2017-12-16 18:06:36 +00:00
has
2017-12-19 16:30:44 +00:00
{ hPos = wrapAround
(hPos has + hVel has * V2 sec sec)
(100 / fromIntegral (hDiv has))
2017-12-16 18:06:36 +00:00
, hRot = hRot has + hPitch has * sec
}
2017-12-19 07:18:57 +00:00
where
sec = realToFrac dsec
2017-12-19 05:49:41 +00:00
clamp :: Ord a => a -> a -> a -> a
clamp a' low up
| a' < low = low
| a' > up = up
| otherwise = a'
2017-12-19 07:18:57 +00:00
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
2017-12-19 16:30:44 +00:00
translate ctx (x + (w/2)) (y + (h/2))
2017-12-19 07:18:57 +00:00
rotate ctx (degToRad $ CFloat rot)
2017-12-19 16:30:44 +00:00
translate ctx (-(w/2)) (-(h/2))
2017-12-19 07:18:57 +00:00
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
2017-12-19 16:30:44 +00:00
liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 255
where
dim = (fmap (/ fromIntegral div) (V2 100 100))