module Exercise10 where

import Data.List
import Data.Map as Map (lookup)
import Data.Maybe (fromMaybe)
import System.IO
import Turtle

-- data type for L-System
data Rule = Char :->: String -- context-free and deterministic!
  deriving (Eq, Show)

data LSystem = LSystem
  { start :: String,
    rules :: [Rule] -- constraint: unique left sides
  }
  deriving (Eq)

instance Show LSystem where
  show (LSystem s r) = unlines $ ["Start: " ++ show s, "Rules: "] ++ map show r

apply :: Char -> Turtle -> Turtle
apply 'F' = move 10
apply 'G' = move 10
apply 'H' = move 10
apply 'I' = move 5
apply 'J' = move 5
apply '+' = turn 30
apply '-' = turn (-30)
apply '*' = turn 15
apply '~' = turn (-15)
apply '[' = branch
apply ']' = endBranch
apply 'b' = changeColor $ Colour 0.4 0.8 1.0
apply _ = sit

-- Use apply to convert movements of turtle to GL lines.
-- Try changing the color to red!
execute :: LSystem -> Integer -> [Ln]
execute ls n = let (pen, ang, pnt, ln, bps) = lines (black, 0, 0, [], []) $ expandLSystem ls n in ln
  where
    lines t [] = t
    lines t (x : xs) = lines (apply x t) xs

-- sample LSystems for (manual) testing
dragoncurve :: LSystem
dragoncurve = LSystem "FX" ['X' :->: "X+++YF+++", 'Y' :->: "---FX---Y"]

kochcurve :: LSystem
kochcurve = LSystem "F" ['F' :->: "F+++F---F+++F---F"]

sierpinski :: LSystem
sierpinski = LSystem "F++++G++++G" ['F' :->: "F++++G----F----G++++F", 'G' :->: "GG"]

tree :: LSystem
tree = LSystem "F" ['F' :->: "G[+*F][-~F]", 'G' :->: "GG"]

-- finds the first occurrence of a fitting rule
findRule :: [Rule] -> Char -> Rule
findRule [] c' = c' :->: [c']
findRule (r@(c :->: _) : rs) c'
  | c == c' = r
  | otherwise = findRule rs c'

-- expands the L-System n times
expandLSystem :: LSystem -> Integer -> String
expandLSystem ls 0 = start ls
expandLSystem ls i = expandLSystem (LSystem (concatMap (applyRule . findRule (rules ls)) $ start ls) $ rules ls) $ i - 1
  where
    applyRule (_ :->: s) = s

-- updating LSystem via command
update :: LSystem -> IO LSystem
update ls = do
  b <- hReady stdin
  if b
    then do
      x <- getLine
      let t : okens = let tokens = words x in if null tokens then [""] else tokens
      let h = head okens
      case t of
        "start" | length okens == 1 -> update $ LSystem h $ rules ls
        "rule" ->
          if length okens == 3 && length h == 1 && okens !! 1 == "->"
            then let c = head h in update $ LSystem (start ls) $ (c :->: last okens) : removeRule (rules ls) c
            else do
              putStrLn "Error parsing rule"
              update ls
        "clear" | null okens -> update $ LSystem "" []
        "print" | null okens -> do
          putStr $ show ls
          update ls
        _ -> do
          putStrLn "Error parsing command"
          update ls
    else return ls
  where
    removeRule [] _ = []
    removeRule (r@(c :->: _) : rs) c'
      | c == c' = rs
      | otherwise = r : removeRule rs c'

-- add the WETT ... TTEW tags if you want to participate in the wettbewerb!

{-WETT-}

spiral :: LSystem
spiral = LSystem "F" ['F' :->: "F*GH", 'G' :->: "GH"]

triangle :: LSystem
triangle = LSystem "bFGF++++FGF++++FGF" ['F' :->: "FGF", 'G' :->: "--FGF++++FGF--"]

snowflake :: LSystem
snowflake = LSystem "b[FGF][++FGF][++++FGF][++++++FGF][----FGF][--FGF]" ['F' :->: "FGF", 'G' :->: "G[+*FGF][-~FGF]"]

-- It ain't much, but it's honest work!
snowflake2 :: LSystem
snowflake2 =
  LSystem "bJ--J--J--J--J--J" ['F' :->: "F+*I---J*+F", 'G' :->: "G+*J---I*+G", 'J' :->: "+++FF~H-----H~GG+++"]

{-TTEW-}