import Data.Bool (bool)
import Data.Tree

rule :: Char -> String
rule c =
  case c of
    'a' -> "daab"
    'b' -> "cbba"
    'c' -> "bccd"
    'd' -> "addc"
    _ -> []

vectors :: Char -> [(Int, Int)]
vectors c =
  case c of
    'a' -> [(-1, 1), (-1, -1), (1, -1), (1, 1)]
    'b' -> [(1, -1), (-1, -1), (-1, 1), (1, 1)]
    'c' -> [(1, -1), (1, 1), (-1, 1), (-1, -1)]
    'd' -> [(-1, 1), (1, 1), (1, -1), (-1, -1)]
    _ -> []

main :: IO ()
main = do
  let w = 1024
  putStrLn $ svgFromPoints w $ hilbertPoints w (hilbertTree 6)

hilbertTree :: Int -> Tree Char
hilbertTree n =
  let go tree =
        let c = rootLabel tree
            xs = subForest tree
        in Node c (bool (go <$> xs) (flip Node [] <$> rule c) (null xs))
      seed = Node 'a' []
  in bool seed (iterate go seed !! pred n) (0 < n)

hilbertPoints :: Int -> Tree Char -> [(Int, Int)]
hilbertPoints w tree =
  let go r xy tree =
        let d = quot r 2
            f g x = g xy + (d * g x)
            centres = ((,) . f fst) <*> f snd <$> vectors (rootLabel tree)
            xs = subForest tree
        in bool (concat $ zipWith (go d) centres xs) centres (null xs)
      r = quot w 2
  in go r (r, r) tree

svgFromPoints :: Int -> [(Int, Int)] -> String
svgFromPoints w xys =
  let sw = show w
      points =
        (unwords . fmap (((++) . show . fst) <*> ((' ':) . show . snd))) xys
  in unlines
       [ "<svg xmlns=\"http://www.w3.org/2000/svg\""
       , unwords ["width=\"512\" height=\"512\" viewBox=\"5 5", sw, sw, "\"> "]
       , "<path d=\"M" ++ points ++ "\" "
       , "stroke-width=\"2\" stroke=\"red\" fill=\"transparent\"/>"
       , "</svg>"
       ]