module Exercise10 where

import Codec.Picture
import Codec.Picture.Gif
import Data.List (find, nubBy)
import Data.Map as Map (lookup)
import Data.Maybe (fromMaybe)
import qualified Data.Vector as V
import qualified Data.Word as W
import System.IO (hReady, stdin)
import System.Random (Random (randomRIO))
import Turtle (Ln, Turtle, black, move, sit, turn)

-- 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 ((x :->: o) : xs) c
  | x == c = x :->: o
  | otherwise = findRule xs c

-- expands the L-System n times
expandLSystem :: LSystem -> Integer -> String
expandLSystem l 0 = start l
expandLSystem l i = expandLSystem (LSystem currentIter (rules l)) (i -1)
  where
    currentIter = applyRule (start l) (rules l)
    applyRule [] _ = []
    applyRule (x : xs) r = ro ++ applyRule xs r
      where
        (ri :->: ro) = findRule r x

updateOne :: LSystem -> IO LSystem
updateOne ls = do
  commandS <- getLine
  let command = words commandS

  case myHead command of
    "start" -> if length command < 2 then failed else return (LSystem (concat (tail command)) (rules ls))
    "rule" ->
      if length command < 4 || command !! 2 /= "->" || length (command !! 1) /= 1
        then do
          putStrLn "Error parsing rule"
          return ls
        else do
          return (LSystem (start ls) (addRule (rules ls) (head (command !! 1)) (concat (drop 3 command))))
    "clear" -> return (LSystem [] [])
    "print" -> do
      print ls
      return ls
    _ -> failed
  where
    myHead [] = []
    myHead x = head x
    failed = do
      putStrLn "Error parsing command"
      return ls
    addRule r c s = nubBy (\(x :->: _) (y :->: _) -> x == y) ((c :->: s) : r)

-- updating LSystem via command
update :: LSystem -> IO LSystem
update ls = do
  ready <- hReady stdin
  if ready
    then do
      uo <- updateOne ls
      update uo
    else return ls

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

{-WETT-}
{-MCCOMMENT
Kein vector image, stattdessen simple Implementation vom Chaos game
inspiriert von: https://www.youtube.com/watch?v=kbKtFN71Lfs

Enthält nur beim SierpinskiTriangle Zufall

Bild wird mit generateMyGif erstellt
Die Datei befindet sich in der Repository und heisst final.gif

Weitere Referenzen:
https://en.wikipedia.org/wiki/Chaos_game
https://beltoforion.de/en/recreational_mathematics/chaos_game.php

haskell logo Quelle:
https://upload.wikimedia.org/wikipedia/commons/thumb/1/1c/Haskell-Logo.svg/320px-Haskell-Logo.svg.png
-}
gifDelay :: GifDelay
gifDelay = 50 -- in 100th of seconds

shortGifDelay :: GifDelay
shortGifDelay = 10 -- in 100th of seconds

longGifDelay :: GifDelay
longGifDelay = 200 -- in 100th of seconds

width :: Int
width = 500

height :: Int
height = 500

type PictureVec = V.Vector W.Word8

initPicture :: PictureVec
initPicture = V.replicate (width * height) 0 -- black at start

to_3x3 :: W.Word8 -> Int -> Int -> [(Int, W.Word8)]
to_3x3 c x y =
  [ (fromPos x y, c),
    (fromPos (x + 1) y, c),
    (fromPos (x + 1) (y -1), c),
    (fromPos x (y + 1), c),
    (fromPos (x -1) (y + 1), c),
    (fromPos (x + 1) (y + 1), c),
    (fromPos (x -1) (y -1), c),
    (fromPos x (y -1), c),
    (fromPos (x -1) y, c)
  ]

markedInitPicture :: PictureVec
markedInitPicture = initPicture V.// (uncurry (to_3x3 3) startPoint ++ concat [uncurry (to_3x3 2) ip | ip <- initPoints])

pentMarkedInitPicture :: PictureVec
--pentMarkedInitPicture = initPicture V.// (uncurry (to_3x3 0) pentStartPoint ++ concat [uncurry (to_3x3 2) ip | ip <- pentInitPoints])
pentMarkedInitPicture = initPicture

initPoints :: [(Int, Int)]
initPoints = [(200, 50), (20, 490), (470, 300)]

startPoint :: (Int, Int)
startPoint = (200, 250)

pentInitPoints :: [(Int, Int)]
pentInitPoints =
  [ (cx + floor (r * cos p0), cy + floor (r * sin p0)),
    (cx + floor (r * cos p1), cy + floor (r * sin p1)),
    (cx + floor (r * cos p2), cy + floor (r * sin p2)),
    (cx + floor (r * cos p3), cy + floor (r * sin p3)),
    (cx + floor (r * cos p4), cy + floor (r * sin p4))
  ]
  where
    (cx, cy) = (width `div` 2, height `div` 2)
    r :: Float
    r = fromIntegral $ (max width height `div` 2) - 10
    p0 = pi * 2 - pi / 2
    p1 = pi * 2 / 5 - pi / 2
    p2 = pi * 4 / 5 - pi / 2
    p3 = pi * 6 / 5 - pi / 2
    p4 = pi * 8 / 5 - pi / 2

