module Exercise10 where

import Data.List (find)
import Data.Map as Map (lookup)
import Data.Maybe (fromMaybe)
import System.IO (hReady, stdin)
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' t = move 10 t
apply 'G' t = move 10 t
apply '+' t = turn 30 t
apply '-' t = turn (-30) t
apply '*' t = turn 15 t
apply '~' t = turn (-15) t
apply _ t = sit t

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

-- finds the first occurrence of a fitting rule
findRule :: [Rule] -> Char -> Rule
findRule [] c = c :->: [c]
findRule ((c :->: cs) : rules) char = if c == char then c :->: cs else findRule rules char

-- expands the L-System n times
expandLSystem :: LSystem -> Integer -> String
expandLSystem (LSystem s _) 0 = s
expandLSystem (LSystem s rules) i = expandLSystem (LSystem result rules) (i -1)
  where
    result = concatMap ((\(_ :->: cs) -> cs) . findRule rules) s

-- updating LSystem via command
updateSystem :: String -> LSystem -> LSystem
updateSystem _ ls = ls

parseCmd :: LSystem -> String -> IO LSystem
-- start
parseCmd (LSystem _ rules) ('s' : 't' : 'a' : 'r' : 't' : ' ' : s) = return (LSystem s rules)
-- clear
parseCmd _ "clear" = return (LSystem "" [])
-- rule
parseCmd (LSystem start rules) ('r' : 'u' : 'l' : 'e' : ' ' : rule) = do
  if checkRule rule
    then return (LSystem start ((w :->: xs) : rulesFiltered))
    else do
      putStrLn "Error parsing rule"
      return (LSystem start rules)
  where
    checkRule :: String -> Bool
    checkRule (w : ' ' : '-' : '>' : ' ' : xs) = not (null xs)
    checkRule _ = False
    parseRule :: String -> (Char, String)
    parseRule (w : ' ' : '-' : '>' : ' ' : xs) = (w, xs)
    (w, xs) = parseRule rule
    rulesFiltered = filter (\(c :->: _) -> c /= w) rules
-- print
parseCmd ls "print" = do
  putStr (show ls ++ "\n")
  return ls
-- unknow
parseCmd ls cmd = do
  putStrLn "Error parsing command"
  return ls

updateWithInit :: LSystem -> String -> IO LSystem
updateWithInit ls _ = do
  cs <- getLine
  newLs <- parseCmd ls cs
  update newLs

update :: LSystem -> IO LSystem
update ls = do
  more <- hReady stdin
  if more then updateWithInit ls "" else return ls

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