{- |
=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
:}
-}