not-gloss-examples 0.1 → 0.2
raw patch · 2 files changed
+115/−7 lines, 2 filesdep +GLUTdep +X11dep +containersdep ~not-glossdep ~spatial-mathnew-component:exe:not-gloss-game
Dependencies added: GLUT, X11, containers
Dependency ranges changed: not-gloss, spatial-math
Files
- not-gloss-examples.cabal +17/−7
- src/Play.hs +98/−0
not-gloss-examples.cabal view
@@ -1,5 +1,5 @@ name: not-gloss-examples-version: 0.1+version: 0.2 stability: Experimental synopsis: examples for not-gloss license: BSD3@@ -13,22 +13,32 @@ executable not-gloss-display main-is: src/Display.hs- build-depends: not-gloss == 0.3.*,- spatial-math == 0.1.*,+ build-depends: not-gloss == 0.4.*,+ spatial-math >= 0.1.4 && < 0.2, base == 4.5.* ghc-options: -threaded -O2 executable not-gloss-animate main-is: src/Animate.hs- build-depends: not-gloss == 0.3.*,- spatial-math == 0.1.*,+ build-depends: not-gloss == 0.4.*,+ spatial-math >= 0.1.4 && < 0.2, base == 4.5.* ghc-options: -threaded -O2 executable not-gloss-simulate main-is: src/Simulate.hs- build-depends: not-gloss == 0.3.*,- spatial-math == 0.1.*,+ build-depends: not-gloss == 0.4.*,+ spatial-math >= 0.1.4 && < 0.2,+ base == 4.5.*+ ghc-options: -threaded -O2++executable not-gloss-game+ main-is: src/Play.hs+ build-depends: not-gloss == 0.4.*,+ spatial-math >= 0.1.4 && < 0.2,+ GLUT == 2.3.*,+ containers == 0.4.*,+ X11, base == 4.5.* ghc-options: -threaded -O2
+ src/Play.hs view
@@ -0,0 +1,98 @@+{-# OPTIONS_GHC -Wall #-}++module Main ( main+ ) where++import SpatialMath+import qualified Xyz+import Graphics.X11 ( initThreads )+import Vis+import Graphics.UI.GLUT hiding ( motionCallback )+import qualified Data.Set as Set++import Control.Monad ( when )++ts :: Double+ts = 0.01++faceHeight :: Double+faceHeight = 1.5++data PlayerState = Running (Xyz Double) (Xyz Double) (Euler Double)++data GameState = GameState { playerState :: PlayerState+ , keySet :: Set.Set Key+ , lastMousePos :: Maybe (GLint,GLint)+ }++toVertex :: (Real a, Fractional b) => Xyz a -> Vertex3 b+toVertex xyz = (\(Xyz x y z) -> Vertex3 x y z) $ fmap realToFrac xyz++setCamera :: PlayerState -> IO ()+setCamera (Running (Xyz x y z) _ euler) = lookAt (toVertex xyz0) (toVertex target) (Vector3 0 0 (-1))+ where+ xyz0 = Xyz x y (z-faceHeight)+ target = xyz0 + rotVecByEulerB2A euler (Xyz 1 0 0)++simfun :: Float -> GameState -> IO GameState+simfun _ (GameState (Running pos _ euler0@(Euler yaw _ _)) keys lmp) = do+ Size x y <- get windowSize+ let x' = (fromIntegral x) `div` 2+ y' = (fromIntegral y) `div` 2++ when (Just (x',y') /= lmp) (pointerPosition $= (Position x' y'))+ return $ GameState (Running (pos + (Xyz.scale ts v)) v euler0) keys (Just (x',y'))+ where+ v = rotateXyzAboutZ (Xyz (w-s) (d-a) 0) (-yaw)+ where+ w = if Set.member (Char 'w') keys then 3 else 0+ a = if Set.member (Char 'a') keys then 3 else 0+ s = if Set.member (Char 's') keys then 3 else 0+ d = if Set.member (Char 'd') keys then 3 else 0++keyMouseCallback :: GameState -> Key -> KeyState -> Modifiers -> Position -> GameState+keyMouseCallback state0 key keystate _ _+ | keystate == Down = state0 {keySet = Set.insert key (keySet state0)}+ | keystate == Up = state0 {keySet = Set.delete key (keySet state0)}+ | otherwise = state0++motionCallback :: Bool -> GameState -> Position -> GameState+motionCallback _ state0@(GameState (Running pos v (Euler yaw0 pitch0 _)) _ lmp) (Position x y) =+ state0 {playerState = newPlayerState, lastMousePos = Just (x,y)}+ where+ (x0,y0) = case lmp of Nothing -> (x,y)+ Just (x0',y0') -> (x0',y0')+ newPlayerState = Running pos v (Euler yaw pitch 0)+ dx = 0.002*realToFrac (x - x0)+ dy = 0.002*realToFrac (y - y0)+ yaw = yaw0 + dx+ pitch = bound (-89) 89 (pitch0 - dy)+ bound min' max' val+ | val < min' = min'+ | val > max' = max'+ | otherwise = val+ ++drawfun :: GameState -> VisObject Double+drawfun (GameState (Running _ _ _) _ _) =+ VisObjects $ [axes,box,ellipsoid,sphere] ++ (map text [-5..5]) ++ [boxText, plane] + where+ x' = -1+ axes = VisAxes (0.5, 15) (Xyz 0 0 0) (Quat 1 0 0 0)+ sphere = VisSphere 0.15 (Xyz 0 x' (-1)) Wireframe (makeColor 0.2 0.3 0.8 1)+ ellipsoid = VisEllipsoid (0.2, 0.3, 0.4) (Xyz x' 0 (-1)) (Quat 1 0 0 0) Solid (makeColor 1 0.3 0.5 1)+ box = VisBox (0.2, 0.2, 0.2) (Xyz 0 0 x') (Quat 1 0 0 0) Wireframe (makeColor 0 1 1 1)+ plane = VisPlane (Xyz 0 0 1) 0 (makeColor 1 1 1 1) (makeColor 0.4 0.6 0.65 0.4)+ text k = Vis2dText "OLOLOLOLOLO" (100,500 - k*100*x') TimesRoman24 (makeColor 0 (0.5 + x''/2) (0.5 - x''/2) 1)+ where+ x'' = realToFrac $ (x' + 1)/0.4*k/5+ boxText = Vis3dText "trololololo" (Xyz 0 0 (x'-0.2)) TimesRoman24 (makeColor 1 0 0 1)++main :: IO ()+main = do+ let state0 = GameState (Running (Xyz (-2) 0 0) 0 (Euler 0 0 0)) (Set.empty) Nothing+ setCam (GameState x _ _) = setCamera x+ drawfun' x = return (drawfun x, Just None)+ _ <- initThreads+ playIO ts state0 drawfun' simfun setCam+ (Just keyMouseCallback) (Just (motionCallback True)) (Just (motionCallback False))