Re: [Haskell-cafe] Lindenmayer Systems, WAS: (no subject)

[Adrian Neumann]

I screwed up the email, sorry about that. What I wanted to say was:

Hello,



Ok, here we go:

as homework I was assigned to "design and draw an image" using the SOE Graphics library [1]. In order to impress my classmates I decided to draw a bush-like thingy using a Lindenmayer-System. It turns out quite nice [2], and so I thought I might share my code with you. Of course criticism is very welcome.

{- I downloaded the source and put my file in the same directory
   You may need to adjust the imports -}
module Main where
import Picture
import Draw -- change xWin to 1000 and yWin to 700 for this to work
import EnableGUI -- I use a Mac
import SOE hiding (Region)
import qualified SOE as G (Region)
import Data.List
import Random

-- lines are not Shapes unfortunately


main = enableGUI >> do
    w <- openWindow "Lindenmayer System" (xWin, yWin)
    newStdGen
    g <- getStdGen
    drawPic w (aufgabe2 g)
    k <- getKey w
    if (k=='q') then do
        closeWindow w
        return () else do
            clearWindow w
            main

-- one big ugly line of code, not that interesting though
aufgabe2 g= dasBild where

            Region Blue (Shape $ Rectangle 14 7)

-- start of the interesting part:
-- A - Axiom, the base shape we use for rendering later
--F - Forward
--Branch - what it says



-- a Axiom is a region with two connector points
type Axiom = (Region, Vertex, Vertex)

-- this seems not to be used anymore?

scaleAxiom :: Float -> Axiom -> Axiom
scaleAxiom f (r,u,v) = (Scale (f,f) r, f .*. u, f .*. v)

-- just for testing purposes


-- a 2D rotation matrix
drehM :: Float -> (Float, Float, Float, Float)
drehM w = (cos w, -sin w, sin w, cos w)

-- matrix vector multiplication
(.**.) :: (Float, Float, Float, Float) -> Vertex -> Vertex
(.**.) (a,b,c,d) (px,py) = (a*px+b*py, c* px+d*py)

-- other vector stuff
(.-.) (a,b) (c,d) = (a-c,b-d)
(.+.) (a,b) (c,d) = (a+c,b+d)
(.*.) l (c,d) = (c*l,d*l)
abs' (a,b) = (abs a, abs b)
betr (a,b) = sqrt (a*a+b*b)

-- SOE doesn't come with a way to rotate Regions, so I wrote my own
rotateRegion :: Float -> Region -> Region
rotateRegion f (Shape s) = Shape (rotateS f s)



-- into the rendering


    x = ((drehM f).**. (fst v,0))
    y = ((drehM f) .**. (0,snd v))
    nv = (abs' x) .+. (abs' y)
rotateRegion f (Complement r) =Complement (rotateRegion f r)

rotateRegion _ s=s

rotateS f (Polygon pts) = Polygon (map ((drehM f) .**.) pts)
rotateS f x = x

-- nondeterministically generate a word in our LSys language
-- lots of copy&paste here, any way to do this better?

lSystem :: Int -> StdGen -> LSys
lSystem n g = f n g (A undefined) where
    f :: Int -> StdGen -> LSys -> LSys
    f 0 _ _ = Done
    f (n+1) g (A _)
        | choose >= 1 = A (f n ng (F undefined))

            (choose, ng) = randomR (0::Int,3::Int) g
            (ng', ng'') = split ng
    f (n+1) g (F _)
        | choose >= 1 = F (f n ng (F undefined))

            (choose, ng) = randomR (0::Int,3::Int) g
            (ng', ng'') = split ng
    f (n+1) g (Branch h lSys _)
        | choose >= 1 = Branch h lSys  (f n ng (F undefined))

            (choose, ng) = randomR (0::Int,5::Int) g
            (ng', ng'') = split ng

-- recursivly render a LSys
renderLSystem :: Axiom -> LSys -> Region
renderLSystem _ Done = Empty
renderLSystem (r,u,v) (A lSys) = r `Union` renderLSystem (r,u,v) lSys

    r'' =  Translate o   $  r
    o = (v .-. u)
renderLSystem (r,u,v) (Branch g lSys rest) =
    theBranches `Union` renderLSystem (r,u,v) rest where
        theBranches = Translate o $ foldr Union Empty $
        -- we need to rotate around the u-Connector, not around (0,0)
        -- thus translation

        o = (v .-. u)

linie = ((Shape $ Polygon [(-0.1,-0.01),(-0.1,0.01),(0.1,0.01), (0.1,-0.01)]), (-0.1,0), (0.1,0)) r = rotateRegion (pi/2) $ Translate (-2.5,0) $ renderLSystem linie (lSystem 20 g) dasBild = Region White r `Over` Region Black ( Translate (0,-1.8) $ Scale (1,0.3)$ Translate (0,-2.6) $ rotateRegion (pi/2 +pi/3) $ Translate (0,2.6) $ r) `Over` Region Green (Shape $ Polygon [(-5,-3.5),(-5,-1.5),(5,-1.5),(5,-3.5)]) `Over` Region Yellow (Translate (4,1.5) (Shape $ circle (0.5))) `Over` data LSys = A LSys | F LSys | Branch StdGen [LSys] LSys | Done deriving Show testLSys = A (Branch (mkStdGen 5) [A (F ((Branch (mkStdGen 5) [A (Branch (mkStdGen 5) [A (F ((Branch (mkStdGen 5) [A (F Done), A (F Done)] Done))), A (F Done)] Done), A (F Done)] Done))), A (F Done)] Done) rotateRegion f (Translate v r) = Translate ((drehM f).**.v) (rotateRegion f r) -- the scaling part is not right I think. Everything seems to break if I try to incorporate scaling rotateRegion f (Scale v r) = Scale ((betr v/ betr nv) .*. nv) (rotateRegion f r) where rotateRegion f (Union r1 r2) = Union (rotateRegion f r1) (rotateRegion f r2) rotateRegion f (Intersect r1 r2) = Intersect (rotateRegion f r1) (rotateRegion f r2) rotateRegion f (Xor r1 r2) = Xor (rotateRegion f r1) (rotateRegion f r2) | choose == 0 = A (f n ng (Branch ng [f n ng' (A undefined), f n ng'' (A undefined)] undefined)) where | choose == 0 = F (f n ng (Branch ng [f n ng' (A undefined), f n ng'' (A undefined)] undefined)) where | choose == 0 = Branch h lSys (f n ng (Branch ng [f n ng' (A undefined), f n ng'' (A undefined)] undefined)) where renderLSystem (r,u,v) (F lSys) = r'' `Union` renderLSystem (r'', u . +. o , v .+.o) lSys where map (Translate u) $ zipWith ($) rotations (map ((Translate ((0,0).-.u)).(renderLSystem (r,u,v))) lSys) rotations = map rotateRegion (randomRs (-pi/4,pi/3) g) -- branches are rotated randomly

What do you think?

Adrian

[1] http://www.haskell.org/soe/graphics.htm
[2] http://img149.imageshack.us/my.php?image=bild1tf4.png

PGP.sig
Description: Signierter Teil der Nachricht

_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe