{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Deck.Diff (
    HunkSYM (..),
    DeckSYM (..),
    DeckRep,
    DiffSig,
    diff,
) where

import Control.Lens
import Control.Monad
import Control.Monad.State

import Data.Function (on)
import Data.Functor.Compose
import Data.Kind
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)

import Refined.Unsafe

import Deck.Category as Category
import Deck.Deck as Deck
import ResourceQueue
import Util

type DiffSig a = a (DeckRep a) -> a (DeckRep a)

type DeckRep :: (Type -> Type) -> Type
type family DeckRep a

class DeckSYM repr where
    -- type DeckRep repr

    -- | Create an empty deck
    empty :: repr (DeckRep repr)

    -- | Lift a deck into object scope
    deck :: DeckRep repr -> repr (DeckRep repr)

    -- | Add a card to the deck
    add ::
        CardName -> CategoryName -> Copies -> DiffSig repr

    -- | Delete all occurences of a card
    delete :: CardName -> DiffSig repr

class HunkSYM repr where
    -- | A diff chunk for a card
    hunk ::
        (Traversable t) =>
        CardName
        -> t (repr (Card -> Maybe Card))
        -> DiffSig repr
    move ::
        CategoryName -> CategoryName -> PositiveNumber -> repr (Card -> Maybe Card)
    deltaCopies :: Int -> CategoryName -> repr (Card -> Maybe Card)

diffCategory ::
    (DeckSYM repr, HunkSYM repr) =>
    Card
    -> [Category]
    -> [Category]
    -> DiffSig repr
diffCategory card left right =
    hunk
        cardname
        (flip evalState (Map.empty, Map.empty) $ go mempty (sorter left) (sorter right))
  where
    sorter = sortBy (compare `on` view Category.name)
    go ::
        (HunkSYM repr, DeckSYM repr) =>
        [repr (Card -> Maybe Card)]
        -> [Category]
        -> [Category]
        -> ResourceQueue [repr (Card -> Maybe Card)]
    go acc [] [] = do
        requested <- ResourceQueue.takeRequested

        changes <- forM requested $ \x -> do
            res <- ResourceQueue.take (x ^. _2)

            let totalTaken = sum . fmap (toNumber @Int) $ Compose res
                moves = map (uncurry (`move` (x ^. _1))) res
                deltas =
                    if totalTaken < toNumber @Int (x ^. _2)
                        then
                            let difference = toNumber @Int (x ^. _2) - totalTaken
                             in singleton $ deltaCopies difference (x ^. _1)
                        else mempty

            pure $ moves ++ deltas

        available <- gets fst
        let deltas =
                Map.foldrWithKey'
                    (\k a xs -> deltaCopies (negate (toNumber @Int a)) k : xs)
                    []
                    available

        put (mempty, mempty)

        pure (acc ++ mconcat changes ++ deltas)
    go acc xs [] = do
        changes <- forM xs $ \x -> fulfillRequest (x ^. copies) (x ^. Category.name)

        go (acc ++ mconcat changes) mempty mempty
    go acc [] ys = do
        changes <- forM ys $ \y -> takeAvailable (y ^. copies) (y ^. Category.name)

        go (acc ++ mconcat changes) mempty mempty
    go acc lx@(x : xs) ly@(y : ys) = do
        case (compare `on` view Category.name) x y of
            LT -> uncurry resource (mkTuple x) >> go acc xs ly
            EQ -> do
                let delta = diffCopies x y
                changes <- case compare delta 0 of
                    LT ->
                        takeAvailable
                            (PositiveNumber . unsafeRefine . fromIntegral . abs $ delta)
                            (x ^. Category.name)
                    EQ -> pure acc
                    GT ->
                        fulfillRequest
                            (PositiveNumber . unsafeRefine . fromIntegral $ delta)
                            (x ^. Category.name)

                go changes xs ys
            GT -> uncurry request (mkTuple y) >> go acc lx ys

    mkTuple x = (x ^. Category.name, x ^. copies)
    diffCopies x y = uncurry (-) $ (x ^. copies, y ^. copies) & both %~ toNumber @Int
    cardname = card ^. Deck.name
    fulfillRequest count categoryname = do
        requests <- ResourceQueue.fulfill count

        let totalTaken = sum . fmap (toNumber @Int) $ Compose requests
        when (totalTaken < toNumber @Int count) $
            resource
                categoryname
                ( PositiveNumber . unsafeRefine . fromIntegral $
                    toNumber @Int count - totalTaken
                )

        pure $ map (uncurry (move categoryname)) requests
    takeAvailable count categoryname = do
        available <- ResourceQueue.take count

        let totalTaken = sum . fmap (toNumber @Int) $ Compose available
        when (totalTaken < toNumber @Int count) $
            request
                categoryname
                ( PositiveNumber . unsafeRefine . fromIntegral $
                    toNumber @Int count - totalTaken
                )

        pure $ map (uncurry (`move` categoryname)) available

toRepr :: (DeckSYM repr) => Card -> [DiffSig repr]
toRepr card =
    let addCard = Deck.Diff.add (card ^. Deck.name)
     in Map.foldr'
            (\x acc -> addCard (x ^. Category.name) (x ^. copies) : acc)
            []
            (card ^. categories)

diff ::
    (HunkSYM repr, DeckSYM repr) => Map Text Card -> Map Text Card -> [DiffSig repr]
diff left right =
    let deckSort = map snd . Map.toAscList
     in go mempty (deckSort left) (deckSort right)
  where
    go acc [] [] = acc
    go acc xs [] = acc ++ map (\x -> Deck.Diff.delete (x ^. Deck.name)) xs
    go acc [] ys = acc ++ concatMap toRepr ys
    go acc lx@(x : xs) ly@(y : ys)
        | x ^. Deck.name < y ^. Deck.name =
            go (Deck.Diff.delete (x ^. Deck.name) : acc) xs ly
        | x ^. Deck.name > y ^. Deck.name = go (acc ++ toRepr y) lx ys
        | x == y = go acc xs ys
        | otherwise =
            go (acc ++ singleton categoryDiffs) xs ys
      where
        categoryDiffs =
            diffCategory
                x
                (Map.elems (x ^. categories))
                (Map.elems (y ^. categories))