-- | This module provides functions for scheduling 1-, 2-, 3-, and
-- 4-qubit operations in a way that maximizes parallelism.

module Scheduler where

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

-- ----------------------------------------------------------------------
-- * Auxiliary functions

-- | Split a list into even and odd-indexed elements. For example:
-- 'split_by_parity' [a,b,c,d,e] = ([a,c,e], [b,d]).
split_by_parity :: [a] -> ([a],[a])
split_by_parity [] = ([],[])
split_by_parity [a] = ([a],[])
split_by_parity (a:b:xs) = (a:as, b:bs)
  where
    (as, bs) = split_by_parity xs

-- | The inverse of 'split_by_parity'.
merge_by_parity :: ([a],[a]) -> [a]
merge_by_parity ([],[]) = []
merge_by_parity ([a],[]) = [a]
merge_by_parity (a:as, b:bs) = a : b : merge_by_parity (as, bs)
merge_by_parity (_,_) = error "merge_by_parity"

-- | Cyclically shift the list to the left by /n/ places. For example,
-- 'cyclic_shift' 3 [a,b,c,d,e,f,g,h] = [d,e,f,g,h,a,b,c]
cyclic_shift :: Int -> [a] -> [a]
cyclic_shift n xs = bs ++ as
  where
    (as, bs) = splitAt n xs

-- | Check if /n/ is prime. Since /n/ is the number of orbitals, it
-- will typically be a fairly small number (such as 120), so we do not
-- bother implementing a fancy prime testing algorithm. We just do
-- trial division.
is_prime :: Integer -> Bool
is_prime n
  | n < 0 = is_prime (-n)
  | n <= 1 = False
is_prime n = and [n `mod` x /= 0 | x <- divisors]
  where
    divisors = takeWhile (\x -> x^2 <= n) [2..]

-- | Return all n-choose-2 unordered pairs that can be chosen from an
-- n-element list.
choose_two :: [a] -> [(a,a)]
choose_two [] = []
choose_two [x] = []
choose_two (h:t) = [(h,x) | x <- t] ++ choose_two t

-- ----------------------------------------------------------------------
-- * Modular arithmetic

-- | The extended Euclidean algorithm. Given /x/ and /y/, return (/d/,
-- /a/, /b/) such that /d/ = gcd(/x/, /y/), and /ax/ + /by/ = /d/.
extended_euclid :: Integer -> Integer -> (Integer, Integer, Integer)
extended_euclid x y
  | x < 0 = let (d,a,b) = extended_euclid (-x) y in (d,-a,b)
  | y < 0 = let (d,a,b) = extended_euclid x (-y) in (d,a,-b)
  | y < x = let (d,a,b) = extended_euclid y x in (d,b,a)
  | x == 0 = (y,0,1)
  | otherwise = (d,b-a*q,a)
  where
    (q, r) = divMod y x           -- qx + r = y   <=>   r = y - qx
    (d,a,b) = extended_euclid r x -- ar + bx = d
    -- Therefore: a(y-qx) + bx = d
    --            (b-aq)x + ay = d

-- | Compute the inverse of /x/ modulo /p/, or 'Nothing' if the
-- inverse does not exist.
invMod :: Integer -> Integer -> Maybe Integer
invMod x p
  | d == 1 = Just (a `mod` p)
  | otherwise = Nothing
  where
    (d,a,b) = extended_euclid x p

-- | Compute the modular exponentiation a^n (mod p).
powerMod :: Integer -> Integer -> Integer -> Integer
powerMod p a n
  | n <= 0 = 1
  | even n = (b * b) `mod` p
  | otherwise = (a * b * b) `mod` p
  where
    b = powerMod p a (n `div` 2)

-- | Check if /a/ is a square in ℤₚ. Here, /p/ must be a prime > 2.
is_quadratic_residue :: Integer -> Integer -> Bool
is_quadratic_residue p a
  | a == 0 = True
  | otherwise = powerMod p a ((p-1) `div` 2) == 1

-- ----------------------------------------------------------------------
-- * Möbius transformations

-- | A datatype for Möbius transformations. Specifically, 'Mobius'
-- (a,b,c,d) p represents the transformation
--
-- >     az + b
-- > z ↦ ──────
-- >     cz + d,
-- 
-- where the arithmetic is taken modulo /p/.

