Dario48/haskell-game
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

partial rewrite of type logic

Browse source
This commit is contained in:
Dario48 2025-12-31 16:47:58 +01:00
commit 2eecc8990e
1 changed files with 60 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

96
app/Main.hs
View file

@ -1,14 +1,17 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Main where module Main where
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Monad (unless) import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO)
import Data.Bifoldable (bimapM_) import Data.Bifoldable (bimapM_)
import Data.Bifunctor (Bifunctor (bimap, second)) import Data.Bifunctor (Bifunctor (bimap, second))
import Data.Foldable (Foldable (toList)) import Data.Foldable (Foldable (toList))
import Data.Functor ((<&>)) import Data.Functor ((<&>))
import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Kind (Type)
import Data.StateVar (StateVar (StateVar), makeStateVar, mapStateVar) import Data.StateVar (StateVar (StateVar), makeStateVar, mapStateVar)
import Foreign.C (CInt) import Foreign.C (CInt)
import SDL ( import SDL (
@ -37,6 +40,7 @@ import SDL (
defaultWindow, defaultWindow,
destroyWindow, destroyWindow,
drawLine, drawLine,
drawPoint,
get, get,
initialize, initialize,
pollEvents, pollEvents,
@ -53,7 +57,7 @@ import System.IO.Unsafe (unsafePerformIO)
import Text.Printf (PrintfType, printf) import Text.Printf (PrintfType, printf)
fps :: Int fps :: Int
fps = 144 fps = 1
data LoggingState = On | Off data LoggingState = On | Off
@ -124,11 +128,19 @@ type Point3D = V3 Float
type Line3D = (Point3D, Point3D) 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) data Pointrel = P2 Point2D | P3 Point3D deriving (Show)
p2 :: Float -> Float -> Pointrel p2 :: Float -> Float -> Pointrel
p2 x y = P2 (V2 x y) 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 :: Pointrel -> Point2D
toP2 (P2 pnt) = pnt toP2 (P2 pnt) = pnt
toP2 (P3 pnt) = to2D pnt toP2 (P3 pnt) = to2D pnt
@ -137,17 +149,32 @@ toP3 :: Pointrel -> Point3D
toP3 (P3 pnt) = pnt toP3 (P3 pnt) = pnt
toP3 (P2 pnt) = let oldvec = toList pnt in V3 (head oldvec) (last oldvec) 0 toP3 (P2 pnt) = let oldvec = toList pnt in V3 (head oldvec) (last oldvec) 0
p3 :: Float -> Float -> Float -> Pointrel instance Drawable Pointrel where
p3 x y z = P3 (V3 x y z) 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
type Line = (Pointrel, Pointrel) newtype Line = Line (Pointrel, Pointrel)
toLines :: [(Pointrel, Pointrel)] -> [Line]
toLines = map Line
unLine :: Line -> (Pointrel, Pointrel)
unLine (Line points) = points
type Object = [Line] 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 -} {- FOURMOLU_DISABLE -}
square :: Object square :: Object
square = 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),
@ -155,36 +182,34 @@ square =
(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),
(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 -} {- FOURMOLU_ENABLE -}
data Direction = X | Y | Z data Direction = X | Y | Z
rotate :: Direction -> Direction -> Float -> Point3D -> Point3D _rotate :: Direction -> Direction -> Float -> Point3D -> Point3D
rotate X Y ang pnt = _rotate X Y ang pnt =
let (c, s, toRotate, x, y, z) = (cos ang, sin ang, toList pnt, head toRotate, toRotate !! 1, last toRotate) 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 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) 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)) in V3 ((x * c) - (z * s)) y ((x * s) + (z * c))
rotate Y Z ang pnt = _rotate Y Z ang pnt =
let (c, s, toRotate, x, y, z) = (cos ang, sin ang, toList pnt, head toRotate, toRotate !! 1, last toRotate) 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)) in V3 x ((y * c) - (z * s)) ((y * s) + (z * c))
rotate Y X a p = rotate X Y a p _rotate Y X a p = _rotate X Y a p
rotate Z X a p = rotate X Z a p _rotate Z X a p = _rotate X Z a p
rotate Z Y a p = rotate Y 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 X X _ _ = error "cant't rotate around 2 axis simultaniously"
rotate Y Y _ _ = 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 Z Z _ _ = error "cant't rotate around 2 axis simultaniously"
_rotateprint :: LoggingState -> Float -> Point3D -> IO () _rotateprint :: LoggingState -> Float -> Point3D -> IO ()
_rotateprint On ang pnt = _rotateprint On ang pnt =
@ -228,15 +253,8 @@ loop renderer window = do
oldObjs <- readIORef objects oldObjs <- readIORef objects
mapM_ (mapM_ (bimapM_ (logPutStr logState . flip (++) " " . show . toP3) (logPrint logState . toP3)) . snd) oldObjs -- readIORef delta >>= writeIORef delta . (+ (0.25 / fromIntegral fps))
logPutStrLn logState "" readIORef delta >>= writeIORef delta . (+ (0.05 / fromIntegral fps))
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 tmpDelta <- readIORef delta
let ang = 2 * pi * tmpDelta 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 . (+) (V3 0 0 delta) . toP3) (P3 . (+) (V3 0 0 delta) . toP3)))))
@ -249,6 +267,8 @@ loop renderer window = do
readIORef objects >>= mapM_ (mapM_ (logPrint logState) . snd) readIORef objects >>= mapM_ (mapM_ (logPrint logState) . snd)
logPutStrLn logState "" 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 mapM_ (mapM_ (uncurry (drawLine renderer) . bimap (tosdl size) (tosdl size))) moved
present renderer present renderer
@ -265,7 +285,11 @@ loop renderer window = do
- and finally from 0..2 to 0..1 - and finally from 0..2 to 0..1
-} -}
to2D :: Point3D -> Point2D to2D :: Point3D -> Point2D
to2D = (\vec -> V2 (head vec / last vec) (vec !! 1 / last vec)) . toList 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` - size `toIntegral`
@ -276,5 +300,5 @@ to2D = (\vec -> V2 (head vec / last vec) (vec !! 1 / last vec)) . toList
- return it in point form - return it in point form
-} -}
tosdl :: V2 CInt -> Pointrel -> Point V2 CInt 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 tosdl size (P3 rel) = tosdl size $ P2 $ to2D rel