diff --git a/app/Main.hs b/app/Main.hs index a36eddc..a055f8e 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,30 +1,33 @@ -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Main where import Control.Concurrent (threadDelay) import Control.Monad (unless) -import Control.Monad.IO.Class (MonadIO) -import Data.Bifunctor (Bifunctor (bimap)) +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.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 (windowGraphicsContext, windowInitialSize), + WindowConfig (WindowConfig, windowGraphicsContext, windowInitialSize), WindowGraphicsContext (OpenGLContext), clear, createRenderer, @@ -34,22 +37,23 @@ import SDL ( 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 (printf) +import Text.Printf (PrintfType, printf) fps :: Int -fps = 60 +fps = 144 data LoggingState = On | Off @@ -94,29 +98,6 @@ main = do logPrint logState $ to2D $ V3 0.75 0.5 2 logPutStrLn logState "" - let tmpPoint = - Lines - ( [ Line (p3 0 0 0, p3 1 0 0) - ], - p3 0 0 0 - ) - let movedPoint = move (Right (V3 0 0 1 :: V3 Float)) tmpPoint - let rotatedPoint = rotate X Z (pi / 2) movedPoint - let rotatedPoint2 = rotate X Z (-(pi / 2)) rotatedPoint - let movedBackPoint = move (Right (V3 0 0 (-1) :: V3 Float)) rotatedPoint2 - putStr "tmpPoint: " - print tmpPoint - putStr "movedPoint: " - print movedPoint - putStr "debugGetCenteredObject movedPoint: " - print $ debugGetCenteredObject movedPoint - putStr "rotatedPoint: " - print rotatedPoint - putStr "rotatedPoint2: " - print rotatedPoint2 - putStr "movedBackPoint: " - print movedBackPoint - initialize [InitVideo] window <- @@ -143,21 +124,11 @@ 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 - move :: Either (V2 Float) (V3 Float) -> a -> a - movePrecise :: a -> 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 @@ -166,109 +137,54 @@ 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 - move (Left d2) (P2 p2D) = P2 $ p2D + d2 - move (Right d3) (P2 p2D) = P3 $ (\x -> V3 (head x) (last x) (0 :: Float)) (toList p2D) + d3 - move (Left d2) (P3 p3D) = P3 $ (\x -> V3 (head x) (last x) (0 :: Float)) (toList d2) + p3D - move (Right d3) (P3 p3D) = P3 $ p3D + d3 - movePrecise a (P2 b) = move (Left b) a - movePrecise a (P3 b) = move (Right b) a - 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 +p3 :: Float -> Float -> Float -> Pointrel +p3 x y z = P3 (V3 x y z) -newtype Line = Line (Pointrel, Pointrel) deriving (Show) -toLines :: [(Pointrel, Pointrel)] -> [Line] -toLines = map Line -unLine :: Line -> (Pointrel, Pointrel) -unLine (Line points) = points +type Line = (Pointrel, Pointrel) -instance Drawable Line where - draw window renderer (Line points) = get (windowSize window) >>= (\size -> uncurry (drawLine renderer) $ bimap (tosdl size) (tosdl size) points) - move a (Line (b, c)) = Line (move a b, move a c) - movePrecise (Line (a1, b1)) (Line (a2, b2)) = Line (movePrecise a1 a2, movePrecise b1 b2) - absRotate dir1 dir2 ang (Line line) = Line $ bimap (absRotate dir1 dir2 ang) (absRotate dir1 dir2 ang) line - rotate dir1 dir2 ang (Line (P2 p_1, P2 p_2)) = let mid = (p_1 + p_2) / 2 in move (Left mid) $ absRotate dir1 dir2 ang $ Line (P2 (p_1 - mid), P2 (p_2 - mid)) - rotate dir1 dir2 ang (Line (P2 _p_1, P3 p_2)) = - let - p_1 = toP3 (P2 _p_1) - mid = (p_1 + p_2) / 2 - in - move (Right mid) $ absRotate dir1 dir2 ang $ Line (P3 (p_1 - mid), P3 (p_2 - mid)) - rotate dir1 dir2 ang (Line (P3 p_1, P2 _p_2)) = - let - p_2 = toP3 (P2 _p_2) - mid = (p_1 + p_2) / 2 - in - move (Right mid) $ absRotate dir1 dir2 ang $ Line (P3 (p_1 - mid), P3 (p_2 - mid)) - rotate dir1 dir2 ang (Line (P3 p_1, P3 p_2)) = let mid = (p_1 + p_2) / 2 in move (Right mid) $ absRotate dir1 dir2 ang $ Line (P3 (p_1 - mid), P3 (p_2 - mid)) - -data Object = Lines ([Line], Pointrel) | Points ([Pointrel], Pointrel) deriving (Show) - -instance Drawable Object where - draw window renderer (Lines (obj, _)) = mapM_ (draw window renderer) obj - draw window renderer (Points (obj, _)) = mapM_ (draw window renderer) obj - move a (Lines (b, c)) = Lines (map (move a) b, move a c) - move a (Points (b, c)) = Points (map (move a) b, move a c) - movePrecise _ = id - absRotate dir1 dir2 ang (Lines (obj, center)) = Lines (map (absRotate dir1 dir2 ang) obj, center) - absRotate dir1 dir2 ang (Points (obj, center)) = Points (map (absRotate dir1 dir2 ang) obj, center) - rotate dir1 dir2 ang (Lines (obj, P3 center)) = move (Right center) $ absRotate dir1 dir2 ang $ Lines (map (move $ Right $ center * (-1)) obj, p3 0 0 0) - rotate dir1 dir2 ang (Lines (obj, P2 center)) = move (Left center) $ absRotate dir1 dir2 ang $ Lines (map (move $ Left $ center * (-1)) obj, p2 0 0) - rotate dir1 dir2 ang (Points (obj, P3 center)) = move (Right center) $ absRotate dir1 dir2 ang $ Points (map (move $ Right $ center * (-1)) obj, p3 0 0 0) - rotate dir1 dir2 ang (Points (obj, P2 center)) = move (Left center) $ absRotate dir1 dir2 ang $ Points (map (move $ Left $ center * (-1)) obj, p2 0 0) - -debugGetCenteredObject :: Object -> Object -debugGetCenteredObject (Lines (obj, P3 center)) = Lines (map (move $ Right $ center * (-1)) obj, P3 center) -debugGetCenteredObject (Lines (obj, P2 center)) = Lines (map (move $ Left $ center * (-1)) obj, P2 center) -debugGetCenteredObject (Points (obj, P3 center)) = Points (map (move $ Right $ center * (-1)) obj, P3 center) -debugGetCenteredObject (Points (obj, P2 center)) = Points (map (move $ Left $ center * (-1)) obj, P2 center) +type Object = [Line] {- FOURMOLU_DISABLE -} square :: Object square = - Lines - ( toLines - [ (p3 (-1) (-1) 0, p3 1 (-1) 0), - (p3 (-1) (-1) 0, p3 (-1) 1 0), - (p3 (-1) (-1) 0, p3 (-1) (-1) 2), + [ (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 1 1 0, p3 1 1 2), - (p3 1 1 0, p3 1 (-1) 0), - (p3 1 1 0, p3 (-1) 1 0), + (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 (-1) 1 2, p3 1 1 2), - (p3 (-1) 1 2, p3 (-1) (-1) 2), - (p3 (-1) 1 2, p3 (-1) 1 0), + (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 1 (-1) 2, p3 1 1 2), - (p3 1 (-1) 2, p3 (-1) (-1) 2), - (p3 1 (-1) 2, p3 1 (-1) 0) - ], - p3 0 0 1 - ) + + (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 = +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 = +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 ((z * c) - (s * x)) -_rotate Y Z ang pnt = + 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" +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 = @@ -308,32 +224,35 @@ loop renderer window = do rendererDrawColor renderer $= V4 0 0 0 255 - -- size <- get $ windowSize window + size <- get $ windowSize window - -- oldObjs <- readIORef objects + oldObjs <- readIORef objects - -- readIORef delta >>= writeIORef delta . (+ (0.05 / fromIntegral fps)) + mapM_ (mapM_ (bimapM_ (logPutStr logState . flip (++) " " . show . toP3) (logPrint logState . toP3)) . snd) oldObjs + logPutStrLn logState "" + logPutStrLn logState "rotateprint" + mapM_ (mapM_ (bimapM_ (rotateprint pi . toP3) (rotateprint pi . toP3)) . snd) oldObjs + logPutStrLn logState "rotateprint" + + logPutStrLn logState "" + + readIORef delta >>= writeIORef delta . (+ (0.25 / 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 snd -- <&> map (rotate Y Z ang . snd) - mapM_ (logPrint logState) rotated + 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 (move (Right (V3 0 0 tmpDelta))) rotated - mapM_ (logPrint logState) moved + 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_ (draw window renderer . rotate Y Z ang . rotate X Y ang . rotate X Z ang) moved - -- mapM_ (draw window renderer) moved + mapM_ (mapM_ (uncurry (drawLine renderer) . bimap (tosdl size) (tosdl size))) moved present renderer - writeIORef delta $ (+) tmpDelta $ 0.25 / fromIntegral fps unless (or stop) continue where continue = threadDelay (1000000 `div` fps) >> loop renderer window @@ -346,11 +265,7 @@ loop renderer window = do - and finally from 0..2 to 0..1 -} to2D :: Point3D -> Point2D -to2D pointin - | last vec == 0 = to2D $ pointin + V3 0 0 0.01 - | otherwise = V2 (head vec / last vec) ((vec !! 1) / last vec) - where - vec = toList pointin +to2D = (\vec -> V2 (head vec / last vec) (vec !! 1 / last vec)) . toList {- - size `toIntegral` @@ -361,5 +276,5 @@ to2D pointin - 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 (P2 rel) = P $ fmap round $ fmap fromIntegral size * (1 - (rel + 1) / 2) tosdl size (P3 rel) = tosdl size $ P2 $ to2D rel