module Render (render, initGL) where
import FRP.Yampa.Geometry
import GHC.Exts (sortWith)
import Graphics.UI.GLUT
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 Data.IORef
import Control.Monad
import Physics
import States
import Global
import Object
import BasicTypes
import Util
import Message
import Helper
import Paths_Rasenschach
win2pitch :: Param -> Int -> Int -> Int -> Int -> Position2
win2pitch param winX winY x y =
Point2 (fromIntegral x) (fromIntegral y)
renderObjects :: Param
-> [ObsObjState]
-> GraphicsData
-> IO ()
renderObjects param oos graphData = do
let texHome = gdTextureHome graphData
let texAway = gdTextureAway graphData
(oldX, oldY, currTZ) <- readIORef (gdCurrentTranslate graphData)
(winX, winY) <- readIORef $ gdWinSize 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
(Point3 (fst (translateToScreen pW pL (realToFrac . point3X $ oosPos')
(realToFrac . point3Y $ oosPos')))
(snd (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 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) $ do
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) $ do
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) $ do
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) $ do
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 pW pL u v =
(u - pW/2, (pL-v)-pL/2)
render :: Param -> [ObsObjState] -> GraphicsData -> IO ()
render param oos gd = renderObjects param oos gd
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) $ do
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 pPos = do
preservingMatrix $ do
(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 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.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)
-- 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 tex numSegs numRings factor =
let ips = innerCircle numSegs 0
ops = concat [outerRing numSegs i | i<-[1..numRings]]
height dir ps =
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')) $ ps
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 xs n =
let xs' = drop n xs
in reverse $ drop n (reverse xs')
upperInnerCircle :: Int -> Int -> [(GLfloat, GLfloat)]
upperInnerCircle numSegs skip =
skipBothEnds ps skip
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 numSegs skip factor =
let ips = case whichCircle of
LowerHalfCircle -> lowerInnerCircle numSegs skip
UpperHalfCircle -> upperInnerCircle numSegs skip
fullCircle -> lowerInnerCircle numSegs skip ++ upperInnerCircle numSegs skip
applyFactor dir ps =
map (\(x,y) -> (x*factor,y*factor,0)) $ ps
ups = applyFactor 1 $ 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 = t - fromIntegral (truncate t)
return $ tFrac < 0.5