{-# LANGUAGE RebindableSyntax #-}
{- |
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 qualified Data.List.Match as Match
import Data.Maybe.HT (toMaybe)
import NumericPrelude.Numeric (fromInteger)
import NumericPrelude.Base


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



fromFunction :: (Ix i) =>
   (i, i) -> (i -> i) -> T i
fromFunction :: (i, i) -> (i -> i) -> T i
fromFunction (i, i)
rng i -> i
f =
   let extractCycle :: Set i -> Maybe ([i], Set i)
extractCycle Set i
available =
          do i
el <- Set i -> Maybe i
forall a. Set a -> Maybe a
choose Set i
available
             let orb :: [i]
orb = (i -> i) -> i -> [i]
forall i. Ord i => (i -> i) -> i -> [i]
orbit i -> i
f i
el
             ([i], Set i) -> Maybe ([i], Set i)
forall (m :: * -> *) a. Monad m => a -> m a
return ([i]
orb, Set i -> Set i -> Set i
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set i
available ([i] -> Set i
forall a. Ord a => [a] -> Set a
Set.fromList [i]
orb))
       cycles :: T i
cycles = (Set i -> Maybe ([i], Set i)) -> Set i -> T i
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr Set i -> Maybe ([i], Set i)
extractCycle ([i] -> Set i
forall a. Ord a => [a] -> Set a
Set.fromList ((i, i) -> [i]
forall a. Ix a => (a, a) -> [a]
Array.range (i, i)
rng))
   in  T i -> T i
forall i. T i -> T i
keepEssentials T i
cycles



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

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

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


cycleOrbit :: (Ord i) => Cycle i -> i -> [i]
cycleOrbit :: Cycle i -> i -> Cycle i
cycleOrbit Cycle i
cyc = (i -> i) -> i -> Cycle i
forall i. Ord i => (i -> i) -> i -> [i]
orbit ((i -> Cycle i -> i) -> Cycle i -> i -> i
forall a b c. (a -> b -> c) -> b -> a -> c
flip i -> Cycle i -> i
forall i. Eq i => i -> Cycle i -> i
cycleRightAction Cycle i
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
T i
p *> :: T i -> i -> i
*> i
x = (Cycle i -> i -> i) -> i -> T i -> i
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((i -> Cycle i -> i) -> Cycle i -> i -> i
forall a b c. (a -> b -> c) -> b -> a -> c
flip i -> Cycle i -> i
forall i. Eq i => i -> Cycle i -> i
cycleRightAction) i
x T i
p

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

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

-- | candidates for Utility ?
takeUntilRepetition :: Ord a => [a] -> [a]
takeUntilRepetition :: [a] -> [a]
takeUntilRepetition [a]
xs =
   let accs :: [Set a]
accs = (Set a -> a -> Set a) -> Set a -> [a] -> [Set a]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl ((a -> Set a -> Set a) -> Set a -> a -> Set a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert) Set a
forall a. Set a
Set.empty [a]
xs
       lenlist :: [Bool]
lenlist = (Bool -> Bool) -> [Bool] -> [Bool]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Bool -> Bool
not ((a -> Set a -> Bool) -> [a] -> [Set a] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member [a]
xs [Set a]
accs)
   in  [Bool] -> [a] -> [a]
forall b a. [b] -> [a] -> [a]
Match.take [Bool]
lenlist [a]
xs

takeUntilRepetitionSlow :: Eq a => [a] -> [a]
takeUntilRepetitionSlow :: [a] -> [a]
takeUntilRepetitionSlow [a]
xs =
   let accs :: [[a]]
accs = ([a] -> a -> [a]) -> [a] -> [a] -> [[a]]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl ((a -> [a] -> [a]) -> [a] -> a -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] [a]
xs
       lenlist :: [Bool]
lenlist = (Bool -> Bool) -> [Bool] -> [Bool]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Bool -> Bool
not ((a -> [a] -> Bool) -> [a] -> [[a]] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [a]
xs [[a]]
accs)
   in  [Bool] -> [a] -> [a]
forall b a. [b] -> [a] -> [a]
Match.take [Bool]
lenlist [a]
xs


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

keepEssentials :: T i -> T i
keepEssentials :: T i -> T i
keepEssentials = (Cycle i -> Bool) -> T i -> T i
forall a. (a -> Bool) -> [a] -> [a]
filter Cycle i -> Bool
forall i. Cycle i -> Bool
isEssential

-- is more lazy than (length cyc > 1)
isEssential :: Cycle i -> Bool
isEssential :: Cycle i -> Bool
isEssential = Bool -> Bool
not (Bool -> Bool) -> (Cycle i -> Bool) -> Cycle i -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cycle i -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Cycle i -> Bool) -> (Cycle i -> Cycle i) -> Cycle i -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Cycle i -> Cycle i
forall a. Int -> [a] -> [a]
drop Int
1

inverse :: T i -> T i
inverse :: T i -> T i
inverse = ([i] -> [i]) -> T i -> T i
forall a b. (a -> b) -> [a] -> [b]
map [i] -> [i]
forall a. [a] -> [a]
reverse