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 qualified Data.List.Match as Match
import Data.Maybe.HT (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
cycleRightAction :: (Eq i) => i -> Cycle i -> i
x `cycleRightAction` c = cycleAction c x
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)
(*>) :: (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)
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 Match.take lenlist xs
takeUntilRepetitionSlow :: Eq a => [a] -> [a]
takeUntilRepetitionSlow xs =
let accs = scanl (flip (:)) [] xs
lenlist = takeWhile not (zipWith elem xs accs)
in Match.take lenlist xs
choose :: Set a -> Maybe a
choose set =
toMaybe (not (Set.null set)) (Set.findMin set)
keepEssentials :: T i -> T i
keepEssentials = filter isEssential
isEssential :: Cycle i -> Bool
isEssential = not . null . drop 1
inverse :: T i -> T i
inverse = map reverse