data Mobius = Mobius {
  mobius_matrix :: (Integer, Integer, Integer, Integer), -- ^ (a,b,c,d).
  mobius_modulus :: Integer                              -- ^ p.
  }
  deriving (Show, Eq, Ord)

-- | Apply a Möbius transformation to z. Return 'Nothing' in case the
-- denominator is 0, or sometimes when /p/ wasn't actually prime.
mobius :: Mobius -> Maybe Integer -> Maybe Integer
mobius mob (Just z) = case invMod denominator p of
  Nothing -> Nothing
  Just invden -> Just ((numerator * invden) `mod` p)
  where
    numerator = (a*z + b) `mod` p
    denominator = (c*z + d) `mod` p
    (a,b,c,d) = mobius_matrix mob
    p = mobius_modulus mob
mobius mob Nothing = case invMod denominator p of
  Nothing -> Nothing
  Just invden -> Just ((numerator * invden) `mod` p)
  where
    numerator = a
    denominator = c
    (a,b,c,d) = mobius_matrix mob
    p = mobius_modulus mob

-- | Compose two Möbius transformations.
mobius_compose :: Mobius -> Mobius -> Mobius
mobius_compose mob1 mob2
  | p /= p' = error "modius_compose: incompatible moduli"
  | otherwise = mob
  where
    p = mobius_modulus mob1
    p' = mobius_modulus mob2
    (a,b,c,d) = mobius_matrix mob2
    (a',b',c',d') = mobius_matrix mob1

    -- [a' b'] [a b]     [a'*a+b'*c  a'*b+b'*d]
    -- [c' d'] [c d]  =  [c'*a+d'*c  c'*b+d'*d]

    a'' = (a'*a+b'*c) `mod` p
    b'' = (a'*b+b'*d) `mod` p
    c'' = (c'*a+d'*c) `mod` p
    d'' = (c'*b+d'*d) `mod` p

    mob = Mobius (a'',b'',c'',d'') p

-- | Invert a Möbius transformation.
mobius_inverse :: Mobius -> Mobius
mobius_inverse mob = mob'
  where
    (a,b,c,d) = mobius_matrix mob
    p = mobius_modulus mob
    det = a*d - b*c
    detinv = case invMod det p of
      Just detinv -> detinv
      Nothing -> error "mobius_inverse: not invertible"
    a' = (d * detinv) `mod` p
    b' = (-b * detinv) `mod` p
    c' = (-c * detinv) `mod` p
    d' = (a * detinv) `mod` p
    mob' = Mobius (a',b',c',d') p

-- | Return the determinant of a Möbius transformation.
mobius_determinant :: Mobius -> Integer
mobius_determinant mob = (a*d - b*c) `mod` p
  where
    (a,b,c,d) = mobius_matrix mob
    p = mobius_modulus mob

-- | Return the unique Möbius transformation mapping (0,1,∞) to the
-- points (0,b,∞), which must be distinct.
mobius_triple1 :: Integer -> Integer -> Mobius
mobius_triple1 p b = Mobius (b,0,0,1) p

-- | Return a Möbius transformation mapping (0,1,∞) to (a,*,∞), where
-- a ≠ ∞ and '*' is arbitrary.
mobius_triple2 :: Integer -> Integer -> Mobius
mobius_triple2 p a = Mobius (1,a,0,1) p

-- | Return the unique Möbius transformation mapping (0,1,∞) to the
-- points (a,b,∞), which must be distinct.
mobius_triple3 :: Integer -> Integer -> Integer -> Mobius
mobius_triple3 p a b = mob
  where
    mob1 = mobius_triple2 p a
    b' = case mobius_inverse mob1 `mobius` Just b of
      Just b' -> b'
      Nothing -> error "mobius_triple3"
    mob2 = mobius_triple1 p b'
    mob = mob1 `mobius_compose` mob2

-- | Return a Möbius transformation mapping (0,1,∞) to (*,*,c), where
-- '*' is arbitrary.
mobius_triple4 :: Integer -> Maybe Integer -> Mobius
mobius_triple4 p (Just c) = Mobius (c,1,1,0) p
mobius_triple4 p Nothing = Mobius (1,0,0,1) p

-- | Return a Möbius transformation mapping (0,1,∞) to (a,*,c), where
-- a,c are distinct and '*' is arbitrary.
mobius_triple5 :: Integer -> Maybe Integer -> Maybe Integer -> Mobius
mobius_triple5 p a c = mob
  where
    mob1 = mobius_triple4 p c
    a' = case mobius_inverse mob1 `mobius` a of
      Just a' -> a'
      Nothing -> error "mobius_triple5"
    mob2 = mobius_triple2 p a'
    mob = mob1 `mobius_compose` mob2
    
