On 2008.06.15 16:50:28 +0200, Adrian Neumann <[EMAIL PROTECTED]> scribbled 6.9K characters: > 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
That's interesting, nice and short. The output actually reminds me a lot of Nymphaea <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/nymphaea>; have you seen't? -- gwern Maple 82 Visa/BCC noise noise FCA Blacknet TELINT WISDIM S/Key
signature.asc
Description: Digital signature
_______________________________________________ Haskell-Cafe mailing list Haskell-Cafe@haskell.org http://www.haskell.org/mailman/listinfo/haskell-cafe