diff --git a/3d-graphics-examples.cabal b/3d-graphics-examples.cabal new file mode 100644 --- /dev/null +++ b/3d-graphics-examples.cabal @@ -0,0 +1,64 @@ +Name: 3d-graphics-examples +Version: 0.0.0.0 +Cabal-Version: >= 1.8 +Build-Type: Simple +License: BSD3 +License-File: LICENSE +Copyright: © 2006 Matthias Reisner; + © 2012, 2013 Wolfgang Jeltsch +Author: Matthias Reisner +Maintainer: wolfgang@cs.ioc.ee +Stability: provisional +Homepage: http://darcs.wolfgang.jeltsch.info/haskell/3d-graphics-examples +Package-URL: http://hackage.haskell.org/packages/archive/3d-graphics-examples/0.0.0.0/3d-graphics-examples-0.0.0.0.tar.gz +Synopsis: Examples of 3D graphics programming with OpenGL +Description: This package demonstrates how to program simple interactive 3D + graphics with OpenGL. It contains two programs, which are both + about fractals: + . + [L-systems] generates graphics from Lindenmayer systems + (L-systems). It defines a language for L-systems as an embedded + DSL. + . + [Mountains] uses the generalized Brownian motion to generate + graphics that resemble mountain landscapes. + . + The original versions of these programs were written by Matthias + Reisner as part of a student project at the Brandenburg + University of Technology at Cottbus, Germany. Wolfgang Jeltsch, + who supervised this student project, is now maintaining these + programs. +Category: Graphics, Fractals +Tested-With: GHC == 7.6.3 + +Source-Repository head + Type: darcs + Location: http://darcs.wolfgang.jeltsch.info/haskell/3d-graphics-examples/main + +Source-Repository this + Type: darcs + Location: http://darcs.wolfgang.jeltsch.info/haskell/3d-graphics-examples/main + Tag: 3d-graphics-examples-0.0.0.0 + +Executable l-systems + Build-Depends: base >= 3.0 && < 5, + GLUT >= 2.4 && < 2.6, + OpenGL >= 2.8 && < 2.10 + Main-Is: LSystems.hs + Other-Modules: Utilities + ConiferLSystem + IslandLSystem + KochLSystem + LSystem + TreeLSystem + Turtle + HS-Source-Dirs: src src/l-systems + +Executable mountains + Build-Depends: base >= 3.0 && < 5, + GLUT >= 2.4 && < 2.6, + OpenGL >= 2.8 && < 2.10, + random >= 1.0 && < 1.1 + Main-Is: Mountains.hs + Other-Modules: Utilities + HS-Source-Dirs: src src/mountains diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright © 2006 Matthias Reisner +Copyright © 2012, 2013 Wolfgang Jeltsch +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + • Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + • Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + • Neither the name of the copyright holders nor the names of the + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runghc + +> import Distribution.Simple +> main = defaultMain diff --git a/src/Utilities.hs b/src/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Utilities.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE FlexibleInstances #-} +module Utilities ( + cBlack, + cLightGray, + cBlue, + cGreen, + cRed, + cCyan, + cMagenta, + cYellow, + cWhite, + + crMat, + cCyanMaterial, + + projection, + + Num (..), + realToReal, + doubleToGLfloat, + glfloatToDouble, + + interleave, + inGroupsOf, + lastAndInit, + tailAndHead, + + showIO + ) where + + +import Graphics.Rendering.OpenGL +import Graphics.UI.GLUT + + +-- Einige Standard-Farben +cBlack = Color4 0 0 0 (1::GLfloat) +cLightGray = Color4 0.7 0.7 0.7 (1::GLfloat) +cBlue = Color4 0 0 1 (1::GLfloat) +cGreen = Color4 0 1 0 (1::GLfloat) +cRed = Color4 1 0 0 (1::GLfloat) +cCyan = Color4 0 1 1 (1::GLfloat) +cMagenta = Color4 1 0 1 (1::GLfloat) +cYellow = Color4 1 1 0 (1::GLfloat) +cWhite = Color4 1 1 1 (1::GLfloat) + + +-- Lichtundurchlässiges Material erzeugen +crMat (rd,gd,bd) (rs,gs,bs) exp = do + materialDiffuse Front $= Color4 rd gd bd 1.0 + materialAmbient Front $= Color4 rd gd bd 1.0 + materialSpecular Front $= Color4 rs gs bs 1.0 + materialShininess Front $= exp + + materialDiffuse Back $= Color4 rd gd bd 1.0 + materialSpecular Back $= Color4 rs gs bs 1.0 + materialShininess Back $= exp + +cCyanMaterial = crMat (0, 0.3, 0.3) (1, 1, 1.0) 5 + + +-- Orthogonale Projektion +projection xl xu yl yu zl zu = do + matrixMode $= Projection + loadIdentity + ortho xl xu yl yu zl zu + matrixMode $= Modelview 0 + + + +-- Vektoraddition, -subtraktion und Kreuzprodukt +{-FIXME: + It is not right to treat vectors as numbers. Introduce separate operators + and then remove the LANGUAGE pragma above. +-} +instance (Num a, Num a, Num a) => Num (a, a, a) where + (x1, y1, z1) + (x2, y2, z2) = (x1 + x2, y1 + y2, z1 + z2) + (x1, y1, z1) - (x2, y2, z2) = (x1 - x2, y1 - y2, z1 - z2) + (x1, y1, z1) * (x2, y2, z2) = (y1*z2 - z1*y2, z1*x2 - x1*z2, x1*y2 - y1*x2) + fromInteger x = (fromInteger x, fromInteger x, fromInteger x) + abs (x, y, z) = (abs x, abs y, abs z) + signum (x, y, z) = (signum x, signum y, signum z) + + +-- Konvertierung zwischen verschiedenen Real-Typen +realToReal :: (Real a, Fractional b) => a -> b +realToReal = fromRational . toRational + +doubleToGLfloat :: Double -> GLfloat +doubleToGLfloat = realToReal + +glfloatToDouble :: GLfloat -> Double +glfloatToDouble = realToReal + + +-- Mischt zwei Listen elementweise abwechselnd +interleave :: [a] -> [a] -> [a] +interleave [] bs = bs +interleave as [] = as +interleave (a:as) (b:bs) = a : b : interleave as bs + + +-- Teilt Liste in Unterlisten gegebener Länge auf +inGroupsOf :: [a] -> Int -> [[a]] +inGroupsOf [] _ = [] +inGroupsOf cs n = lcs : inGroupsOf rcs n + where (lcs, rcs) = splitAt n cs + + +-- Verschiebt das letzte Element einer Liste an den Anfang +lastAndInit :: [a] -> [a] +lastAndInit [] = [] +lastAndInit cs = last cs : init cs + + +-- Verschiebt das erste Element einer Liste ans Ende +tailAndHead :: [a] -> [a] +tailAndHead [] = [] +tailAndHead (c:cs) = cs ++ [c] + + +-- Führt IO-Aktion aus und gibt den Ergebniswert aus +showIO :: (Show a) => IO (a) -> IO () +showIO ioVal = ioVal >>= putStr . show diff --git a/src/l-systems/ConiferLSystem.hs b/src/l-systems/ConiferLSystem.hs new file mode 100644 --- /dev/null +++ b/src/l-systems/ConiferLSystem.hs @@ -0,0 +1,46 @@ +module ConiferLSystem ( + ConiferModule (..), + coniferLSystem, + coniferInterpretation, + ) where + +import LSystem +import Turtle + + +data ConiferModule = + ConiferX Double | ConiferY Double | ConiferF Double | + ConiferLineWidth Double | + ConiferTL Double | ConiferTR Double | -- Turn-Befehle + ConiferRL Double | ConiferRR Double | -- Roll-Befehle + ConiferPU Double | ConiferPD Double -- Pitch-Befehle + + +coniferLSystem :: LSystem ConiferModule +coniferLSystem = + LSystem (map LPrim [ConiferLineWidth 10, ConiferPU 90, ConiferX 20]) rules + where + rules (ConiferX a) + | a > 6 = [ LPrim $ ConiferF 5, + LStack [ LPrim $ ConiferPD 80, LPrim $ ConiferY (a/2) ], + LPrim $ ConiferRR 137, LPrim $ ConiferX (a-1) ] + | otherwise = [ LPrim $ ConiferF 6 ] + rules (ConiferY a) + | a >= 3 = [ LPrim $ ConiferF 3, + LStack [ LPrim $ ConiferTL 50, LPrim $ ConiferF a ], + LPrim $ ConiferRR 180, LPrim $ ConiferY (a-1) ] + | otherwise = [ LPrim $ ConiferF 3 ] + rules m = [LPrim m] + + +coniferInterpretation :: ConiferModule -> [LPrim TurtleModule] +coniferInterpretation m = case m of + ConiferF len -> [LPrim $ TDraw (10*len)] + ConiferTL a -> [LPrim $ TTurnLeft a] + ConiferTR a -> [LPrim $ TTurnRight a] + ConiferPU a -> [LPrim $ TPitchUp a] + ConiferPD a -> [LPrim $ TPitchDown a] + ConiferRL a -> [LPrim $ TRollLeft a] + ConiferRR a -> [LPrim $ TRollRight a] + ConiferLineWidth wid -> [LPrim $ TSetLineWidth wid] + _ -> [] diff --git a/src/l-systems/IslandLSystem.hs b/src/l-systems/IslandLSystem.hs new file mode 100644 --- /dev/null +++ b/src/l-systems/IslandLSystem.hs @@ -0,0 +1,32 @@ +module IslandLSystem ( + IslandModule (..), + islandLSystem, + islandInterpretation, + ) where + +import LSystem +import Turtle + + +data IslandModule = IslandLineWidth Double | IslandMove Double | + IslandF Double | IslandL | IslandR + +islandLSystem :: LSystem IslandModule +islandLSystem = LSystem (map LPrim [IslandLineWidth 5, IslandL, IslandL, + IslandMove 100, IslandR, IslandMove 100, IslandR] ++ + (take 8 $ cycle [LPrim (IslandF 200.0), LPrim IslandR])) rules + where + rules (IslandF len) = [f, r, f, l, f, l, f, f, r, f, r, f, l, f] + where + f = LPrim $ IslandF (len/4) + l = LPrim IslandL + r = LPrim IslandR + rules m = [LPrim m] + +islandInterpretation :: IslandModule -> [LPrim TurtleModule] +islandInterpretation m = case m of + IslandLineWidth wid -> [LPrim $ TSetLineWidth wid] + IslandF len -> [LPrim $ TDraw len] + IslandMove len -> [LPrim $ TMove len] + IslandL -> [LPrim (TTurnLeft 90)] + IslandR -> [LPrim (TTurnRight 90)] diff --git a/src/l-systems/KochLSystem.hs b/src/l-systems/KochLSystem.hs new file mode 100644 --- /dev/null +++ b/src/l-systems/KochLSystem.hs @@ -0,0 +1,29 @@ +module KochLSystem ( + KochModule (..), + kochLSystem, + kochInterpretation + ) where + +import LSystem +import Turtle + + +data KochModule = KochF Double | KochLeft | KochRight | KochLineWidth Double + + +kochLSystem :: LSystem KochModule +kochLSystem = LSystem ([LPrim $ KochLineWidth 5] ++ (take 9 $ cycle + [LPrim $ KochF 200.0, LPrim KochRight, LPrim KochRight])) rules + where + rules (KochF len) = map (\p -> LPrim p) + [KochF (len/3), KochLeft, KochF (len/3), KochRight, + KochRight, KochF (len/3), KochLeft, KochF (len/3)] + rules m = [LPrim m] + + +kochInterpretation :: KochModule -> [LPrim TurtleModule] +kochInterpretation m = case m of + KochLineWidth wid -> [LPrim $ TSetLineWidth wid] + KochF len -> [LPrim $ TDraw len] + KochLeft -> [LPrim $ TTurnLeft 60] + KochRight -> [LPrim $ TTurnRight 60] diff --git a/src/l-systems/LSystem.hs b/src/l-systems/LSystem.hs new file mode 100644 --- /dev/null +++ b/src/l-systems/LSystem.hs @@ -0,0 +1,49 @@ +module LSystem ( + LSystem (..), + LPrim (..), + + derivations, + interprete, + interpretations + ) where + +import Turtle + + +-- LSystem module = LSystem axiom ableitungsregeln +data LSystem m = LSystem [LPrim m] (m -> [LPrim m]) + +data LPrim m = LPrim m | LStack [LPrim m] + + + +------------------------------------------------------------------------------- + + +-- Einzelnes, primitives Modul ableiten +derive :: (m -> [LPrim m]) -> LPrim m -> [LPrim m] +derive rules x = case x of + LPrim p -> rules p + LStack s -> [LStack $ concatMap (derive rules) s] + + +-- Erzeugt Liste aller Ableitungen eines L-Systems +derivations :: LSystem m -> [ [LPrim m] ] +derivations (LSystem startword rules) = derivations' + where + derivations' = startword : map (concatMap $ derive rules) derivations' + + +-- Übersetzt ein Wort von Modulen des Typs m in ein Wort von Modulen des Typs +-- TurtleModule +interprete :: (m -> [LPrim TurtleModule]) -> [m] -> [LPrim TurtleModule] +interprete = concatMap + + +-- Wendet interprete auf eine Liste von Modulworten an +interpretations :: (m -> [LPrim TurtleModule]) -> [[LPrim m]] -> [[LPrim TurtleModule]] +interpretations rules = map (interprete intPrim) + where + intPrim x = case x of + LPrim p -> rules p + LStack s -> [LStack $ (interprete intPrim) s] diff --git a/src/l-systems/LSystems.hs b/src/l-systems/LSystems.hs new file mode 100644 --- /dev/null +++ b/src/l-systems/LSystems.hs @@ -0,0 +1,342 @@ +module Main (main) where + +-------------------------------------------------------------------------------- +-- +-- Graphische Darstellung von Lindenmayer-Systemen +-- +-- Tastenbelegungen im Hauptfenster: +-- Links, Rechts -> Ansicht um Up-Achse drehen +-- Oben, Unten -> Ansicht um Head-Achse drehen +-- Strg + Pfeiltaste -> Ansicht verschieben +-- '+', '-' -> Ableitungsschritt ändern +-- 'I', 'O' -> Hinein- bzw. Hinauszoomen +-- +-------------------------------------------------------------------------------- + +import Graphics.UI.GLUT hiding (initState) +import Graphics.Rendering.OpenGL + +import LSystem +import Turtle + +import Utilities + +import Data.Char (toUpper) +import Data.IORef + +import KochLSystem -- Koch'sche Schneeflocke, Präfix: "koch" +import IslandLSystem -- Aufgabe 1.a, Präfix: "island" +import TreeLSystem -- Aufgabe 1.b, Präfix: "tree" +import ConiferLSystem -- Aufgabe 1.c, Präfix: "conifer" + +-- Präfix für andere Beispiele ändern +global_Interpretation = kochInterpretation +global_LSystem = kochLSystem + + +-- Aktueller Zustand des Systems +data State = State { + derivationIndex :: Int, + + viewPhi :: Double, + viewTheta :: Double, + zoom :: Double, + pan :: (Double, Double), + viewRatio :: Double, + renderingRequired :: Bool, + + currentLineWidth :: Double, + lineWidthStack :: [Double] + } + + +initState = State { + derivationIndex = 0, + + viewPhi = 0, + viewTheta = 0, + zoom = 1, + pan = (0,0), + viewRatio = + (fromIntegral global_windowSizeX) / (fromIntegral global_windowSizeY), + renderingRequired = True, + + currentLineWidth = 1, + lineWidthStack = [] + } + + +-- globale Werte +global_windowTitle = "Lindenmayer-Systeme" +global_windowSizeX = 400 +global_windowSizeY = 400 +global_pixelWidth = 2 / (fromIntegral global_windowSizeX) + + + +------------------------------------------------------------------------------- +-- MAIN +------------------------------------------------------------------------------- + + +main = do + getArgsAndInitialize + initialDisplayMode $= [WithDepthBuffer, DoubleBuffered] + + state <- newIORef initState + + depthFunc $= Just Less + createWindow global_windowTitle + windowSize $= Size global_windowSizeX global_windowSizeY + + lighting $= Enabled + normalize $= Enabled + depthFunc $= Just Less + + displayCallback $= display state + keyboardMouseCallback $= Just (keyboard state) + reshapeCallback $= Just (reshape state) + + mainLoop + + + +-- Hauptzeichenfunktion -------------------------------------------------------- + + +display state = do + curState <- get state + let + z = realToReal $ zoom curState + (panX, panY) = pan curState + rat = viewRatio curState + + projection (-z) (z) (-z / realToReal rat) (z / realToReal rat) (-1000) (1000) + + clearColor $= Color4 0 0 0 0 + clear [ColorBuffer, DepthBuffer] + + loadIdentity + + position (Light 0) $= Vertex4 (-1) (1) 10 1 + ambient (Light 0) $= Color4 1 1 1 1 + diffuse (Light 0) $= Color4 1 1 1 1 + specular (Light 0) $= Color4 1 1 1 1 + light (Light 0) $= Enabled + + cCyanMaterial + + translate $ Vector3 (doubleToGLfloat panX) (doubleToGLfloat panY) 0 + + rotate (doubleToGLfloat $ negate $ viewTheta curState) $ Vector3 1 0 0 + rotate (doubleToGLfloat $ viewPhi curState) $ Vector3 0 0 1 + + let i = derivationIndex curState + + if (renderingRequired curState) + then defineList (DisplayList 1) CompileAndExecute $ do + sequence_ $ (render state $ + interpretations global_Interpretation $ + derivations global_LSystem) !! i + + else do + callList (DisplayList 1) + + windowTitle $= global_windowTitle ++ " (n=" ++ (show i) ++ ")" + state $= curState { renderingRequired = False } + swapBuffers + + + +-- Fensterskalierung ----------------------------------------------------------- + + +reshape state s = do + curState <- get state + let (Size x y) = s + state $= curState { viewRatio = (fromIntegral x) / (fromIntegral y) } + viewport $= (Position 0 0, s) + + + +-- Tastatur-Ereignisverarbeitung ----------------------------------------------- + + +keyboard state (Char key) Down _ _ = do + curState <- get state + let + i = derivationIndex curState + z = zoom curState + + case toUpper key of + 'I' -> do + state $= curState { zoom = z / 1.05 } + postRedisplay Nothing + 'O' -> do + state $= curState { zoom = z * 1.05 } + postRedisplay Nothing + '+' -> do + state $= curState { derivationIndex = i+1, renderingRequired = True } + postRedisplay Nothing + '-' -> do + state $= curState { derivationIndex = if (i==0) then 0 else i-1, + renderingRequired = True } + postRedisplay Nothing + _ -> return () + +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 + + case specialKey of + KeyLeft -> do + if ctrlPressed + then do + state $= curState { pan = (x-0.05*z, y) } + else do + state $= curState { viewPhi = if phi < 0 then phi+355 else phi-5 } + postRedisplay Nothing + KeyRight -> do + if ctrlPressed + then do + state $= curState { pan = (x+0.05*z, y) } + else do + state $= curState { viewPhi = if phi >= 360 then phi-355 else phi+5 } + postRedisplay Nothing + + KeyDown -> do + if ctrlPressed + then do + state $= curState { pan = (x, y-0.05*z) } + else do + state $= curState + { viewTheta = if theta < 0 then theta+355 else theta-5 } + postRedisplay Nothing + KeyUp -> do + if ctrlPressed + then do + state $= curState { pan = (x, y+0.05*z) } + else do + state $= curState + { viewTheta = if theta >= 360 then theta-355 else theta+5 } + postRedisplay Nothing + _ -> return () + +keyboard _ _ _ _ _ = return () + + + +-- Grafik-Berechnung ----------------------------------------------------------- + + +-- Drehung um alpha Grad um die Up-Achse +rotateU :: GLfloat -> IO () +rotateU alpha = rotate alpha $ Vector3 0 0 (1::GLfloat) + +turnLeft = rotateU +turnRight = rotateU . negate +turnAround = rotateU 180 + + +-- Drehung um alpha Grad um die Left-Achse +rotateL :: GLfloat -> IO () +rotateL alpha = rotate alpha $ Vector3 0 (1) (0::GLfloat) + +pitchDown = rotateL +pitchUp = rotateL . negate + + +-- Drehung um alpha Grad um die Heading-Achse +rotateH :: GLfloat -> IO () +rotateH alpha = rotate alpha $ Vector3 (-1) 0 (0::GLfloat) + +rollLeft = rotateH +rollRight = rotateH . negate + + +-- forward state length draw +-- +-- Turtle length Pixel vorwärts bewegen. Ist draw = True wird ein Zylinder +-- der Länge length im Raum gezeichnet, sonst nur die Position verändert. +-- +forward :: IORef State -> GLfloat -> Bool -> IO () +forward state length draw = do + curState <- get state + + let + len = global_pixelWidth * length + wid = global_pixelWidth * realToReal (currentLineWidth curState) + r = wid/2 + d = global_pixelWidth + + if draw + then do + if len/=0 then drawCylinder r r len 32 else return () + translate $ Vector3 len 0 0 + renderObject Solid $ + Sphere' (realToReal $ r + (global_pixelWidth/10)) 8 8 + else do + translate $ Vector3 len 0 0 + + +-- Liste von TurtleModul-Sequenzen in Zeichenfunktionen übersetzen +render :: IORef State -> [ [LPrim TurtleModule] ] -> [ [IO ()] ] +render state = map render' + where + render' = map r + r (LStack s) = do + curState <- get state + let + oldStack = lineWidthStack curState + wid = currentLineWidth curState + state $= curState { lineWidthStack = wid:oldStack } + preservingMatrix $ sequence_ $ render' s + state $= curState { lineWidthStack = oldStack } + + r (LPrim p) = case p of + TDraw len -> forward state (realToReal len) True + TMove len -> forward state (realToReal len) False + + TTurnLeft alpha -> turnLeft $ realToReal alpha + TTurnRight alpha -> turnRight $ realToReal alpha + TTurnAround -> turnAround + + TPitchDown alpha -> pitchDown $ realToReal alpha + TPitchUp alpha -> pitchUp $ realToReal alpha + + TRollLeft alpha -> rollLeft $ realToReal alpha + TRollRight alpha -> rollRight $ realToReal alpha + + TSetLineWidth wid -> do + curState <- get state + state $= curState { currentLineWidth = realToReal wid } + + +-- Zeichnet Zylinder in der y-z-Ebene (= Turtle-Rücken-Ebene) +drawCylinder ry rz len n = do + renderPrimitive QuadStrip (vertexesN $ interleave fullE fullE') + where + fullE' = map (\(x,y,z) -> (x+len,y,z)) fullE + fullE = [(0,y,z::GLfloat) | i<-[0..n], + let a = 2 * pi * i/n, let y = -ry * cos a, let z = rz * sin a] + + +-- Gibt eine Liste von Punkten in Form von vertex-Befehlen wieder. Die Liste +-- wird als QuadStrip interpretiert und für jedes Rechteck der entsprechende +-- Normalenvektor eingefügt +vertexesN :: (VertexComponent a, NormalComponent a, Num a) => [(a,a,a)] -> IO () +vertexesN (a:b:c:d:rs) = do + normal $ norm a b c + vertex $ vert a + vertex $ vert b + vertexesN (c:d:rs) + where + vert = \(x,y,z) -> Vertex3 x y z + norm = \v1 v2 v3 -> let (x, y, z) = (v2-v1) * (v3-v1) in Normal3 x y z +-- Restliche Punkte einfach in Vertexes umwandeln +vertexesN rs = sequence_ $ map (\(x,y,z) -> vertex (Vertex3 x y z)) rs diff --git a/src/l-systems/TreeLSystem.hs b/src/l-systems/TreeLSystem.hs new file mode 100644 --- /dev/null +++ b/src/l-systems/TreeLSystem.hs @@ -0,0 +1,42 @@ +module TreeLSystem ( + TreeModule (..), + treeLSystem, + treeInterpretation, + ) where + +import LSystem +import Turtle + + +data TreeModule = + TreeA | TreeF Double | TreeEx Double | TreeLineWidth Double | + -- Turn-, Roll und Pitch-Befehle + TreeRR Double | TreePU Double | TreePD Double + +treeLSystem :: LSystem TreeModule +treeLSystem = LSystem + (map LPrim [TreePU 90, TreeEx 1, TreeF 200, TreeRR 45, TreeA]) rules + where + d1 = 112.50 -- divergence angle 1 + d2 = 157.50 -- divergence angle 2 + a = 32.50 -- branching angle + lr = 1.14 -- elongation rate + vr = 1.732 -- width increase rate + rules TreeA = [ LPrim $ TreeEx vr, LPrim $ TreeF 50, + LStack [LPrim $ TreePD a, LPrim $ TreeF 50, LPrim TreeA], + LPrim $ TreeRR d1, + LStack [LPrim $ TreePD a, LPrim $ TreeF 50, LPrim TreeA], + LPrim $ TreeRR d2, + LStack [LPrim $ TreePD a, LPrim $ TreeF 50, LPrim TreeA] ] + rules (TreeF len) = [LPrim $ TreeF (len*lr)] + rules (TreeEx wid) = [LPrim $ TreeEx (wid*vr)] + rules m = [LPrim m] + +treeInterpretation :: TreeModule -> [LPrim TurtleModule] +treeInterpretation m = case m of + TreeF len -> [LPrim $ TDraw len] + TreePU a -> [LPrim $ TPitchUp a] + TreePD a -> [LPrim $ TPitchDown a] + TreeRR a -> [LPrim $ TRollRight a] + TreeEx wid -> [LPrim $ TSetLineWidth wid] + _ -> [] diff --git a/src/l-systems/Turtle.hs b/src/l-systems/Turtle.hs new file mode 100644 --- /dev/null +++ b/src/l-systems/Turtle.hs @@ -0,0 +1,27 @@ +module Turtle ( + TurtleModule (..) + ) where + + +-- Turtle-Modul +-- ____ +-- _//__\\=o +-- ^ ^ + +data TurtleModule = + TDraw Double | -- Länge len vorwärts bewegen und eine Linie zeichnen + TMove Double | -- Länge len vorwärts bewegen ohne eine Linie zu zeichnen + + TTurnLeft Double | -- alpha Grad links um die Up-Achse drehen + TTurnRight Double | -- alpha Grad rechts um die Up-Achse drehen + TTurnAround | -- 180 Grad um die Up-Achse drehen + + TPitchDown Double | -- alpha Grad auf der Left-Achse nach unten neigen + TPitchUp Double | -- alpha Grad auf der Left-Achse nach oben neigen + + TRollLeft Double | -- alpha Grad auf der Head-Achse nach links rollen + TRollRight Double | -- alpha Grad auf der Head-Achse nach rechts rollen + + TSetLineWidth Double -- Linienbreite setzen + + deriving (Eq, Show) diff --git a/src/mountains/Mountains.hs b/src/mountains/Mountains.hs new file mode 100644 --- /dev/null +++ b/src/mountains/Mountains.hs @@ -0,0 +1,494 @@ +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]