content: {-# OPTIONS_GHC -Wall -fglasgow-exts -fno-warn-missing-methods -fno-warn-orphans -fno-warn-type-defaults -fno-warn-unused-binds #-}
  
  import Data.Ord
  import Data.Set (Set)
  import System.Random
  import Test.QuickCheck
  import Control.Monad.Error
  import System.CPUTime
  import Control.Parallel.Strategies  
  import Data.Monoid
  import Text.Printf
  import qualified Data.List as List
  import qualified Data.Set as Set
  
  newtype Sig = MkSig Int deriving (Show, Eq, Ord)
  
  instance (Ord a, Arbitrary a) => Arbitrary (Set a) where
      arbitrary = fmap Set.fromList arbitrary
  
  instance Arbitrary Sig where
      arbitrary = fmap (MkSig . (`mod` 32768)) arbitrary
  
  sigCompare :: Sig -> Sig -> Ordering
  sigCompare sx@(MkSig x) sy@(MkSig y) = case compare x y of
      GT  -> case res `mod` 3 of
          0   -> LT
          1   -> GT
          _   -> EQ
      LT -> case sigCompare sy sx of
          LT  -> GT
          GT  -> LT
          _   -> EQ
      EQ -> EQ
      where
      res = fst . next $ mkStdGen (x * 32768 + y)
  
  dumpCmp :: [Sig] -> String
  dumpCmp = concatMap dumpCmp' . List.tails
      where
      dumpCmp' :: [Sig] -> String
      dumpCmp' []     = ""
      dumpCmp' [_]    = ""
      dumpCmp' (x:xs) = (concatMap (\c -> show x ++ " " ++ (show $ x `sigCompare` c) ++ " " ++ show c ++ "\n") xs)
  
  prop_sigCompare :: (Sig, Sig) -> Bool
  prop_sigCompare (x, y) = case (sigCompare x y, sigCompare y x) of
      (LT, GT)    -> True
      (GT, LT)    -> True
      (EQ, EQ)    -> True
      _           -> False
  
  prop_dispatch :: Set Sig -> Bool
  prop_dispatch xs = case dispatch (Set.toAscList xs) sigCompare of
      ROk winner  -> winsOverRest winner
      _           -> Set.null (Set.filter winsOverRest xs)
      where
      winsOverRest x = Set.null (Set.filter winsOrTiesWithX rest)
          where
          rest                = Set.delete x xs
          winsOrTiesWithX y   = (sigCompare x y) /= GT
  
  data DispatchResult a
      = ROk !a
      | RTied
      | RSpoiled
  
  dispatch :: Eq a => [a] -> (a -> a -> Ordering) -> DispatchResult a
  dispatch candlist cmp = dispatch' candlist
      where
      dispatch' []        = RTied
      dispatch' (x:y:zs)  = dispatch' $ case cmp x y of
          GT -> x:zs
          LT -> y:zs
          _  -> zs
      dispatch' [x]
          | all losesToX spoilers = ROk x
          | otherwise             = RSpoiled
          where
          spoilers   = case takeWhile (/= x) candlist of
              []  -> []
              [_] -> []
              xs  -> xs
          losesToX y = case cmp x y of
              GT  -> True
              _   -> False
  
  data Total = Total { tied :: !Int, spoiled :: !Int, okay :: !Int }
      deriving Show
  
  instance Monoid Total where
      mempty = Total 0 0 0
      mappend (Total t1 s1 o1) (Total t2 s2 o2) = Total (t1+t2) (s1+s2) (o1+o2)
  
  classify_dispatches :: Int -> Int -> Int -> String
  classify_dispatches seed size count = show (foldl cls mempty runs)
      where
      runs = map (`dispatch` sigCompare) samp
      samp = generate size (mkStdGen seed) (replicateM count (arbitrary :: Gen [Sig]))
      cls total x = case x of
          RTied       -> total{ tied      = succ (tied total) }
          RSpoiled    -> total{ spoiled   = succ (spoiled total) }
          ROk{}       -> total{ okay      = succ (okay total) }
  
  getCPUDuration :: NFData a => a -> IO (a, Integer)
  getCPUDuration res = do
      v0  <- getCPUTime
      v1  <- (res `using` rnf) `seq` getCPUTime
      return (res, v1 - v0)
  
  main :: IO ()
  main = do
      putStrLn "Testing prop_sigCompare"
      quickCheck prop_sigCompare
      putStrLn "Testing prop_dispatch"
      --check defaultConfig{ configMaxTest = 1000 } prop_dispatch
      sequence_ [quickCheck prop_dispatch | _ <- [1..10]]
      
      let times = 100000
      putStrLn $ "Timing " ++ (show times) ++ " dispatches"
      (res, time') <- getCPUDuration (classify_dispatches 23452 10 times)
      let time = ((fromInteger time') :: Double) / fromInteger 1000000000000
      putStrLn res
      printf "%.2f seconds, %.2f dispatches/sec\n" time (fromIntegral times / time)
  
  
  