import qualified Data.Map.Strict as M
import Data.List (transpose, intercalate)
import Data.Maybe (fromJust, isJust)
import Control.Monad (forM_)
import Data.Monoid ((<>))

magic :: Int -> [[Int]]
magic n = mapAsTable ((4 * n) + 2) (hiResMap n)


hiResMap :: Int -> M.Map (Int, Int) Int
hiResMap n =
  let mapLux = luxMap n
      mapSiam = siamMap n
  in M.fromList $
     foldMap
       (\(xy, n) ->
           luxNums xy (fromJust (M.lookup xy mapLux)) ((4 * (n - 1)) + 1))
       (M.toList mapSiam)


luxNums :: (Int, Int) -> Char -> Int -> [((Int, Int), Int)]
luxNums xy lux n =
  zipWith (\x d -> (x, n + d)) (hiRes xy) $
  case lux of
    'L' -> [3, 0, 1, 2]
    'U' -> [0, 3, 1, 2]
    'X' -> [0, 3, 2, 1]
    _ -> [0, 0, 0, 0]


mapAsTable :: Int -> M.Map (Int, Int) Int -> [[Int]]
mapAsTable nCols xyMap =
  let axis = [0 .. nCols - 1]
  in fmap (fromJust . flip M.lookup xyMap) <$>
     (axis >>= \y -> [axis >>= \x -> [(x, y)]])


luxMap :: Int -> M.Map (Int, Int) Char
luxMap n =
  (M.fromList . concat) $
  zipWith
    (\y xs -> (zipWith (\x c -> ((x, y), c)) [0 ..] xs))
    [0 ..]
    (luxPattern n)


luxPattern :: Int -> [String]
luxPattern n =
  let d = (2 * n) + 1
      [ls, us] = replicate n <$> "LU"
      [lRow, xRow] = replicate d <$> "LX"
  in replicate n lRow <> [ls <> ('U': ls)] <> [us <> ('L': us)] <>
     replicate (n - 1) xRow


siamMap :: Int -> M.Map (Int, Int) Int
siamMap n =
  let uBound = (2 * n)
      sPath uBound sMap (x, y) n =
        let newMap = M.insert (x, y) n sMap
        in if y == uBound && x == quot uBound 2
             then newMap
             else sPath uBound newMap (nextSiam uBound sMap (x, y)) (n + 1)
  in sPath uBound (M.fromList []) (n, 0) 1


nextSiam :: Int -> M.Map (Int, Int) Int -> (Int, Int) -> (Int, Int)
nextSiam uBound sMap (x, y) =
  let alt (a, b)
        | a > uBound && b < 0 = (uBound, 1) 
        | a > uBound = (0, b) 
        | b < 0 = (a, uBound) 
        | isJust (M.lookup (a, b) sMap) = (a - 1, b + 2) 
        | otherwise = (a, b) 
  in alt (x + 1, y - 1)


hiRes :: (Int, Int) -> [(Int, Int)]
hiRes (x, y) =
  let [col, row] = (* 2) <$> [x, y]
      [col1, row1] = succ <$> [col, row]
  in [(col, row), (col1, row), (col, row1), (col1, row1)]


checked :: [[Int]] -> (Int, Bool)
checked square = (h, all (h ==) t)
  where
    diagonals = fmap (flip (zipWith (!!)) [0 ..]) . ((:) <*> (return . reverse))
    h:t = sum <$> square <> transpose square <> diagonals square

table :: String -> [[String]] -> [String]
table delim rows =
  let justifyRight c n s = drop (length s) (replicate n c <> s)
  in intercalate delim <$>
     transpose
       ((fmap =<< justifyRight ' ' . maximum . fmap length) <$> transpose rows)

main :: IO ()
main =
  forM_ [1, 2, 3] $
  \n -> do
    let test = magic n
    putStrLn $ unlines (table " " (fmap show <$> test))
    print $ checked test
    putStrLn ""