content: {- |
  =Basic Elements
  
  ==Simple Boxes
  
  >>> :{
  aa2u "++  +-----+  +--+--+-----+  \n\
       \++  +--+  |  |  |  |     |  \n\
       \       |  |  +--+--+--+--+  \n\
       \+---+  |  |  |     |  |  |  \n\
       \+---+  +--+  +-----+--+--+  "
  :}
  ┌┐  ┌─────┐  ┌──┬──┬─────┐
  └┘  └──┐  │  │  │  │     │
         │  │  ├──┴──┼──┬──┤
  ┌───┐  │  │  │     │  │  │
  └───┘  └──┘  └─────┴──┴──┘
  
  ==Rounded Boxes
  
  >>> :{
  aa2u "..  .-----.  .--+--+-----.  \n\
       \''  '--.  |  |  |  |     |  \n\
       \       |  |  +--+--+--+--+  \n\
       \.---.  |  |  |     |  |  |  \n\
       \'---'  '--'  '-----+--+--'  "
  :}
  ╭╮  ╭─────╮  ╭──┬──┬─────╮
  ╰╯  ╰──╮  │  │  │  │     │
         │  │  ├──┴──┼──┬──┤
  ╭───╮  │  │  │     │  │  │
  ╰───╯  ╰──╯  ╰─────┴──┴──╯
  
  ==Dotted and double strokes
  
  >>> :{
  aa2u "++  .-----.  +==+==+=====+  \n\
       \++  +==+  :  |  :  |     |  \n\
       \       :  :  +==+==+==+==+  \n\
       \+===+  :  :  |     |  :  |  \n\
       \+---+  '--'  +=====+==+==+  "
  :}
  ┌┐  ╭─────╮  ╒══╤══╤═════╕
  └┘  ╘══╕  ┆  │  ┆  │     │
         ┆  ┆  ╞══╧══╪══╤══╡
  ╒═══╕  ┆  ┆  │     │  ┆  │
  └───┘  ╰──╯  ╘═════╧══╧══╛
  
  ==Cast shadows
  
  >>> :{
  aa2u "+-------------+   \n\
       \|             |   \n\
       \+---+     +---+#  \n\
       \  ##|     |#####  \n\
       \    |     |#      \n\
       \    +-----+#      \n\
       \      ######      "
  :}
  ┌─────────────┐
  │             │
  └───┐     ┌───┘█
    ██│     │█████
      │     │█
      └─────┘█
        ██████
  
  =Properties
  
  ==Idempotent
  
  Already rendered portions are not affected:
  
  >>> :{
  aa2u "┌┐  ╭─────╮  ╒══╤══╤═════╕  ┌───┐   \n\
       \└┘  ╘══╕  ┆  │  ┆  │     │  │   │   \n\
       \       ┆  ┆  ╞══╧══╪══╤══╡  │   │█  \n\
       \╒═══╕  ┆  ┆  │     │  ┆  │  └───┘█  \n\
       \└───┘  ╰──╯  ╘═════╧══╧══╛    ████  "
  :}
  ┌┐  ╭─────╮  ╒══╤══╤═════╕  ┌───┐
  └┘  ╘══╕  ┆  │  ┆  │     │  │   │
         ┆  ┆  ╞══╧══╪══╤══╡  │   │█
  ╒═══╕  ┆  ┆  │     │  ┆  │  └───┘█
  └───┘  ╰──╯  ╘═════╧══╧══╛    ████
  
  ==Incremental
  
  Existing characters can be removed:
  
  >>> :{
  aa2u "┌──┬ ┬──┐\n\
       \   │ │  │\n\
       \╞══╪ ╪══╡\n\
       \│        \n\
       \├──┼ ┼──┤\n\
       \   │ │  │\n\
       \└──┴ ┴──┘"
  :}
  ───┐ ┌──┐
     │ │  │
  ╒══╛ ╘══╛
  │
  └──┐ ┌──┐
     │ │  │
  ───┘ └──┘
  
  New connections can be added:
  
  >>> :{
  aa2u "┌──┐-┌──┐\n\
       \│  │ │  │\n\
       \╘══╛=╘══╛\n\
       \|  : :  |\n\
       \┌──┐-┌──┐\n\
       \│  │ │  │\n\
       \└──┘-└──┘"
  :}
  ┌──┬─┬──┐
  │  │ │  │
  ╞══╪═╪══╡
  │  ┆ ┆  │
  ├──┼─┼──┤
  │  │ │  │
  └──┴─┴──┘
  
  Existing connections can be altered by replacing/adding characters:
  
  >>> :{
  aa2u "┌──+──┐  .─────+─────.  ┌────┐    \n\
       \│  +==+  │     |     │  │####│    \n\
       \+==+  |  │     |     │  │#   │█   \n\
       \└──+─-┘  │     +-----+  └────┘█#  \n\
       \         +=====+     │    █████#  \n\
       \╭──+─-╮  │     |     │     #####  \n\
       \│  |  |  │     |     │            \n\
       \╰──+──╯  '───────────'            "
  :}
  ┌──┬──┐  ╭─────┬─────╮  ┌────┐
  │  ╞══╡  │     │     │  │████│
  ╞══╡  │  │     │     │  │█   │█
  └──┴──┘  │     ├─────┤  └────┘██
           ╞═════╡     │    ██████
  ╭──┬──╮  │     │     │     █████
  │  │  │  │     │     │
  ╰──┴──╯  ╰───────────╯
  
  =Limitations
  
  Some connections do not work as expected (mostly because the corresponding
  Unicode characters do not exist), e.g. rounded corners with double-stroke lines,
  or connection pieces connecting horizontal single- and double-stroke lines:
  
  >>> :{
  aa2u "--+==  .==.  .--.--.   \n\
       \  |    |  |  |  |  |   \n\
       \==+--  '=='  .--+--'   \n\
       \  |          |  |  |   \n\
       \--+==  --==  '--'--'   "
  :}
  ──┐══  ╒══╕  ╭──╮──╮
    │    │  │  │  │  │
  ══├──  ╘══╛  ╰──┼──╯
    │          │  │  │
  ──┘══  ──══  ╰──╰──╯
  
  -}
  {-# LANGUAGE DeriveFunctor   #-}
  {-# LANGUAGE LambdaCase      #-}
  {-# LANGUAGE RecordWildCards #-}
  
  module Text.AsciiArt where
  
  import           Control.Comonad
  import           Data.Maybe
  
  
  
  --------------------------------------------------------------------------------
  -- * Zipper
  --------------------------------------------------------------------------------
  
  -- | The 'Zipper' is assumed to be infinite, i.e. filled with empty values
  -- outside the defined area.
  data Zipper a = Zipper
      { before  :: [a]
      , current :: a
      , after   :: [a] }
      deriving (Functor)
  
  moveBefore, moveAfter :: Zipper a -> Zipper a
  moveBefore zipper@Zipper { before = a : as, current = b, after = cs }
      = zipper { before = as, current = a, after = b : cs }
  moveAfter  zipper@Zipper { before = as, current = b, after = c : cs }
      = zipper { before = b : as, current = c, after = cs }
  
  -- | Renders the 'current' and the @n - 1@ elements 'after' as list.
  zipperToList :: Int -> Zipper a -> [a]
  zipperToList n Zipper{..} = current : take (n - 1) after
  
  -- | An infinite 'Zipper' filled with @a@s.
  zipperOf :: a -> Zipper a
  zipperOf a = Zipper { before = repeat a, current = a, after = repeat a }
  
  -- | Takes a list and creates a 'Zipper' from it. The 'current' element will be
  -- the 'head' of the list, and 'after' that 'tail'. The rest will be filled with
  -- @a@s to an infinite 'Zipper'.
  zipperFromList :: a -> [a] -> Zipper a
  zipperFromList a = \case
      []     -> zipperOf a
      b : bs -> (zipperOf a) { current = b, after = bs ++ repeat a }
  
  
  instance Comonad Zipper where
      extract = current
      extend f zipper = fmap f $ Zipper
          { before  = iterate1 moveBefore zipper
          , current = zipper
          , after   = iterate1 moveAfter zipper }
        where
          iterate1 f x = tail (iterate f x)
  
  
  
  --------------------------------------------------------------------------------
  -- * Plane (two-dimensional 'Zipper')
  --------------------------------------------------------------------------------
  
  -- | A plane is a 'Zipper' of 'Zipper's. The outer layer zips through lines
  -- (up\/down), the inner layer through columns (left\/right).
  -- Like the 'Zipper', the 'Plane' is assumed to be infinite in all directions.
  newtype Plane a = Plane { unPlane :: Zipper (Zipper a) }
      deriving (Functor)
  
  moveLeft, moveRight, moveUp, moveDown :: Plane a -> Plane a
  moveLeft  = Plane . fmap moveBefore . unPlane
  moveRight = Plane . fmap moveAfter  . unPlane
  moveUp    = Plane . moveBefore      . unPlane
  moveDown  = Plane . moveAfter       . unPlane
  
  
  -- | Renders @m@ lines and @n@ columns as nested list.
  planeToList :: Int -> Int -> Plane a -> [[a]]
  planeToList m n (Plane Zipper{..}) = fmap (zipperToList n) $
      current : take (m - 1) after
  
  -- | An infinite 'Plane' filled with @a@s.
  planeOf :: a -> Plane a
  planeOf a = Plane $ Zipper
      { before  = repeat (zipperOf a)
      , current = zipperOf a
      , after   = repeat (zipperOf a) }
  
  -- | Create a 'Plane' from a list of lists, filling the rest with @a@s in all
  -- directions.
  planeFromList :: a -> [[a]] -> Plane a
  planeFromList a = \case
      []       -> planeOf a
      as : ass -> Plane $ (zipperOf (zipperOf a))
          { current = zipperFromList a as
          , after = fmap (zipperFromList a) ass ++ repeat (zipperOf a) }
  
  
  instance Comonad Plane where
      extract = current . current . unPlane
      extend f plane = fmap f $ Plane $ Zipper
          { before  = fmap foo (iterate1 moveUp plane)
          , current = foo plane
          , after   = fmap foo (iterate1 moveDown plane) }
        where
          foo p = Zipper
              { before = iterate1 moveLeft p
              , current = p
              , after = iterate1 moveRight p }
          iterate1 f x = tail (iterate f x)
  
  
  
  --------------------------------------------------------------------------------
  -- * Patterns
  --------------------------------------------------------------------------------
  
  newtype Pattern = Pattern ((Char, Char, Char), (Char, Char, Char), (Char, Char, Char))
  
  
  patternFromString :: String -> Pattern
  patternFromString [a, b, c, d, e, f, g, h, i] = Pattern ((a, b, c), (d, e, f), (g, h, i))
  patternFromString _ = undefined
  
  patternToString :: Pattern -> String
  patternToString (Pattern ((a, b, c), (d, e, f), (g, h, i))) = [a, b, c, d, e, f, g, h, i]
  
  -- | Find the 'Char' to replace the center of a 'Pattern'.
  lookupPattern :: Pattern -> Maybe Char
  lookupPattern pattern = case filter (satisfies pattern) patterns of
      []    -> Nothing
      a : _ -> Just (snd a)
    where
      satisfies :: Pattern -> (Pattern, Char) -> Bool
      satisfies diagram (pattern, _)
          = and (zipWith connectsLike (patternToString diagram) (patternToString pattern))
  
  -- | Whether a character can connect to another character. For example, @+@
  -- connects both horizontally (like @-@) and vertically (like @|@), so it
  -- 'connectsLike' @-@, @|@, and of course like itself.
  connectsLike :: Char -> Char -> Bool
  char `connectsLike` pattern = case pattern of
      '-'   -> char `elem` ['-', '>', '<', '─'] || char `connectsLike` '+'
      '='   -> char `elem` ['=', '>', '<', '═'] || char `connectsLike` '+'
      '|'   -> char `elem` ['|', '^', 'v', '│'] || char `connectsLike` ':' || char `connectsLike` '+'
      ':'   -> char `elem` [':', '┆']
      '+'   -> char `elem` [ '+'
                           , '└', '┘', '┌', '┐'
                           , '╘', '╛', '╒', '╕'
                           , '├', '┤', '┬', '┴', '┼'
                           , '╞', '╡', '╤', '╧', '╪' ]
                           || char `connectsLike` '.'
      '.'   -> char `elem` [ '\'', '.'
                           , '╭', '╮', '╯', '╰' ]
      '\''  -> char `connectsLike` '.'
      ' '   -> True
      other -> char == other
  
  -- | The actual pattern definitions. For convenience, the simple patterns are at
  -- the top, and more complex ones at the bottom. 'lookupPattern' will first try
  -- the most complex pattern and work its way to the simpler patterns, thus
  -- avoiding to choose a simpler pattern and forgetting some connection.
  patterns :: [(Pattern, Char)]
  patterns = reverse $ fmap (\(a, b) -> (patternFromString a, b))
      [ ( "   \
          \ --\
          \   ", '─' )
  
      , ( "   \
          \-- \
          \   ", '─' )
  
      , ( "   \
          \ ==\
          \   ", '═' )
  
      , ( "   \
          \== \
          \   ", '═' )
  
      , ( "   \
          \ | \
          \ | ", '│' )
  
      , ( " | \
          \ | \
          \   ", '│' )
  
      , ( "   \
          \ : \
          \ | ", '┆' )
  
      , ( " | \
          \ : \
          \   ", '┆' )
  
      , ( "   \
          \ : \
          \ : ", '┆' )
  
      , ( " : \
          \ : \
          \   ", '┆' )
  
      , ( " | \
          \=+ \
          \   ", '╛' )
  
      , ( " | \
          \ +=\
          \   ", '╘' )
  
      , ( "   \
          \ +=\
          \ | ", '╒' )
  
      , ( "   \
          \=+ \
          \ | ", '╕' )
  
      , ( " | \
          \ +=\
          \ | ", '╞' )
  
      , ( " | \
          \=+ \
          \ | ", '╡' )
  
      , ( "   \
          \=+=\
          \ | ", '╤' )
  
      , ( " | \
          \=+=\
          \   ", '╧' )
  
      , ( " | \
          \=+=\
          \ | ", '╪' )
  
      , ( " | \
          \-+ \
          \   ", '┘' )
  
      , ( " | \
          \ +-\
          \   ", '└' )
  
      , ( "   \
          \ +-\
          \ | ", '┌' )
  
      , ( "   \
          \-+ \
          \ | ", '┐' )
  
      , ( " | \
          \ +-\
          \ | ", '├' )
  
      , ( " | \
          \-+ \
          \ | ", '┤' )
  
      , ( "   \
          \-+-\
          \ | ", '┬' )
  
      , ( " | \
          \-+-\
          \   ", '┴' )
  
      , ( " | \
          \-+-\
          \ | ", '┼' )
  
      , ( "   \
          \ .-\
          \ | ", '╭' )
  
      , ( "   \
          \-. \
          \ | ", '╮' )
  
      , ( " | \
          \-' \
          \   ", '╯' )
  
      , ( " | \
          \ '-\
          \   ", '╰' )
  
      , ( "   \
          \ # \
          \ # ", '█' )
  
      , ( "   \
          \## \
          \   ", '█' )
  
      , ( "   \
          \ ##\
          \   ", '█' )
  
      , ( " # \
          \ # \
          \   ", '█' )
  
      , ( "   \
          \-> \
          \   ", '▷' )
  
      , ( "   \
          \ <-\
          \   ", '◁' )
  
      , ( "   \
          \ ^ \
          \ | ", '△' )
  
      , ( " | \
          \ v \
          \   ", '▽' )
      ]
  
  
  
  --------------------------------------------------------------------------------
  -- * Transforming ASCII to Unicode
  --------------------------------------------------------------------------------
  
  -- | Match the 'current' element and its eight neighbours against the defined
  -- 'patterns' and choose the 'Char' from the matching 'Pattern'.
  substituteChar :: Plane Char -> Char
  substituteChar = \case
      Plane ( Zipper ((Zipper (a : as) b (c : cs)) : _)
                     ( Zipper (d : ds) e (f : fs))
                     ((Zipper (g : gs) h (i : is)) : _) )
          -> fromMaybe e (lookupPattern (patternFromString [a, b, c, d, e, f, g, h, i]))
      _ -> undefined -- We assume an infinite Zipper!
  
  -- | Transform a 'Plane' of ASCII characters to an equivalent plane where the
  -- ASCII box drawings have been replaced by their Unicode counterpart.
  --
  -- This function is a convolution with 'substituteChar' using the 'Comonad'ic
  -- 'extend'.
  renderAsciiToUnicode :: Plane Char -> Plane Char
  renderAsciiToUnicode = extend substituteChar
  
  
  
  {- $setup
  >>> :{
  aa2u :: String -> IO ()
  aa2u input =
      let inputLines = lines input
          plane = planeFromList ' ' inputLines
          width = maximum (fmap length inputLines)
          height = length inputLines
      in  putStr
          . unlines
          . fmap (reverse . dropWhile (== ' ') . reverse)
          . planeToList height width
          . renderAsciiToUnicode
          $ plane
  :}
  -}
  