started work on Coordinate-System for the Map
This commit is contained in:
parent
f23ef3cadb
commit
47788b4ef0
@ -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
|
||||
|
||||
|
||||
61
src/Main.hs
61
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
|
||||
|
||||
|
||||
131
src/Map/Coordinates.hs
Normal file
131
src/Map/Coordinates.hs
Normal file
@ -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)
|
||||
Loading…
Reference in New Issue
Block a user