started work on Coordinate-System for the Map

Pioneers.cabal

@@ -11,6 +11,8 @@ executable Pioneers
                   base >= 4,
                   gtk,
                   OpenGL >=2.8.0 && <2.9,
-                  gtkglext >=0.12
+                  gtkglext >=0.12,
+                  containers >=0.5 && <0.6
   ghc-options:     -Wall
+  other-modules:   Map.Coordinates
 

src/Main.hs

@@ -4,20 +4,21 @@ import Graphics.UI.Gtk (AttrOp((:=)))
 import qualified Graphics.UI.Gtk.OpenGL as GtkGL
 
 import Graphics.Rendering.OpenGL as GL
+import qualified Graphics.UI.Gtk.Gdk.Events as Event
+
+import Map.Coordinates
+
+import Data.Maybe (fromMaybe)
 
 animationWaitTime = 3
+canvasWidth = 640
+canvasHeight = 480
 
 -- OpenGL polygon-function for drawing stuff.
 display :: IO ()
 display = do
   loadIdentity
-  color (Color3 1 0.5 0.5 :: Color3 GLfloat)
   -- Instead of glBegin ... glEnd there is renderPrimitive.  
-  renderPrimitive Polygon $ do
-    vertex (Vertex3 (-1.0) (-1.0) 0.0 :: Vertex3 GLfloat)
-    vertex (Vertex3  (1.0) (-1.0) 0.0 :: Vertex3 GLfloat)
-    vertex (Vertex3  (1.0)  (1.0) 0.0 :: Vertex3 GLfloat)
-    vertex (Vertex3 (-1.0)  (1.0) 0.0 :: Vertex3 GLfloat)
   color (Color3 1 1 1 :: Color3 GLfloat)
   renderPrimitive Polygon $ do
     vertex (Vertex3 0.25 0.25 0.0 :: Vertex3 GLfloat)
@@ -25,6 +26,33 @@ display = do
     vertex (Vertex3 0.75 0.75 0.0 :: Vertex3 GLfloat)
     vertex (Vertex3 0.25 0.75 0.0 :: Vertex3 GLfloat)
 
+--Adjust size to given dimensions
+reconfigure :: Int -> Int -> IO (Int, Int)
+reconfigure w h = do
+  -- maintain aspect ratio
+  let aspectRatio = (fromIntegral canvasWidth) / (fromIntegral canvasHeight)
+      (w1, h1)    = (fromIntegral w, (fromIntegral w) / aspectRatio)
+      (w2, h2)    = ((fromIntegral h) * aspectRatio, fromIntegral h)
+      (w', h')    = if h1 <= fromIntegral h
+                      then (floor w1, floor h1)
+                      else (floor w2, floor h2)
+  reshape $ Just (w', h') 
+  return (w', h')
+
+-- Called by reconfigure to fix the OpenGL viewport according to the
+-- dimensions of the widget, appropriately.
+reshape :: Maybe (Int, Int) -> IO ()
+reshape dims = do
+  let (width, height) = fromMaybe (canvasWidth, canvasHeight) dims
+  viewport $= (Position 0 0, Size (fromIntegral width) (fromIntegral height))
+  matrixMode $= Projection
+  loadIdentity
+  let (w, h) = if width <= height
+                then (fromIntegral height, fromIntegral width )
+                else (fromIntegral width,  fromIntegral height)
+  perspective 60.0 (fromIntegral canvasWidth / fromIntegral canvasHeight) 1.0 20.0
+  matrixMode $= Modelview 0
+  loadIdentity
 
 main :: IO ()
 main = do
@@ -42,7 +70,7 @@ main = do
   -- Create an OpenGL drawing area widget
   canvas <- GtkGL.glDrawingAreaNew glconfig
 
