304 lines
9.2 KiB
Haskell
304 lines
9.2 KiB
Haskell
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Main where
|
|
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Monad (unless)
|
|
import Control.Monad.IO.Class (MonadIO)
|
|
import Data.Bifoldable (bimapM_)
|
|
import Data.Bifunctor (Bifunctor (bimap, second))
|
|
import Data.Foldable (Foldable (toList))
|
|
import Data.Functor ((<&>))
|
|
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
|
import Data.Kind (Type)
|
|
import Data.StateVar (StateVar (StateVar), makeStateVar, mapStateVar)
|
|
import Foreign.C (CInt)
|
|
import SDL (
|
|
Event (eventPayload),
|
|
EventPayload (KeyboardEvent, QuitEvent),
|
|
Hint (HintRenderScaleQuality),
|
|
HintPriority (DefaultPriority),
|
|
InitFlag (InitVideo),
|
|
InputMotion (Pressed, Released),
|
|
KeyboardEventData (keyboardEventKeyMotion, keyboardEventKeysym),
|
|
Keysym (keysymKeycode),
|
|
OpenGLConfig (glMultisampleSamples),
|
|
Point (P),
|
|
Renderer,
|
|
V2 (V2),
|
|
V3 (V3),
|
|
V4 (V4),
|
|
Window,
|
|
WindowConfig (WindowConfig, windowGraphicsContext, windowInitialSize),
|
|
WindowGraphicsContext (OpenGLContext),
|
|
clear,
|
|
createRenderer,
|
|
createWindow,
|
|
defaultOpenGL,
|
|
defaultRenderer,
|
|
defaultWindow,
|
|
destroyWindow,
|
|
drawLine,
|
|
drawPoint,
|
|
get,
|
|
initialize,
|
|
pollEvents,
|
|
present,
|
|
quit,
|
|
rendererDrawColor,
|
|
setHintWithPriority,
|
|
waitEvent,
|
|
windowSize,
|
|
($=),
|
|
)
|
|
import SDL.Input.Keyboard.Codes
|
|
import System.IO.Unsafe (unsafePerformIO)
|
|
import Text.Printf (PrintfType, printf)
|
|
|
|
fps :: Int
|
|
fps = 1
|
|
|
|
data LoggingState = On | Off
|
|
|
|
{-# INLINE logState #-}
|
|
logState :: LoggingState
|
|
logState = Off
|
|
|
|
{-# INLINE logPrint #-}
|
|
logPrint :: (Show a) => LoggingState -> a -> IO ()
|
|
logPrint On = print
|
|
logPrint Off = return . donothing
|
|
|
|
{-# INLINE logPutStr #-}
|
|
logPutStr :: LoggingState -> String -> IO ()
|
|
logPutStr On = putStr
|
|
logPutStr Off = return . donothing
|
|
|
|
{-# INLINE logPutStrLn #-}
|
|
logPutStrLn :: LoggingState -> String -> IO ()
|
|
logPutStrLn On = putStrLn
|
|
logPutStrLn Off = return . donothing
|
|
|
|
{-# INLINE donothing #-}
|
|
donothing :: a -> ()
|
|
donothing _ = ()
|
|
|
|
main :: IO ()
|
|
main = do
|
|
logPutStrLn logState "to2D test:"
|
|
logPutStr logState "V3 0.5 0.5 0: "
|
|
logPrint logState $ to2D $ V3 0.5 0.5 0
|
|
logPutStr logState "V3 0.5 0.5 1: "
|
|
logPrint logState $ to2D $ V3 0.5 0.5 1
|
|
logPutStr logState "V3 0.5 0.5 2: "
|
|
logPrint logState $ to2D $ V3 0.5 0.5 2
|
|
|
|
logPutStr logState "V3 0.75 0.5 0: "
|
|
logPrint logState $ to2D $ V3 0.75 0.5 0
|
|
logPutStr logState "V3 0.75 0.5 1: "
|
|
logPrint logState $ to2D $ V3 0.75 0.5 1
|
|
logPutStr logState "V3 0.75 0.5 2: "
|
|
logPrint logState $ to2D $ V3 0.75 0.5 2
|
|
logPutStrLn logState ""
|
|
|
|
initialize [InitVideo]
|
|
|
|
window <-
|
|
createWindow
|
|
"Test"
|
|
defaultWindow{windowGraphicsContext = OpenGLContext defaultOpenGL, windowInitialSize = V2 800 800}
|
|
|
|
renderer <- createRenderer window (-1) defaultRenderer
|
|
|
|
loop renderer window
|
|
|
|
destroyWindow window
|
|
|
|
quit
|
|
|
|
exitCodes :: [Keycode]
|
|
exitCodes = [KeycodeQ, KeycodeEscape]
|
|
|
|
type Point2D = V2 Float
|
|
|
|
type Line2D = (Point2D, Point2D)
|
|
|
|
type Point3D = V3 Float
|
|
|
|
type Line3D = (Point3D, Point3D)
|
|
|
|
class Drawable a where
|
|
draw :: (MonadIO m, Functor m) => Window -> Renderer -> a -> m ()
|
|
absRotate :: Direction -> Direction -> Float -> a -> a
|
|
rotate :: Direction -> Direction -> Float -> a -> a
|
|
|
|
data Pointrel = P2 Point2D | P3 Point3D deriving (Show)
|
|
|
|
p2 :: Float -> Float -> Pointrel
|
|
p2 x y = P2 (V2 x y)
|
|
|
|
p3 :: Float -> Float -> Float -> Pointrel
|
|
p3 x y z = P3 (V3 x y z)
|
|
|
|
toP2 :: Pointrel -> Point2D
|
|
toP2 (P2 pnt) = pnt
|
|
toP2 (P3 pnt) = to2D pnt
|
|
|
|
toP3 :: Pointrel -> Point3D
|
|
toP3 (P3 pnt) = pnt
|
|
toP3 (P2 pnt) = let oldvec = toList pnt in V3 (head oldvec) (last oldvec) 0
|
|
|
|
instance Drawable Pointrel where
|
|
draw window renderer (P3 pnt) = draw window renderer $ P2 $ to2D pnt
|
|
draw window renderer pnt = get $ windowSize window >>= drawPoint renderer . flip tosdl pnt
|
|
absRotate dir1 dir2 ang (P3 pnt) = P3 $ _rotate dir1 dir2 ang pnt
|
|
absRotate dir1 dir2 ang pnt = P3 $ _rotate dir1 dir2 ang $ toP3 pnt
|
|
rotate _ _ _ = id
|
|
|
|
newtype Line = Line (Pointrel, Pointrel)
|
|
toLines :: [(Pointrel, Pointrel)] -> [Line]
|
|
toLines = map Line
|
|
unLine :: Line -> (Pointrel, Pointrel)
|
|
unLine (Line points) = points
|
|
|
|
instance Drawable Line where
|
|
draw window renderer (Line points) = get (windowSize window) >>= (\size -> uncurry (drawLine renderer) $ bimap (tosdl size) (tosdl size) points)
|
|
|
|
data Object = Lines [Line] | Points [Pointrel]
|
|
|
|
instance Drawable Object where
|
|
draw window renderer (Lines obj) = mapM_ (draw window renderer) obj
|
|
draw window renderer (Points obj) = mapM_ (draw window renderer) obj
|
|
|
|
{- FOURMOLU_DISABLE -}
|
|
square :: Object
|
|
square = Lines $ toLines [
|
|
(p3 (-0.5) (-0.5) (-0.5), p3 0.5 (-0.5) (-0.5)),
|
|
(p3 (-0.5) (-0.5) (-0.5), p3 (-0.5) 0.5 (-0.5)),
|
|
(p3 (-0.5) (-0.5) (-0.5), p3 (-0.5) (-0.5) 0.5),
|
|
|
|
(p3 0.5 0.5 (-0.5), p3 0.5 0.5 0.5),
|
|
(p3 0.5 0.5 (-0.5), p3 0.5 (-0.5) (-0.5)),
|
|
(p3 0.5 0.5 (-0.5), p3 (-0.5) 0.5 (-0.5)),
|
|
|
|
(p3 (-0.5) 0.5 0.5, p3 0.5 0.5 0.5),
|
|
(p3 (-0.5) 0.5 0.5, p3 (-0.5) (-0.5) 0.5),
|
|
(p3 (-0.5) 0.5 0.5, p3 (-0.5) 0.5 (-0.5)),
|
|
|
|
(p3 0.5 (-0.5) 0.5, p3 0.5 0.5 0.5),
|
|
(p3 0.5 (-0.5) 0.5, p3 (-0.5) (-0.5) 0.5),
|
|
(p3 0.5 (-0.5) 0.5, p3 0.5 (-0.5) (-0.5))
|
|
]
|
|
{- FOURMOLU_ENABLE -}
|
|
|
|
data Direction = X | Y | Z
|
|
|
|
_rotate :: Direction -> Direction -> Float -> Point3D -> Point3D
|
|
_rotate X Y ang pnt =
|
|
let (c, s, toRotate, x, y, z) = (cos ang, sin ang, toList pnt, head toRotate, toRotate !! 1, last toRotate)
|
|
in V3 ((x * c) - (y * s)) ((x * s) + (y * c)) z
|
|
_rotate X Z ang pnt =
|
|
let (c, s, toRotate, x, y, z) = (cos ang, sin ang, toList pnt, head toRotate, toRotate !! 1, last toRotate)
|
|
in V3 ((x * c) - (z * s)) y ((x * s) + (z * c))
|
|
_rotate Y Z ang pnt =
|
|
let (c, s, toRotate, x, y, z) = (cos ang, sin ang, toList pnt, head toRotate, toRotate !! 1, last toRotate)
|
|
in V3 x ((y * c) - (z * s)) ((y * s) + (z * c))
|
|
_rotate Y X a p = _rotate X Y a p
|
|
_rotate Z X a p = _rotate X Z a p
|
|
_rotate Z Y a p = _rotate Y Z a p
|
|
_rotate X X _ _ = error "cant't rotate around 2 axis simultaniously"
|
|
_rotate Y Y _ _ = error "cant't rotate around 2 axis simultaniously"
|
|
_rotate Z Z _ _ = error "cant't rotate around 2 axis simultaniously"
|
|
|
|
_rotateprint :: LoggingState -> Float -> Point3D -> IO ()
|
|
_rotateprint On ang pnt =
|
|
let (c, s, toRotate, x, y, z) = (cos ang, sin ang, toList pnt, head toRotate, toRotate !! 1, last toRotate)
|
|
in printf "c: %f, s: %f, x: %f, y: %f, z: %f\n" c s x y z
|
|
_rotateprint Off _ _ = return ()
|
|
|
|
rotateprint :: Float -> Point3D -> IO ()
|
|
rotateprint = _rotateprint logState
|
|
|
|
objects :: IORef [(Int, Object)]
|
|
{-# NOINLINE objects #-}
|
|
objects = unsafePerformIO (newIORef [(0 :: Int, square)])
|
|
|
|
delta :: IORef Float
|
|
{-# NOINLINE delta #-}
|
|
delta = unsafePerformIO (newIORef 0)
|
|
|
|
loop :: Renderer -> Window -> IO ()
|
|
loop renderer window = do
|
|
events <- pollEvents
|
|
stop <-
|
|
mapM
|
|
( \event -> case eventPayload event of
|
|
QuitEvent -> return True
|
|
KeyboardEvent kevent -> case keyboardEventKeyMotion kevent of
|
|
Pressed -> return False
|
|
Released
|
|
| keyof kevent `elem` exitCodes -> return True
|
|
| otherwise -> return False
|
|
_ -> return False
|
|
)
|
|
events
|
|
|
|
rendererDrawColor renderer $= V4 255 255 255 255
|
|
clear renderer
|
|
|
|
rendererDrawColor renderer $= V4 0 0 0 255
|
|
|
|
size <- get $ windowSize window
|
|
|
|
oldObjs <- readIORef objects
|
|
|
|
-- readIORef delta >>= writeIORef delta . (+ (0.25 / fromIntegral fps))
|
|
readIORef delta >>= writeIORef delta . (+ (0.05 / fromIntegral fps))
|
|
tmpDelta <- readIORef delta
|
|
let ang = 2 * pi * tmpDelta
|
|
-- readIORef objects >>= (writeIORef objects . map (second (map (bimap (P3 . (+) (V3 0 0 delta) . toP3) (P3 . (+) (V3 0 0 delta) . toP3)))))
|
|
-- readIORef objects >>= (writeIORef objects . map (second (map (bimap (P3 . rotate X Z ang . toP3) (P3 . rotate X Z ang . toP3)))))
|
|
|
|
rotated <- readIORef objects <&> map (map (bimap (P3 . rotate X Z ang . toP3) (P3 . rotate X Z ang . toP3)) . snd)
|
|
-- let rotated = map (map (bimap (P3 . rotate X Y ang . toP3) (P3 . rotate X Z ang . toP3))) rotated1
|
|
let moved = map (map (bimap (P3 . (+) (V3 0 0 tmpDelta) . toP3) (P3 . (+) (V3 0 0 tmpDelta) . toP3))) rotated
|
|
|
|
readIORef objects >>= mapM_ (mapM_ (logPrint logState) . snd)
|
|
logPutStrLn logState ""
|
|
|
|
-- putStr "\ESC[H\ESC[2J"
|
|
mapM_ (mapM_ (bimapM_ (putStr . flip (++) " " . show . toP3) (print . toP3))) moved
|
|
mapM_ (mapM_ (uncurry (drawLine renderer) . bimap (tosdl size) (tosdl size))) moved
|
|
|
|
present renderer
|
|
|
|
unless (or stop) continue
|
|
where
|
|
continue = threadDelay (1000000 `div` fps) >> loop renderer window
|
|
keyof = keysymKeycode . keyboardEventKeysym
|
|
|
|
{-
|
|
- we apply the formula
|
|
- (x, y, z) -> (x/z, y/z)
|
|
- then change back from -1..1 to 0..2
|
|
- and finally from 0..2 to 0..1
|
|
-}
|
|
to2D :: Point3D -> Point2D
|
|
to2D pointin
|
|
| last vec == 0 = to2D $ pointin * V3 1 (-1) 1
|
|
| otherwise = V2 (head vec / last vec) (vec !! 1 / last vec)
|
|
where
|
|
vec = toList pointin
|
|
|
|
{-
|
|
- size `toIntegral`
|
|
- rel from -1..1 to 0..2
|
|
- rel from 0..2 to 0..1
|
|
- multiply size to rel
|
|
- round it
|
|
- return it in point form
|
|
-}
|
|
tosdl :: V2 CInt -> Pointrel -> Point V2 CInt
|
|
tosdl size (P2 rel) = P $ fmap round $ fmap fromIntegral size * (1 - ((rel + 1) / 2))
|
|
tosdl size (P3 rel) = tosdl size $ P2 $ to2D rel
|