module Crossword (
    Site, makeGrid, getSites, getLinkedSites, rotateLeft, rotateRight,
    siteBoxes, sinkSites, sinkConstraints, applyConstraints, loopSink,
    onePass, compatible, toLinear, render, unique, xy, triage, sinkable,
    pathSplit
    ) where

import Control.Monad
import Data.List

-- Coordinate
type Pos = (Int, Int)

-- Reference Grid
type Grid = [[Cell]]

-- Letter / position constraint
type Constraint = (Pos, Char)

-- Partial Solution
type Partial = ([Constraint], [Site])

-- Ready to be render
-- (row length, [(index, character)])
type LinearEncoded = (Int, [(Int, Char)])

-- Word site
data Site = Site {
    siteXY :: Pos,
    siteWord :: String,
    siteLen :: Int,
    isVert :: Bool,
    candidates :: [String],
    siteBoxes :: [Pos]
    } deriving (Eq)

instance Show Site where
    show s = (
        (if (isVert s) then "Vert" else "Horiz")
        ++ " :: " ++ (show $ siteXY s)
        ++ " :: " ++ (intercalate "|" $ candidates s)
        )


-- Horiz and vertical sites
data Cell = Cell {
    xy :: Pos,
    avail :: Bool
    } deriving (Eq, Show)

-- Right pad string to i length
rPad :: Int -> String -> String
rPad i xs
    | i < ll = xs
    | i >= ll = xs ++ (replicate (i - ll) ' ')
    where
        ll = length xs

-- Make a full data grid
makeGrid :: Bool -> [String] -> Grid
makeGrid vert xs = zipWith oneRow [1..(length padded)] padded
    where
        oneRow y zs = zipWith (oneCell y) [1..(length zs)] zs
        oneCell y a b = Cell {
            xy=if vert then ((total - y) + 1, a) else (a, y),
            avail=(b == '.')
        }

        total = length xs
        padded = map (rPad longest) xs
        longest = foldl max 0 $ map length xs

getSites :: Bool -> [String] -> Grid -> [Site]
getSites is_vert words xs = concat $ zipWith oneRow [0..(length xs)] xs
    where
        oneRow z x = (collectSites . grouping) x

        collectSites zs = foldl collectOne [] zs
        collectOne acc x = if isSite x then (oneSite x):acc else acc
        oneSite x = Site {
            siteLen=(length x),
            siteXY=(getFirst x),
            siteBoxes=(getBoxes is_vert (getFirst x) (length x)),
            siteWord="",
            candidates=(filter (\a -> length a == length x) words),
            isVert=is_vert
            }

        grouping = groupBy (\a b -> (avail a) == (avail b))

        getFirst x = xy $ head x
        isSite x = (length x) >= 2 && (ifHead x)
        ifHead [] = False
        ifHead ys = avail $ head ys

getBoxes :: Bool -> Pos -> Int -> [Pos]
getBoxes vert start len = if vert then zip (repeat f) [s..(s + len - 1)]
        else zip [f..(f + len - 1)] (repeat s)
    where
        f = fst start
        s = snd start

getLinkedSites :: Site -> [Site] -> [Site]
getLinkedSites src sites = filter ((/=) src) $ filter shared sites
    where
        boxes = siteBoxes src
        shared one = foldl (\acc x -> acc || (elem x boxes)) False (siteBoxes one)

sinkable :: Partial -> (Bool, Partial)
sinkable xs = (yes, sortSites (cons, sites))
    where
        cons = fst xs
        sites = snd xs
        yes = (length may) >= 1
        may = filter (\x -> 1 == (length $ candidates x)) sites

-- sort for fewest remaining candidates
-- then by longest sites descending
sortSites :: Partial -> Partial
sortSites xs = (cons, sortBy sortCompare sites)
    where
        cons = fst xs
        sites = snd xs
        sortCompare a b = let
                clen = length . candidates
                alen = clen a
                blen = clen b
            in if alen == blen then compare (siteLen b) (siteLen a) else compare (clen a) (clen b)

