{-# LANGUAGE TypeSynonymInstances #-}

module Strategy where

import Data.Ord
import Data.List
import Data.Function (on)
import Data.Monoid
import Data.Maybe (mapMaybe)
import Control.Monad (mplus)

import GameBoard
import Rules
import Types

dist (x,y) = x*x + y*y -- intentionally left squared
mag (Dir c) = 1/dist c
dir :: Location -> Location -> Direction
dir c1 c2 = toDir $ c1 - c2
infinity = 100

-- Attractive forces are just the negation of repelling
-- forces. It may be useful to add in some multiplying
-- factor at some pooint (which should be easy).
attract :: Location -> Location -> Direction
attract t d = negate $ repel t d

repel :: Location -> Location -> Direction
repel t1 t2 = scale d $ signum $ dir t1 t2
    where d = mag $ dir t1 t2

repulsion :: Location -> [Location] -> Direction
repulsion l ls = mconcat $ map (repel l) ls

attraction :: Location -> [Location] -> Direction
attraction l ls = mconcat $ map (attract l) ls

attractfoes :: Strategy
attractfoes (me,_,foes) = attraction me foes

attractfriends :: Strategy
attractfriends (me,friends,_) = attraction me friends

repelfriends :: Strategy
repelfriends (me,friends,_) = repulsion me friends

repelfoes :: Strategy
repelfoes (me,_,foes) = repulsion me foes

hidebehindfriends :: Strategy
hidebehindfriends (me,friends,foes) = if null candidates
                                        then (Dir (0,0))
                                        else toDir $ result - me
    where candidates = filter (accessible me) $ concatMap nearby friends
          blockedfoes c = distancetofoes (c, friends, hiddenfoes (c,friends,foes))
          result = minimumBy (comparing blockedfoes) candidates

attackwithsupport :: Strategy
attackwithsupport s@(me,friends,foes) = if null inreach
                                            then Dir (0,0)
                                            else toDir $ result - me
    where inreach = concatMap (filter isfoe . map opp) $ supporters s
          opp l = me + (me - l)
          isfoe l = l `elem` foes
          result = minimumBy (comparing (distance me)) inreach

distancetofoes, distancetofriends :: Situation -> Int
distancetofoes (_,_, []) = infinity
distancetofoes (me,_,foes) = minimum $ map (distance me) foes
distancetofriends (_,_, []) = infinity
distancetofriends (me,friends,_) = minimum $ map (distance me) friends

hiddenfoes :: Situation -> [Location]
hiddenfoes (me,friends,foes) = filter hidden reachablefoes
    where reachablefoes = filter (accessible me) foes
          hidden foe = any (`elem` friends) (path me foe)

supporters :: Situation -> [[Location]]
supporters (me,friends,_) = filter (not . null) $ map (takeWhile isfriend) compassdirs
    where isfriend f = f `elem` friends
          vectors = map Loc $ zip [-1,0,1,-1,1,-1,0,1] [1,1,1,0,0,-1,-1,-1]
          compassdirs = map (\vec -> tail $ iterate (+vec) me) vectors

nearerfoes :: Situation -> Bool
nearerfoes s = distancetofoes s < distancetofriends s

reduce, increase :: Strategy -> Strategy
reduce s = 0.7 <*> s
increase s = 1.3 <*> s

trollSituations :: Board -> [Situation]
trollSituations b = map helper tss
    where tss = wraps $ trolls b
          ds  = dwarves b
          helper [] = error "No trolls left on the board!"
          helper ts = (head ts, tail ts, ds)

dwarfSituations :: Board -> [Situation]
dwarfSituations b = map helper $ wraps $ dwarves b
    where ts  = trolls b
          helper [] = error "No dwarves left on the board!"
          helper ds = (head ds, tail ds, ts) 

rankTrolls :: Board -> [(Location,Direction)]
rankTrolls b = sortBy (comparing (mag . snd)) $ zip (trolls b) (map strategy sits)
    where sits = trollSituations b
          strategy = attractfoes <+> repelfriends

rankDwarves :: Board -> [(Location,Direction)]
rankDwarves b = sortBy (comparing (mag . snd)) $ zip (dwarves b) $ map strategy sits
    where sits = dwarfSituations b
          strategy = attractfriends <+> repelfoes <+> (20 <*> attackwithsupport)

clusters :: [Location] -> [Location]
clusters ds = horizontal `intersect` vertical
    where horizontal = maximumBy (comparing length) $ groupBy (diffBy1 `on` xCoord) $ sortBy (compare `on` xCoord) ds
          vertical = maximumBy (comparing length) $ groupBy (diffBy1 `on` yCoord) $ sortBy (compare `on` yCoord) ds
          diffBy1 a b = abs (a-b) < 2

-- Given an arbitrary vector, which single move best expresses
-- the direction this piece should move?
nextMove :: Direction -> Direction
nextMove (Dir (dx,dy)) | angle < (pi/6) = Dir (dx, 0)
                       | angle > (pi/3) = Dir (0, dy)
                       | otherwise      = Dir (dx,dy)
    where (x,y) = abs (dx,dy)
          angle = atan (y/x)
-- Trolls can only move one square at a time.
nextOneMove = signum . nextMove

suggestTrollMove :: Board -> [Action]
suggestTrollMove b = filter (`valid` b) $ map mkMove suggested
    where suggested = rankTrolls b
          mkMove (c,d) = Move Troll c (c + toLoc (nextOneMove d))

suggestDwarfMove :: Board -> [Action]
suggestDwarfMove b = filter (`valid` b) $ mapMaybe (\m -> mkHurl m`mplus`mkMove m) suggested
    where suggested = rankDwarves b
          mkMove (l,d) = case takeWhile onside (path l (l + toLoc (nextMove d))) of
                          [] -> Nothing
                          ms -> Just (Move Dwarf l (last ms))
          mkHurl (l,d) = let l' = l + toLoc (nextMove d)
                         in case takeWhile onside (path l l') of
                          [] -> Nothing
                          ms -> if l' `elem` (trolls b)
                                    then Just (Toss Dwarf l l' (l + l - l'))
                                    else Nothing

turnabout = cycle [suggestTrollMove, suggestDwarfMove]

bothdirs :: Location -> Location -> [(Location,Location)]
bothdirs pivot neighbour = zip dwarves empties
    where dwarves = zipWith (+) (repeat pivot) magnitudes
          empties = zipWith (+) (repeat pivot) $ map (liftL negate) magnitudes
          magnitudes = zipWith liftL (map (*) [1..]) $ repeat $ neighbour - pivot

-- utility functions

xCoord (Loc (a,_)) = a
yCoord (Loc (_,b)) = b
xShift (Dir (a,_)) = a
yShift (Dir (_,b)) = b

liftL f (Loc (x,y)) = Loc (f x, f y)
liftL2 f (Loc (x1,y1)) (Loc (x2,y2)) = Loc (f x1 x2, f y1 y2)

toDir (Loc (l,r)) = Dir (fromIntegral l, fromIntegral r)
toLoc (Dir (l,r)) = Loc (round l, round r)

wraps xs = init $ zipWith (++) (tails xs) (inits xs)

findPieces Troll b = trolls b
findPieces Dwarf b = dwarves b