module Render (render, initGL, runMenu) where import FRP.Yampa.Geometry import GHC.Exts (sortWith) import Graphics.UI.GLUT hiding (MenuEntry) import Graphics.Rendering.OpenGL.Raw import qualified Graphics.UI.GLUT as G(Vector3(..)) import Foreign ( withForeignPtr, plusPtr, alloca, peek ) import qualified Data.ByteString.Internal as BSI import Data.Time.Clock import Foreign.C.Types import Data.IORef import Data.Maybe (isJust, fromJust) import Data.List import Control.Monad import Control.Applicative ((<$>)) import States import Global import Object import BasicTypes import Util import Message import Helper import Menu import Paths_Rasenschach renderObjects :: Param -> [ObsObjState] -> GraphicsData -> IO () renderObjects param oos graphData = do let texHome = gdTextureHome graphData texAway = gdTextureAway graphData (oldX, oldY, currTZ) <- readIORef (gdCurrentTranslate graphData) clear [ ColorBuffer, DepthBuffer ] loadIdentity let ballOOS = fetchBallOOS oos let Point3 ballX ballY _ = oosPos ballOOS let adjY = ballY - (0.5*pPitchLength param) let adjX = ballX - (0.5*pPitchWidth param) -- don't allow too big adjustments, otherwise ugly flipping around let adjX' = if (adjX - oldX) > 0.5 then oldX + 0.1 * (adjX - oldX) else adjX let adjY' = if (adjY - oldY) > 0.5 then oldY + 0.1 * (adjY - oldY) else adjY writeIORef (gdCurrentTranslate graphData) (adjX', adjY', currTZ) translate $ G.Vector3 (realToFrac $ -adjX'::R) (realToFrac adjY') (-(realToFrac currTZ)) -- -141 -71 scheint so: wenn sich die Entfernung verdoppelt, -- dann doppelt so viel Spielfeld; (29) schiebt den Platz um ein Viertel position (Light 0) $= Vertex4 100 (-100) 50 1 -- 1 0.4 0.8 1 playingField pW pL forM_ sorted $ \os -> case os of OOSBall oosPos' _ _ -- oosBounced' _ -- oosPState -> renderBall (uncurry Point3 (translateToScreen pW pL (realToFrac . point3X $ oosPos') (realToFrac . point3Y $ oosPos')) (realToFrac . point3Z $ oosPos')) OOSPlayer oosPos' _ _ _ _ designated _ (team,_,_) _ _ _ (ts, _) _ -> renderPlayer texHome texAway team (ts==TSNonAI) designated (translateToScreen pW pL (realToFrac . point3X $ oosPos') (realToFrac . point3Y $ oosPos')) OOSGame oosGameTime' oosGameScore' oosGameState' _ -- oosAttacker' _ -> renderGame adjX' adjY' oosGameTime' oosGameScore' oosGameState' flush swapBuffers where sorted = sortWith (point3Z . oosPos) oos pW = realToFrac $ pPitchWidth param pL = realToFrac $ pPitchLength param renderGame :: (Num a1, Ord a1, Real a2, Real a3, RealFrac a, Show a1) => a2 -> a3 -> a -> (a1, a1) -> (GameState, GameMsgParam) -> IO () renderGame adjX' adjY' t (scoreHome, scoreAway) (gState, gStateParam) = do preservingMatrix $ do translate $ G.Vector3 (realToFrac $ adjX'-30::R) (realToFrac (-(adjY'-20))) 0 scale 0.04 0.04 (0.04::GLfloat) let tt = truncate t let (min', sec) = (tt `div` 60, tt `mod` 60) :: (Int, Int) renderString Roman $ show scoreHome ++ " - " ++ show scoreAway ++ " " ++ show min' ++ ":" ++ show sec when (gState == GSKickOff && scoreHome + scoreAway > 0) $ preservingMatrix $ do translate $ G.Vector3 (realToFrac $ adjX'-10::R) (realToFrac (-(adjY'-5))) 0 scale 0.04 0.04 (0.04::GLfloat) renderString Roman "GOAL!" let (GPTeamPosition _ _ _ _ _ _ oop) = gStateParam when (oop == OOPSideOut) $ preservingMatrix $ do translate $ G.Vector3 (realToFrac $ adjX'-10::R) (realToFrac (-(adjY'-5))) 0 scale 0.04 0.04 (0.04::GLfloat) renderString Roman "THROW IN!" when (oop == OOPOffsite) $ preservingMatrix $ do translate $ G.Vector3 (realToFrac $ adjX'-10::R) (realToFrac (-(adjY'-5))) 0 scale 0.04 0.04 (0.04::GLfloat) renderString Roman "OFFSITE!" when (oop == OOPBaseOut) $ preservingMatrix $ do translate $ G.Vector3 (realToFrac $ adjX'-10::R) (realToFrac (-(adjY'-5))) 0 scale 0.04 0.04 (0.04::GLfloat) renderString Roman "CORNER!" translateToScreen :: (Fractional t, Fractional t1) => t -> t1 -> t -> t1 -> (t, t1) translateToScreen pW pL u v = (u - pW/2, (pL-v)-pL/2) render :: Param -> [ObsObjState] -> GraphicsData -> IO () render = renderObjects renderPlayer :: GLuint -> GLuint-> Team -> Bool -> Bool -> (GLfloat, GLfloat) -> DisplayCallback renderPlayer texHome texAway team selected designated pos = do let tex = if team==Home then texHome else texAway blink <- blinker when (team==Home && (not selected || (selected && not blink))) $ color $ Color3 (1.0::GLfloat) (1.0::GLfloat) (1.0::GLfloat) when (team==Away) $ color $ Color3 (1.0::GLfloat) (1.0::GLfloat) (1.0::GLfloat) when (selected && blink) $ color $ Color3 (116/255::GLfloat) (172/255::GLfloat) (223/255::GLfloat) preservingMatrix $ do translate $ Vector3 x y 0.5 renderChip tex 12 6 0.10 when designated $ do translate $ Vector3 (-0.3) (2::R) 0 scale 0.02 0.02 (0.02::GLfloat) renderString Roman "!" where (x,y) = pos renderBall :: RealFloat t => Point3 t -> IO () renderBall pPos = preservingMatrix $ (color red >>) . renderShapeAt (Sphere' 0.60 20 20) $ v where red = Color4 1.0 0.7 0.8 1.0 :: Color4 R Point3 x y z = pPos v = vector3 (realToFrac x) (realToFrac y) (realToFrac z) renderShapeAt s p = preservingMatrix $ do translate $ Vector3 (vector3X p :: R) (vector3Y p :: R) ((vector3Z p :: R)*5) renderObject Solid s playingField :: GLfloat -> GLfloat -> IO () playingField a b = do color $ Color3 (1.0::GLfloat) (1.0::GLfloat) (1.0::GLfloat) renderPrimitive Lines $ mapM_ (pushV a b) vs circle FullCircle 15 0 10 preservingMatrix $ do translate $ G.Vector3 0 41 (0::R) circle LowerHalfCircle 15 6 10 preservingMatrix $ do translate $ G.Vector3 0 (-41) (0::R) circle UpperHalfCircle 15 6 10 where pushV :: GLfloat -> GLfloat -> (GLfloat, GLfloat, GLfloat) -> IO () pushV a' b' (u,v,w) = vertex $ Vertex3 (a'*u/2) (b'*v/2) w vs :: [(GLfloat, GLfloat, GLfloat)] vs = [(-1,-1,0) ,(-1,1, 0) ,(-1,1, 0) ,( 1,1, 0) ,( 1,1, 0) ,(1,-1,0) ,(1,-1,0) ,(-1,-1,0) ,(-1,0,0) ,(1,0,0) -- lower box ,(-0.6,-0.60,0) ,(0.6,-0.60,0) ,(-0.6,-0.60,0) ,(-0.6,-1.00,0) ,(0.6,-0.60,0) ,(0.6,-1.0,0) -- goalie box ,(-0.3,-0.85,0) ,(0.3,-0.85,0) ,(-0.3,-0.85,0) ,(-0.3,-1.0,0) ,(0.3,-0.85,0) ,(0.3,-1.0,0) -- goal ,(-0.12,-0.999,0) ,(-0.12,-0.999,0.1) ,(0.12,-0.999,0) ,(0.12,-0.999,0.1) ,(-0.12,-0.999,0.1) ,(0.12,-0.999,0.1) ,(-0.12,-0.999,0.1) ,(-0.12,-1.05,0) ,(0.12,-0.999,0.1) ,(0.12,-1.05,0) ,(-0.12,-1.05,0) ,(0.12,-1.05,0) -- upper box ,(-0.6,0.60,0) ,(0.6,0.60,0) ,(-0.6,0.60,0) ,(-0.6,1.0,0) ,(0.6,0.60,0) ,(0.6,1.0,0) -- goalie box ,(-0.3,0.85,0) ,(0.3,0.85,0) ,(-0.3,0.85,0) ,(-0.3,1.0,0) ,(0.3,0.85,0) ,(0.3,1.0,0) -- goal ,(-0.12,0.999,0) ,(-0.12,0.999,0.1) ,(0.12,0.999,0) ,(0.12,0.999,0.1) ,(-0.12,0.999,0.1) ,(0.12,0.999,0.1) ,(-0.12,0.999,0.1) ,(-0.12,1.05,0) ,(0.12,0.999,0.1) ,(0.12,1.05,0) ,(-0.12,1.05,0) ,(0.12,1.05,0) ] initGL :: IO (Window, GraphicsData) initGL = do ws <- newIORef (1200,1000) ct <- newIORef (0,0,71) getArgsAndInitialize initialDisplayMode $= [DoubleBuffered] initialWindowSize $= Size 1200 1000 win <- createWindow "Rasenschach!" initialDisplayMode $= [ WithDepthBuffer ] depthFunc $= Just Less glEnable gl_TEXTURE_2D glShadeModel gl_SMOOTH clearColor $= Color4 (151/255) (197/255) (7/255) 0 -- 151 197 7 light (Light 0) $= Enabled lighting $= Enabled lightModelAmbient $= Color4 0.5 0.5 0.5 1 diffuse (Light 0) $= Color4 1 1 1 1 blend $= Enabled blendFunc $= (SrcAlpha, OneMinusSrcAlpha) colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse) reshapeCallback $= Just (resizeScene ws) fn1 <- getDataFileName "argentina.bmp" texHome <-loadTexture fn1 fn2 <- getDataFileName "england2.bmp" texAway <-loadTexture fn2 return (win, GraphicsData ws 141 ct texHome texHome texHome texAway texAway texAway) -- Copied from reactive-glut resizeScene :: IORef (Int, Int) -> Size -> IO () resizeScene ws (Size w 0) = resizeScene ws (Size w 1) -- prevent divide by zero resizeScene ws s@(Size width height) = do writeIORef ws (fromIntegral width, fromIntegral height) viewport $= (Position 0 0, s) matrixMode $= Projection loadIdentity perspective 45 (w2/h2) 1 1000 matrixMode $= Modelview 0 flush where w2 = half' width h2 = half' height half' z = realToFrac z / 2 -- -------------------------------------------------------------------- -- A B H I E R C H I P - C O D E -- -------------------------------------------------------------------- quadrToTripel :: (t, t1, t2, t3) -> (t1, t2, t3) quadrToTripel (_,b,c,d) = (b,c,d) pushTriangle :: ((GLfloat, GLfloat, GLfloat, GLfloat) ,(GLfloat, GLfloat, GLfloat, GLfloat) ,(GLfloat, GLfloat, GLfloat, GLfloat)) -> IO () pushTriangle (p0, p1, p2) = do let (dir,_,d0,_)=p0 let (_,_,d1,_)=p1 let (_,_,d2,_)=p2 let (p0',p1',p2') = (quadrToTripel p0, quadrToTripel p1, quadrToTripel p2) --if it points upwards, reverse normal let d=if d0+d1+d2>0 then (-1) else 1 let n = cross (minus p1' p0') (minus p2' p1') let nL = 1/lenVec n let (n1, n2, n3) = scaleVec n (nL*d*dir) normal $ Normal3 n1 n2 n3 vertex3f (dir>0) p0' vertex3f (dir>0) p1' vertex3f (dir>0) p2' vertex3f :: Bool -> (GLfloat, GLfloat, GLfloat) -> IO () vertex3f texture' (x, y, z) = do let (x',y') = ((x+1)/2, (y+1)/2) when texture' $ texCoord (TexCoord2 x' y') vertex $ Vertex3 x y z lenVec :: Floating a => (a, a, a) -> a lenVec (a1,a2,a3) = sqrt $ a1*a1 + a2*a2 + a3*a3 scaleVec :: Num t => (t, t, t) -> t -> (t, t, t) scaleVec (a1,a2,a3) x = (a1*x,a2*x,a3*x) cross :: Num t => (t, t, t) -> (t, t, t) -> (t, t, t) cross (a1,a2,a3) (b1,b2,b3) = (a2*b3-a3*b2 ,a3*b1-a1*b3 ,a1*b2-a2*b1) minus :: (Num t, Num t1, Num t2) => (t, t1, t2) -> (t, t1, t2) -> (t, t1, t2) minus (a1,a2,a3) (b1,b2,b3) = (a1-b1, a2-b2, a3-b3) innerCircle :: Int -> Int -> [(GLfloat, GLfloat)] innerCircle numSegs skip = upperInnerCircle numSegs skip ++ lowerInnerCircle numSegs skip upperOutSegment :: Int -> Int -> Int -> [(GLfloat, GLfloat)] upperOutSegment numSegs ring seg = [x,y,u, v,u,y] where seg'=pi/fromIntegral numSegs (a, b) = (fromIntegral seg * seg', fromIntegral (seg+1) * seg') x = (fromIntegral ring * cos a, fromIntegral ring * sqrt(1-cos a*cos a)) y = (fromIntegral ring * cos b, fromIntegral ring * sqrt(1-cos b*cos b)) u = (fromIntegral (ring+1) * cos a, fromIntegral (ring+1) * sqrt(1-cos a*cos a)) v = (fromIntegral (ring+1) * cos b, fromIntegral (ring+1) * sqrt(1-cos b*cos b)) lowerOutSegment :: Int -> Int -> Int -> [(GLfloat, GLfloat)] lowerOutSegment numSegs ring seg = map (\(x,y) -> (x,-y)) $ upperOutSegment numSegs ring seg outSegment :: Int -> Int -> Int -> [(GLfloat, GLfloat)] outSegment numSegs ring seg = upperOutSegment numSegs ring seg ++ lowerOutSegment numSegs ring seg outerRing :: Int -> Int -> [(GLfloat, GLfloat)] outerRing numSegs ring = concat [outSegment numSegs ring n | n<-[0..numSegs-1]] toTriples :: [a] -> [(a,a,a)] toTriples [] = [] toTriples (a:b:c:rest) = (a,b,c):toTriples rest renderChip :: GLuint -> Int -> Int -> Foreign.C.Types.CFloat -> IO () renderChip tex numSegs numRings factor = let ips = innerCircle numSegs 0 ops = concat [outerRing numSegs i | i<-[1..numRings]] height dir = map (\(x,y) -> let dist = sqrt(x*x+y*y)/fromIntegral (numRings+1) height' = sqrt(1.001-dist*dist)*factor*fromIntegral (numRings+1)*0.2 in (dir,x*factor,y*factor,dir*height')) ups = height 1 $ ips ++ ops lps = height (-1) $ ips ++ ops in do glBindTexture gl_TEXTURE_2D tex renderPrimitive Triangles $ mapM_ pushTriangle (toTriples (ups++lps)) loadTexture :: String -> IO GLuint loadTexture fp = do putStrLn $ "loading texture: " ++ fp Just (Image w h pd) <- bitmapLoad fp putStrLn $ "Image width = " ++ show w putStrLn $ "Image height = " ++ show h tex <- alloca $ \p -> do glGenTextures 1 p peek p let (ptr, off, _) = BSI.toForeignPtr pd withForeignPtr ptr $ \p -> do let p' = p `plusPtr` off glBindTexture gl_TEXTURE_2D tex glTexImage2D gl_TEXTURE_2D 0 3 (fromIntegral w) (fromIntegral h) 0 gl_RGB gl_UNSIGNED_BYTE p' let glLinear = fromIntegral gl_LINEAR glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER glLinear glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER glLinear return tex -- -------------------------------------------------------------------- -- Half circle -- -------------------------------------------------------------------- skipBothEnds :: [a] -> Int -> [a] skipBothEnds xs n = let xs' = drop n xs in reverse $ drop n (reverse xs') upperInnerCircle :: Int -> Int -> [(GLfloat, GLfloat)] upperInnerCircle numSegs = skipBothEnds ps where seg'=pi/fromIntegral numSegs as = [(fromIntegral n * seg', fromIntegral (n+1) * seg') | n<-[0..numSegs-1]] ps = concat [[(cos a, sqrt(1-cos a*cos a)) ,(cos b, sqrt(1-cos b*cos b))] | (a,b)<-as ] lowerInnerCircle :: Int -> Int -> [(GLfloat, GLfloat)] lowerInnerCircle numSegs skip = map (\(x,y) -> (x,-y)) $ upperInnerCircle numSegs skip pushLine :: ((GLfloat, GLfloat, GLfloat) ,(GLfloat, GLfloat, GLfloat)) -> IO () pushLine ((x,y,z), (a,b,c)) = do vertex $ Vertex3 x y z vertex $ Vertex3 a b c data WhichCircle = FullCircle | UpperHalfCircle | LowerHalfCircle circle :: WhichCircle -> Int -> Int -> CFloat -> IO () circle whichCircle numSegs skip factor = let ips = case whichCircle of LowerHalfCircle -> lowerInnerCircle numSegs skip UpperHalfCircle -> upperInnerCircle numSegs skip FullCircle -> lowerInnerCircle numSegs skip ++ upperInnerCircle numSegs skip applyFactor = map (\(x,y) -> (x*factor,y*factor,0)) ups = applyFactor ips in renderPrimitive Lines $ mapM_ pushLine (toTuples ups) toTuples :: [a] -> [(a,a)] toTuples [] = [] toTuples (a:b:rest) = (a,b):toTuples rest -- Helpful OpenGL constants for rotation -- xAxis = G.Vector3 1 0 0 :: G.Vector3 R -- yAxis = G.Vector3 0 1 0 :: G.Vector3 R -- zAxis = G.Vector3 0 0 1 :: G.Vector3 R blinker :: IO Bool blinker = do t <- fmap utctDayTime getCurrentTime let tFrac = truncate $ 6 * (t - fromIntegral (truncate t::Int)) return $ odd tFrac data MenuEntry = MenuEntry { meId :: Int, meTrans :: MenuTransition, meText :: String, mePosx :: GLfloat, mePosy :: GLfloat, meEndx :: GLfloat, meEndy :: GLfloat } deriving (Show) menues :: [(MenuState, [MenuEntry])] menues = [ (MSMain, [MenuEntry 00 MTToFriendly "FRIENDLY" (-30) 10 0 5, MenuEntry 01 MTToTournament "TOURNAMENT" (-30) 0 0 (-5), MenuEntry 02 MTHelp "HELP" (-30) (-10) 0 (-15), MenuEntry 03 MTFinished "EXIT" (-30) (-20) 0 (-25)]), (MSHelp, [MenuEntry 10 MTToMain "BACK" (-30) (-20) 0 (-20)]), (MSTournament, [MenuEntry 10 MTToMain "BACK" (-30) (-20) 0 (-20)]), (MSTerminated, [MenuEntry 20 MTFinished "" (-30) (-10) 0 (-15)]) ] menuSelected (x, y) (mx, my) = x > 15 && x < 60 && y > (55-my) && y < (60-my) whichMenuItem :: [MenuEntry] -> (GLfloat, GLfloat) -> Maybe MenuEntry whichMenuItem mes (x,y) = find (\me -> menuSelected (x, y) (mePosx me, mePosy me)) mes runMenu :: IORef (GLfloat, GLfloat) -> Maybe [RSEvent] -> MenuState -> IO (Bool, Maybe MenuTransition) runMenu lastPos is mst = do xy <- readIORef lastPos let xyNew = getPosIfPossible xy is writeIORef lastPos xyNew clear [ ColorBuffer, DepthBuffer ] loadIdentity position (Light 0) $= Vertex4 100 (-100) 50 1 -- 1 0.4 0.8 1 let Just menu = lookup mst menues let mmi = whichMenuItem menu xyNew let trans = if clicked is then meTrans <$> mmi else Nothing let go = trans == Just MTToFriendly when (clicked is) $ print $ show trans renderMenu mst mmi return (go, trans) renderMenu mId mmi = do let Just mis = lookup mId menues color $ Color3 (1.0::GLfloat) (1.0::GLfloat) (1.0::GLfloat) renderFrame mId forM_ mis $ \ mi -> printIt (mePosx mi) (mePosy mi) 0.04 (meText mi) when (isJust mmi) $ renderquad mmi flush swapBuffers renderFrame MSMain = printIt (-30::GLfloat) (22::GLfloat) 0.04 "=== MAIN MENU ===" renderFrame MSHelp = do printIt (-30::GLfloat) (22::GLfloat) 0.04 "=== HELP ===" forM_ ts $ \(x, y, t) -> printIt x y 0.01 t where ts = [(-30, 15,"MOUSE:"), (-30, 13,"Move"), (-15, 13,"User controlled player follows mouse pointer"), (-30, 11,"Left button"), (-15, 11,"Select nearest player"), (-30, 09,"Wheel"), (-15, 09,"Zoom in / out"), (-30, 04,"KEYS:"), (-30, 02,"q/Q"), (-15, 02,"Move designated player (marked with !) to goal / to me"), (-30, 00,"w/W "), (-15, 00,"Move designated player to left / right"), (-30,-02,"e/E"), (-15,-02,"Move designated player forward / backward"), (-30,-04,"a/A"), (-15,-04,"Pass low / high (hold key for faster pass)"), (-30,-06,"s/S"), (-15,-06,"Kick low / high (hold key for faster kick)"), (-30,-08,"d/D"), (-15,-08,"Flip ball to designated player"), (-30,-10,"SPACE"), (-15,-10,"toggle ball from one side to other")] :: [(GLfloat, GLfloat, String)] renderFrame MSTournament = do printIt (-30::GLfloat) (22::GLfloat) 0.04 "=== TOURNAMENT ===" printIt (-30::GLfloat) (00::GLfloat) 0.04 "" renderFrame _ = return () printIt x y sc t = preservingMatrix $ do translate $ G.Vector3 (x::GLfloat) (y::GLfloat) (-71::GLfloat) scale sc sc (sc::GLfloat) renderString Roman t renderquad mmi = do let vertex3f x y z = vertex $ Vertex3 x y (z :: GLfloat) c = Color4 1 0.5 10 0.5 :: Color4 R when (isJust mmi) $ preservingMatrix $ do translate $ G.Vector3 (0::GLfloat) (0::GLfloat) (-71) let mi = fromJust mmi let (x,y) = (mePosx mi, mePosy mi) (color c >>) . renderPrimitive Quads $ do vertex3f (-30) (y+4.5) 0 vertex3f 20 (y+4.5) 0 vertex3f 20 (y-0.5) 0 vertex3f (-30) (y-0.5) 0 clicked Nothing = False clicked (Just []) = False clicked (Just (r:rs)) = r == RSMouseButtonDownLeft || clicked (Just rs) getPosIfPossible :: (GLfloat, GLfloat) -> Maybe [RSEvent] -> (GLfloat, GLfloat) getPosIfPossible xy Nothing = xy getPosIfPossible xy (Just []) = xy getPosIfPossible xy (Just (r:rs)) = case r of RSMouseMotion x y -> (realToFrac x, realToFrac y) _ -> getPosIfPossible xy (Just rs) lll :: Maybe [a] -> Int lll mxs = case mxs of Nothing -> 0 Just xs -> length xs