packages feed

Rasenschach-0.1.3.2: Render.hs

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 "<Nothing here yet>"
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