haskelloids/src/Commons.hs

118 lines
2.9 KiB
Haskell
Raw Permalink Normal View History

2016-12-31 16:01:24 +00:00
module Commons where
import Affection
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-22 08:01:07 +00:00
wrapAround (V2 nx ny) w = V2 nnx nny
2017-01-03 16:34:37 +00:00
where
2017-01-03 18:36:01 +00:00
nnx
2017-12-22 08:01:07 +00:00
| nx > 800 + half = nx - (800 + w)
| nx < -half = nx + 800 + w
2017-12-19 16:30:44 +00:00
| otherwise = nx
2017-01-03 18:36:01 +00:00
nny
2017-12-22 08:01:07 +00:00
| ny > 600 + half = ny - (600 + w)
| ny < -half = ny + 600 + w
2017-12-19 16:30:44 +00:00
| otherwise = ny
2017-12-22 08:01:07 +00:00
half = w / 2
2017-12-16 18:06:36 +00:00
2020-05-04 19:17:06 +00:00
newHaskelloids :: Image -> Affection [Haskelloid]
newHaskelloids img =
do
2017-12-20 01:00:28 +00:00
liftIO $ mapM (\_ -> do
2017-12-22 08:01:07 +00:00
d <- randomRIO (1, 2)
(posx, posy) <- getCoordinates d
2017-12-20 01:00:28 +00:00
velx <- randomRIO (-10, 10)
vely <- randomRIO (-10, 10)
rot <- randomRIO (-180, 180)
pitch <- randomRIO (-pi, pi)
return $ Haskelloid
(V2 posx posy)
(V2 velx vely)
rot
pitch
2017-12-22 08:01:07 +00:00
d
2017-12-20 01:00:28 +00:00
img
2017-12-22 08:01:07 +00:00
) ([1..10] :: [Int])
where
2017-12-22 08:01:07 +00:00
getCoordinates d = do
posx <- randomRIO (0, 800)
posy <- randomRIO (0, 600)
2017-12-22 08:01:07 +00:00
if distance (V2 posx posy) (V2 400 300) < 20 + (50 / fromIntegral d)
then getCoordinates d
else return (posx, posy)
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
2020-05-04 19:17:06 +00:00
drawHaskelloid :: Context -> Haskelloid -> Affection ()
drawHaskelloid ctx (Haskelloid pos _ rot _ d img) = do
2018-01-08 21:26:31 +00:00
liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 1
2017-12-19 16:30:44 +00:00
where
2017-12-22 08:01:07 +00:00
dim = fmap (/ fromIntegral d) (V2 100 100)