NextLexPerm.hs

{-# LANGUAGE GADTs, ScopedTypeVariables, RankNTypes #-}

import Data.List (unfoldr)

nextLexPerm :: Ord a => [a] -> Maybe [a]
nextLexPerm (x:y:xs) 
  | Just ys <- nextLexPerm (y:xs) = Just (x:ys)
  | x < y = Just (go x y xs [])
  where
    go i j (k:xs) ys | i < k = go i k xs (j:ys)
    go i j xs ys = j : reverse xs ++ i : ys
nextLexPerm _ = Nothing

iterMay :: (a -> Maybe a) -> a -> [a]
iterMay f = unfoldr (fmap ((,) <*> f)) . Just

permsFrom :: Ord a => [a] -> [[a]]
permsFrom = iterMay nextLexPerm

data Sum a b c d e where
  Inl :: a -> Sum a b c d c
  Inr :: b -> Sum a b c d d
  
type PC a = forall x. Sum (Maybe a) ([a], Maybe (a,a)) (Maybe [a]) [a] x -> x 

newtype PermCont a = PC { rpc :: PC a }

nextLexPerm' :: forall a. Ord a => [a] -> Maybe [a]
nextLexPerm' xs = rpc (foldr (\x xs -> PC (f x (rpc xs))) (PC b) xs) (Inl Nothing)
  where
    
    b :: PC a
    b (Inl _)  = Nothing
    b (Inr (ys,Nothing)) = ys
    b (Inr (ys,Just (i,j))) = j : i : ys

    f :: a -> PC a -> PC a
    f x xs (Inl Nothing) = xs (Inl (Just x))
    f y xs (Inl (Just x))
      | Just ys <- xs (Inl (Just y)) = Just (x:ys)
      | x < y = Just (xs (Inr ([], Just (x,y))))
      | otherwise = Nothing
    f k xs (Inr (ys, Just (i,j)))
      | i < k = xs (Inr (j:ys, Just (i,k)))
      | otherwise = j : xs (Inr (k:i:ys,Nothing))
    f k xs (Inr (ys,Nothing)) = xs (Inr (k:ys, Nothing))