{-
Basic Drawing of Lindenmayer systems to svg/ps.  With thanks to Philip
for the postscript backend, which I pulled an Enrico Tassi on.
-}
{-# LANGUAGE TypeApplications #-}

import Control.Monad.State
import Data.List (singleton)
import Data.Maybe (catMaybes)
import Data.Tree (Tree (..))
import System.Environment (getArgs)

type Point = (Int, Int)

type Angle = Double

type Pos = (Point, Angle)

data Turtle = T
  { pos :: Pos,
    stack :: [Pos]
  }

data PS
  = MoveTo Point
  | LineTo Point

mpos :: PS -> Point
mpos (MoveTo p) = p
mpos (LineTo p) = p

class Lindenmayer a where
  rule :: a -> [a]
  axiom :: a
  move :: a -> State Turtle (Maybe PS)

point :: State Turtle (Maybe PS)
point = do
  (p, _) <- gets pos
  pure $ Just $ LineTo p

-- FIXME: MonadFail for empty stack
pop :: State Turtle (Maybe PS)
pop = do
  s <- gets stack
  put (T (head s) (tail s))
  pure $ Just $ MoveTo (fst (head s))

push :: State Turtle (Maybe PS)
push = do
  modify (\(T p s) -> T p (p : s))
  pure Nothing

angle :: (Angle -> Angle) -> State Turtle (Maybe PS)
angle f = do
  modify (\(T (p, theta) s) -> T (p, f theta) s)
  pure Nothing

step :: Double -> State Turtle (Maybe PS)
step size = do
  ((x, y), theta) <- gets pos
  let x' = round $ fromIntegral x + size * cos theta
  let y' = round $ fromIntegral y + size * sin theta
  s <- gets stack
  put $ T ((x', y'), theta) s
  pure $ Just $ LineTo (x, y)

data Hilbert
  = HA
  | HB
  | HM
  | HP
  | HF

instance Lindenmayer Hilbert where
  rule HA = [HP, HB, HF, HM, HA, HF, HA, HM, HF, HB, HP]
  rule HB = [HM, HA, HF, HP, HB, HF, HB, HP, HF, HA, HM]
  rule x = [x]
  axiom = HA

  move HP = angle (+ (pi / 2))
  move HM = angle (subtract (pi / 2))
  move HF = step 10
  move _ = pure Nothing

data Dragon
  = DF
  | DG
  | DP
  | DM

instance Lindenmayer Dragon where
  rule DF = [DF, DP, DG]
  rule DG = [DF, DM, DG]
  rule x = [x]

  axiom = DF

  move DP = angle (+ (pi / 2))
  move DM = angle (subtract (pi / 2))
  move DF = step 10
  move DG = step 10

data Sierpinski = SF | SG | SP | SM | SAX

instance Lindenmayer Sierpinski where
  rule SAX = [SF, SM, SG, SM, SG]
  rule SF = [SF, SM, SG, SP, SF, SP, SG, SM, SF]
  rule SG = [SG, SG]
  rule x = [x]

  axiom = SAX

  move SP = angle (+ (pi * 2 / 3))
  move SM = angle (subtract (pi * 2 / 3))
  move SF = step 15
  move SG = step 15

data Koch = KF | KP | KM

instance Lindenmayer Koch where
  rule KF = [KF, KP, KF, KM, KF, KM, KF, KP, KF]
  rule x = [x]

  axiom = KF

  move KF = step 10
  move KP = angle (+ (pi / 2))
  move KM = angle (subtract (pi / 2))

data BTree = BO | BI | BL | BR

instance Lindenmayer BTree where
  rule BI = [BI, BI]
  rule BO = [BI, BL, BO, BR, BO]
  rule x = [x]

  axiom = BO

  move BI = step 10
  move BO = step 5
  move BL = do
    push
    angle (+ (pi / 4))
  move BR = do
    pop
    angle (subtract (pi / 4))

data Plant = PX | PF | PM | PP | PL | PR

instance Lindenmayer Plant where
  rule PX = [PF, PP, PL, PL, PX, PR, PM, PX, PR, PM, PF, PL, PM, PF, PX, PR, PP, PX]
  rule PF = [PF, PF]
  rule x = [x]

  axiom = PX

  move PF = step 10
  move PP = angle (+ (0.13 * pi))
  move PM = angle (subtract (0.13 * pi))
  move PL = push
  move PR = pop
  move PX = point

leaves :: Tree a -> [a]
leaves (Node a []) = [a]
leaves (Node a xs) = xs >>= leaves

lindenmayer :: (Lindenmayer a) => [Tree a]
lindenmayer = iterate go (Node axiom [])
  where
    go (Node c []) = Node c ((`Node` []) <$> rule c)
    go (Node c xs) = Node c (go <$> xs)

points :: (Lindenmayer a) => Int -> [Tree a] -> [PS]
points n = catMaybes . (`evalState` initial) . mapM move . leaves . (!! n)
  where
    initial = T ((0, 0), -pi / 2) []

curve :: String -> Int -> [PS]
curve "hilbert" n = points n $ lindenmayer @Hilbert
curve "dragon" n = points n $ lindenmayer @Dragon
curve "sierpinski" n = points n $ lindenmayer @Sierpinski
curve "koch" n = points n $ lindenmayer @Koch
curve "btree" n = points n $ lindenmayer @BTree
curve "plant" n = points n $ lindenmayer @Plant

svg :: [PS] -> String
svg px =
  "<svg xmlns=\"http://www.w3.org/2000/svg\""
    <> " width="
    <> quote (show width)
    <> " height="
    <> quote (show height)
    <> " viewBox="
    <> quote (unwords [show xmin, show ymin, show width, show height])
    <> ">"
    <> "<path d="
    <> quote path
    <> " stroke-width=\"2\" stroke=\"#79a8ff\" fill=\"transparent\" style=\"fill:none\"/>"
    <> "</svg>"
  where
    xmax = maximum $ fst . mpos <$> px
    xmin = subtract padding $ minimum $ fst . mpos <$> px
    width = xmax + abs xmin + padding
    ymax = maximum $ snd . mpos <$> px
    ymin = subtract padding $ minimum $ snd . mpos <$> px
    height = ymax + abs ymin + padding
    padding = 100
    quote s = "\"" <> s <> "\""
    turtle :: PS -> String
    turtle (MoveTo (x, y)) = "M " <> show x <> "," <> show y <> " "
    turtle (LineTo (x, y)) = "L " <> show x <> "," <> show y <> " "
    path = "M 0,0 " <> (px >>= turtle)

ps :: [PS] -> String
ps px = "0 0 moveto " <> unwords (px >>= cmd) <> " stroke"
  where
    cmd (MoveTo (x, y)) = [show x, show y, "moveto"]
    cmd (LineTo (x, y)) = [show x, show y, "lineto"]

main :: IO ()
main = do
  [f, t, n] <- getArgs
  putStrLn $ (case f of "ps" -> ps; "svg" -> svg) $ curve t (read n)