module Hoogle.Score.Scoring(scoring) where

import Hoogle.Score.Type
import Data.List
import Control.Arrow
import Data.Ord
import Data.Maybe
import Control.Monad
import System.Random


-- | Given a set of scores, where the first is lower than the second, returns details for how to rank scores.
--   This function is in the 'IO' monad since it may require randomness, and it may output status messages while solving,
--   particularly if in Verbose mode.
scoring :: [(Score,Score)] -> IO String
scoring xs = do
    let cost ys = sum [max 0 $ 1 + vals a - vals b | (a,b) <- xs
                      ,let vals = sum . map (fromRange . fromJust . flip lookup ys) . scoreCosts]
    config <- solveConfig cost [(x::TypeCost, toRange [1..10]) | x <- [minBound..maxBound]]
    return $ unlines ["cost " ++ show a ++ " = " ++ show (fromRange b) | (a,b) <- config]


---------------------------------------------------------------------
-- SOLVER

type Cost = Int

-- zipper on the value
data Range a = Range [a] a [a] deriving Show
toRange (x:xs) = Range [] x xs
fromRange (Range _ x _) = x

type Config = [(TypeCost,Range Int)]

bestConfig f = snd . minimumBy (comparing fst) . map (f &&& id)

nextRange (Range a b c) = [Range as a (b:c) | a:as <- [a]] ++ [Range (b:a) c cs | c:cs <- [c]]
nextConfig = perturb $ \(a,b) -> map ((,) a) $ nextRange b

randomRange (Range x y z) = do
    let xs = reverse x ++ y:z
    i <- randomRIO (0,length xs-1)
    let (x2,y2:z2) = splitAt i xs
    return $ Range (reverse x2) y2 z2

randomConfig = mapM $ \(a,b) -> fmap ((,) a) $ randomRange b


-- | Greedy hill climbing to improve a config
improveConfig :: (Config -> Cost) -> Config -> Config
improveConfig f now | f next < f now = improveConfig f next
                    | otherwise = now
    where next = bestConfig f $ nextConfig now


-- | Try and minimize the cost of the config
solveConfig :: (Config -> Cost) -> Config -> IO Config
solveConfig f x = fmap (bestConfig f) $ replicateM 25 $ do
    putChar '.'
    y <- randomConfig x
    let z = improveConfig f y
    print (f y,f z)
    return z


-- | Perturb one value in the list
perturb :: (a -> [a]) -> [a] -> [[a]]
perturb f [] = [[]]
perturb f (x:xs) = map (:xs) (f x) ++ map (x:) (perturb f xs)