From 7c95cec010651a4a5cad5e4c29c2d1451b8cdec0 Mon Sep 17 00:00:00 2001
From: KtorZ <matthias.benkort@gmail.com>
Date: Tue, 3 Dec 2019 15:38:29 +0100
Subject: [PATCH] implement 'mkSeed' to generate a seed from a text

This would be pretty useful to bridge use any entity (e.g. WalletId) with a
ToText instance as a seed for such generator
---
 lib/core/src/Data/Vector/Shuffle.hs           | 37 +++++++++-
 lib/core/test/unit/Data/Vector/ShuffleSpec.hs | 68 +++++++++++++++++--
 2 files changed, 99 insertions(+), 6 deletions(-)

diff --git a/lib/core/src/Data/Vector/Shuffle.hs b/lib/core/src/Data/Vector/Shuffle.hs
index 1e3f8700b80..26718cfb4d8 100644
--- a/lib/core/src/Data/Vector/Shuffle.hs
+++ b/lib/core/src/Data/Vector/Shuffle.hs
@@ -1,7 +1,13 @@
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Data.Vector.Shuffle
-    ( shuffle
+    ( -- * Simple
+      shuffle
+
+      -- * Advanced
+    , mkSeed
+    , shuffleWith
     ) where
 
 import Prelude
@@ -12,14 +18,36 @@ import Control.Monad.Trans.Class
     ( lift )
 import Control.Monad.Trans.State.Strict
     ( evalStateT, state )
+import Crypto.Hash
+    ( hash )
+import Crypto.Hash.Algorithms
+    ( MD5 )
+import Data.Text
+    ( Text )
 import Data.Vector.Mutable
     ( IOVector )
+import Data.Word
+    ( Word8 )
 import System.Random
-    ( RandomGen, newStdGen, randomR )
+    ( RandomGen, StdGen, mkStdGen, newStdGen, randomR )
 
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as BS
+import qualified Data.Text.Encoding as T
 import qualified Data.Vector as V
 import qualified Data.Vector.Mutable as MV
 
+
+-- | Generate a random generator seed from a text string
+mkSeed :: Text -> StdGen
+mkSeed = mkStdGen . toInt . quickHash . T.encodeUtf16LE
+  where
+    quickHash = BA.convert . hash @_ @MD5
+    toInt = snd . BS.foldl' exponentiation (0,0)
+      where
+        exponentiation :: (Int, Int) -> Word8 -> (Int, Int)
+        exponentiation (e, n) i = (e+1, n + fromIntegral i*2^e)
+
 -- | Shuffles a list of elements.
 --
 -- >>> shuffle (outputs coinSel)
@@ -29,6 +57,11 @@ shuffle xs = newStdGen >>= flip shuffleWith xs
 
 -- | Like 'shuffle', but from a given seed. 'shuffle' will use a randomly
 -- generate seed using 'newStdGen' from @System.Random@.
+--
+-- __Properties:__
+--
+-- - @shuffleWith g es == shuffleWith g es@
+-- - @∃Δ> 1. g ≠g', length es > Δ⇒ shuffleWith g es ≠shuffleWith g' es@
 shuffleWith :: RandomGen g => g -> [a] -> IO [a]
 shuffleWith seed = modifyInPlace $ \v -> flip evalStateT seed $ do
     let (lo, hi) = (0, MV.length v - 1)
diff --git a/lib/core/test/unit/Data/Vector/ShuffleSpec.hs b/lib/core/test/unit/Data/Vector/ShuffleSpec.hs
index 95df0a427e4..ea0a86e8020 100644
--- a/lib/core/test/unit/Data/Vector/ShuffleSpec.hs
+++ b/lib/core/test/unit/Data/Vector/ShuffleSpec.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeApplications #-}
+
 module Data.Vector.ShuffleSpec
     ( spec
     ) where
@@ -5,16 +7,27 @@ module Data.Vector.ShuffleSpec
 import Prelude
 
 import Data.Vector.Shuffle
-    ( shuffle )
+    ( mkSeed, shuffle, shuffleWith )
 import Test.Hspec
     ( Spec, describe, it )
 import Test.QuickCheck
-    ( Confidence (..), NonEmptyList (..), Property, checkCoverageWith, cover )
+    ( Confidence (..)
+    , NonEmptyList (..)
+    , Positive (..)
+    , PrintableString (..)
+    , Property
+    , arbitrary
+    , checkCoverageWith
+    , cover
+    , label
+    , vectorOf
+    , (==>)
+    )
 import Test.QuickCheck.Monadic
-    ( monadicIO, run )
+    ( assert, monadicIO, monitor, pick, run )
 
 import qualified Data.List as L
-
+import qualified Data.Text as T
 
 spec :: Spec
 spec = do
@@ -25,6 +38,13 @@ spec = do
             (checkCoverageWith lowerConfidence prop_shuffleNotDeterministic)
         it "sort (shuffled xs) == sort xs"
             (checkCoverageWith lowerConfidence prop_shufflePreserveElements)
+
+    describe "shuffleWith / mkSeed" $ do
+        it "shuffling with the same seed is deterministic"
+            (checkCoverageWith lowerConfidence prop_shuffleWithDeterministic)
+        it "different seed means different shuffles"
+            (checkCoverageWith lowerConfidence prop_shuffleDifferentSeed)
+
   where
     lowerConfidence :: Confidence
     lowerConfidence = Confidence (10^(6 :: Integer)) 0.75
@@ -54,3 +74,43 @@ prop_shufflePreserveElements
 prop_shufflePreserveElements xs = monadicIO $ run $ do
     xs' <- shuffle xs
     return $ cover 90 (not $ null xs) "non-empty" (L.sort xs == L.sort xs')
+
+-- ∀(g :: RandomGen).
+-- ∀(es :: [a]).
+--
+-- shuffleWith g es == shuffleWith g es
+prop_shuffleWithDeterministic
+    :: PrintableString
+    -> NonEmptyList Int
+    -> Property
+prop_shuffleWithDeterministic (PrintableString seed) (NonEmpty xs) =
+    monadicIO $ do
+        ys0 <- run $ shuffleWith (mkSeed $ T.pack seed) xs
+        ys1 <- run $ shuffleWith (mkSeed $ T.pack seed) xs
+        monitor $ cover 90 (length xs > 1) "non singleton"
+        assert (ys0 == ys1)
+
+-- ∀(x0 : Text, x1 : Text). g0 = mkSeed x0, g1 = mkSeed x1
+-- ∃(Δ: Int).
+-- ∀(es :: [a]).
+--
+-- g0 ≠g1, length es > Δ⇒ shuffleWith g0 es ≠shuffleWith g1 es
+prop_shuffleDifferentSeed
+    :: (PrintableString, PrintableString)
+    -> Positive Int
+    -> Property
+prop_shuffleDifferentSeed (x0, x1) (Positive len) = do
+    x0 /= x1 ==> monadicIO $ do
+        let g0 = mkSeed $ T.pack $ getPrintableString x0
+        let g1 = mkSeed $ T.pack $ getPrintableString x1
+        es <- pick $ vectorOf len (arbitrary @Int)
+        ys0 <- run $ shuffleWith g0 es
+        ys1 <- run $ shuffleWith g1 es
+        monitor $ label (prettyLen es)
+        monitor $ cover 90 (ys0 /= ys1) "different"
+  where
+    prettyLen :: [a] -> String
+    prettyLen xs = case length xs of
+        n | n <= 1 -> "singleton"
+        n | n <= 10 -> "small list"
+        _ -> "big list"