pentStartPoint :: (Int, Int)
pentStartPoint = (width `div` 2, height `div` 2)

-- using black Background for better contrast
myPalette :: Palette
myPalette = generateImage color 5 1
  where
    color :: Int -> Int -> PixelRGB8
    color 1 _ = PixelRGB8 255 255 255 --white
    color 0 _ = PixelRGB8 0 0 0 -- black
    color 2 _ = PixelRGB8 255 0 0 -- Red
    color 3 _ = PixelRGB8 0 255 0 -- Green
    color 4 _ = PixelRGB8 0 0 255 --Blue
    --color x _ = paletteColors V.! x

coloredPalette :: Palette
coloredPalette = generateImage color 193 1
  where
    color :: Int -> Int -> PixelRGB8
    color 0 _ = PixelRGB8 0 0 0 --black
    color x _ = PixelRGB8 (fromIntegral r) (fromIntegral g) (fromIntegral b)
      where
        r
          | x < 32 = 255
          | x < 64 = 255 - (x -32) * 4
          | x < 96 = 0
          | x < 128 = 0
          | x < 160 = (x -128) * 4
          | otherwise = 255
        g
          | x < 32 = 0
          | x < 64 = 0
          | x < 96 = (x - 64) * 4
          | x < 128 = 255
          | x < 160 = 255
          | otherwise = 255 - (x -160) * 4
        b
          | x < 32 = x * 4
          | x < 64 = 255
          | x < 96 = 255
          | x < 128 = 255 - (x -96) * 4
          | x < 160 = 0
          | otherwise = 0

toPos :: Int -> (Int, Int)
toPos n = (n `mod` width, n `div` height)

fromPos :: Int -> Int -> Int
fromPos x y = x + height * y

toImage :: PictureVec -> Image Pixel8
toImage vec = generateImage (mapPicture vec) width height
  where
    mapPicture :: PictureVec -> Int -> Int -> W.Word8
    mapPicture pic x y = pic V.! fromPos x y

generateSierpinskiTriangle :: Int -> [(Int, Int)] -> Int -> Int -> IO [Image Pixel8]
generateSierpinskiTriangle iter edgePoints xs ys = do
  result <- gst markedInitPicture iter xs ys
  -- return [toImage r | (r, c) <- zip result [0 ..], takeIt (c `div` 10)] -- dont take all (only power of two)
  -- return $ map toImage result -- take all
  -- return [toImage (last result)] -- only last
  return [toImage r | (r, c) <- zip result [0 ..], takeIt2 (c `div` 10)]
  where
    takeIt 0 = True
    takeIt 1 = True
    takeIt x
      | even x = takeIt (x `div` 2)
      | otherwise = False
    takeIt2 x
      | x < 3 = True
      | otherwise = x `mod` floor (logBase 2 $ fromIntegral x) == 0
    gst :: PictureVec -> Int -> Int -> Int -> IO [PictureVec]
    gst _ 0 _ _ = return []
    gst pic iter x y = do
      (new_pic, nx, ny) <- stepRandomHalf pic edgePoints x y
      next <- gst new_pic (iter -1) nx ny
      return (new_pic : next)

-- this funktion goes randomly 1/2 to one edge point makes (3x3 points)
stepRandomHalf :: PictureVec -> [(Int, Int)] -> Int -> Int -> IO (PictureVec, Int, Int)
stepRandomHalf pic edgePoints x y = do
  rnd <- randomRIO (0, length edgePoints -1)
  let (cx, cy) = edgePoints !! rnd
  let (nx, ny) = (x + ((cx - x) `div` 2), y + ((cy - y) `div` 2)) -- div 2 rule
  let npic = pic V.// if (x, y) == startPoint || (x, y) `elem` initPoints then [] else to_3x3 1 x y -- make white
  return (npic, nx, ny)

{-
generateHaskell :: Int -> [(Int, Int)] -> Int -> Int -> IO [Image Pixel8]
generateHaskell iter edgePoints xs ys = do
  r <- result
  return $ map toImage r
  where
    result = do
      has <- getHaskell
      return $ gst pentMarkedInitPicture iter [(xs, ys)] 1 has
    gst :: PictureVec -> Int -> [(Int, Int)] -> W.Word8-> Image PixelYA8 -> IO [PictureVec]
    gst _ 0 _ _ _ =  return[]
    gst pic iter points color has = do
       new_pic : next
      where
        (new_pic, new_points) = stepHaskell pic edgePoints points (color + 15) has
        next = gst new_pic (iter -1) new_points (color + 15)

stepHaskell :: PictureVec -> [(Int, Int)] -> [(Int, Int)] -> W.Word8 -> Image PixelYA8 -> (PictureVec, [(Int, Int)])
stepHaskell pic edgePoints points color has = (npic, npoints)
  where
    npoints = concat [[(x + ((ex - x) `div` 2), y + ((ey - y) `div` 2)) | ((ex, ey), ed) <- zip edgePoints [0 ..]] | (x, y) <- points, rule x y]
    npic = pic V.// [(fromPos x y, color) | (x, y) <- npoints, (x, y) /= startPoint && (x, y) `notElem` initPoints]
    rule x y = True
-}
generateCrap :: Int -> [(Int, Int)] -> Int -> Int -> [Image Pixel8]
generateCrap iter edgePoints xs ys = map toImage result
  where
    result = gst pentMarkedInitPicture iter [(xs, ys, -10)] 1
    gst :: PictureVec -> Int -> [(Int, Int, Int)] -> W.Word8 -> [PictureVec]
    gst _ 0 _ _ = []
    gst pic iter points color = new_pic : next
      where
        (new_pic, new_points) = stepCrap pic edgePoints points (color + 15)
        next = gst new_pic (iter -1) new_points (color + 15)

