functional(ish) rotation on a single axis

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
+```

app/Main.hs

@@ -2,22 +2,32 @@
 
 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
+import SDL (
-  ( Event (eventPayload),
+  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,
@@ -29,23 +39,71 @@ import SDL
   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)]
+type Point2D = 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)
-  ]
 
-_loop :: Renderer -> Window -> Event -> IO ()
+type Line2D = (Point2D, Point2D)
-_loop renderer window event = do
+
-  let stop =
+type Point3D = V3 Float
-        case eventPayload event of
+
-          QuitEvent -> True
+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
+              | keyof kevent `elem` exitCodes -> return True
-              | otherwise -> False
+              | otherwise -> return False
-          _ -> 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
+  unless (or stop) continue
  where
-    continue = waitEvent >>= _loop renderer window
+  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

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: []

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