-  Gtk.widgetSetSizeRequest canvas 500 350
+  Gtk.widgetSetSizeRequest canvas canvasWidth canvasHeight
 
   -- Initialise some GL setting just before the canvas first gets shown
   -- (We can't initialise these things earlier since the GL resources that
@@ -76,6 +104,7 @@ main = do
   window <- Gtk.windowNew
   button <- Gtk.buttonNew
   exitButton <- Gtk.buttonNew
+  label <- Gtk.labelNew (Just "Gtk2Hs using OpenGL via HOpenGL!")
   vbox <- Gtk.vBoxNew False 4
 
   --Wrench them together
@@ -88,13 +117,29 @@ main = do
   Gtk.set vbox [
                    Gtk.containerChild := canvas,
                    Gtk.containerChild := button,
-                   Gtk.containerChild := exitButton
+                   Gtk.containerChild := exitButton,
+                   Gtk.containerChild := label
                 ]
 
   Gtk.afterClicked button (putStrLn "Hello World")
   Gtk.afterClicked exitButton Gtk.mainQuit
   Gtk.onDestroy window Gtk.mainQuit
 
+ -- "reshape" event handler
+  Gtk.onConfigure canvas $ \ (Event.Configure _ _ _ w h) -> do
+    (w', h') <- reconfigure w h
+    {- texW   <- Gtk.pixbufGetWidth pb
+    texH   <- Gtk.pixbufGetHeight pb
+    texBPS <- Gtk.pixbufGetBitsPerSample pb
+    texRS  <- Gtk.pixbufGetRowstride pb
+    texNCh <- Gtk.pixbufGetNChannels pb-}
+    Gtk.labelSetText label $ unwords ["Width:",show w',"Height:",show h'{- ,
+                                      "TexW:",show texW,"TexH:",show texH,
+                                      "BPS:",show texBPS,"RS:",show texRS,
+                                      "NCh:",show texNCh-}]
+    return True
+
+
   Gtk.widgetShowAll window
   Gtk.mainGUI
 

src/Map/Coordinates.hs

@@ -0,0 +1,131 @@
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns #-}
+module Map.Coordinates 
+
+--exports..
+(getTileVertices)
+
+where
+
+import Graphics.Rendering.OpenGL as GL
+import Data.Map as M
+import Data.IntMap
+import Data.Maybe
+import Prelude as P
+
+
+
+type Coordinates = (Integer, Integer)
+type Pos = (Float, Float)
+
+-- | a Tile is 1 unit in size. Due to hexagonality the real rendered Area is less.
+type Tile = Coordinates
+-- | The heights of a Map in a random accessible way. 
+type MapHeights = Map Coordinates Int
+
+instance Num Tile where
+        (i,j) + (x,y) = (i+x, j+y)
+        (i,j) * (x,y) = (i*x, j*y)
+        (i,j) - (x,y) = (i-x, j-y)
+        negate (x,y) = (negate x, negate y)
+        abs (x,y) = (abs x, abs y)
+        signum (_,_) = undefined
+        fromInteger a = (a,a)
+
+instance Num Pos where
+        (i,j) + (x,y) = (i+x, j+y)
+        (i,j) * (x,y) = (i*x, j*y)
+        (i,j) - (x,y) = (i-x, j-y)
+        negate (x,y) = (negate x, negate y)
+        abs (x,y) = (abs x, abs y)
+        signum (_,_) = undefined
+        fromInteger a = (fromIntegral a, fromIntegral a)
+
+tileToPos :: Tile -> Pos
+tileToPos (x,y) = (fromIntegral x, fromIntegral y)
+
+data Neighbours =
+          North
+        | South
+        | NorthEast
+        | SouthEast
+        | NorthWest
+        | SouthWest
+        deriving (Show, Eq)
+
+-- | Ordered Vertice-List for rendering (clockwise)
+data TileVertex =
+          VertexNW
+        | VertexNE
+        | VertexE
+        | VertexSE
+        | VertexSW
+        | VertexW
+        deriving (Show, Eq, Ord)
+
+--getGrid :: Coordinates -> Coordinates -> []
+
+getTileVertices :: MapHeights -> Tile -> [Vertex3 GLfloat]
+getTileVertices heights t@(x,y) = let p = P.map (+ tileToPos t) hexagon in
+                                        P.map floatToVertex $
+                                  [
+                                        (fst $ p !! 0, snd $ p !! 0,fromMaybe 0.0 $ getHeight heights VertexNW t),
+                                        (fst $ p !! 1, snd $ p !! 1,fromMaybe 0.0 $ getHeight heights VertexNW t),
+                                        (fst $ p !! 2, snd $ p !! 2,fromMaybe 0.0 $ getHeight heights VertexNW t),
+                                        (fst $ p !! 3, snd $ p !! 3,fromMaybe 0.0 $ getHeight heights VertexNW t),
+                                        (fst $ p !! 4, snd $ p !! 4,fromMaybe 0.0 $ getHeight heights VertexNW t),
+                                        (fst $ p !! 5, snd $ p !! 5,fromMaybe 0.0 $ getHeight heights VertexNW t)
+                                  ]
+
+getHeight :: MapHeights -> TileVertex -> Tile -> Maybe Float
+getHeight h v t@(_,ty) =
+        let 
+                ! tileheight = fmap fromIntegral $ M.lookup t h
+                ! y = if even ty then -1 else 0
+        in
+        case v of
+                VertexNW -> do
+                                c <- tileheight
+                                n <- M.lookup (t+(0,-1)) h
+                                nw <- M.lookup (t+(-1,y)) h
+                                return $ (fromIntegral $ n+nw+c) / 3.0
+                VertexNE -> do
+                                c <- tileheight
+                                n <- M.lookup (t+(0,-1)) h
+                                ne <- M.lookup (t+(1,y)) h
+                                return $ (fromIntegral $ n+ne+c) / 3.0
+                VertexE -> do
+                                c <- tileheight
+                                ne <- M.lookup (t+(1,y)) h
+                                se <- M.lookup (t+(1,y+1)) h
+                                return $ (fromIntegral $ ne+se+c) / 3.0
+                VertexSE -> do
+                                c <- tileheight
+                                s <- M.lookup (t+(0,1)) h
+                                se <- M.lookup (t+(1,y+1)) h
+                                return $ (fromIntegral $ s+se+c) / 3.0
+                VertexSW -> do
+                                c <- tileheight
+                                s <- M.lookup (t+(0,1)) h
+                                sw <- M.lookup (t+(-1,y+1)) h
+                                return $ (fromIntegral $ s+sw+c) / 3.0
+                VertexW -> do
+                                c <- tileheight
+                                sw <- M.lookup (t+(-1,y+1)) h
+                                nw <- M.lookup (t+(-1,y)) h
+                                return $ (fromIntegral $ sw+nw+c) / 3.0
+
+
+hexagon :: IntMap (Float,Float)
+hexagon = undefined {- fromList [
+                (0.2,0),
+                (0.6,0),
+                (0.5,1),
+                (1,0.6),
+                (1,0.2),
+                (0.5,0)
+                ]-}
+
+
+-- | convert triple of floats to GLfloat (== CFloat)
+floatToVertex :: (Float, Float, Float) -> Vertex3 GLfloat
+floatToVertex (a,b,c) = Vertex3 (realToFrac a::GLfloat) (realToFrac b::GLfloat) (realToFrac c::GLfloat)