stepCrap :: PictureVec -> [(Int, Int)] -> [(Int, Int, Int)] -> W.Word8 -> (PictureVec, [(Int, Int, Int)]) -- points also contain the previously used edge point
stepCrap pic edgePoints points color = (npic, npoints)
  where
    npoints = concat [[(x + ((ex - x) `div` 2), y + ((ey - y) `div` 2), eb) | ((ex, ey), eb) <- zip edgePoints [0 ..], rule eb b] | (x, y, b) <- points]
    -- rule n b = (n + 1) `mod` 5 /= b && (n - 1) `mod` 5 /= b
    rule n b = n /= b
    npic = pic V.// [(fromPos x y, color) | (x, y, _) <- npoints, (x, y) /= startPoint && (x, y) `notElem` initPoints]

generateStar :: Int -> [(Int, Int)] -> Int -> Int -> [Image Pixel8]
generateStar iter edgePoints xs ys = map toImage result
  where
    result = gst pentMarkedInitPicture iter [(xs, ys, -10, -10)] 100
    gst :: PictureVec -> Int -> [(Int, Int, Int, Int)] -> W.Word8 -> [PictureVec]
    gst _ 0 _ _ = []
    gst pic iter points color = new_pic : next
      where
        (new_pic, new_points) = stepStar pic edgePoints points (color)
        next = gst new_pic (iter -1) new_points (color)

stepStar :: PictureVec -> [(Int, Int)] -> [(Int, Int, Int, Int)] -> W.Word8 -> (PictureVec, [(Int, Int, Int, Int)]) -- points also contain the 2 previously used edge points
stepStar pic edgePoints points _ = (npic, npoints)
  where
    npoints = concat [[(x + ((ex - x) `div` 2), y + ((ey - y) `div` 2), eb, b1) | ((ex, ey), eb) <- zip edgePoints [0 ..], rule eb b1 b2] | (x, y, b1, b2) <- points]
    rule n b1 b2 = b1 /= b2 || (n + 1) `mod` 5 /= b1 && (n - 1) `mod` 5 /= b1
    npic = pic V.// [(fromPos x y, newColor x y) | (x, y, _, _) <- npoints, (x, y) /= startPoint && (x, y) `notElem` initPoints]
    newColor x y
      | cc == 0 = 150
      | otherwise = cc + 12
      where
        cc = pic V.! fromPos x y

getHaskell :: IO (Image PixelYA8)
getHaskell = do
  png <- readPng "haskell.png"
  case png of
    Left failed -> return undefined
    Right png -> case png of
      ImageYA8 p -> return p
      _ -> return undefined

-- main funktion (takes iteration steps and file name)
generateMyGif :: IO ()
generateMyGif = do
  {-
  -- SierpinskiTriangle
  st <- uncurry (generateSierpinskiTriangle 100 initPoints) startPoint
  case writeGifImages "SierpinskiTriangle.gif" LoopingForever (zip3 (repeat myPalette) (repeat gifDelay) st) of
    Right make -> make
    Left failed -> putStrLn failed
  -- Crap
  let crap = uncurry (generateCrap 10 pentInitPoints) pentStartPoint
  case writeGifImages "Crap.gif" LoopingForever (zip3 (repeat coloredPalette) (repeat gifDelay) crap) of
    Right make -> make
    Left failed -> putStrLn failed
  -- Star
  let star = uncurry (generateStar 8 pentInitPoints) pentStartPoint
  case writeGifImages "Star.gif" LoopingForever (zip3 (repeat greyPalette) (repeat gifDelay) star) of
    Right make -> make
    Left failed -> putStrLn failed
  -}

  st <- uncurry (generateSierpinskiTriangle 100 initPoints) startPoint
  let crap = uncurry (generateCrap 10 pentInitPoints) pentStartPoint
  let star = uncurry (generateStar 8 pentInitPoints) pentStartPoint
  let final = zip3 (repeat myPalette) (repeat shortGifDelay) st ++ zip3 (repeat myPalette) (repeat longGifDelay) [last st] ++ zip3 (repeat coloredPalette) (repeat gifDelay) crap ++ zip3 (repeat greyPalette) (repeat gifDelay) star

  case writeGifImages "final.gif" LoopingForever final of
    Right make -> make
    Left failed -> putStrLn failed

{-TTEW-}