{-# LANGUAGE LambdaCase, TupleSections, RecordWildCards, BangPatterns #-}

module PlayGen (genAllPlays, showPlay) where

import qualified Data.DAWG.Packed as D
import Data.Int                     
import Data.Array.Unboxed                                            
import Data.List                    
import Data.List.Split           
import Data.Char                                       
import Control.Arrow               
import Control.Parallel.Strategies
import Data.Ord                    
import Data.Tuple                  
import Text.Printf            
import GameData

maxRackSize = 7
maxWcards = 2

genPlays :: Direction -> [String] -> D.Node -> String -> [Play]
genPlays dir tbl dawg rck | length rck > maxRackSize = error $ printf "Rack too big, limit is %d" maxRackSize
                          | wcardnum   > maxWcards   = error $ printf "Too many wildcards, limit is %d" maxWcards
                          | otherwise = concat $ parMap rdeepseq (getScores . genPlaysAt) (range tableBounds) where


    table = parseTable tbl dawg 
    (wcardnum, rack) = first length $ partition (==wildcard) rck 

    maybeDel :: String -> D.Node -> Maybe (D.Node, String)
    maybeDel []     n = Nothing
    maybeDel (x:xs) n | x == D.value n = Just (n, xs)
                      | otherwise  = second (x:) `fmap` maybeDel xs n

    leftParts :: [PrefixData]
    leftParts = (dawg, "", (wcardnum, rack)): next dawg rack wcardnum where

        next n r w = concat $ no_wcard ++ with_wcard where
            chs        = D.getChildren n 
            no_wcard   = [go id ch r' w | not (null r), Just (ch, r') <- map (maybeDel r) chs]
            with_wcard = [go toLower ch r (w - 1) | w /= 0, ch <- chs]

        go f n r w = (n, [c], (w, r)): [(n, c:p, wr) | (n, p, wr) <- next n r w] where
            c = f (D.value n)


    leftPartMemo :: Array Int [PrefixData]
    leftPartMemo = accumArray (flip (:)) [] (0, maxRackSize) [(length pref, a) | a@(_, pref, _) <- leftParts]


    getLeftParts :: Int -> [PrefixData]
    getLeftParts l = [0..l] >>= (leftPartMemo!)


    getRightParts :: CellIndex -> PrefixData -> [(String, String)]
    getRightParts i (n, pref, (w, r)) = map (pref,) $ concat $ next n r w i (table ! i) where

        next n r w (i,j) (Filled c) = [go (const c) ch r w (i, j + 1) | ch <- D.getChildren n, D.value ch == toUpper c]
        next n r w (i,j) cell       = no_wcard ++ with_wcard where
            i'         = (i, j + 1)
            chs        = (if isEmpty cell then id else filter (hasLetter (lset cell) . D.value)) (D.getChildren n)
            no_wcard   = [go id ch r' w i' | not (null r), Just (ch, r') <- map (maybeDel r) chs]
            with_wcard = [go toLower ch r (w - 1) i' | w /= 0, ch <- chs]

        go f n r w i = word ++ rest where
            c    = f (D.value n)
            cell = table ! i
            inb  = inBounds i
            word = [[c] | D.endOfWord n, (not inb) || (not $ isFilled cell)]
            rest = [c:x | inb, x <- concat $ next n r w i cell]


    genPlaysAt :: CellIndex -> (CellIndex, [(String, String)])
    genPlaysAt i = (i, plays) where

        plays | not $ isAnchor $ table ! i = []
              | not $ null leftWord        = getRightParts i (leftNode, leftWord, (wcardnum, rack))
              | otherwise                  = getLeftParts prefLen >>= getRightParts i

        goLeft   = map (table!) $ drop 1 $ stepLeft i
        leftWord = reverse $ map (\(Filled c) -> c) $ takeWhile isFilled goLeft
        leftNode = maybe (error "invalid word in scrabble table") id (D.lookupPrefix leftWord dawg)
        prefLen  = min maxRackSize (length $ takeWhile isEmpty $ goLeft)


    getScores :: (CellIndex, [(String, String)]) -> [Play]
    getScores ((i, j), playwords) = map go playwords where

        go (a, b) = Play dir start' totalScore word where
            start   = (i, j - (fromIntegral $ length a))
            cells   = map (table!) (stepRight start)
            bonuses = map (bonusTable!) (stepRight start)
            word    = a ++ b
            start'  = (if dir == H then id else swap) start

            wordMod s = \case
                WS2 -> 2 * s
                WS3 -> 3 * s
                _   -> s 

            process (!wsc, !csc, !wmods, !bingo) (char, cell, bonus) = let
                notfill = not $ isFilled cell
                ps      = pieceScore char
                cscore  = crossScore cell

                lscore | not notfill  = ps
                       | bonus == LS2 = 2*ps
                       | bonus == LS3 = 3*ps
                       | otherwise    = ps

                csc' = csc + (if isAnchor cell && cscore /= 0
                                then wordMod (lscore + cscore) bonus
                                else 0)

                wmods' = (if elem bonus [WS2, WS3] && notfill then (bonus:) else id) wmods
                in (wsc + lscore, csc', wmods', bingo + fromEnum notfill)

            (wsc, csc, wmods, bingo) = foldl' process (0, 0, [], 0) (zip3 word cells bonuses)
            totalScore = csc + foldl' wordMod wsc wmods + 50 * fromEnum (bingo == 7)


genAllPlays :: [String] -> D.Node -> String -> [Play]
genAllPlays table dawg rack = sortBy (flip $ comparing score) plays where
    plays = zip [H, V] [table, transpose table] >>= \(d, t) -> genPlays d t dawg rack


showPlay :: [String] -> Play -> IO ()
showPlay table p@(Play d l s w) = let
    as = zip ((if d == H then stepRight else stepDown) l) w
    bs = zip (range tableBounds) (concat table)

    insert ((i, a):as) ((j, b):bs)
        | i == j    = a: insert as bs
        | otherwise = b: insert ((i, a):as) bs
    insert a b = map snd a ++ map snd b

    in do putStrLn (show p)
          mapM_ print $ chunksOf (length table) (insert as bs)