[Haskell-cafe] (no subject)

[Adrian Neumann]

{- 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)
-------------- 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/e4c3e999/PGP.bin