From 7e72c05b0bca74a6b70818945f0378ba0abfb1b6 Mon Sep 17 00:00:00 2001 From: Dario48 Date: Mon, 29 Dec 2025 01:48:14 +0100 Subject: [PATCH 1/4] .git/COMMIT_EDITMSG --- README.md | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 README.md diff --git a/README.md b/README.md new file mode 100644 index 0000000..4f3cbcf --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +# Haskel game +what if game, but in haskel? +a game made in Haskell with the sdl2 library +not a game yet + +to build execute: +```sh +cabal build +``` +to run execute: +```sh +cabal run +``` From 9c6f8eedc5741566a08b16a2015dea1031617df1 Mon Sep 17 00:00:00 2001 From: Dario48 Date: Tue, 30 Dec 2025 21:31:42 +0100 Subject: [PATCH 2/4] functional(ish) rotation on a single axis --- app/Main.hs | 297 ++++++++++++++++++++++++++++++++++++--------- fourmolu.yaml | 77 ++++++++++++ haskell-game.cabal | 4 +- 3 files changed, 318 insertions(+), 60 deletions(-) create mode 100644 fourmolu.yaml diff --git a/app/Main.hs b/app/Main.hs index e65418b..a055f8e 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,50 +2,108 @@ module Main where +import Control.Concurrent (threadDelay) import Control.Monad (unless) -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), - InitFlag (InitVideo), - InputMotion (Pressed, Released), - KeyboardEventData (keyboardEventKeyMotion, keyboardEventKeysym), - Keysym (keysymKeycode), - Point (P), - Renderer, - V2 (V2), - V4 (V4), - Window, - WindowConfig (windowGraphicsContext, windowInitialSize), - WindowGraphicsContext (OpenGLContext), - clear, - createRenderer, - createWindow, - defaultOpenGL, - defaultRenderer, - defaultWindow, - destroyWindow, - drawLine, - get, - initialize, - present, - quit, - rendererDrawColor, - waitEvent, - windowSize, - ($=), - ) +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, + 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 = 144 + +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 600} + defaultWindow{windowGraphicsContext = OpenGLContext defaultOpenGL, windowInitialSize = V2 800 800} renderer <- createRenderer window (-1) defaultRenderer @@ -55,30 +113,111 @@ main = do quit -loop :: Renderer -> Window -> IO () -loop renderer window = waitEvent >>= _loop renderer window - exitCodes :: [Keycode] exitCodes = [KeycodeQ, KeycodeEscape] -triangle :: [(V2 Float, V2 Float)] -triangle = - [ (V2 0.25 0.75, V2 0.5 0.25), - (V2 0.5 0.25, V2 0.75 0.75), - (V2 0.75 0.75, V2 0.25 0.75) - ] +type Point2D = V2 Float -_loop :: Renderer -> Window -> Event -> IO () -_loop renderer window event = do - let stop = - case eventPayload event of - QuitEvent -> True +type Line2D = (Point2D, Point2D) + +type Point3D = V3 Float + +type Line3D = (Point3D, Point3D) + +data Pointrel = P2 Point2D | P3 Point3D deriving (Show) + +p2 :: Float -> Float -> Pointrel +p2 x y = P2 (V2 x y) + +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 + +p3 :: Float -> Float -> Float -> Pointrel +p3 x y z = P3 (V3 x y z) + +type Line = (Pointrel, Pointrel) + +type Object = [Line] + +{- FOURMOLU_DISABLE -} +square :: Object +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)) + + ] +{- 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 -> False + Pressed -> return False Released - | keyof kevent `elem` exitCodes -> True - | otherwise -> False - _ -> False + | keyof kevent `elem` exitCodes -> return True + | otherwise -> return False + _ -> return False + ) + events rendererDrawColor renderer $= V4 255 255 255 255 clear renderer @@ -86,14 +225,56 @@ _loop renderer window event = do rendererDrawColor renderer $= V4 0 0 0 255 size <- get $ windowSize window - mapM_ (uncurry (drawLine renderer) . bimap (tosdl size) (tosdl size)) triangle + + oldObjs <- readIORef objects + + 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 (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 "" + + mapM_ (mapM_ (uncurry (drawLine renderer) . bimap (tosdl size) (tosdl size))) moved present renderer - unless stop continue - where - continue = waitEvent >>= _loop renderer window - keyof = keysymKeycode . keyboardEventKeysym + unless (or stop) continue + where + continue = threadDelay (1000000 `div` fps) >> loop renderer window + keyof = keysymKeycode . keyboardEventKeysym -tosdl :: V2 CInt -> V2 Float -> Point V2 CInt -tosdl size rel = P $ fmap round $ fmap fromIntegral size * rel +{- + - 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 = (\vec -> V2 (head vec / last vec) (vec !! 1 / last vec)) . toList + +{- + - 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 diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..0d3efb9 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,77 @@ +# Number of spaces per indentation step +indentation: 2 + +# Max line length for automatic line breaking +column-limit: none + +# Styling of arrows in type signatures (choices: trailing, leading, or leading-args) +function-arrows: trailing + +# How to place commas in multi-line lists, records, etc. (choices: leading or trailing) +comma-style: trailing + +# Styling of import/export lists (choices: leading, trailing, or diff-friendly) +import-export-style: diff-friendly + +# Rules for grouping import declarations +import-grouping: legacy + +# Whether to full-indent or half-indent 'where' bindings past the preceding body +indent-wheres: false + +# Whether to leave a space before an opening record brace +record-brace-space: false + +# Number of spaces between top-level declarations +newlines-between-decls: 1 + +# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) +haddock-style: multi-line + +# How to print module docstring +haddock-style-module: null + +# Where to put docstring comments in function signatures (choices: auto, leading, or trailing) +haddock-location-signature: auto + +# Styling of let blocks (choices: auto, inline, newline, or mixed) +let-style: auto + +# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) +in-style: right-align + +# Styling of if-statements (choices: indented or hanging) +if-style: indented + +# Whether to put parentheses around a single constraint (choices: auto, always, or never) +single-constraint-parens: always + +# Whether to put parentheses around a single deriving class (choices: auto, always, or never) +single-deriving-parens: always + +# Whether to sort constraints +sort-constraints: false + +# Whether to sort derived classes +sort-derived-classes: false + +# Whether to sort deriving clauses +sort-deriving-clauses: false + +# Whether to place section operators (those that are infixr 0, such as $) in trailing position, continuing the expression indented below +trailing-section-operators: true + +# Output Unicode syntax (choices: detect, always, or never) +unicode: detect + +# Give the programmer more choice on where to insert blank lines +respectful: true + +# Fixity information for operators +fixities: [] + +# Module reexports Fourmolu should know about +reexports: [] + +# Modules defined by the current Cabal package for import grouping +local-modules: [] diff --git a/haskell-game.cabal b/haskell-game.cabal index 854856f..99684aa 100644 --- a/haskell-game.cabal +++ b/haskell-game.cabal @@ -49,7 +49,7 @@ category: Game build-type: Simple -- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. -extra-doc-files: CHANGELOG.md +extra-doc-files: README.md -- Extra source files to be distributed with the package, such as examples, or a tutorial module. -- extra-source-files: @@ -71,7 +71,7 @@ executable haskell-game -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base ^>=4.18.3.0, sdl2 >= 2.5.5.1 + build-depends: base ^>=4.18.3.0, sdl2 >= 2.5.5.1, StateVar -- Directories containing source files. hs-source-dirs: app From 2eecc8990ef17f65a76451e980bb4887728f260e Mon Sep 17 00:00:00 2001 From: Dario48 Date: Wed, 31 Dec 2025 16:47:58 +0100 Subject: [PATCH 3/4] partial rewrite of type logic --- app/Main.hs | 96 +++++++++++++++++++++++++++++++++-------------------- 1 file changed, 60 insertions(+), 36 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index a055f8e..c75103c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,14 +1,17 @@ +{-# 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 ( @@ -37,6 +40,7 @@ import SDL ( defaultWindow, destroyWindow, drawLine, + drawPoint, get, initialize, pollEvents, @@ -53,7 +57,7 @@ import System.IO.Unsafe (unsafePerformIO) import Text.Printf (PrintfType, printf) fps :: Int -fps = 144 +fps = 1 data LoggingState = On | Off @@ -124,11 +128,19 @@ 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 @@ -137,17 +149,32 @@ toP3 :: Pointrel -> Point3D toP3 (P3 pnt) = pnt toP3 (P2 pnt) = let oldvec = toList pnt in V3 (head oldvec) (last oldvec) 0 -p3 :: Float -> Float -> Float -> Pointrel -p3 x y z = P3 (V3 x y z) +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 -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 -} square :: Object -square = - [ (p3 (-0.5) (-0.5) (-0.5), p3 0.5 (-0.5) (-0.5)), +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), @@ -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)) ] {- 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 ((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) 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 = @@ -228,15 +253,8 @@ loop renderer window = do oldObjs <- readIORef objects - 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)) + -- 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))))) @@ -249,6 +267,8 @@ loop renderer window = do 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 @@ -265,7 +285,11 @@ loop renderer window = do - and finally from 0..2 to 0..1 -} 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` @@ -276,5 +300,5 @@ to2D = (\vec -> V2 (head vec / last vec) (vec !! 1 / last vec)) . toList - 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 From d284e7f6d3e47efe6f294a577f2fa96bbc4acd10 Mon Sep 17 00:00:00 2001 From: Dario48 Date: Mon, 2 Feb 2026 16:51:05 +0100 Subject: [PATCH 4/4] almost complete type overhaul, working relative rotation --- app/Main.hs | 147 +++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 104 insertions(+), 43 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index c75103c..a36eddc 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -6,31 +6,25 @@ 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.Bifunctor (Bifunctor (bimap)) 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), + WindowConfig (windowGraphicsContext, windowInitialSize), WindowGraphicsContext (OpenGLContext), clear, createRenderer, @@ -47,17 +41,15 @@ import SDL ( present, quit, rendererDrawColor, - setHintWithPriority, - waitEvent, windowSize, ($=), ) import SDL.Input.Keyboard.Codes import System.IO.Unsafe (unsafePerformIO) -import Text.Printf (PrintfType, printf) +import Text.Printf (printf) fps :: Int -fps = 1 +fps = 60 data LoggingState = On | Off @@ -102,6 +94,29 @@ 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 <- @@ -132,6 +147,8 @@ 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) @@ -151,12 +168,18 @@ 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 + 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 -newtype Line = Line (Pointrel, Pointrel) +newtype Line = Line (Pointrel, Pointrel) deriving (Show) toLines :: [(Pointrel, Pointrel)] -> [Line] toLines = map Line unLine :: Line -> (Pointrel, Pointrel) @@ -164,32 +187,68 @@ 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) + 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] | Points [Pointrel] +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 + 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) {- 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), +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 + ) {- FOURMOLU_ENABLE -} data Direction = X | Y | Z @@ -200,7 +259,7 @@ _rotate X Y ang pnt = 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)) + in V3 ((x * c) + (z * s)) y ((z * c) - (s * x)) _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)) @@ -249,30 +308,32 @@ 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.25 / fromIntegral fps)) - readIORef delta >>= writeIORef delta . (+ (0.05 / 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) + rotated <- readIORef objects <&> map snd -- <&> map (rotate Y Z ang . snd) + mapM_ (logPrint logState) rotated -- 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 + let moved = map (move (Right (V3 0 0 tmpDelta))) rotated + mapM_ (logPrint logState) moved - 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 + -- 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 present renderer + writeIORef delta $ (+) tmpDelta $ 0.25 / fromIntegral fps unless (or stop) continue where continue = threadDelay (1000000 `div` fps) >> loop renderer window @@ -286,8 +347,8 @@ loop renderer window = do -} to2D :: Point3D -> Point2D to2D pointin - | last vec == 0 = to2D $ pointin * V3 1 (-1) 1 - | otherwise = V2 (head vec / last vec) (vec !! 1 / last vec) + | last vec == 0 = to2D $ pointin + V3 0 0 0.01 + | otherwise = V2 (head vec / last vec) ((vec !! 1) / last vec) where vec = toList pointin