Bogosort and Bogobogosort in Haskell

Bogosort.hs

module Bogosort where

import Control.Monad.Primitive
import Control.Monad.ST
import Control.Monad.ST.Unsafe
import Control.Monad.Trans.State.Strict
import Data.Monoid
import qualified Data.Vector as V
import qualified Data.Vector.Generic.Mutable as VGM
import Data.Vector.Generic.Mutable (MVector)
import System.Random

isSorted :: (PrimMonad m, Ord a, MVector v a) => v (PrimState m) a -> m Bool
isSorted v = do
  let l = VGM.length v
  let is = zip [0..l-2] [1..l-1]
  fmap getAll . getAp . flip foldMap is $ \(i,j) -> Ap $ do
    x <- VGM.unsafeRead v i
    y <- VGM.unsafeRead v j
    pure . All $ x <= y

shuffle :: (RandomGen g, PrimMonad m, Ord a, MVector v a) => v (PrimState m) a -> g -> m g
shuffle v = execStateT . go $ VGM.length v - 1
  where
    go 0 = pure ()
    go l = do
      i <- state $ randomR (0, l)
      VGM.unsafeSwap v i l

bogosort' :: (RandomGen g, PrimMonad m, Ord a, MVector v a) => v (PrimState m) a -> g -> m g
bogosort' v g = do
  s <- isSorted v
  if s 
  then pure g
  else do
    g' <- shuffle v g
    bogosort' v g'

bogosort :: Ord a => V.Vector a -> V.Vector a
bogosort v = runST $ do
  g <- unsafeIOToST newStdGen -- (mostly) harmless evil
  w <- V.thaw v
  _ <- bogosort' w g
  V.unsafeFreeze w

-- bogobogosort! :D
-- http://dangermouse.net/esoteric/bogobogosort.html

isBogoSorted :: (RandomGen g, PrimMonad m, Ord a, MVector v a) => v (PrimState m) a -> g -> m (Bool, g)
isBogoSorted v g | l <= 1 = pure (True, g)
                 | otherwise = do
  w <- VGM.clone v
  g' <- makeRef w g
  r <- fmap getAll . getAp . flip foldMap [0..l-1] $ \i -> Ap $ do
    x <- VGM.unsafeRead v i
    y <- VGM.unsafeRead w i
    pure . All $ x == y
  pure (r, g')
  where
    l = VGM.length v
    makeRef w g' = do
      g'' <- bogobogosort' (VGM.unsafeInit w) g'
      x <- VGM.unsafeRead w (l - 2)
      y <- VGM.unsafeRead w (l - 1)
      if x <= y
      then pure g''
      else shuffle w g'' >>= makeRef w

bogobogosort' :: (RandomGen g, PrimMonad m, Ord a, MVector v a) => v (PrimState m) a -> g -> m g
bogobogosort' v g = do
  (s, g') <- isBogoSorted v g
  if s
  then pure g'
  else do
    g'' <- shuffle v g'
    bogobogosort' v g''

bogobogosort :: Ord a => V.Vector a -> V.Vector a
bogobogosort v = runST $ do
  g <- unsafeIOToST newStdGen -- (mostly) harmless evil
  w <- V.thaw v
  _ <- bogobogosort' w g
  V.unsafeFreeze w