module Exercise10 where

import Data.Char (isDigit, isLower)
import Data.List (delete, elemIndex, find, isPrefixOf, (\\))
import Data.Map as Map (lookup)
import Data.Maybe (fromJust, 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

{-WETT-}

apply :: Char -> Turtle -> Turtle
apply 'C' t = move 1.5 t
apply 'F' t = move 3 t
apply 'G' t = move 9 t
apply '+' t = turn 60 t
apply 'p' t = apply '+' t
apply '-' t = turn (-60) t
apply '*' t = turn 65 t
apply '~' t = turn (-65) t
apply '[' t = branch t
apply ']' t = endBranch t
apply '(' t = posBranch t
apply ')' t = endPosBranch t
apply 'S' t = iterate (hex . apply '+') (hex t) !! 5
  where
    hex = applyChain "[CCCC[~([C-(C)+(C)+(C)])*([C-(C)+(C)+(C)])*([C-(C)+(C)+(C)])]CCC~([F-(F)+(F)+(F)])*([F-(F)+(F)+(F)])*([F-(F)+(F)+(F)])]"
{-MCCOMMENT Use the simplified snowflake below for better performance-}
-- hex = applyChain "([FF-(F)+(F)+(F)])"
apply s t
  | s `elem` ['0' .. '9'] = jump (30 + 4 * fromIntegral (fromJust $ s `elemIndex` "5248190763")) t
  | s `elem` ['a' .. 'z'] = turn (fromIntegral (fromJust $ s `elemIndex` "bwxqkztafdrnicvuhpyemlgjso") + 0.5 * (360 / 26)) t
  | otherwise = sit t

applyChain :: String -> Turtle -> Turtle
applyChain s t = foldl (flip apply) t s

snowfall :: LSystem
snowfall =
  LSystem "SH" $
    ('H' :->: "a0SH") :
    ( [let sc = succ c in c :->: if isLower sc then [sc] else "a" | c <- ['a' .. 'z']]
        ++ [let sc = succ c in c :->: if isDigit sc then [sc] else "0" | c <- ['0' .. '9']]
    )

snowflake :: LSystem
snowflake = LSystem "(F)p(F)p(F)p(F)p(F)p(F)" ['F' :->: "[FF-(F)+(F)+(F)]", '+' :->: "+*", '-' :->: "-~"]

-- 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 (white, 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 rs c = fromMaybe (c :->: [c]) $ find (\(ch :->: _) -> ch == c) rs

aux :: Rule -> String
aux (_ :->: str) = str

-- expands the L-System n times
expandLSystem :: LSystem -> Integer -> String
expandLSystem LSystem {start = s} 0 = s
expandLSystem LSystem {start = s, rules = r} n = expandLSystem (newsys $ concatMap (aux . findRule r) s) (n -1)
  where
    newsys :: String -> LSystem
    newsys st = LSystem {start = st, rules = r}

-- updating LSystem via command
update :: LSystem -> IO LSystem
update lsys@LSystem {start = s, rules = r} = do
  r <- hReady stdin
  if not r
    then return lsys
    else do
      (again, newsys) <- getLine >>= executeCmd
      if again
        then update newsys
        else return newsys
  where
    executeCmd c
      | "start " `isPrefixOf` c = return (True, LSystem {start = c \\ "start ", rules = r})
      | "rule" `isPrefixOf` c =
        let string = drop 10 c
            char = c !! 5
         in if length c > 6 && " -> " `isPrefixOf` tail (c \\ "rule ") && not (null string) && ' ' `notElem` string
              then return (True, LSystem {start = s, rules = (char :->: drop 10 c) : filter (\(ch :->: _) -> ch /= char) r})
              else do
                putStrLn "Error parsing rule"
                return (True, lsys)
      | c == "clear" = return (True, LSystem {start = "", rules = []})
      | c == "print" = do
        print lsys
        return (True, lsys)
      | otherwise = do
        putStrLn "Error parsing command"
        return (True, lsys)

{-TTEW-}