module Exercise10 where

import Data.Char
import Data.List (find)
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 'H' t = move 10 t
apply 'I' t = move 10 t
apply 'J' t = move 1 t
apply 'C' (_, a, Pnt x y, ls, ps) = (Colour (redFunction f) (greenFunction f) (blueFunction f), a, Pnt x y, ls, ps)
  where
    f = fromIntegral (length ls `mod` 1001) / 1000
apply '+' t = turn 30 t
apply '-' t = turn (-30) t
apply '*' t = turn 15 t
apply '~' t = turn (-15) t
apply '>' t = turn 60 t
apply '<' t = turn (-60) t
apply _ t = sit t

redFunction :: Float -> Float
redFunction f
  | f <= 1 / 6 = 0.75
  | f < 2 / 6 = 1.25 - 3 * f
  | f <= 4 / 6 = 0.25
  | f < 5 / 6 = 3 * f -1.75
  | otherwise = 0.75

greenFunction :: Float -> Float
greenFunction f
  | f < 1 / 6 = 3 * f + 0.25
  | f <= 3 / 6 = 0.75
  | f < 4 / 6 = 2.25 -3 * f
  | otherwise = 0.25

blueFunction :: Float -> Float
blueFunction f
  | f <= 2 / 6 = 0.25
  | f < 3 / 6 = 3 * f -0.75
  | f <= 5 / 6 = 0.75
  | otherwise = 3.25 -3 * 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 (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 "CFX" ['X' :->: "X+++YCF+++", 'Y' :->: "---CFX---Y"]

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

sierpinski :: LSystem
sierpinski = LSystem "CF++++CG++++CG" ['F' :->: "F++++CG----CF----CG++++CF", 'G' :->: "GCG"]

{-MCCOMMENT

Below you can find my Wettbewerb submission
This piece of art is called "A Special Snowflake" and is inspired by the Koch Snowflake
Use "savePngs specialSnowflake 5 "A_special_snowflake" to generate the png
I played around with changing the Turtle's colour a little bit to generate a nice shifting effect
The effect looks especially stunning on the Sierpinski Triangle, I also included this image and modified all the other examples

-}

{-WETT-}

specialSnowflake :: LSystem
specialSnowflake = LSystem "CF>CF>CF>CF>CF>CF" ['F' :->: "F>CH<CJ<CI>CF", 'H' :->: "F>CH<CF", 'I' :->: "F<CI>CF", 'J' :->: ">F<CJ<CF>"]

{-TTEW-}

-- finds the first occurrence of a fitting rule
findRule :: [Rule] -> Char -> Rule
findRule ((d :->: s) : rs) c = if c == d then d :->: s else findRule rs c
findRule _ c = c :->: [c]

-- expands the L-System n times
expandLSystem :: LSystem -> Integer -> String
expandLSystem sys 0 = start sys
expandLSystem sys n = expandLSystem (sys {start = concatMap (getString . findRule (rules sys)) (start sys)}) (n -1)

getString :: Rule -> String
getString (c :->: d) = d

-- updating LSystem via command
update :: LSystem -> IO LSystem
update sys = do
  ready <- hReady stdin
  if not ready
    then return sys
    else do
      cmd <- getLine
      let tokens = words cmd
      if isValidInstruction tokens
        then case head tokens of
          "start" -> update (sys {start = tokens !! 1})
          "rule" -> update (sys {rules = (head (tokens !! 1) :->: (tokens !! 3)) : filter (\(c :->: _) -> c /= head (tokens !! 1)) (rules sys)})
          "clear" -> update (LSystem "" [])
          "print" -> do
            print sys
            update sys
        else do
          if (not . null) tokens && head tokens == "rule"
            then putStrLn "Error parsing rule"
            else putStrLn "Error parsing command"
          update sys

isValidInstruction :: [String] -> Bool
isValidInstruction ss =
  (not . null) ss
    && case head ss of
      "start" -> length ss == 2
      "rule" -> length ss == 4 && length (ss !! 1) == 1 && ss !! 2 == "->"
      "clear" -> length ss == 1
      "print" -> length ss == 1
      _ -> False

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