-- | Return the unique Möbius transformation mapping (0,1,∞) to the
-- points (a,b,c), which must be distinct.
mobius_triple :: Integer -> Maybe Integer -> Maybe Integer -> Maybe Integer -> Mobius
mobius_triple p a b c = mob
  where
    mob1 = mobius_triple5 p a c
    b' = case mobius_inverse mob1 `mobius` b of
      Just b' -> b'
      Nothing -> error "mobius_triple"
    mob2 = mobius_triple1 p b'
    mob = mob1 `mobius_compose` mob2

-- | Return the unique Möbius transformation mapping (a,b,c) to
-- (a',b',c'), where a,b,c are distinct and a',b',c' are distinct.
mobius_triples :: Integer -> Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe Integer -> Mobius
mobius_triples p a b c a' b' c' = mob
  where
    mob1 = mobius_triple p a b c
    mob2 = mobius_triple p a' b' c'
    mob = mob2 `mobius_compose` mobius_inverse mob1

-- | Return the unique self-inverse Möbius transformation that maps /a/ to /b/ and /c/ to /d/.
mobius_of_pair_of_pairs :: Integer -> Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe Integer -> Mobius
mobius_of_pair_of_pairs p a b c d = mobius_triples p a b c b a d

-- | Return the unique Möbius transformation that has /x/ and /y/ as
-- fixed points and is an involution.
mobius_of_fixedpoints p x y = mob2 `mobius_compose` mob1 `mobius_compose` mobius_inverse mob2
  where
    mob1 = Mobius (1,0,0,-1) p
    mob2 = mobius_triple5 p x y

-- | Normalize a Möbius transformation: if the determinant is a
-- quadratic residue, change it to determinant 1.
mobius_normalize_determinant :: Mobius -> Mobius
mobius_normalize_determinant mob
  | is_quadratic_residue p det = mob'
  | otherwise = mob
  where
    det = mobius_determinant mob
    p = mobius_modulus mob
    x = head [x | x <- [1..p-1], powerMod p x 2 == det]
    xinv = case invMod x p of
      Just xinv -> xinv
      Nothing -> error "mobius_normalize_determinant"
    (a,b,c,d) = mobius_matrix mob
    a' = (a * xinv) `mod` p
    b' = (b * xinv) `mod` p
    c' = (c * xinv) `mod` p
    d' = (d * xinv) `mod` p
    mob' = Mobius (a',b',c',d') p
    
-- ----------------------------------------------------------------------
-- * Skilift algorithms

-- | A /seat/ on the skilift is either a singleton, pair, triple, or
-- quad.
data Seat a =
  Noop a
  | Singleton a
  | Pair a a
  | Triple a a a
  | Quad a a a a
  deriving (Show, Eq, Ord)

-- | Return the list of occupants of a seat.
occupants :: Seat a -> [a]
occupants (Noop x) = [x]
occupants (Singleton x) = [x]
occupants (Pair x y) = [x, y]
occupants (Triple x y z) = [x, y, z]
occupants (Quad x y z w) = [x, y, z, w]

-- | Convert a seat into a list of noops with the same occupants.
noops_from_seat :: Seat a -> [Seat a]
noops_from_seat t = [Noop x | x <- occupants t]

-- | A /stage/ is a list of seats. This amounts to a permutation of
-- [0,...,m-1], together with an indication of which pairs, triples,
-- and quads should be "active" in the stage.
type Stage a = [Seat a]

-- | Return the ordered list of occupants in the stage. This amounts
-- to a permutation.
perm_of_stage :: Stage a -> [a]
perm_of_stage s = concat [occupants seat | seat <- s]

-- ----------------------------------------------------------------------
-- ** Singleton stage

-- | The scheduler for singletons is very easy. Just do all singletons
-- in a single stage!
schedule_singletons :: Integer -> [Stage Integer]
schedule_singletons m = [[Singleton x | x <- [0..m-1]]]

-- ----------------------------------------------------------------------
-- ** Pair stages

-- | A basic skilift of pairs.
schedule_pairs :: Integer -> [Stage Integer]
schedule_pairs m = stages
  where
    m'
      | even m = m - 1  -- If m is even, rotate only m-1 passengers.
      | otherwise = m
    passengers = [0..m'-1]
    rotations = [skilift_rotate n passengers | n <- [0..m'-1]]
    -- Re-add the stationary passenger, if necessary.
    rotations'
      | even m = [r ++ [m-1] | r <- rotations]
      | otherwise = rotations
    stages = [stage_of_rotation r | r <- rotations']
    stage_of_rotation [] = []
    stage_of_rotation [a] = [Noop a]
    stage_of_rotation (a:b:xs) = Pair a b : stage_of_rotation xs

-- | Take a list, such as [0,1,2,3,4], and permute the elements
-- according to the ski lift rule, namely, output [0,2,4,3,1].
rotation_in :: [a] -> [a]
rotation_in xs = as ++ reverse bs
  where
    (as,bs) = split_by_parity xs

-- | Inverse of 'rotation_in'.
rotation_out :: [a] -> [a]
rotation_out xs = merge_by_parity (as, bs)
  where
    len = length xs
    half = (len + 1) `div` 2
    (as, bs') = splitAt half xs
    bs = reverse bs'

-- | Move the skilift by 'n' positions.
skilift_rotate :: Integer -> [a] -> [a]
skilift_rotate n xs = xs'
  where
    n' = fromInteger n
    as = rotation_in xs
    as' = cyclic_shift n' as
    xs' = rotation_out as'

-- ----------------------------------------------------------------------
-- ** Triple stages

-- $ We handle triples slightly differently: without a ski lift. This
-- leads to greater permutation depths between stages, but is probably
-- fine until we come up with a better method.

-- | Schedule triples from [0..p]. Here /p/ must be prime.
schedule_triples_prime :: Integer -> [Stage Integer]
schedule_triples_prime p
  | p == 3 = [[Triple 0 1 2, Noop 3], [Triple 0 1 3, Noop 2], [Triple 0 2 3, Noop 1], [Triple 1 2 3, Noop 0]]
  | p `mod` 3 == 2 = stage0s
  | otherwise = stage0s ++ stage1s
  where
    t0s = [(Just x,Just y,Nothing) | x <- [0..p-1], y <- [x+1..p-1]]
    stage_of_mob mob = [Triple x y z | (x,y,z) <- triples] ++ [Noop x | x <- noops]
      where
        rawtriples = [(x,y,z) | x <- Nothing : map Just [0..p-1], let y = mobius mob x, let z = mobius mob y]
        triples = [(x',y',z') | (x,y,z) <- rawtriples, let (x',y',z') = (f x, f y, f z), x' < y' && x' < z']
        noops = [f x | (x,y,z) <- rawtriples, x == y]
    -- | Return the unique stage such that (a,b,c) is in it.
    stage_of_triple (a,b,c) = stage_of_mob mob
      where
        mob = mobius_triples p a b c b c a
    f (Just x) = x
    f Nothing = p
    stage0s = [stage_of_triple t0 | t0 <- t0s]
    stage1s = [stage_of_x x | x <- [0..p-1]]
    -- /r/ is a non-trivial 3rd root of unity, which exists iff p ≡ 1 (mod 3).
    r = head [y | x <- [2..p-1], let y = x^((p-1)`div`3) `mod` p, y /= 1]
    -- | Return one of the stages that has ∞ as a noop.
    stage_of_x x = stage_of_mob mob
      where
        mob = Mobius (r, x, 0, 1) p

-- | Schedule triples from [0..m-1].
schedule_triples :: Integer -> [Stage Integer]
schedule_triples m = reduce_stages m stages
  where
    p = head [p | p <- [m-1..], is_prime p]
    stages = schedule_triples_prime p

-- ----------------------------------------------------------------------
-- ** Quad stages

-- | Given a positive prime /p/ ≡ 3 (mod 4), return a list of
-- pairings, where each pairing is a partition of [0..p] into
-- pairs. These pairings are such that every quad appears in at least
-- one pairing as the union of two of its pairs.
pairings_prime3 :: Integer -> [[(Integer,Integer)]]
pairings_prime3 p = [pairs_of_mob mob | mob <- mobs]
  where
    -- When p ≡ 3 (mod 4), the ones whose determinant is a quadratic
    -- residue never have any fixed points.
    mobs1 = [mobius_of_pair_of_pairs p Nothing (Just 0) (Just 1) (Just x) | x <- [2..p-1]]
    mobs2 = [mobius_of_pair_of_pairs p Nothing (Just x) (Just 0) (Just y) | x <- [1..p-1], y <- [1..p-1], x /= y]
    mobs = [mob | mob <- mobs1 ++ mobs2, let d = mobius_determinant mob, is_quadratic_residue p d]
    pairs_of_mob mob = [(x',y') | x <- map Just [0..p-1], let y = mobius mob x, let (x',y') = (f x, f y), x' < y']
    f (Just x) = x
    f Nothing = p

-- | Given a positive prime /p/ ≡ 1 (mod 4), return a list of
-- pairings, where each pairing is a partition of [0..p] into
-- pairs. These pairings are such that every quad appears in at least
-- one pairing as the union of two of its pairs.
pairings_prime1 :: Integer -> [[(Integer,Integer)]]
pairings_prime1 p = [pairs_of_mob mob | mob <- mobs]
  where
    mobs = [mobius_of_fixedpoints p x y | (x,y) <- choose_two $ map Just [0..p-1] ++ [Nothing]]
    pairs_of_mob mob = [(x',y') | x <- map Just [0..p-1], let y = mobius mob x, let (x',y') = (f x, f y), x' < y']
    f (Just x) = x
    f Nothing = p

-- | Given a positive prime /p/, return a list of pairings, where each
-- pairing is a partition of [0..p] into pairs. These pairings are
-- such that every quad appears in at least one pairing as the union
-- of two of its pairs.
pairings_prime :: Integer -> [[(Integer,Integer)]]
pairings_prime p
  | p == 2 = []
  | p `mod` 4 == 1 = pairings_prime1 p
  | p `mod` 4 == 3 = pairings_prime3 p
  | otherwise = error "pairings_prime: not a positive prime"
  
-- | For debugging.
pairings_prime_debug :: Integer -> [([(Integer, Integer)], Mobius, Integer)]
pairings_prime_debug p = [(pairs_of_mob mob, mob, mobius_determinant mob) | mob <- mobs']
  where
    mobs1 = [mobius_of_pair_of_pairs p Nothing (Just 0) (Just 1) (Just x) | x <- [2..p-1]]
    mobs2 = [mobius_of_pair_of_pairs p Nothing (Just x) (Just 0) (Just y) | x <- [1..p-1], y <- [1..p-1], x /= y]
    mobs = [mob | mob <- mobs1 ++ mobs2, let d = mobius_determinant mob, is_quadratic_residue p d]
    pairs_of_mob mob = [(x',y') | x <- map Just [0..p-1], let y = mobius mob x, let (x',y') = (f x, f y), x' < y']
    f (Just x) = x
    f Nothing = p
    mobs' = map mobius_normalize_determinant mobs

-- | Return a list of pairings, where each pairing is a partial
-- partitition of [0..m-1] into pairs (possibly with some noops
-- added).
pairings :: Integer -> [[(Integer, Integer)]]
pairings m = pairings3
  where
    p = head [p | p <- [m-1..], is_prime p]
    pairings1 = pairings_prime p
    pairings2 = [cull pairing | pairing <- pairings1]
    cull pairing = [(x,y) | (x,y) <- pairing, x < m, y < m]
    pairings3 = [pairing | pairing <- pairings2, pairing /= []]

-- | Take a pairing and return a list of stages of quads. Do not yet
-- worry about duplicate quads or triples.
stages_of_pairing_new :: Integer -> [(Integer, Integer)] -> [Stage Integer]
stages_of_pairing_new m pairs = stages
  where
    -- Divide the pairs into seats. How exactly this is done depends
    -- on whether we have an even or odd number of pairs. The schema is:
    --
    -- seat_pairs [(1,2),(3,4),(5,6)] = ([1,3,2,4,5,6],[])
    -- seat_pairs [(1,2),(3,4),(5,6),(7,8)] = ([1,3,2,4,5,6],[7,8])
    --
    -- In other words, if there is an odd number of pairs, all of them
    -- go on the ski lift, but if there is an even number of pairs,
    -- one pair is stationary.
    seat_pairs :: [(Integer, Integer)] -> ([Integer],[Integer])
    seat_pairs [] = error "seat_pairs: should not happen"
    seat_pairs [(x,y)] = ([x,y],[])
    seat_pairs [(x,y),(z,w)] = ([x,y],[z,w])
    seat_pairs ((x,y):(z,w):ps) = (x:z:y:w:ps1,ps2)
      where
        (ps1,ps2) = seat_pairs ps
    (perm0, rest) = seat_pairs pairs
    non_participants = [x | x <- [0..m-1], not (x `elem` (perm0 ++ rest))]
    len = fromIntegral (length perm0)
    perms = [skilift_rotate n perm0 | n <- [0,2..len-1]]
    perms' = [p ++ rest | p <- perms]
    stage_of_perm :: [Integer] -> [Seat Integer]
    stage_of_perm [] = []
    stage_of_perm [x,y] = [Noop x, Noop y]
    stage_of_perm (x:y:z:w:xs) = Quad x y z w : stage_of_perm xs
    stage_of_perm _ = error "stage_of_perm: this should not happen"
    stages = [stage_of_perm p ++ map Noop non_participants | p <- perms']

-- | This scheduler produces all possible quads from [0..m-1].
schedule_quads :: Integer -> [Stage Integer]
schedule_quads m = reduce_stages m stages'
  where
    stages = concat [stages_of_pairing_new m p | p <- pairings m]
    stages' = remove_duplicates stages

-- ----------------------------------------------------------------------
-- ** Schedule for triples and quads (old)

-- | Input a prime /p/ ≡ 3 (mod 4) and two parameters /a/ ∈ ℤₚ and /b/
-- ∈ ℤₚ*, and output a list of pairs and one singleton from [0,...,p-1].
andre_pairing :: Integer -> Integer -> Integer -> ([(Integer, Integer)], Integer)
andre_pairing p a b = case invMod b p of
  Nothing -> error "andre_pairing: b must be invertible mod p"
  Just binv -> case matchings of
    (as, [b], []) -> (as, b)
    _ -> error "andre_pairing: this should not happen"
    where
      c = (-(1+a^2)*binv) `mod` p
      mob = Mobius (a,b,c,-a) p
      f x = mobius mob (Just x)
      matchings = foldr combine unit [ process z | z <- [0..p-1]]
      process z = case f z of
        Nothing -> ([], [z], [])
        Just w
          | w == z -> ([], [], [z])
          | w < z -> ([], [], [])
          | otherwise -> ([(z,w)], [], [])
      unit = ([], [], [])
      combine (as, bs, cs) (as', bs', cs') = (as++as', bs++bs', cs++cs')

-- | This skilift produces all possible triples and quads. It assumes
-- that /p/ is prime and /p/ ≡ 3 (mod 4). The more general case is
-- handled later.
schedule_triples_and_quads_prime :: Integer -> [Stage Integer]
schedule_triples_and_quads_prime p = remove_duplicates stages
  where
    pairings = [andre_pairing p a b | (a,b) <- parameters]
    stages = concat [stages_of_pairing x | x <- pairings]

    -- | The list of parameters for relevant Möbius transformations.
    -- The point is that (a,b) and (-a,-b) are equivalent, so we only
    -- pick one of each.
    parameters = do
      a <- [0..(p-1) `div` 2]
      b <- if a == 0 then [1..(p-1) `div` 2] else [1..p-1]
      return (a,b)

-- | Take a pairing a la Andre, with the last integer \"paired with
-- the dud\", and return a bunch of stages with quads and triples. Do
-- not yet worry about duplicate quads or triples.
stages_of_pairing :: ([(Integer, Integer)], Integer) -> [Stage Integer]
stages_of_pairing (pairs, last) = stages
  where
    seat_pairs :: [(Integer, Integer)] -> [Integer]
    seat_pairs [] = error "seat_pairs: should not happen"
    seat_pairs [(x,y)] = [x,y]
    seat_pairs ((x,y):(z,w):ps) = x:z:y:w:seat_pairs ps
    perm0 = seat_pairs pairs
    len = fromIntegral (length perm0)
    perms = [skilift_rotate n perm0 | n <- [0,2..len-1]]
    perms' = [p ++ [last] | p <- perms]
    stage_of_perm :: [Integer] -> [Seat Integer]
    stage_of_perm [x,y,z] = [Triple x y z]
    stage_of_perm (x:y:z:w:xs) = Quad x y z w : stage_of_perm xs
    stage_of_perm _ = error "stage_of_perm: this should not happen"
    stages = [stage_of_perm p | p <- perms']

-- | Remove duplicate quads, triples, and pairs from a list of stages.
remove_duplicates :: [Stage Integer] -> [Stage Integer]
remove_duplicates xs = aux xs Set.empty
  where
    aux [] seen = []
    aux (stage:xs) seen = stage' : aux xs seen'
      where
        (stage',seen') = aux2 stage seen

    aux2 [] seen = ([], seen)
    aux2 (x:xs) seen
      | Set.member y seen = (noops_from_seat x ++ xs', seen'')
      | otherwise = (x:xs', seen'')
      where
        y = standardize x
        seen' = Set.insert y seen
        (xs',seen'') = aux2 xs seen'

    standardize x = sort (occupants x)

-- | Produce all possible triples and quads. This version works even
-- when /m/ is not prime or not congruent to 3 mod 4. This is the
-- naive implementation which is not very optimal: we simply make a
-- schedule for the next largest appropriate prime and throw away the
-- excess indices.
schedule_triples_and_quads :: Integer -> [Stage Integer]
schedule_triples_and_quads m = reduce_stages m stages
  where
    p = head [p | p <- [m..], p `mod` 4 == 3, is_prime p]
    stages = schedule_triples_and_quads_prime p    

-- | Remove non-participants from a list of stages. Drop empty stages
-- altogether.
reduce_stages :: Integer -> [Stage Integer] -> [Stage Integer]
reduce_stages m stages = drop_noop_stages [reduce_stage m s | s <- stages]

-- | Remove non-participants from a stage.
reduce_stage :: Integer -> Stage Integer -> Stage Integer
reduce_stage m stage = drop_impostors (fix_stage stage)
  where
    fix_stage s = concat [fix_seat x | x <- s]
    -- | Replace every operation involving invalid indices by no-ops.
    fix_seat x
      | and [o < m | o <- occupants x] = [x]
      | otherwise = noops_from_seat x
    -- | Drop all no-ops involving invalid indices.
    drop_impostors s = [x | x <- s, and [o < m | o <- occupants x]]

-- | Drop all stages that consist only of noops.
drop_noop_stages :: [Stage Integer] -> [Stage Integer]
drop_noop_stages stages = [s | s <- stages, not (and [is_noop x | x <- s])]
  where
    is_noop (Noop x) = True
    is_noop _ = False

-- | A scheduler inputs 'm', and outputs a list of stages for
-- [0,...,m-1], so that each singleton, pair, triple, and quad appears
-- exactly once.
scheduler :: Integer -> [Stage Integer]
scheduler m = schedule_singletons m ++ schedule_pairs m ++ schedule_triples m ++ schedule_quads m

-- ----------------------------------------------------------------------
-- * Low-depth permutations

-- | A datatype to represent an elementary swap operation or the
-- absence thereof. 'Swap' operates on two elements and 'Id' operates
-- on one. For example, [Swap,Id,Swap] represents the permutation
-- [1,2,3,4,5] ↦ [2,1,3,5,4].
data SwapOp = Swap | Id
  deriving (Show, Eq, Ord)

-- | Given a pair of lists that are a permutation of each other,
-- output a sequence of swapping stages that implement the
-- permutation.  Each swapping stage consists of a number of pairwise
-- swap operations that can be done in parallel. We are trying to
-- minimize (as much as possible) the number of such parallel stages.
--
-- Example:
--
-- a = [1,2,3,4,5]
-- b = [2,4,1,5,3]
--
-- >    1 2 3 4 5
-- >     X   X  |
-- >    2 1 4 3 5
-- >    |  X   X
-- >    2 4 1 5 3
--
-- Therefore, parallel_swaps [1,2,3,4,5] [2,4,1,5,3] = [[Swap,Swap,Id],[Id,Swap,Swap]]
--
-- This implementation uses a greedy algorithm. We do not know whether
-- it is optimal (in terms of returning the smallest number of
-- parallel stages).
parallel_swaps :: (Ord a) => [a] -> [a] -> [[SwapOp]]
parallel_swaps xs ys = aux xs
  where
    ytable = Map.fromList [(y,i) | (y,i) <- zip ys [0..]]
    should_swap a b = ytable Map.! a > ytable Map.! b

    aux xs
      | xs == ys = []
      | otherwise = stage:rest
      where
        (stage, xs') = next_stage xs
        rest = aux xs'

    next_stage [] = ([],[])
    next_stage [a] = ([Id], [a])
    next_stage (a:b:xs)
      | should_swap a b = (Swap:rest, b:a:xs')
      where
        (rest, xs') = next_stage xs
    next_stage (a:xs)
      | otherwise = (Id:rest, a:xs')
      where
        (rest, xs') = next_stage xs
