-- 2007 programming competition entry by Stuart Taylor ( s0784458 ) module StuProgComp where -- The first part of this file is all the stuff from LSystem.hs, and a few functions from the tutorial exercise. The actual competition code is in the second half -- Run the "main" function to see the image! import List import System import Control.Monad.State ( get,put,runState,State ) display :: Float -> Command -> IO () display n ps = do username <- getEnv "LOGNAME" let filename = "/tmp/turtle-" ++ username ++ ".ps" system ( "rm -f " ++ filename ) writeFile filename ( dumpPS n ps ) system ( "gv " ++ filename ) return () data Pen = Colour Float Float Float | Inkless deriving ( Eq, Ord, Show ) mix :: Pen -> Pen -> Pen mix ( Colour a b c ) ( Colour a' b' c' ) = Colour ( ( a+a' ) / 2 ) ( ( b+b' ) / 2 ) ( ( c+c' ) / 2 ) type Distance = Float type Angle = Float data Command = Go Distance | Turn Angle | Sit | Command :#: Command | Branch Command | GrabPen Pen deriving ( Eq, Ord, Show ) type PostScript = String toPSC ( Colour r g b ) = show r ++ " " ++ show g ++ " " ++ show b ++ " c\n" toPSC Inkless = "" type PState a = State Pen a toPSM :: Command -> PState String toPSM ( Go d ) = do pen <- get return \$ case pen of Inkless -> show d ++ " 0 moveto currentpoint translate\n" _ -> show d ++ " 0 f\n" toPSM ( Turn angle ) = return \$ show angle ++ " rotate\n" toPSM ( p :#: q ) = do pen <- get p1 <- toPSM p p2 <- toPSM q return \$ p1 ++ p2 toPSM ( GrabPen c ) = do put c; return \$ toPSC c toPSM ( Branch p ) = do path <- toPSM p return \$ "gsave\n" ++ path ++ " grestore\n" toPSM Sit = return "" header = ( "/f { lineto currentpoint translate currentpoint stroke moveto } def\n" ++ "/c { /DeviceRGB setcolorspace setrgbcolor } def\n" ++ "newpath\n" ++ "300 450 translate\n" ++ "90 rotate\n" ) dumpPS :: Float -> Command -> PostScript dumpPS n p = header ++ scale ++ " 0 0 moveto\n" ++ pathbit ++ " stroke showpage\n" where ( pathbit, _ ) = runState ( toPSM p ) ( Colour 0 0 0 ) scale = show n ++ " " ++ show n ++ " scale\n" equivalent a b = nosit ( flatten a ) == nosit ( flatten b ) where nosit ( a :#: Sit ) = nosit a nosit ( Sit :#: b ) = b nosit ( a :#: b ) = nosit a :#: b nosit cmd = cmd flatten :: Command -> Command flatten ( a :#: ( b :#: c ) ) = flatten( a :#: b :#: c ) flatten ( a :#: b ) = ( flatten a :#: b ) flatten cmd = cmd copy :: Int -> Command -> Command copy n x = foldl ( :#: ) Sit \$ replicate n x -- Competition code starts here -- Gradient colours for the tree part of the picture c :: Int -> Pen c x = Colour ( 0.65 + fromIntegral x * 0.05 ) ( fromIntegral x * 0.15 ) ( 0.2 - fromIntegral x * 0.03 ) -- Gradient colours for the shell part of the picture d :: Int -> Pen d x = Colour ( 0.55 + fromIntegral x * 0.05 ) ( fromIntegral x * 0.15 ) ( 0.35 - fromIntegral x * 0.02 ) -- Colour for certain bits e :: Pen e = Colour 0.6 0.2 0.35 -- Draws a circle circle :: Pen -> Distance -> Command circle p d = Turn ( -90 ) :#: GrabPen p :#: copy 36 ( Go ( d * 3 ) :#: Turn 10 ) :#: Turn 90 -- Draws a predefined circle cCircle :: Float -> Int -> Command cCircle scale x = circle ( d x ) \$ fromIntegral ( x + 1 ) * scale -- Draws several circles in a cool pattern circles :: Float -> Command circles scale = f 5 where f 0 = cCircle scale 0 f n = cCircle scale n :#: f ( n - 1 ) -- Sets the cursor to the right place to start drawing the image startPos :: Command startPos = GrabPen Inkless :#: Go ( -300 ) :#: Turn 90 :#: Go ( -40 ) :#: Turn ( -90 ) -- Draws part of the image using recursion bigShell :: Int -> Command bigShell x = f x x :#: circle e 6 where f ( x + 1 ) a = Turn ( 460.0 / fromIntegral ( x - 2 * a ) ) :#: circles ( 0.5 * ( 1 + fromIntegral ( a - x ) / ( fromIntegral a ) ) ) :#: f x a f 0 _ = Sit -- Draws a cool tree-like fractal fractal :: Int -> Command fractal x = f x where f 0 = Go 20 :#: circle e 0.2 f ( x + 1 ) = GrabPen ( c ( 5 - x ) ) :#: g x :#: Branch ( Turn 45 :#: f x ) :#: Branch ( Turn ( -45 ) :#: f x ) :#: Branch ( g x :#: f x ) g 0 = Go 35 g ( x + 1 ) = g x :#: Branch ( Turn 30 :#: g x ) :#: Branch ( Turn ( -30 ) :#: g x ) -- Draws the connecting line and the fractal sprout :: Command sprout = GrabPen Inkless :#: Turn ( -43.14 ) :#: Turn 90 :#: Go 18 :#: Turn ( -90 ) :#: Go 10 :#: GrabPen ( d 0 ) :#: Go 175 :#: GrabPen ( c 0 ) :#: Go 75 :#: fractal 6 -- Draws the picture main :: IO () main = display 0.75 \$ startPos :#: bigShell 60 :#: sprout