{-# OPTIONS -fno-implicit-prelude #-}
{- |
Copyright    :   (c) Mikael Johansson 2006
Maintainer   :   mik@math.uni-jena.de
Stability    :   provisional
Portability  :   requires multi-parameter type classes

Permutation of Integers represented by cycles.
-}

module MathObj.Permutation.CycleList where

import Data.Set(Set)
import qualified Data.Set as Set

import Data.List (unfoldr)
import Data.Array(Ix)
import qualified Data.Array as Array

import NumericPrelude.List (takeMatch)
import NumericPrelude.Condition (toMaybe)
import NumericPrelude (fromInteger)
import PreludeBase


type Cycle i = [i]
type T i = [Cycle i]



fromFunction :: (Ix i) =>
   (i, i) -> (i -> i) -> T i
fromFunction rng f =
   let extractCycle available =
          do el <- choose available
             let orb = orbit f el
             return (orb, Set.difference available (Set.fromList orb))
       cycles = unfoldr extractCycle (Set.fromList (Array.range rng))
   in  keepEssentials cycles



-- right action of a cycle
cycleRightAction :: (Eq i) => i -> Cycle i -> i
x `cycleRightAction` c = cycleAction c x

-- left action of a cycle
cycleLeftAction :: (Eq i) => Cycle i -> i -> i
c `cycleLeftAction` x = cycleAction (reverse c) x

cycleAction :: (Eq i) => [i] -> i -> i
cycleAction cyc x =
   case dropWhile (x/=) (cyc ++ [head cyc]) of
      _:y:_ -> y
      _ -> x


cycleOrbit :: (Ord i) => Cycle i -> i -> [i]
cycleOrbit cyc = orbit (flip cycleRightAction cyc)

{- |
Right (left?) group action on the Integers.
Close to, but not the same as the module action in Algebra.Module.
-}
(*>) :: (Eq i) => T i -> i -> i
p *> x = foldr (flip cycleRightAction) x p

cyclesOrbit ::(Ord i) => T i -> i -> [i]
cyclesOrbit p = orbit (p *>)

orbit :: (Ord i) => (i -> i) -> i -> [i]
orbit op x0 = takeUntilRepetition (iterate op x0)

-- | candidates for NumericPrelude.List ?
takeUntilRepetition :: Ord a => [a] -> [a]
takeUntilRepetition xs =
   let accs = scanl (flip Set.insert) Set.empty xs
       lenlist = takeWhile not (zipWith Set.member xs accs)
   in  takeMatch lenlist xs

takeUntilRepetitionSlow :: Eq a => [a] -> [a]
takeUntilRepetitionSlow xs =
   let accs = scanl (flip (:)) [] xs
       lenlist = takeWhile not (zipWith elem xs accs)
   in  takeMatch lenlist xs


{-
Alternative to Data.Set.minView in GHC-6.6.
-}
choose :: Set a -> Maybe a
choose set =
   toMaybe (not (Set.null set)) (Set.findMin set)

keepEssentials :: T i -> T i
keepEssentials = filter isEssential

-- is more lazy than (length cyc > 1)
isEssential :: Cycle i -> Bool
isEssential = not . null . drop 1

inverse :: T i -> T i
inverse = map reverse