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' 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 '7' t = turn 7 t
apply '8' t = turn (-7) t
apply '1' t = turn 1 t
apply '2' t = turn (-1) t
apply '3' t = move 5 t
apply 'b' t = changeColor blue t
apply 'w' t = changeColor white t
apply 'r' t = changeColor red t
apply 'g' t = changeColor green t
apply 'B' t = changeColor black t
apply 'N' (Colour a b c, angle, pnt, xs, ys) = changeColor (Colour b c a) (Colour a b c, angle, pnt, xs, ys)
apply 'P' (Colour a b c, angle, pnt, xs, ys) = changeColor (Colour c a b) (Colour a b c, angle, pnt, xs, ys)
apply _ t = sit t

inverseString :: Char -> String -> String
inverseString _ [] = []
inverseString color (x : xs) = inverseString newColor xs ++ xInv
  where
    xInv
      | x == 'F' || x == 'G' = "++++++F------"
      | x == '+' = "-"
      | x == '-' = "+"
      | x == '*' = "~"
      | x == '~' = "*"
      | x == '7' = "8"
      | x == '8' = "7"
      | x == '1' = "2"
      | x == '2' = "1"
      | x == '3' = "++++++3------"
      | x == 'b' || x == 'w' || x == 'r' || x == 'g' || x == 'B' = [color]
      | x == 'N' = "P"
      | x == 'P' = "N"
      | otherwise = ""
    newColor
      | x == 'b' || x == 'w' || x == 'r' || x == 'g' || x == 'B' = x
      | x == 'P' && color == 'r' = 'g'
      | x == 'P' && color == 'g' = 'b'
      | x == 'P' && color == 'b' = 'r'
      | x == 'N' && color == 'r' = 'b'
      | x == 'N' && color == 'g' = 'r'
      | x == 'N' && color == 'b' = 'g'
      | otherwise = color

getBranchString :: Char -> String -> String -> (String, String)
getBranchString _ [] branch = (branch, [])
getBranchString color (x : xs) branch
  | x == '[' = let (inner, rest) = getBranchString newColor xs [] in getBranchString newColor rest (branch ++ inner ++ inverseString newColor inner)
  | x == ']' = (branch, xs)
  | otherwise = getBranchString newColor xs (branch ++ [x])
  where
    newColor
      | x == 'b' || x == 'w' || x == 'r' || x == 'g' || x == 'B' = x
      | x == 'P' && color == 'r' = 'g'
      | x == 'P' && color == 'g' = 'b'
      | x == 'P' && color == 'b' = 'r'
      | x == 'N' && color == 'r' = 'b'
      | x == 'N' && color == 'g' = 'r'
      | x == 'N' && color == 'b' = 'g'
      | otherwise = color

-- 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 (penL, angL, pntL, lnL, bpsL) (x : xs) = if x == '[' then let (branch, rest) = getBranchString color xs [] in lines (penL, angL, pntL, lnL, bpsL) ((branch ++ inverseString color branch) ++ rest) else lines (apply x (penL, angL, pntL, lnL, bpsL)) xs
      where
        color
          | penL == white = 'w'
          | penL == red = 'r'
          | penL == green = 'g'
          | penL == blue = 'b'
          | otherwise = 'B'

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

-- Darstellung einer Pflanze
plant :: LSystem
plant = LSystem "+gXF" ['F' :->: "FF", 'X' :->: "F-[[X]+X]+F[+FX]-X"]

-- Fast eine Hilbertkurve, ist aber durch einen kleinen Fehler etwas völlig anderes geworden. Eine Methapher für das Leben.
almostHilbert :: LSystem
almostHilbert = LSystem "X" ['X' :->: "---YF+++XFX+FY---", 'Y' :->: "+++XF-YFY---FX+++"]

-- Normale Hilbertkurve
hilbert :: LSystem
hilbert = LSystem "X" ['X' :->: "---YF+++XFX+++FY---", 'Y' :->: "+++XF---YFY---FX+++"]

-- Bunte Hilbertkurve
hilbertColored :: LSystem
hilbertColored = LSystem "X" ['X' :->: "---gYF+++rXFbX+++FbY---", 'Y' :->: "+++BXF---gYFrY---FX+++"]

-- LevyC Kurve
levyC :: LSystem
levyC = LSystem "F" ['F' :->: "***F---F***"]

-- Zwei Kreise drehen sich umeinander
spiral :: LSystem
spiral = LSystem "XFX" ['F' :->: "G[r-G]~F*GP[g+G]", 'X' :->: "GX"]

-- Versuch einer Uhr
clock :: LSystem
clock = LSystem "F[---8wGrGGGYbGG]" ['F' :->: "F~GX~G", 'X' :->: "[~--wG-B3]", 'Y':->:"Y+22"]

-- Farbenfroh
colorfull :: LSystem
colorfull = LSystem "rF" ['F':->:"GN-F++G~F"]

-- Exzellenz
tum :: LSystem
tum = LSystem "X" ['X':->:"bFFFFF---FF+++F+++FFFFF+++F+++FF---FFFFF+++FwFFFFFbFF+*FF*+FFFF3+++F+++FFFF-~F-~FF-~F-~FFFF+++F+++FFFF3+*FF+*FF3w ---F+++FF3+++FbFFFFFF---F-~FFF+++FFF-~F---FFFFFF---F---FFFF3++++*FFF---FFF++++*FFFF3---F+++wFFFFFFF+++++++++wFFFFFFFF---bX"]

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

-- expands the L-System n times
expandLSystem :: LSystem -> Integer -> String
expandLSystem lSys times
  | times <= 0 = str
  | otherwise = expandLHelper rul str times
  where
    str = start lSys
    rul = rules lSys

expandLHelper :: [Rule] -> String -> Integer -> String
expandLHelper _ str 0 = str
expandLHelper rules str times = expandLHelper rules (concat [let (from :->: to) = findRule rules c in to | c <- str]) (times -1)

-- updating LSystem via command
update :: LSystem -> IO LSystem
update ls = blub
  where
    str = start ls
    rul = rules ls
    blub = do
      b <- hReady stdin
      if b
        then do
          x <- getLine
          if "clear" == x
            then update (LSystem "" [])
            else
              if "print" == x
                then do
                  putStrLn (show ls)
                  update ls
                else
                  if "start " `isPrefixOf` x
                    then update (LSystem (drop 6 x) rul)
                    else
                      if "rule " `isPrefixOf` x
                        then
                          if " -> " `isPrefixOf` drop 6 x && not (null (drop 10 x))
                            then update (LSystem str (replaceRule rul (x !! 5 :->: drop 10 x)))
                            else do
                              putStrLn "Error parsing rule"
                              update ls
                        else do
                          putStrLn "Error parsing command"
                          update ls
        else return ls

replaceRule :: [Rule] -> Rule -> [Rule]
replaceRule rules (from :->: to) = (from :->: to) : filter (\(c :->: str) -> c /= from) rules

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

{-WETT-}

{-TTEW-}