STUArray generic, help on IRC.

STUArray generic

{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE PartialTypeSignatures #-}
import Data.Array.MArray
import Data.Array.Unboxed
import Data.Array.ST
import Data.Function (fix)
import Control.Monad (forM_, when)
import Data.Array.Unsafe
import Control.Monad.ST

mean = undefined

type SearchPlace t = UArray Int t -> (Int, Int) -> t -> Int
-- En point fixe, c'est la même forme qu'en récursif.
dichoFix :: (IArray UArray t, Ord t) => SearchPlace t
dichoFix a (inf0, sup0) val
  | val < a ! inf0        = inf0
  | val >= a ! (sup0 - 1) = sup0
  | otherwise             = fix dicho (inf0, sup0-1)
    where
      dicho recurse (inf, sup)
        | inf == sup-1   = sup
        | a ! mid <= val = recurse (mid, sup)
        | otherwise      = recurse (inf, mid)
          where mid = mean inf sup
                --
-- Tri par insertion. Le tri ce fait sur place mais ne modifie pas
-- le tableau original. On fait d'abord une copie.
insertSort :: forall t. (forall s. MArray (STUArray s) t (ST s), IArray UArray t) => SearchPlace t -> UArray Int t -> UArray Int t
insertSort search a = runSTUArray $ do
  a' :: STUArray s Int t <- thaw a
  let (inf, sup) = bounds a
  forM_ [inf+1..sup] $ \i -> do
    cur <- readArray a' i
    a'' <- unsafeFreeze a' -- On utilise la « copie » qu'une seule fois avant de mofifier a'
    let p = search a'' (inf, i) cur
    when (p /= i) $ do -- si p == i, cur est à sa place
       -- pour j <- [p..i] on recopie les (a' ! (j-1)) vers (a' ! j)
       -- il faut débuter la copie depuis la fin
      forM_ [i, i-1..p+1] $ \j -> do
        val <- readArray a' (j-1)
        writeArray a' j val
      writeArray a' p cur
  return a'

main = print ()