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

[Adrian Neumann]

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

Hello,

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.

Ok, here we go:


> {- 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
> 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))
>
> 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
>     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`
>             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
>
> data LSys = A LSys | F LSys | Branch StdGen [LSys] LSys | Done  
> deriving Show
>
> -- 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
> 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)
>
> -- 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)
> 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
> -- into the rendering
>
> rotateRegion f (Scale v r) = Scale ((betr v/ betr nv) .*. nv)  
> (rotateRegion f r) where
>     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 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)
> 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 == 0 = A (f n ng (Branch ng [f n ng' (A  
> undefined), f n ng'' (A undefined)] undefined)) where
>             (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 == 0 = F (f n ng (Branch ng [f n ng' (A  
> undefined), f n ng'' (A undefined)] undefined)) where
>             (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 == 0 = Branch h lSys (f n ng (Branch ng [f n  
> ng' (A undefined), f n ng'' (A undefined)] undefined)) where
>             (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
> renderLSystem (r,u,v) (F lSys) = r'' `Union` renderLSystem (r'', u . 
> +. o , v .+.o) lSys where
>     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
>             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
>         o = (v .-. u)

What do you think?

Adrian

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


-------------- next part --------------
A non-text attachment was scrubbed...
Name: PGP.sig
Type: application/pgp-signature
Size: 194 bytes
Desc: Signierter Teil der Nachricht
Url : http://www.haskell.org/pipermail/haskell-cafe/attachments/20080615/febb4538/PGP.bin