sinkSites :: Partial -> Partial
sinkSites xs = (unique constraints, dropped)
    where 
        cons = fst xs
        sites = snd xs

        dropped = map (\x -> dropWords excluded x) changed

        (excluded, constraints, changed) = foldl sinkSite ([], cons, []) sites

        -- Gather dropped words, new constraints, and altered sites
        sinkSite (accWords, accCons, accSites) s = let
                cs = candidates s
                yes = length cs == 1 -- if one candidtate then sink
                word = head cs
                newCons = zip (siteBoxes s) word

                one = if yes then word:accWords else accWords
                two = if yes then (accCons ++ newCons) else accCons
                three = if yes then accSites else s:accSites
            in (one, two, three)

        -- Drop the words that were sunk from the rest of the sites
        dropWords ex x = let cs = candidates x
            in x{candidates=filter (\y -> not (elem y ex)) cs}

-- Sink all current constraints
sinkConstraints :: Partial -> Partial
sinkConstraints (cons, sites) = (cons, map (\x -> applyConstraints cons x) sites)

-- Apply a set of constraints to a site
applyConstraints :: [Constraint] -> Site -> Site
applyConstraints cs site = site{candidates=limitWords}
    where
        boxes = siteBoxes site
        words = candidates site
        zipOne x = zip boxes x
        fake = map zipOne words
        limitWords = do
            f <- fake
            guard (compatible f cs)
            return $ map snd f -- returns String

-- Check whether two constraint sets are compatible
compatible :: [Constraint] -> [Constraint] -> Bool
compatible check against = all (== True) mapped
    where
        full = check ++ against
        sorted = sortBy (\a b -> compare (fst a) (fst b)) full
        grouped = groupBy (\a b -> (fst a) == (fst b)) sorted
        mapped = map okOne grouped
        okOne row = let h = head row
            in all (\a -> a == h) row

-- Alternate sinking sites and constraints to solve
onePass :: Partial -> Partial
onePass = sinkSites . sinkConstraints

loopSink :: Int -> Partial -> (Int, Partial)
loopSink depth p@(cons, []) = (depth, p) -- solved
loopSink depth p@(cons, sites)
    | depth >= 10 = (depth, p)
    | otherwise = loopSink (depth + 1) (onePass p)

-- Take a sorted Partial, and break the first entry into multiple paths
pathSplit :: Partial -> [Partial]
pathSplit (cons, []) = return (cons, [])
pathSplit (cons, sites) = let first = head sites in do
    x <- candidates first -- get one word
    let changed = first { candidates=[x] }
    return (cons, changed:(tail sites))

-- See if a partial is still a valid path forward
validPath :: Partial -> Bool
validPath (cons, []) = True
validPath (cons, sites) = foldl (\acc x -> acc && (length $ candidates x) >= 1) True sites


triage :: Int -> Partial -> [Partial]
triage depth p@(cons, []) = return p
triage depth p
    | depth >= 20 = return p
    | otherwise = do
        one <- next
        triage (depth + 1) one
    where
        first = onePass p
        (yes, sorted) = sinkable first
        valid = validPath first
        next
            | not valid = []
            | yes = [first]
            | otherwise = pathSplit sorted

-- Encode completed graph for rendering
toLinear :: Partial -> LinearEncoded
toLinear (cons, _) = (xlen, sorted $ map linear cons)
    where
        sorted = sortBy (\a b -> compare (fst a) (fst b))
        xlen = foldl (\acc ((a, b), c) -> if a > acc then a else acc) 0 cons
        linear ((x, y), c) = (((y - 1) * xlen) + x, c)

-- Render completed graph
render :: Int -> LinearEncoded -> IO ()
render _ (xlen, []) = return ()
render current (xlen, encs) = do
        putStr (use:newLine)
        -- guard (current <= 70)
        render (current + 1) (xlen, next)
    where
        index = fst $ head encs
        letter = snd $ head encs
        yes = index == current
        use = if yes then letter else ' '
        next = if yes then (tail encs) else encs
        newLine = if current > 0 && (mod current xlen) == 0 then "\n" else ""

unique :: (Eq a) => [a] -> [a]
unique [] = []
unique [x] = [x]
unique (x:xs) = let rest = unique xs
    in if elem x xs then rest else x:rest
        
rotateLeft :: [[x]] -> [[x]]
rotateLeft = reverse . transpose

rotateRight :: [[x]] -> [[x]]
rotateRight = transpose