import System.IO
import Text.Printf (hPrintf)
import Control.Exception (finally)

main :: IO ()
main = draw "drawing.ps" $ turtle $ createSnow 4

-- Snow:

createSnow :: Int -> String
createSnow depth = lSystem rules "k7 + k7 + k7 + k7 + k7 + k7" depth where
  rules :: String -> String 
  rules "k"   = "d fff ++++ fff ++++ fff u"
  rules "k2"  = "d fff + fff + fff + fff + fff + fff u"
  rules "fff" = "fff + fff -- fff + fff"
  rules "mf"  = "mf mf mf"
  rules "k6"  = "k2 +++ mf k +++ mf k +++ mf k +++ mf k +++ mf k +++ mf k mf"
  rules "k7"  = "k6 k6 k6 k6 k6 k6 mf"
  rules cmd   = cmd

-- L-System:

lSystem :: (String -> String) -> String -> Int -> String
lSystem rules start 0     = start
lSystem rules start depth = lSystem rules (apply rules start) (depth-1) where
  apply rules start = join " " $ map rules $ split ' ' start

  -- do I really have to write this functions myself?
  split :: Char -> String -> [String]
  split _ [] = [""]
  split del (c:cs)
    | c == del  = "" : rest
    | otherwise = (c : head rest) : tail rest
    where rest = split del cs

  join :: String -> [String] -> String
  join _ [] = ""
  join sep (x:xs)
    | null xs   = x
    | otherwise = x ++ sep ++ join sep xs

-- Turtle:

type Point = (Float,Float)
type Path  = [Point]
data State = State Point Float Bool
     deriving Show

turtle :: String -> [Path]
turtle commands = process commands (State (0,0) 0 False) [] where

  process :: String -> State -> [Path] -> [Path]
  process [] _ paths = reverse $ map reverse $ paths
  process (cmd:cmds) state paths = process cmds state' paths' where
    state' = execute cmd state
    paths' = setup cmd paths state state'

  execute :: Char -> State -> State
  execute cmd (State (x,y) a pen) = 
    case cmd of
      'd' -> State (x,y)   a    True
      'u' -> State (x,y)   a    False
      '+' -> State (x,y)  (a+1) pen
      '-' -> State (x,y)  (a-1) pen
      'f' -> State (x',y') a    pen where
               x'  = x + cos rad
               y'  = y + sin rad
               rad = pi/3 * a
      _   -> State (x,y) a pen

  setup :: Char -> [Path] -> State -> State -> [Path]
  setup 'd' paths (State (x,y) _ False) _ = [(x,y)]:paths
  setup 'f' (path:paths) _ (State (x,y) _ True) = ((x,y):path):paths
  setup _ paths _ _ = paths

-- PostScript:

draw :: String -> [Path] -> IO ()
draw filename paths = do
  file <- openFile filename WriteMode
  postscript file paths `finally` hClose file
  return ()
  where

  postscript :: Handle -> [Path] -> IO ()
  postscript file paths = do
    hPutStrLn file "300 300 scale"
    hPutStrLn file "0.7 1.2 translate"
    hPutStrLn file "0 setlinewidth\n"
    let (xs,ys) = unzip $ concat paths
        x       = minimum xs
        x'      = maximum xs
        y       = minimum ys
        y'      = maximum ys
        scale   = 1 / maximum [1, x'-x, y'-y]
    process file scale paths
    hPutStrLn file "showpage"

  process :: Handle -> Float -> [Path] -> IO ()
  process _ _ [] = return ()
  process _ _ ([]:_) = return ()
  process file scale (((x,y):path):paths) = do
    hPrintf file "%f %f moveto\n" (x*scale) (y*scale)
    foldr (>>) (return ()) $ map (lineto file scale) path
    hPutStrLn file "stroke\n"
    process file scale paths

  lineto :: Handle -> Float -> Point -> IO ()
  lineto file scale (x,y) =
    hPrintf file "%f %f lineto\n" (x*scale) (y*scale)