module Main (main) where -------------------------------------------------------------------------------- -- -- Parkettierf�ige Brown'sche 2D-Fl�he (Diamond-Square-Algorithums) -- -- -- Tastenbelegungen im Hauptfenster: -- Links, Rechts -> Ansicht drehen -- Oben, Unten -> Blickh�enwinkel �dern -- Strg + Pfeiltaste -> Ansicht verschieben -- '+', '-' -> Ableitungsschritt �dern -- 'I', 'O' -> Hinein- bzw. Hinauszoomen -- 'S' -> Darstellungsmodus: gefllte Polygone -- 'W' -> Darstellungsmodus: Drahtgitter -- 'P' -> Darstellungsmodus: H�en als Punkte -- 'F' -> zwischen flachem Wasser und -- Wassertiefendarstellung wechseln -- 'N' -> Neues Zufallsterrain erzeugen -- -------------------------------------------------------------------------------- import Graphics.Rendering.OpenGL import Graphics.UI.GLUT hiding (initState) import Utilities import Data.List import Data.IORef import System.Random import Data.Char (toUpper) type Pair t = (t, t) type Tupel3 t = (t, t, t) data TerrainDrawMode = TerrainPoints | TerrainWireframe | TerrainSolid deriving (Eq, Show) data Distribution = UniformDistribution | NormalDistribution deriving (Eq, Show) data State = State { iteration :: Int, -- Ableitungsschritt viewPhi :: Double, -- Drehwinkel des Terrains um die z-Achse viewTheta :: Double, -- Blickwinkel (zwischen Boden und Zenit) zoom :: Double, -- Vergr�erungsfaktor pan :: (Double, Double), -- Verschiebung roughness :: Double, -- Rauhigkeit drawMode :: TerrainDrawMode, -- Zeichenmodus terrainNumber :: Int, -- Initialwert fr Zufallsgenerator flattenWater :: Bool, -- True -> Wasser zu Ebene abflachen -- False -> Wassertiefen darstellen renderingRequired :: Bool -- Mu�Terrain neu gerendert werden? } initState = State { iteration = 1, viewPhi = -30, viewTheta = 60, zoom = 1, pan = (0,0), roughness = global_roughness, drawMode = TerrainSolid, terrainNumber = 0, flattenWater = False, renderingRequired = True } global_roughness = 0.4 -- Rauhigkeit des Terrains, Standard: 0.5 -- 0,..,0.5 = rauher; 0.5,..,1.0 = glatter global_distribution = UniformDistribution global_windowTitle = "Fraktale Gebirgslandschaft" global_windowSizeX = 640 global_windowSizeY = 480 maximumBound = 1.0 clearWaterLimit = -0.315 waterLimit = -0.3 vegetationLimit = 0.1 rockLimit = 0.4 snowLimit = 1.0 cSnow = Color4 1.0 1.0 1.0 (1.0::GLfloat) cDarkRock = Color4 0.5 0.5 0.5 (1.0::GLfloat) cLightRock = Color4 0.25 0.25 0.25 (1.0::GLfloat) cDarkVeg = Color4 0.1 0.25 0.1 (1.0::GLfloat) cLightVeg = Color4 0.1 0.7 0.2 (1.0::GLfloat) cClearWater = Color4 0.1 0.7 0.9 (0.35::GLfloat) cLightWater = Color4 0.1 0.3 0.7 (1.0::GLfloat) cDarkWater = Color4 0.0 0.1 0.3 (1.0::GLfloat) -- Main-Funktion --------------------------------------------------------------- main = do getArgsAndInitialize initialDisplayMode $= [RGBAMode, WithDepthBuffer, DoubleBuffered, WithAlphaComponent] createWindow global_windowTitle windowSize $= Size global_windowSizeX global_windowSizeY shadeModel $= Smooth depthFunc $= Just Less normalize $= Enabled state <- newIORef initState displayCallback $= display state keyboardMouseCallback $= Just (keyboard state) mainLoop -- Hauptzeichenfunktion -------------------------------------------------------- display state = do curState <- get state clear [DepthBuffer, ColorBuffer] let z = realToReal $ zoom curState projection (-z) (z) (-z) (z) (-100) (100) loadIdentity let (xPan, yPan) = pan curState translate $ Vector3 (doubleToGLfloat xPan) (doubleToGLfloat yPan) 0 rotate (doubleToGLfloat $ negate $ viewTheta curState) $ Vector3 1 0 0 rotate (doubleToGLfloat $ viewPhi curState) $ Vector3 0 0 1 let d = 0.6 flat = \z -> if z < clearWaterLimit then clearWaterLimit else z initGen = mkStdGen (terrainNumber curState) (matrix, _) = (allTerrainSteps initGen) !! (iteration curState) matrix' = if (flattenWater curState) then map (map (flat)) matrix else matrix if (renderingRequired curState) then defineList (DisplayList 1) CompileAndExecute $ do blend $= Disabled drawTerrain (drawMode curState) (-d,-d) (d,d) $ enlargeTerrain matrix' if (drawMode curState == TerrainSolid) then if (not $ flattenWater curState) then do blend $= Enabled blendFunc $= (SrcAlpha, OneMinusSrcAlpha) drawClearWaterPlane (-d,-d) (d,d) else return () else return () else do callList (DisplayList 1) windowTitle $= global_windowTitle ++ " (Terrain " ++ (show $ terrainNumber curState) ++ ", n=" ++ (show $ iteration curState) ++ ")" state $= curState { renderingRequired = False } swapBuffers -- Keyboard-Ereignisverarbeitung ----------------------------------------------- keyboard state (SpecialKey specialKey) Down mod _ = do curState <- get state let phi = viewPhi curState theta = viewTheta curState ctrlPressed = ctrl mod == Down z = zoom curState (x,y) = pan curState if ctrlPressed then case specialKey of KeyLeft -> state $= curState { pan = (x - 0.05 * z, y) } KeyRight -> state $= curState { pan = (x + 0.05 * z, y) } KeyDown -> state $= curState { pan = (x, y - 0.05 * z) } KeyUp -> state $= curState { pan = (x, y + 0.05 * z) } _ -> return () else case specialKey of KeyLeft -> state $= curState { viewPhi = if phi<0 then phi+355 else phi-5 } KeyRight -> state $= curState { viewPhi = if phi>360 then phi-355 else phi+5 } KeyDown -> state $= curState { viewTheta = if theta<=0 then 0 else theta-5 } KeyUp -> state $= curState { viewTheta = if theta>=90 then 90 else theta+5 } _ -> return () postRedisplay Nothing keyboard state (Char charKey) Down _ _ = do curState <- get state let i = iteration curState z = zoom curState state $= curState { renderingRequired = True } curState <- get state case toUpper charKey of 'I' -> do state $= curState { zoom = z / 1.05, renderingRequired = False } postRedisplay Nothing 'O' -> do state $= curState { zoom = z * 1.05, renderingRequired = False } postRedisplay Nothing '+' -> do state $= curState { iteration = i + 1 } postRedisplay Nothing '-' -> do state $= curState { iteration = if i <= 0 then 0 else i - 1 } postRedisplay Nothing 'F' -> do let flatten = flattenWater curState state $= curState { flattenWater = not flatten } postRedisplay Nothing 'N' -> do newTerrainNumber <- (randomIO :: IO Int) state $= curState { terrainNumber = newTerrainNumber } postRedisplay Nothing 'P' -> do state $= curState { drawMode = TerrainPoints } postRedisplay Nothing 'S' -> do state $= curState { drawMode = TerrainSolid } postRedisplay Nothing 'W' -> do state $= curState { drawMode = TerrainWireframe } postRedisplay Nothing _ -> state $= curState { renderingRequired = False } keyboard _ _ _ _ _ = return () -- Terrain-Zeichenfunktionen --------------------------------------------------- -- pointsToQuadStrip mode (xl,yl) (xr,yr) lzs rzs -- -- Zeichnet ein QuadStrip mit den parallel nebeneinander gelegten H�enwerten -- aus lzs und rzs zwischen dem Anfangspunkt (xl,yl) und dem Endpunkt (xr,yr) -- mit dem gegebenen Zeichenmodus mode. -- pointsToQuadStrip :: TerrainDrawMode -> (Double,Double) -> (Double,Double) -> [Double] -> [Double] -> IO () pointsToQuadStrip mode (xl,yl) (xr,yr) lzs rzs = do let n = length lzs - 1 dx = (xr - xl) / fromIntegral n dy = (yr - yl) / fromIntegral n xs = concat [ [x,x] | x <- [xl + dx*fromIntegral i | i<-[0..n]] ] ys = cycle [yl,yr] zs = interleave lzs rzs case mode of TerrainSolid -> renderPrimitive QuadStrip $ do sequence_ $ zipWith3 toColorVertex xs ys zs TerrainPoints -> renderPrimitive Points $ do sequence_ $ zipWith3 toColorVertex xs ys zs _ -> return () -- Gibt die dem H�enwert zugeordnete Farbe zurck chooseColor z | z <= waterLimit = return $ interpolateColor (-maximumBound, cDarkWater) (waterLimit, cLightWater) z | z <= vegetationLimit = return $ interpolateColor (waterLimit, cLightVeg) (vegetationLimit, cDarkVeg) z | z <= rockLimit = return $ interpolateColor (vegetationLimit, cDarkRock) (rockLimit, cLightRock) z | otherwise = return cSnow -- interpolateColor (lower, colorL) (upper, colorU) height -- -- Gibt eine linear interpolierte Farbe zwischen colorL und colorU zurck -- interpolateColor (lower, colorL) (upper, colorU) height = Color4 rH gH bH aH where aH = max aL aU bH = bL + diff*(bU-bL) gH = gL + diff*(gU-gL) rH = rL + diff*(rU-rL) Color4 rU gU bU aU = colorU Color4 rL gL bL aL = colorL diff = (fromRational.toRational) $ (height-lower) / (upper-lower) -- Farbe entsprechend z-Wert w�len und gef�bten Vertex setzen toColorVertex x y z = do color <- chooseColor z currentColor $= color vertex $ Vertex3 (doubleToGLfloat x) (doubleToGLfloat y) (doubleToGLfloat z) -- pointsToLines (x0,y0) (xn,yn) zs -- -- Zeichnet eine gebrochene Linie mit den gleichm�ig verteilten H�enwerten -- aus zs zwischen dem Anfangspunkt (x0,y0) und dem Endpunkt (xn,yn). -- pointsToLines :: (Double,Double) -> (Double,Double) -> [Double] -> IO () pointsToLines (x0,y0) (xn,yn) zs = do let n = length zs - 1 dx = (xn - x0) / fromIntegral n dy = (yn - y0) / fromIntegral n toLine i zl zr = do let yl = y0 + dy * fromIntegral i xl = x0 + dx * fromIntegral i renderPrimitive Lines $ do toColorVertex xl yl zl toColorVertex (xl+dx) (yl+dy) zr sequence_ $ zipWith3 toLine [0..n] zs $ tail zs -- drawTerrain mode (xl,yl) (xr,yr) hss -- -- Zeichnet das Terrain mit den H�enwerten hss zwischen den Punkten (xl,yl) -- und (xr,yr) mit dem Zeichenmodus mode. -- drawTerrain :: TerrainDrawMode -> Pair Double -> Pair Double -> [[Double]] -> IO () drawTerrain mode (xl,yl) (xr,yr) hss@(fhs:_) = do let rps = [ (xr, y + dy) | (_,y) <- lps ] lps = [ (xl, yl + dy*fromIntegral i) | i <- [0..n-1] ] drawStrips = sequence_ $ zipWith4 (pointsToQuadStrip mode) lps rps hss (tail hss) if mode == TerrainWireframe then do sequence_ $ zipWith3 pointsToLines xly xry hss sequence_ $ zipWith3 pointsToLines xyl xyr hssT else drawStrips where hssT = transpose hss xyr = [(x, yr) | (x,_) <- xyl] xyl = [(xl + dx * fromIntegral i, yl) | i<-[0..n]] xry = [(xr, y) | (_,y) <- xly] xly = [(xl, yl + dy * fromIntegral i) | i<-[0..n]] dy = (yr - yl) / fromIntegral n dx = (xr - xl) / fromIntegral n n = length fhs - 1 -- Zeichnet halbtransparente Wasserfl�he zwischen zwei Punkten. drawClearWaterPlane (xl,yl) (xr,yr) = renderPrimitive Quads $ do currentColor $= cClearWater vertex $ Vertex3 (doubleToGLfloat xl) (doubleToGLfloat yl) (doubleToGLfloat clearWaterLimit) vertex $ Vertex3 (doubleToGLfloat xr) (doubleToGLfloat yl) (doubleToGLfloat clearWaterLimit) vertex $ Vertex3 (doubleToGLfloat xr) (doubleToGLfloat yr) (doubleToGLfloat clearWaterLimit) vertex $ Vertex3 (doubleToGLfloat xl) (doubleToGLfloat yr) (doubleToGLfloat clearWaterLimit) -- Terrain-Berechnung ---------------------------------------------------------- -- logBase2 z liefert n mit 2^n = z logBase2 :: Int -> Int logBase2 z | z `mod` 2 == 0 = 1 + logBase2 (z `div` 2) | otherwise = 0 -- variance i h = Varianz mit Rauhigkeit h im i-ten Schrit der Terrainableitung variance :: Double -> Double -> Double variance i h = (1-2**(2*h-2)) / (2**(2*h*i)) -- Unendliche Liste von gleichverteilten Zufallswerten mit zugeh�igem -- neuen Generator allUniforms :: RandomGen gen => gen -> Double -> [(Double, gen)] allUniforms gen var = (x, nextGen) : allUniforms nextGen var where (x, nextGen) = randomR (-var, var) gen -- Unendliche Liste von normalverteilten Zufallswerten mit zugeh�igem -- neuen Generator allNormals :: RandomGen gen => gen -> Double -> [(Double, gen)] allNormals gen sqrSigma = (z1, nextGen1) : (z2, nextGen2) : allNormals nextGen2 sqrSigma where z1 = sigma * sqrt (-2 * log x1') * cos (2 * pi * x2') z2 = sigma * sqrt (-2 * log x1') * sin (2 * pi * x2') sigma = sqrt sqrSigma x1' = if x1==0 then 1 else x1 x2' = if x2==0 then 1 else x2 (x1, nextGen1) = randomR (0, 1) gen (x2, nextGen2) = randomR (0, 1) nextGen1 -- terrainRandomFunc distrib n gen var -- -- Erzeugt aus Generator gen eine Liste mit n Zufallswerten der Varianz var -- und der Verteilungsart distrib, sowie einen neuen Generator. -- terrainRandomFunc :: RandomGen gen => Distribution -> Int -> gen -> Double -> ([Double], gen) terrainRandomFunc distrib n gen var = (map fst $ tail ls, nextGen) where (_, nextGen) = last ls ls = (0, gen) : (take n $ distribFunc gen var) distribFunc = case distrib of UniformDistribution -> allUniforms NormalDistribution -> allNormals -- neuner interpolierter H�enwert zwischen 4 H�enwerten und Zufallswert d newHeight :: Double -> Double -> Double -> Double -> Double -> Double newHeight h1 h2 h3 h4 d = (h1 + h2 + h3 + h4)/4 + d -- Erzeugt aus einer Terrain-Ableitung und einem Zufallsgenerator -- den n�hsten Ableitungsschritt und einen neuen Zufallsgenerator nextTerrainStep :: RandomGen gen => ([[Double]], gen) -> ([[Double]], gen) nextTerrainStep (hss, gen) = (hss', gen') where hss' = interleave (zipWith interleave hss squares1) (zipWith interleave squares2 diamonds) squares2 = zipWith4 squareStep hss (map lastAndInit diamonds) (tailAndHead hss) (dsSquares2 `inGroupsOf` nx) squares1 = zipWith4 squareStep (lastAndInit diamonds) hss diamonds (dsSquares1 `inGroupsOf` nx) diamonds = zipWith3 diamondStep hss (tailAndHead hss) (dsDiamonds `inGroupsOf` nx) [dsDiamonds, dsSquares1, dsSquares2] = dsAll `inGroupsOf` (nx*ny) (dsAll, gen') = terrainRandomFunc global_distribution (3*nx*ny) gen (variance (fromInteger n) global_roughness) n = toInteger $ logBase2 nx nx = length (head hss) ny = length hss -- Diamond-Schritt -- o o o o o o <- uppers -- => x x -- o o o o o o <- lowers diamondStep :: [Double] -> [Double] -> [Double] -> [Double] diamondStep lowers uppers ds = zipWith5 newHeight lowers uppers (tailAndHead lowers) (tailAndHead uppers) ds -- Square-Schritt -- o o o o <- uppers -- o o o => o x o x o <- centers -- o o o o <- lowers squareStep :: [Double] -> [Double] -> [Double] -> [Double] -> [Double] squareStep lowers centers uppers ds = zipWith5 newHeight lowers centers (tailAndHead centers) uppers ds -- Unendliche Liste aller Ableitungen eines Terrains allTerrainSteps gen = iterate nextTerrainStep ([[0]], gen) -- Erweitert Terrain um den redundanten oberen und rechten Rand enlargeTerrain :: [[Double]] -> [[Double]] enlargeTerrain hss = map enlarge (enlarge hss) where enlarge = \cs -> if null cs then [] else cs ++ [head cs]