-- 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