Sample.hs

{-# LANGUAGE RankNTypes #-}

module Test.Patricia.Word.Sample
  ( Sample
  , zero
  , one
  , tiny
  , small
  , medium
  , large

  , mkUnary0
  , mkUnary1
  , mkUnary2

  , mkBinary
  , mkBinaryL

  , mkEqual
  , mkSuperset
  , mkSubset
  ) where

import           No.Tree (NoTree)
import qualified No.Tree as No
import           Test.Kit
import           Test.Random

import qualified Data.List as List
import           System.Random



data Sample = Sample
                [(Word, Int)] -- ^ Keys in the dictionary
                [(Word, Int)] -- ^ Keys not in the dictionary
              deriving Show

zero, one :: Sample
zero = Sample [] [(4507, 1), (5824, 2), (6183, 3), (6858, 4)]
one  = Sample [(6593, 0)]
              [(4905, 1), (6285, 2), (6134, 3), (6737, 4), (6928, 5), (7513, 6)]



halve :: [a] -> ([a], [a])
halve (a:b:cs) = let ~(xs, ys) = halve cs
                 in (a:xs, b:ys)
halve a        = (a, [])

sample :: (Word, Word) -> Int -> StdGen -> Sample
sample r n g =
  let ~(xs, _) = list (uniformR r) n g

      ~(ys, zs) = halve $ zip (List.nub xs) [0..]

  in Sample ys zs

tiny, small, medium, large :: Sample
tiny   = sample (0x1000, 0x80000) 8    (mkStdGen 0)
small  = sample (0x1000, 0x80000) 64   (mkStdGen 1)
medium = sample (0x1000, 0x80000) 512  (mkStdGen 2)
large  = sample (0x1000, 0x80000) 4096 (mkStdGen 3)



type FromList pat = forall x. [(Word, x)] -> pat x

mkUnary0 :: FromList pat -> Sample -> [Case () (pat Int) (NoTree Word Int)]
mkUnary0 patFromList (Sample xs _) = [Case () (patFromList xs) (No.fromList xs)]

mkUnary1 :: FromList pat -> Sample -> [Case (Word, Int) (pat Int) (NoTree Word Int)]
mkUnary1 patFromList (Sample xs ys) =
  let pat = patFromList xs
      no  = No.fromList xs

  in foldr (\x -> (:) (Case x pat no)) [] $ xs <> ys

mkUnary2
  :: FromList pat -> Sample -> [Case (Word, Word, Int) (pat Int) (NoTree Word Int)]
mkUnary2 patFromList (Sample xs ys) =
  let pat = patFromList xs
      no  = No.fromList xs

      ~(as, bs) = halve xs
      ~(cs, ds) = halve ys

      ones = fmap (\(a, i) -> (a, a, i)) $ as <> cs

      twos = zipWith (\(a, i) (b, _) -> (a, b, i)) bs ds

  in foldr (\x -> (:) (Case x pat no)) [] $ ones <> twos


mkBinary
  :: FromList pat
  -> Sample
  -> [Case (pat Int, NoTree Word Int) (pat Int) (NoTree Word Int)]
mkBinary patFromList (Sample xs ys) =
  [Case (patFromList ys, No.fromList ys) (patFromList xs) (No.fromList xs)]

mkBinaryL
  :: FromList pat
  -> Sample
  -> [Case (pat Int, NoTree Word Int) (pat Int) (NoTree Word Int)]
mkBinaryL patFromList (Sample xs ys) =
  let ~(as, _) = halve xs
      ~(bs, _) = halve ys

      ls = fmap (\(k, a) -> (k, negate a)) bs <> xs
      rs = fmap (\(k, a) -> (k, negate a)) as <> ys

  in [Case (patFromList rs, No.fromList rs) (patFromList ls) (No.fromList ls)]


mkEqual
  :: FromList pat
  -> Sample
  -> [Case (pat Int, NoTree Word Int) (pat Int) (NoTree Word Int)]
mkEqual patFromList (Sample xs _) =
  let pat = patFromList xs
      no  = No.fromList xs

  in [Case (pat, no) pat no]

mkSuperset
  :: FromList pat
  -> Sample
  -> [Case (pat Int, NoTree Word Int) (pat Int) (NoTree Word Int)]
mkSuperset patFromList (Sample xs ys) =
  let zs = xs <> ys
  in [Case (patFromList zs, No.fromList zs) (patFromList xs) (No.fromList xs)]

mkSubset
  :: FromList pat
  -> Sample
  -> [Case (pat Int, NoTree Word Int) (pat Int) (NoTree Word Int)]
mkSubset patFromList (Sample xs ys) =
  let zs = xs <> ys
  in [Case (patFromList xs, No.fromList xs) (patFromList zs) (No.fromList zs)]