module Exercise10 where

import Data.List (foldl', groupBy, find)
import Data.Maybe (fromMaybe)
import Data.Map as Map (lookup)

import Turtle ( Ln, Turtle, black, move, turn, sit )
import Data.Bifunctor (Bifunctor(second))
import Data.Function (on)
import System.IO (hWaitForInput, hGetLine, Handle, stdin, hReady)
-- import System.IO (Handle, hReady, stdin, hWaitForInput)
-- import qualified Data.Text.Lazy as Lazy (unpack, Text)
-- import qualified Data.Text.Lazy.IO as LazyIO (hGetLine)
import Control.Monad (foldM, when)
import Data.Char (isSpace)
import Data.Functor ((<&>))
import Text.Read (readMaybe)

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

predecessor :: Rule -> Char
predecessor (pred :->: _) = pred

successor :: Rule -> String
successor (_ :->: succ) = succ

($:) :: [Rule] -> Char -> String
rs $: c = let _ :->: succ = findRule rs c in succ

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 'a' t = turn 90 t
apply 'c' t = turn (-90) 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

lempty :: LSystem
lempty = LSystem "" []

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

hilbert :: LSystem
hilbert = LSystem "cC" ['C' :->: "aAFcCFCcFAa", 'A' :->: "cCFaAFAaFCc"]

-- finds the first occurrence of a fitting rule
findRule :: [Rule] -> Char -> Rule
findRule rs c = fromMaybe (c :->: [c]) $ find (\(pred :->: _) -> pred == c) rs

-- removes any existing rules for the given predescessor, the prepends a new rule
updateRule :: Char -> String -> [Rule] -> [Rule]
updateRule pred succ rules = (pred :->: succ) : filter ((/= pred) . predecessor) rules
  
-- expands the L-System n times
expandLSystem :: LSystem -> Integer -> String
expandLSystem LSystem {start=s} 0 = s
expandLSystem LSystem {start=s, rules=rs} k = expandLSystem LSystem {start=concatMap (rs $:) s, rules=rs} (k - 1)

tokenizeOn :: (a -> Bool) -> [a] -> [[a]]
tokenizeOn sepPred = filter (not . sepPred . head) . groupBy ((==) `on` sepPred)

type CommandAction a b = [String] -> a -> Either String b
data Command a b = String :>>: CommandAction a b
type RunnableCommand a b = (CommandAction a b, [String])

key :: Command a b -> String
key (k :>>: _) = k

action :: Command a b -> CommandAction a b
action (_ :>>: a) = a

runCommand :: RunnableCommand a b -> a -> Either String b
runCommand = uncurry ($)

startCmd :: CommandAction LSystem LSystem
startCmd args LSystem {start=s, rules=rs} = Right LSystem {start=unwords args, rules=rs}

ruleCmd :: CommandAction LSystem LSystem
ruleCmd args LSystem {start=s, rules=rs} = case second (drop 1) $ break (== "->") args of
                                            ([[pred]], [succ]) -> Right LSystem {start=s, rules=updateRule pred succ rs}
                                            _ -> Left "Error parsing rule"

clearCmd :: CommandAction LSystem LSystem
clearCmd _ _ = Right LSystem {start="", rules=[]}

printCmd :: (Show a) => CommandAction a b
printCmd _ x = Left $ show x

errorMsg :: String -> CommandAction a b
errorMsg msg _ _ = Left msg

lsysParseErrorAction :: CommandAction a b
lsysParseErrorAction = errorMsg "Error parsing command"

lsysCommands :: [Command LSystem LSystem]
lsysCommands = ["start" :>>: startCmd,
                "rule"  :>>: ruleCmd,
                "clear" :>>: clearCmd,
                "print" :>>: printCmd]

parseCommand :: [Command a b] -> [String] -> RunnableCommand a b
parseCommand cmds [] = (lsysParseErrorAction, [])
parseCommand cmds (name:args) = (fromMaybe lsysParseErrorAction act, args)  
  where act = action <$> find ((== name) . key) cmds

executeCommand :: (String -> RunnableCommand a b) -> (a -> b) -> String -> a -> IO b
executeCommand parser failf cmd x = case runCommand (parser cmd) x of
  Left err -> do
    putStrLn err
    return $ failf x
  Right val -> return val

inputLines :: (Handle -> IO Bool) -> Handle -> a -> (String -> a -> IO a) -> IO a
inputLines readyPred h z f = do
  ready <- readyPred h
  if ready
    then do
      line <- hGetLine h
      n <- f line z
      inputLines readyPred h n f
    else do
      return z

updateWhile :: (Handle -> IO Bool) -> Handle -> LSystem -> IO LSystem
updateWhile readyPred h z = inputLines readyPred h z (executeCommand (parseCommand lsysCommands . words) id)

update :: LSystem -> IO LSystem
update = updateWhile hReady stdin

main = updateWhile (`hWaitForInput` 5000) stdin lempty >>= print

-- parseCommands :: [Command a b] -> (String -> [String]) -> [String] -> [RunnableCommand a b]
-- parseCommands cmds tokenize = map (parseCommand cmds . tokenize)

-- runCommands :: a -> [RunnableCommand a a] -> IO a
-- runCommands = foldM f
--   where f prev cmd = do
--           case runCommand cmd prev of
--             Left str -> do
--               putStrLn str
--               return prev
--             Right result -> do
--               return result

-- main = inputLines (`hWaitForInput` 5000) stdin 0 f
--   where f cmd x = do
--           let n = maybe x (+x) $ readMaybe cmd
--           putStrLn $ "sum: " ++ show n
--           return n

  -- if ready
  --   then do
  --     l <- hGetLine h
  --     ls <- inputLines readyPred h
  --     return $ l : ls
  --   else return []

-- updateWhile :: (Handle -> IO Bool) -> Handle -> LSystem -> IO LSystem
-- updateWhile readyPred h z = inputLines readyPred h >>= runCommands z . parseCommands lsysCommands words

-- update :: LSystem -> IO LSystem
-- update = updateWhile hReady stdin
-- update z = inputLines hReady stdin >>= runCommands z . parseCommands lsysCommands words

-- main = updateWhile (`hWaitForInput` 1000) stdin lempty >>= print
-- main = updateWhile hReady stdin lempty >>= print

-- update z = getContents >>= runCommands z . parseCommands lsysCommands words . takeWhile (not . all isSpace) . lines

-- bar :: IO ()
-- bar = getContents >>= runCommands lempty . parseCommands lsysCommands words . takeWhile (not . all isSpace) . lines >>= print
-- main = bar

-- inputLines :: (Handle -> IO Bool) -> Handle -> IO [String]
-- inputLines readyPred = do
--   ready <- readyPred
--   rLine <- getLine
--   return $ (if ready then (rLine :) <$> inputLines readyPred else [""])


-- main = inputLines (`hWaitForInput` 5000) stdin >>= putStr . unlines
  
-- foo = do
--   ready <- hReady stdin
--   if ready
--     then do
--       putStrLn "ready"
--       l <- hGetLine stdin
--       putStrLn $ "(" ++ l ++ ")"
--       foo
--     else do
--       putStrLn "nothing ready"
--       return ()


-- main = foo
-- main = putStr . unlines . zipWith (curry show) [0..] <$> inputLines hReady stdin
-- main = getContents >>= putStr

-- updating LSystem via command
-- update :: LSystem -> IO LSystem
-- update = return
-- update lsys = do
--   inputReady <- hReady stdin
--   if inputReady then undefined else 
-- update lsys | hReady stdin = undefined 
-- update lsys = return lsys



-- f :: Bool -> String -> IO Bool
-- f False _ = return False
-- f _ "" = return False
-- f _ s = True <$ putStrLn s