{-# OPTIONS_GHC -F -pgmF htfpp #-}
{-# LANGUAGE ScopedTypeVariables #-}

module DPM.Core.ShortID (getShortID, allHTFTests) where

import qualified Data.List as List
import qualified Data.Set as Set
import Data.Maybe ( isJust )
import Test.Framework

import DPM.Core.DataTypes
import DPM.Core.Utils ( retain )

getShortID :: [PatchID] -> PatchID -> String
getShortID allIds id =
    case susLen (map unPatchID allIds) of
      Nothing -> error ("List of patch IDs " ++ show allIds ++
                        " contains duplicates!")
      Just n -> retain (lowerBounded minLength n) (unPatchID id)
    where minLength = 4
          lowerBounded m n | n < m = m
                           | otherwise = n

-- sus stands for "shortest unique suffix"
susLen :: Ord a => [[a]] -> Maybe Int
susLen [] = Just 0
susLen input =
    let rev = map List.reverse input
        n = minimum (map length input)
        allSuffices = [(i, [take i l | l <- rev]) | i <- [1..n]]
    in case filter (\(_,l) -> hasUniqueElements l) allSuffices of
         [] -> Nothing
         ((i,_):_) -> Just i

prop_susInputNotUnique :: Property
prop_susInputNotUnique =
    forAll (listOf (vectorOf 5 arbitrary)) $ \ (l::[[Bool]]) ->
    not (hasUniqueElements l) ==> susLen l == Nothing

-- FIXME: fails sometimes, replay argument "Just (1419540369 504813816,61)"
prop_susUnique1 :: Property
prop_susUnique1 =
    forAll uniqueListGen $ \l -> isJust (susLen l)

prop_susUnique1Replay :: TestableWithQCArgs
prop_susUnique1Replay =
    withQCArgs (\a -> a { replay = read "Just (1419540369 504813816,61)"})
               prop_susUnique1

prop_susUnique2 :: Property
prop_susUnique2 =
    forAll uniqueListGen $ \l ->
    let Just n = susLen l
        l' = map (retain n) l
    in List.nub l' == l'

prop_susShortest :: Property
prop_susShortest =
    forAll uniqueListGen $ \l ->
      let Just n = susLen l
          l' = map (retain (n-1)) l
      in n > 1 ==> List.nub l' /= l'

uniqueListGen :: Gen [[Int]]
uniqueListGen =
    do n <- choose (10, 20)
       l <- sequence [elementGen i | i <- [0..n]]
       let n = minimum (map length l)
           l' = map (reverse . take n . reverse) l
       return (removeDups l' l [] [])
    where
      elementGen :: Int -> Gen [Int]
      elementGen i =
          do n <- choose (5, 100)
             vectorOf n (choose (0,9))
      removeDups [] _ acc1 acc2 = acc2
      removeDups (x:xs) (y:ys) acc1 acc2
          | x `elem` acc1 = removeDups xs ys acc1 acc2
          | otherwise    = removeDups xs ys (x:acc1) (y:acc2)
      removeDups _ _ _ _ = error ("DPM.Core.ShortID.uniqueListGen.removeDups: "
                                  ++ "invalid arguments")

prop_uniqueListGenOK :: Property
prop_uniqueListGenOK =
    forAll uniqueListGen check
    where check l = let n = minimum (map length l)
                    in hasUniqueElements (map (reverse . take n . reverse) l)

prop_uniqueListGenOKReplay :: TestableWithQCArgs
prop_uniqueListGenOKReplay =
    withQCArgs (\a -> a { replay = read "Just (1419540369 504813816,61)"})
               prop_uniqueListGenOK

hasUniqueElements :: Ord a => [a] -> Bool
hasUniqueElements l =
    walk l Set.empty
    where walk [] _ = True
          walk (x:xs) set = if Set.member x set then False
                               else walk xs (Set.insert x set)

prop_hasUniqueElementsOK :: [[Int]] -> Bool
prop_hasUniqueElementsOK l =
    hasUniqueElements l == (List.nub l == l)