perms.hs

import Data.List
import GHC.Base (build)
import qualified Data.Set as Set
import Control.Monad.State
import Test.QuickCheck

toFact n = unfoldl (uncurry go) (n,1)
  where
    go 0 _ = Nothing
    go n m = case n `quotRem` m of
      (q,r) -> Just (r,(q,m+1))
      
unfoldl :: (b -> Maybe (a, b)) -> b -> [a]
unfoldl f b =
    build
        (\c n ->
              let r a = maybe a (uncurry (r . (`c` a))) . f
              in r n b)
   
factLen 0 = 0   
factLen n = (succ . length . takeWhile (>0) . flip (scanl (-)) (snd (mapAccumL (\f e -> (f*e,f*e*e)) 1 [1..]))) n

data Tree = Leaf | Node {-# UNPACK #-} !Int {-# UNPACK #-} !Int Tree Tree deriving Show

size Leaf = 0
size (Node _ _ l r) = 1 + size l + size r

correct Leaf = True
correct (Node _ s l r) = size l == s && correct l && correct r

mk b e
  | b > e = Leaf
  | otherwise = Node m (m - b) (mk b (m - 1)) (mk (m + 1) e)
  where
    m = (b + e) `div` 2

pop i Leaf = (i,Leaf)
pop i (Node j s l r) = case compare i s of
  LT -> fmap (\l' -> Node j (s-1) l' r) (pop i l)
  EQ -> (j, merge l r)
  GT -> fmap (\r' -> Node j s l r') (pop (i-s-1) r)
  where
    merge Leaf Leaf = Leaf
    merge l Leaf = l
    merge Leaf r = r
    merge (Node y ys yl yr) r = Node key s' l' r
      where
        (key,s',l') = maxView y ys yl yr
    maxView y s l Leaf = (y, s, l)
    maxView y s l (Node x xs xl xr) =
        case maxView x xs xl xr of
            (ny,s',nr) -> (ny, s+s'+1, Node y s l nr)
            

permute :: Int -> Int -> [Int]
permute ln n = [0..ln-prml-1] ++ map ((ln-prml)+) (evalState (traverse (state . pop) prms) (mk 0 (prml-1)))
  where
    prms = toFact n
    prml = factLen n