3d-graphics-examples (empty) → 0.0.0.0
raw patch · 12 files changed
+1281/−0 lines, 12 filesdep +GLUTdep +OpenGLdep +basesetup-changed
Dependencies added: GLUT, OpenGL, base, random
Files
- 3d-graphics-examples.cabal +64/−0
- LICENSE +28/−0
- Setup.lhs +4/−0
- src/Utilities.hs +124/−0
- src/l-systems/ConiferLSystem.hs +46/−0
- src/l-systems/IslandLSystem.hs +32/−0
- src/l-systems/KochLSystem.hs +29/−0
- src/l-systems/LSystem.hs +49/−0
- src/l-systems/LSystems.hs +342/−0
- src/l-systems/TreeLSystem.hs +42/−0
- src/l-systems/Turtle.hs +27/−0
- src/mountains/Mountains.hs +494/−0
+ 3d-graphics-examples.cabal view
@@ -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
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runghc++> import Distribution.Simple+> main = defaultMain
+ src/Utilities.hs view
@@ -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
+ src/l-systems/ConiferLSystem.hs view
@@ -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]+ _ -> []
+ src/l-systems/IslandLSystem.hs view
@@ -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)]
+ src/l-systems/KochLSystem.hs view
@@ -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]
+ src/l-systems/LSystem.hs view
@@ -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]
+ src/l-systems/LSystems.hs view
@@ -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
+ src/l-systems/TreeLSystem.hs view
@@ -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]+ _ -> []
+ src/l-systems/Turtle.hs view
@@ -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)
+ src/mountains/Mountains.hs view
@@ -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]