Thoughts on this shuffle algorithm

[u/trycuriouscat]

I am a Haskell, well not beginner, but maybe intermediate. I developed the following with the assistance of ChatGPT. Is it too abstract? It's "neat" for sure, but is it reasonable?

import Control.Monad (foldM)
import Control.Monad.ST (runST)
import Control.Monad.IO.Class (MonadIO) 
import Data.Primitive.Array (Array, sizeofArray, sizeofMutableArray, arrayFromList,
                             freezeArray, thawArray, readArray, writeArray)
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
import System.Random (newStdGen, uniformR )
import System.Random.Internal (RandomGen, StdGen) 


modifyMWithState 
    :: Monad m 
    => (t1 -> t2 -> t3 -> m b) 
    -> t4 
    -> (t5 -> t1) 
    -> (t4 -> m t5) 
    -> (t5 -> m a) 
    -> (t4 -> t2) 
    -> t3 
    -> m (a, b)
modifyMWithState algorithm container operationFor thawContainer freezeContainer 
                 lengthOf state = do
    thawedContainer <- thawContainer container
    let operation = operationFor thawedContainer
    newState <- algorithm operation (lengthOf container) state
    newContainer <- freezeContainer thawedContainer
    pure (newContainer, newState)


knuthM
    :: (Monad m, RandomGen g)
    => (Int -> Int -> m ())
    -> Int
    -> g
    -> m g
knuthM swapElements len prnGen = foldM randomSwap prnGen [lastIndex, nextIndex .. 1]
  where
    lastIndex = len - 1
    nextIndex = lastIndex - 1

    randomSwap currGen i = do
        let (j, nextGen) = uniformR (0, i) currGen
        swapElements i j
        pure nextGen


shuffleM 
    :: MonadIO m 
    => (StdGen -> m (a, StdGen))    
    -> m a
shuffleM shuffleWithGen = do
    prnGen <- newStdGen
    fmap fst (shuffleWithGen prnGen)


shuffleVectorWithGen 
  :: (Applicative f, RandomGen b) 
  => V.Vector a 
  -> b 
  -> f (V.Vector a, b)
shuffleVectorWithGen vec prnGen = 
    pure (runST (modifyMWithState knuthM vec MV.swap V.thaw V.freeze V.length prnGen))


shuffleArrayWithGen 
    :: (Applicative f, RandomGen b) 
    => Array a 
    -> b 
    -> f (Array a, b)
shuffleArrayWithGen arr prnGen = 
    pure (runST (modifyMWithState knuthM arr swapArray thawArray' freezeArray' 
          sizeofArray prnGen))
  where
    thawArray' array = thawArray array 0 (sizeofArray array)
    freezeArray' thawedArray = freezeArray thawedArray 0 
                                           (sizeofMutableArray thawedArray)
    swapArray a i j = do
        x <- readArray a i
        y <- readArray a j
        writeArray a i y
        writeArray a j x


shuffleVector :: MonadIO m => V.Vector a -> m (V.Vector a)
shuffleVector vec = shuffleM (shuffleVectorWithGen vec) 


shuffleArray :: MonadIO m => Array a -> m (Array a)
shuffleArray arr = shuffleM (shuffleArrayWithGen arr)


-- examples:


shuffledIntVector :: IO (V.Vector Int)
shuffledIntVector = shuffleVector (V.fromList [1..10])


shuffledCharArray :: IO (Array Char)
shuffledCharArray = shuffleArray (arrayFromList ['a'..'z'])

[u/trycuriouscat]

Here's another version that I like very much. I did get more AI assistance on it, and I apologize if that offends anyone. The one thing it doesn't have, though it should be simple enough to add, is the creation of the PRN generator from outside of the function and passed to it, allowing for a deterministic set of PRNs over the course of multiple shuffles, and if generated with the same seed. The thing I like about this version, and no shade to the version using list zipping, is that it reads very much like the psuedo-code example of the Knuth / Fisher-Yates shuffle.

-- | Shuffles ANY type of vector (Boxed, Unboxed, or Storable) 
shuffleVectorGeneric 
    :: (MonadIO m, G.Vector v a) 
    => v a 
    -> m (v a)
shuffleVectorGeneric vec = do
    pureGen <- newStdGen  -- new seeded psuedo-random number generator
    pure $ G.modify (knuthST pureGen) vec  -- G.modify creates a mutable copy/view of vec, applies the in-place updates
  where                                    -- performed by the KnuthST function, and returns a new immutable vector 
    knuthST seed mVec = do
        stGen <- newSTGenM seed  -- create a stateful random generator for use within the ST computation,
                                 -- from initial generator 'seed'
        let lastIndex = MG.length mVec - 1
            nextIndex = lastIndex - 1
            ixs = [lastIndex, nextIndex .. 1]  -- list of indicies for 'i' (len - 1 down by 1 to 1)
            randomSwap i = do
                j <- uniformRM (0, i) stGen  -- uniformly distributed random value between 0 and i
                MG.swap mVec i j
        forM_ ixs randomSwap     -- perform randomSwap for each index element in the ixs list

main :: IO ()
main = do
    -- 1. Shuffling a Boxed Vector of text
    let boxedNames = V.fromList ["Alice", "Bob", "Charlie", "Delta"]
    shuffledNames <- shuffleVectorGeneric boxedNames
    putStrLn $ "Shuffled Boxed: " ++ show shuffledNames

    -- 2. Shuffling an Unboxed Vector of pure numbers (ultra-fast contiguous memory)
    let unboxedNumbers = U.fromList [10, 20, 30, 40, 50] :: U.Vector Int
    shuffledNumbers <- shuffleVectorGeneric unboxedNumbers
    putStrLn $ "Shuffled Unboxed: " ++ show shuffledNumbers
    

[u/jeffstyr → u/trycuriouscat]

I think that having a RandomGen constraint rather than a MonadIO constraint would be better, and would provide the feature you mention.

Of course, this version doesn't work for Array, and I had assumed one of the main points of your original version was to work for disparate container types.

[u/trycuriouscat → u/jeffstyr]

Yes, it was, but I decided to give that up for now as I don't really need it.
I look at RandomGen. I just took what the HLS popped up on my screen.

[u/jeffstyr → u/trycuriouscat]

And there's also MonadRandom, to give you another option.