-- Copyright (c) 2008, David Amos. All rights reserved.


-- |A module for constructing and working with combinatorial designs.

--

-- Given integers t \< k \< v and lambda > 0, a t-design or t-(v,k,lambda) design is an incidence structure of points X and blocks B,

-- where X is a set of v points, B is a collection of k-subsets of X, with the property that any t points are contained

-- in exactly lambda blocks. If lambda = 1 and t >= 2, then a t-design is also called a Steiner system S(t,k,v).

--

-- Many designs are highly symmetric structures, having large automorphism groups. In particular, the Mathieu groups,

-- which were the first discovered sporadic finite simple groups, turn up as the automorphism groups of the Witt designs.

module Math.Combinatorics.Design where

import Data.Maybe (fromJust, isJust)
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S

import Math.Common.ListSet (intersect, symDiff)
import Math.Core.Utils (combinationsOf)

import Math.Algebra.Field.Base
import Math.Algebra.Field.Extension
import Math.Algebra.Group.PermutationGroup hiding (elts, order, isMember)
import Math.Algebra.Group.SchreierSims as SS
import Math.Combinatorics.Graph as G hiding (to1n, incidenceMatrix)
import Math.Combinatorics.GraphAuts (graphAuts, incidenceAuts) -- , removeGens)

import Math.Combinatorics.FiniteGeometry

-- Cameron & van Lint, Designs, Graphs, Codes and their Links



{-
set xs = map head $ group $ sort xs
-}
isSubset :: t a -> t a -> Bool
isSubset xs :: t a
xs ys :: t a
ys = (a -> Bool) -> t a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
ys) t a
xs


-- DESIGNS


data Design a = D [a] [[a]] deriving (Design a -> Design a -> Bool
(Design a -> Design a -> Bool)
-> (Design a -> Design a -> Bool) -> Eq (Design a)
forall a. Eq a => Design a -> Design a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Design a -> Design a -> Bool
$c/= :: forall a. Eq a => Design a -> Design a -> Bool
== :: Design a -> Design a -> Bool
$c== :: forall a. Eq a => Design a -> Design a -> Bool
Eq,Eq (Design a)
Eq (Design a) =>
(Design a -> Design a -> Ordering)
-> (Design a -> Design a -> Bool)
-> (Design a -> Design a -> Bool)
-> (Design a -> Design a -> Bool)
-> (Design a -> Design a -> Bool)
-> (Design a -> Design a -> Design a)
-> (Design a -> Design a -> Design a)
-> Ord (Design a)
Design a -> Design a -> Bool
Design a -> Design a -> Ordering
Design a -> Design a -> Design a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Design a)
forall a. Ord a => Design a -> Design a -> Bool
forall a. Ord a => Design a -> Design a -> Ordering
forall a. Ord a => Design a -> Design a -> Design a
min :: Design a -> Design a -> Design a
$cmin :: forall a. Ord a => Design a -> Design a -> Design a
max :: Design a -> Design a -> Design a
$cmax :: forall a. Ord a => Design a -> Design a -> Design a
>= :: Design a -> Design a -> Bool
$c>= :: forall a. Ord a => Design a -> Design a -> Bool
> :: Design a -> Design a -> Bool
$c> :: forall a. Ord a => Design a -> Design a -> Bool
<= :: Design a -> Design a -> Bool
$c<= :: forall a. Ord a => Design a -> Design a -> Bool
< :: Design a -> Design a -> Bool
$c< :: forall a. Ord a => Design a -> Design a -> Bool
compare :: Design a -> Design a -> Ordering
$ccompare :: forall a. Ord a => Design a -> Design a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Design a)
Ord,Int -> Design a -> ShowS
[Design a] -> ShowS
Design a -> String
(Int -> Design a -> ShowS)
-> (Design a -> String) -> ([Design a] -> ShowS) -> Show (Design a)
forall a. Show a => Int -> Design a -> ShowS
forall a. Show a => [Design a] -> ShowS
forall a. Show a => Design a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Design a] -> ShowS
$cshowList :: forall a. Show a => [Design a] -> ShowS
show :: Design a -> String
$cshow :: forall a. Show a => Design a -> String
showsPrec :: Int -> Design a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Design a -> ShowS
Show)
-- Do we or should we insist on ordering of the xs or bs?


design :: ([a], [[a]]) -> Design a
design (xs :: [a]
xs,bs :: [[a]]
bs) | Design a -> Bool
forall a. Ord a => Design a -> Bool
isValid Design a
d = Design a
d where d :: Design a
d = [a] -> [[a]] -> Design a
forall a. [a] -> [[a]] -> Design a
D [a]
xs [[a]]
bs

toDesign :: ([a], [[a]]) -> Design a
toDesign (xs :: [a]
xs,bs :: [[a]]
bs) = [a] -> [[a]] -> Design a
forall a. [a] -> [[a]] -> Design a
D [a]
xs' [[a]]
bs' where
    xs' :: [a]
xs' = [a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a]
xs
    bs' :: [[a]]
bs' = [[a]] -> [[a]]
forall a. Ord a => [a] -> [a]
L.sort ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [[a]]
bs -- in fact don't require that the blocks are in order


isValid :: Design a -> Bool
isValid (D xs :: [a]
xs bs :: [[a]]
bs) = ([a]
xs [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a]
xs Bool -> Bool -> Bool
|| String -> Bool
forall a. HasCallStack => String -> a
error "design: points are not in order")
                 Bool -> Bool -> Bool
&& (([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\b :: [a]
b -> [a]
b [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a]
b) [[a]]
bs Bool -> Bool -> Bool
|| String -> Bool
forall a. HasCallStack => String -> a
error "design: blocks do not have points in order")
-- could also check that each block is a subset of xs, etc


points :: Design a -> [a]
points (D xs :: [a]
xs bs :: [[a]]
bs) = [a]
xs

blocks :: Design a -> [[a]]
blocks (D xs :: [a]
xs bs :: [[a]]
bs) = [[a]]
bs


-- FINDING DESIGN PARAMETERS


noRepeatedBlocks :: Design a -> Bool
noRepeatedBlocks (D xs :: [a]
xs bs :: [[a]]
bs) = ([[a]] -> Bool) -> [[[a]]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ( (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==1) (Int -> Bool) -> ([[a]] -> Int) -> [[a]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ) ([[[a]]] -> Bool) -> [[[a]]] -> Bool
forall a b. (a -> b) -> a -> b
$ [[a]] -> [[[a]]]
forall a. Eq a => [a] -> [[a]]
L.group ([[a]] -> [[[a]]]) -> [[a]] -> [[[a]]]
forall a b. (a -> b) -> a -> b
$ [[a]] -> [[a]]
forall a. Ord a => [a] -> [a]
L.sort [[a]]
bs


-- Note that the design parameters functions don't check no repeated blocks, so they're also valid for t-structures


-- given t and a t-(v,k,lambda) design, return (v,k,lambda)

tDesignParams :: Int -> Design a -> Maybe (Int, Int, Int)
tDesignParams t :: Int
t d :: Design a
d =
    case Design a -> Maybe (Int, Int)
forall a. Design a -> Maybe (Int, Int)
findvk Design a
d of
    Nothing -> Maybe (Int, Int, Int)
forall a. Maybe a
Nothing
    Just (v :: Int
v,k :: Int
k) ->
        case Int -> Design a -> Maybe Int
forall a. Eq a => Int -> Design a -> Maybe Int
findlambda Int
t Design a
d of
        Nothing -> Maybe (Int, Int, Int)
forall a. Maybe a
Nothing
        Just lambda :: Int
lambda -> (Int, Int, Int) -> Maybe (Int, Int, Int)
forall a. a -> Maybe a
Just (Int
v,Int
k,Int
lambda)

findvk :: Design a -> Maybe (Int, Int)
findvk (D xs :: [a]
xs bs :: [[a]]
bs) =
    let k :: Int
k:ls :: [Int]
ls = ([a] -> Int) -> [[a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
bs
    in if (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
k) [Int]
ls then (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int
v,Int
k) else Maybe (Int, Int)
forall a. Maybe a
Nothing
    where v :: Int
v = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs

findlambda :: Int -> Design a -> Maybe Int
findlambda t :: Int
t (D xs :: [a]
xs bs :: [[a]]
bs) =
    let lambda :: Int
lambda:ls :: [Int]
ls = [[[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]
b | [a]
b <- [[a]]
bs, [a]
ts [a] -> [a] -> Bool
forall (t :: * -> *) (t :: * -> *) a.
(Foldable t, Foldable t, Eq a) =>
t a -> t a -> Bool
`isSubset` [a]
b] | [a]
ts <- Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
combinationsOf Int
t [a]
xs]
    in if (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
lambda) [Int]
ls then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
lambda else Maybe Int
forall a. Maybe a
Nothing

-- given (xs,bs), return design parameters t-(v,k,lambda) with t maximal

designParams :: Design a -> Maybe (Int, (Int, Int, Int))
designParams d :: Design a
d =
    case Design a -> Maybe (Int, Int)
forall a. Design a -> Maybe (Int, Int)
findvk Design a
d of
    Nothing -> Maybe (Int, (Int, Int, Int))
forall a. Maybe a
Nothing
    Just (v :: Int
v,k :: Int
k) ->
        case [(Int, Maybe Int)] -> [(Int, Maybe Int)]
forall a. [a] -> [a]
reverse (((Int, Maybe Int) -> Bool)
-> [(Int, Maybe Int)] -> [(Int, Maybe Int)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool)
-> ((Int, Maybe Int) -> Maybe Int) -> (Int, Maybe Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Maybe Int) -> Maybe Int
forall a b. (a, b) -> b
snd) [(Int
t, Int -> Design a -> Maybe Int
forall a. Eq a => Int -> Design a -> Maybe Int
findlambda Int
t Design a
d) | Int
t <- [0..Int
k] ]) of
        [] -> Maybe (Int, (Int, Int, Int))
forall a. Maybe a
Nothing
        (t :: Int
t,Just lambda :: Int
lambda):_ -> (Int, (Int, Int, Int)) -> Maybe (Int, (Int, Int, Int))
forall a. a -> Maybe a
Just (Int
t,(Int
v,Int
k,Int
lambda))
-- Note that a 0-(v,k,lambda) design just means that there are lambda blocks, all of size k, with no other regularity


isStructure :: Int -> Design a -> Bool
isStructure t :: Int
t d :: Design a
d = Maybe (Int, Int, Int) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Int, Int, Int) -> Bool) -> Maybe (Int, Int, Int) -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Design a -> Maybe (Int, Int, Int)
forall a. Eq a => Int -> Design a -> Maybe (Int, Int, Int)
tDesignParams Int
t Design a
d

isDesign :: Int -> Design a -> Bool
isDesign t :: Int
t d :: Design a
d = Design a -> Bool
forall a. Ord a => Design a -> Bool
noRepeatedBlocks Design a
d Bool -> Bool -> Bool
&& Int -> Design a -> Bool
forall a. Eq a => Int -> Design a -> Bool
isStructure Int
t Design a
d

is2Design :: Design a -> Bool
is2Design d :: Design a
d = Int -> Design a -> Bool
forall a. Ord a => Int -> Design a -> Bool
isDesign 2 Design a
d

-- square 2-design (more often called "symmetric" in the literature)

isSquare :: Design a -> Bool
isSquare d :: Design a
d@(D xs :: [a]
xs bs :: [[a]]
bs) = Design a -> Bool
forall a. Ord a => Design a -> Bool
is2Design Design a
d Bool -> Bool -> Bool
&& [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
bs


-- (We follow Cameron & van Lint.)

-- |The incidence matrix of a design, with rows indexed by blocks and columns by points.

-- (Note that in the literature, the opposite convention is sometimes used instead.)

incidenceMatrix :: (Eq t) => Design t -> [[Int]]
incidenceMatrix :: Design t -> [[Int]]
incidenceMatrix (D xs :: [t]
xs bs :: [[t]]
bs) = [ [if t
x t -> [t] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [t]
b then 1 else 0 | t
x <- [t]
xs] | [t]
b <- [[t]]
bs]


-- SOME FAMILIES OF DESIGNS


-- the following is trivially a k-(v,k,lambda) design

subsetDesign :: a -> Int -> Design a
subsetDesign v :: a
v k :: Int
k = ([a], [[a]]) -> Design a
forall a. Ord a => ([a], [[a]]) -> Design a
design ([a]
xs,[[a]]
bs) where
    xs :: [a]
xs = [1..a
v]
    bs :: [[a]]
bs = Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
combinationsOf Int
k [a]
xs

-- Cameron & van Lint, p30

-- the pair design on n points is the complete graph on n points considered as a 2-(n,2,1) design

pairDesign :: a -> Design a
pairDesign n :: a
n = [a] -> [[a]] -> Design a
forall a. [a] -> [[a]] -> Design a
D [a]
vs [[a]]
es where
    graph :: Graph a
graph = a -> Graph a
forall t. Integral t => t -> Graph t
G.k a
n
    vs :: [a]
vs = Graph a -> [a]
forall a. Graph a -> [a]
vertices Graph a
graph
    es :: [[a]]
es = Graph a -> [[a]]
forall a. Graph a -> [[a]]
edges Graph a
graph

-- |The affine plane AG(2,Fq), a 2-(q^2,q,1) design or Steiner system S(2,q,q^2).

ag2 :: (FiniteField k, Ord k) => [k] -> Design [k]
ag2 :: [k] -> Design [k]
ag2 fq :: [k]
fq = ([[k]], [[[k]]]) -> Design [k]
forall a. Ord a => ([a], [[a]]) -> Design a
design ([[k]]
points, [[[k]]]
lines) where
    points :: [[k]]
points = Int -> [k] -> [[k]]
forall a. Int -> [a] -> [[a]]
ptsAG 2 [k]
fq
    lines :: [[[k]]]
lines = ([k] -> [[k]]) -> [[k]] -> [[[k]]]
forall a b. (a -> b) -> [a] -> [b]
map [k] -> [[k]]
line ([[k]] -> [[[k]]]) -> [[k]] -> [[[k]]]
forall a b. (a -> b) -> a -> b
$ [[k]] -> [[k]]
forall a. [a] -> [a]
tail ([[k]] -> [[k]]) -> [[k]] -> [[k]]
forall a b. (a -> b) -> a -> b
$ Int -> [k] -> [[k]]
forall a. Num a => Int -> [a] -> [[a]]
ptsPG 2 [k]
fq
    line :: [k] -> [[k]]
line [a :: k
a,b :: k
b,c :: k
c] = [ [k
x,k
y] | [x :: k
x,y :: k
y] <- [[k]]
points, k
ak -> k -> k
forall a. Num a => a -> a -> a
*k
xk -> k -> k
forall a. Num a => a -> a -> a
+k
bk -> k -> k
forall a. Num a => a -> a -> a
*k
yk -> k -> k
forall a. Num a => a -> a -> a
+k
ck -> k -> Bool
forall a. Eq a => a -> a -> Bool
==0 ]

-- |The projective plane PG(2,Fq), a square 2-(q^2+q+1,q+1,1) design or Steiner system S(2,q+1,q^2+q+1).

-- For example, @pg2 f2@ is the Fano plane, a Steiner triple system S(2,3,7).

pg2 :: (FiniteField k, Ord k) => [k] -> Design [k]
pg2 :: [k] -> Design [k]
pg2 fq :: [k]
fq = ([[k]], [[[k]]]) -> Design [k]
forall a. Ord a => ([a], [[a]]) -> Design a
design ([[k]]
points, [[[k]]]
lines) where
    points :: [[k]]
points = Int -> [k] -> [[k]]
forall a. Num a => Int -> [a] -> [[a]]
ptsPG 2 [k]
fq
    lines :: [[[k]]]
lines = [[[k]]] -> [[[k]]]
forall a. Ord a => [a] -> [a]
L.sort ([[[k]]] -> [[[k]]]) -> [[[k]]] -> [[[k]]]
forall a b. (a -> b) -> a -> b
$ ([k] -> [[k]]) -> [[k]] -> [[[k]]]
forall a b. (a -> b) -> [a] -> [b]
map [k] -> [[k]]
line [[k]]
points
    line :: [k] -> [[k]]
line u :: [k]
u = [[k]
v | [k]
v <- [[k]]
points, [k]
u [k] -> [k] -> k
forall a. Num a => [a] -> [a] -> a
<.> [k]
v k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== 0]
    u :: [a]
u <.> :: [a] -> [a] -> a
<.> v :: [a]
v = [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> a
forall a. Num a => a -> a -> a
(*) [a]
u [a]
v)
-- Remember that the points and lines of PG(2,Fp) are really the lines and planes of AG(3,Fp).

-- A line in AG(3,Fp) defines a plane orthogonal to it.



-- The points and i-flats of PG(n,fq), 1<=i<=n-1, form a 2-design

-- For i==1, this is a 2-((q^(n+1)-1)/(q-1),q+1,1) design

-- For i==n-1, this is a 2-((q^(n+1)-1)/(q-1),(q^n-1)/(q-1),(q^(n-1)-1)/(q-1)) design

-- Cameron & van Lint, p8

flatsDesignPG :: Int -> [a] -> Int -> Design [a]
flatsDesignPG n :: Int
n fq :: [a]
fq k :: Int
k = ([[a]], [[[a]]]) -> Design [a]
forall a. Ord a => ([a], [[a]]) -> Design a
design ([[a]]
points, [[[a]]]
blocks) where
    points :: [[a]]
points = Int -> [a] -> [[a]]
forall a. Num a => Int -> [a] -> [[a]]
ptsPG Int
n [a]
fq
    blocks :: [[[a]]]
blocks = ([[a]] -> [[a]]) -> [[[a]]] -> [[[a]]]
forall a b. (a -> b) -> [a] -> [b]
map [[a]] -> [[a]]
forall a. (Num a, Ord a, FinSet a) => [[a]] -> [[a]]
closurePG ([[[a]]] -> [[[a]]]) -> [[[a]]] -> [[[a]]]
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> Int -> [[[a]]]
forall a. (Eq a, Num a) => Int -> [a] -> Int -> [[[a]]]
flatsPG Int
n [a]
fq Int
k -- the closurePG replaces the generators of the flat by the list of points of the flat


-- The projective point-hyperplane design is also denoted PG(n,q)

pg :: Int -> [a] -> Design [a]
pg n :: Int
n fq :: [a]
fq = Int -> [a] -> Int -> Design [a]
forall a.
(Ord a, FinSet a, Num a) =>
Int -> [a] -> Int -> Design [a]
flatsDesignPG Int
n [a]
fq (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)

-- (Cameron & van Lint don't actually state that this is a design except when k == n-1)

flatsDesignAG :: Int -> [a] -> Int -> Design [a]
flatsDesignAG n :: Int
n fq :: [a]
fq k :: Int
k = ([[a]], [[[a]]]) -> Design [a]
forall a. Ord a => ([a], [[a]]) -> Design a
design ([[a]]
points, [[[a]]]
blocks) where
    points :: [[a]]
points = Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
ptsAG Int
n [a]
fq
    blocks :: [[[a]]]
blocks = ([[a]] -> [[a]]) -> [[[a]]] -> [[[a]]]
forall a b. (a -> b) -> [a] -> [b]
map [[a]] -> [[a]]
forall a. (Num a, Ord a, FinSet a) => [[a]] -> [[a]]
closureAG ([[[a]]] -> [[[a]]]) -> [[[a]]] -> [[[a]]]
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> Int -> [[[a]]]
forall a. (Eq a, Num a) => Int -> [a] -> Int -> [[[a]]]
flatsAG Int
n [a]
fq Int
k -- the closureAG replaces the generators of the flat by the list of points of the flat


-- The affine point-hyperplane design is also denoted AG(n,q)

-- It a 2-(q^n,q^(n-1),(q^(n-1)-1)/(q-1)) design

-- Cameron & van Lint, p17

ag :: Int -> [a] -> Design [a]
ag n :: Int
n fq :: [a]
fq = Int -> [a] -> Int -> Design [a]
forall a.
(Num a, Ord a, FinSet a) =>
Int -> [a] -> Int -> Design [a]
flatsDesignAG Int
n [a]
fq (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)



-- convert a design to be defined over the set [1..n]

to1n :: Design a -> Design a
to1n (D xs :: [a]
xs bs :: [[a]]
bs) = ([a] -> [[a]] -> Design a
forall a. [a] -> [[a]] -> Design a
D [a]
xs' [[a]]
bs') where
    mapping :: Map a a
mapping = [(a, a)] -> Map a a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(a, a)] -> Map a a) -> [(a, a)] -> Map a a
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs [1..] -- the mapping from vs to [1..n]

    xs' :: [a]
xs' = Map a a -> [a]
forall k a. Map k a -> [a]
M.elems Map a a
mapping
    bs' :: [[a]]
bs' = [(a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Map a a
mapping Map a a -> a -> a
forall k a. Ord k => Map k a -> k -> a
M.!) [a]
b | [a]
b <- [[a]]
bs] -- the blocks will already be sorted correctly by construction



-- Cameron & van Lint p10

paleyDesign :: [a] -> Design a
paleyDesign fq :: [a]
fq | [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
fq Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 4 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3 = ([a], [[a]]) -> Design a
forall a. Ord a => ([a], [[a]]) -> Design a
design ([a]
xs,[[a]]
bs) where
    xs :: [a]
xs = [a]
fq
    qs :: [a]
qs = [a] -> [a]
forall a. Ord a => [a] -> [a]
set [a
xa -> Integer -> a
forall a b. (Num a, Integral b) => a -> b -> a
^2 | a
x <- [a]
xs] [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [0] -- the non-zero squares in Fq

    bs :: [[a]]
bs = [[a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort ((a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a
xa -> a -> a
forall a. Num a => a -> a -> a
+) [a]
qs) | a
x <- [a]
xs]

fanoPlane :: Design F7
fanoPlane = [F7] -> Design F7
forall a. (Ord a, Num a) => [a] -> Design a
paleyDesign [F7]
f7
-- isomorphic to PG(2,F2)



-- NEW DESIGNS FROM OLD


-- Dual of a design. Cameron & van Lint p11

-- |The dual of a design

dual :: (Ord t) => Design t -> Design [t]
dual :: Design t -> Design [t]
dual (D xs :: [t]
xs bs :: [[t]]
bs) = ([[t]], [[[t]]]) -> Design [t]
forall a. Ord a => ([a], [[a]]) -> Design a
design ([[t]]
bs, (t -> [[t]]) -> [t] -> [[[t]]]
forall a b. (a -> b) -> [a] -> [b]
map t -> [[t]]
beta [t]
xs) where
    beta :: t -> [[t]]
beta x :: t
x = ([t] -> Bool) -> [[t]] -> [[t]]
forall a. (a -> Bool) -> [a] -> [a]
filter (t
x t -> [t] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) [[t]]
bs

-- Derived design relative to a point. Cameron & van Lint p11

-- Derived design of a t-(v,k,lambda) is a t-1-(v-1,k-1,lambda) design.

derivedDesign :: (Ord t) => Design t -> t -> Design t
derivedDesign :: Design t -> t -> Design t
derivedDesign (D xs :: [t]
xs bs :: [[t]]
bs) p :: t
p = ([t], [[t]]) -> Design t
forall a. Ord a => ([a], [[a]]) -> Design a
design ([t]
xs [t] -> [t] -> [t]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [t
p], [[t]
b [t] -> [t] -> [t]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [t
p] | [t]
b <- [[t]]
bs, t
p t -> [t] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [t]
b])

-- Residual design relative to a point. Cameron & van Lint p13

-- Point-residual of a t-(v,k,lambda) is a t-1-(v-1,k,mu).

pointResidual :: (Ord t) => Design t -> t -> Design t
pointResidual :: Design t -> t -> Design t
pointResidual (D xs :: [t]
xs bs :: [[t]]
bs) p :: t
p = ([t], [[t]]) -> Design t
forall a. Ord a => ([a], [[a]]) -> Design a
design ([t]
xs [t] -> [t] -> [t]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [t
p], [[t]
b | [t]
b <- [[t]]
bs, t
p t -> [t] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [t]
b])

-- Complementary design. Cameron & van Lint p13

-- Complement of a t-(v,k,lambda) is a t-(v,v-k,mu).

complementaryDesign :: Design a -> Design a
complementaryDesign (D xs :: [a]
xs bs :: [[a]]
bs) = ([a], [[a]]) -> Design a
forall a. Ord a => ([a], [[a]]) -> Design a
design ([a]
xs, [[a]
xs [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [a]
b | [a]
b <- [[a]]
bs])

-- Residual design relative to a block. Cameron & van Lint p13

-- This is only a design if (xs,bs) is a square design

-- It may have repeated blocks - but if so, residuals of the complement will not

-- Block-residual of a 2-(v,k,lambda) is a 2-(v-k,k-lambda,lambda).

blockResidual :: (Ord t) => Design t -> [t] -> Design t
blockResidual :: Design t -> [t] -> Design t
blockResidual d :: Design t
d@(D xs :: [t]
xs bs :: [[t]]
bs) b :: [t]
b | Design t -> Bool
forall a. Ord a => Design a -> Bool
isSquare Design t
d = ([t], [[t]]) -> Design t
forall a. Ord a => ([a], [[a]]) -> Design a
design ([t]
xs [t] -> [t] -> [t]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [t]
b, [[t]
b' [t] -> [t] -> [t]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [t]
b | [t]
b' <- [[t]]
bs, [t]
b' [t] -> [t] -> Bool
forall a. Eq a => a -> a -> Bool
/= [t]
b])


-- DESIGN AUTOMORPHISMS


isDesignAut :: Design a -> Permutation a -> Bool
isDesignAut (D xs :: [a]
xs bs :: [[a]]
bs) g :: Permutation a
g | Permutation a -> [a]
forall a. Permutation a -> [a]
supp Permutation a
g [a] -> [a] -> Bool
forall (t :: * -> *) (t :: * -> *) a.
(Foldable t, Foldable t, Eq a) =>
t a -> t a -> Bool
`isSubset` [a]
xs = ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([a] -> Set [a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [a]
bs') [[a]
b [a] -> Permutation a -> [a]
forall a. Ord a => [a] -> Permutation a -> [a]
-^ Permutation a
g | [a]
b <- [[a]]
bs]
    where bs' :: Set [a]
bs' = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList [[a]]
bs

-- |The incidence graph of a design

incidenceGraph :: (Ord a) => Design a -> Graph (Either a [a])
incidenceGraph :: Design a -> Graph (Either a [a])
incidenceGraph (D xs :: [a]
xs bs :: [[a]]
bs) = [Either a [a]] -> [[Either a [a]]] -> Graph (Either a [a])
forall a. [a] -> [[a]] -> Graph a
G [Either a [a]]
vs [[Either a [a]]]
es where -- graph (vs,es) where

    vs :: [Either a [a]]
vs = [Either a [a]] -> [Either a [a]]
forall a. Ord a => [a] -> [a]
L.sort ([Either a [a]] -> [Either a [a]])
-> [Either a [a]] -> [Either a [a]]
forall a b. (a -> b) -> a -> b
$ (a -> Either a [a]) -> [a] -> [Either a [a]]
forall a b. (a -> b) -> [a] -> [b]
map a -> Either a [a]
forall a b. a -> Either a b
Left [a]
xs [Either a [a]] -> [Either a [a]] -> [Either a [a]]
forall a. [a] -> [a] -> [a]
++ ([a] -> Either a [a]) -> [[a]] -> [Either a [a]]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Either a [a]
forall a b. b -> Either a b
Right [[a]]
bs
    es :: [[Either a [a]]]
es = [[Either a [a]]] -> [[Either a [a]]]
forall a. Ord a => [a] -> [a]
L.sort [ [a -> Either a [a]
forall a b. a -> Either a b
Left a
x, [a] -> Either a [a]
forall a b. b -> Either a b
Right [a]
b] | a
x <- [a]
xs, [a]
b <- [[a]]
bs, a
x a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
b ]


-- |Find a strong generating set for the automorphism group of a design

designAuts :: (Ord t) => Design t -> [Permutation t]
designAuts :: Design t -> [Permutation t]
designAuts d :: Design t
d = Graph (Either t [t]) -> [Permutation t]
forall p b. (Ord p, Ord b) => Graph (Either p b) -> [Permutation p]
incidenceAuts (Graph (Either t [t]) -> [Permutation t])
-> Graph (Either t [t]) -> [Permutation t]
forall a b. (a -> b) -> a -> b
$ Design t -> Graph (Either t [t])
forall a. Ord a => Design a -> Graph (Either a [a])
incidenceGraph Design t
d

-- We find design auts by finding graph auts of the incidence graph of the design

-- In a square design, we need to watch out for graph auts which are mapping points <-> blocks

designAuts1 :: Design a -> [Permutation a]
designAuts1 d :: Design a
d = (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Permutation a -> Permutation a -> Bool
forall a. Eq a => a -> a -> Bool
/=1) ([Permutation a] -> [Permutation a])
-> [Permutation a] -> [Permutation a]
forall a b. (a -> b) -> a -> b
$ (Permutation (Either a [a]) -> Permutation a)
-> [Permutation (Either a [a])] -> [Permutation a]
forall a b. (a -> b) -> [a] -> [b]
map Permutation (Either a [a]) -> Permutation a
forall a b. Ord a => Permutation (Either a b) -> Permutation a
points ([Permutation (Either a [a])] -> [Permutation a])
-> [Permutation (Either a [a])] -> [Permutation a]
forall a b. (a -> b) -> a -> b
$ Graph (Either a [a]) -> [Permutation (Either a [a])]
forall a. Ord a => Graph a -> [Permutation a]
graphAuts (Graph (Either a [a]) -> [Permutation (Either a [a])])
-> Graph (Either a [a]) -> [Permutation (Either a [a])]
forall a b. (a -> b) -> a -> b
$ Design a -> Graph (Either a [a])
forall a. Ord a => Design a -> Graph (Either a [a])
incidenceGraph Design a
d where
    points :: Permutation (Either a b) -> Permutation a
points h :: Permutation (Either a b)
h = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [(a
x,a
y) | (Left x :: a
x, Left y :: a
y) <- Permutation (Either a b) -> [(Either a b, Either a b)]
forall a. Permutation a -> [(a, a)]
toPairs Permutation (Either a b)
h]
     -- This implicitly filters out (Right x, Right y) action on blocks,

     -- and also (Left x, Right y) auts taking points to blocks.

     -- The filter (/=1) is to remove points <-> blocks auts


-- The incidence graph is a bipartite graph, so the distance function naturally partitions points from blocks



-- MATHIEU GROUPS AND WITT DESIGNS


alphaL2_23 :: Permutation Integer
alphaL2_23 = [[Integer]] -> Permutation Integer
forall a. Ord a => [[a]] -> Permutation a
p [[-1],[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22]]                      -- t -> t+1

betaL2_23 :: Permutation Integer
betaL2_23  = [[Integer]] -> Permutation Integer
forall a. Ord a => [[a]] -> Permutation a
p [[-1],[0],[1,2,4,8,16,9,18,13,3,6,12],[5,10,20,17,11,22,21,19,15,7,14]]                  -- t -> 2*t

gammaL2_23 :: Permutation Integer
gammaL2_23 = [[Integer]] -> Permutation Integer
forall a. Ord a => [[a]] -> Permutation a
p [[-1,0],[1,22],[2,11],[3,15],[4,17],[5,9],[6,19],[7,13],[8,20],[10,16],[12,21],[14,18]]  -- t -> -1/t


l2_23 :: [Permutation Integer]
l2_23 = [Permutation Integer
alphaL2_23, Permutation Integer
betaL2_23, Permutation Integer
gammaL2_23]

-- Mathieu group M24

-- Conway and Sloane p274ff

-- This is the automorphism group of the extended binary Golay code G24

-- or alternatively of the unique Steiner system S(5,8,24) (which consists of the weight 8 codewords of the above)


deltaM24 :: Permutation Integer
deltaM24 = [[Integer]] -> Permutation Integer
forall a. Ord a => [[a]] -> Permutation a
p [[-1],[0],[1,18,4,2,6],[3],[5,21,20,10,7],[8,16,13,9,12],[11,19,22,14,17],[15]]
-- this is t -> t^3 / 9 (for t a quadratic residue), t -> 9 t^3 (t a non-residue)


-- |Generators for the Mathieu group M24, a finite simple group of order 244823040

m24 :: [Permutation Integer]
m24 :: [Permutation Integer]
m24 = [Permutation Integer
alphaL2_23, Permutation Integer
betaL2_23, Permutation Integer
gammaL2_23, Permutation Integer
deltaM24]

-- |A strong generating set for the Mathieu group M24, a finite simple group of order 244823040

m24sgs :: [Permutation Integer]
m24sgs :: [Permutation Integer]
m24sgs = [Permutation Integer] -> [Permutation Integer]
forall a. (Ord a, Show a) => [Permutation a] -> [Permutation a]
sgs [Permutation Integer]
m24

-- |A strong generating set for the Mathieu group M23, a finite simple group of order 10200960

m23sgs :: [Permutation Integer]
m23sgs :: [Permutation Integer]
m23sgs = (Permutation Integer -> Bool)
-> [Permutation Integer] -> [Permutation Integer]
forall a. (a -> Bool) -> [a] -> [a]
filter (\g :: Permutation Integer
g -> (-1)Integer -> Permutation Integer -> Integer
forall a. Ord a => a -> Permutation a -> a
.^Permutation Integer
g Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -1) [Permutation Integer]
m24sgs

-- |A strong generating set for the Mathieu group M22, a finite simple group of order 443520

m22sgs :: [Permutation Integer]
m22sgs :: [Permutation Integer]
m22sgs = (Permutation Integer -> Bool)
-> [Permutation Integer] -> [Permutation Integer]
forall a. (a -> Bool) -> [a] -> [a]
filter (\g :: Permutation Integer
g -> 0Integer -> Permutation Integer -> Integer
forall a. Ord a => a -> Permutation a -> a
.^Permutation Integer
g Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0) [Permutation Integer]
m23sgs

-- sgs uses the base implied by the Ord instance, which will be [-1,0,..]



-- Steiner system S(5,8,24)


octad :: [Integer]
octad = [0,1,2,3,4,7,10,12]
-- Conway&Sloane p276 - this is a weight 8 codeword from Golay code G24


-- |The Steiner system S(5,8,24), with 759 blocks, whose automorphism group is M24

s_5_8_24 :: Design Integer
s_5_8_24 :: Design Integer
s_5_8_24 = ([Integer], [[Integer]]) -> Design Integer
forall a. Ord a => ([a], [[a]]) -> Design a
design ([-1..22], [Integer]
octad [Integer] -> [Permutation Integer] -> [[Integer]]
forall a. Ord a => [a] -> [Permutation a] -> [[a]]
-^^ [Permutation Integer]
l2_23)
-- S(5,8,24) constructed as the image of a single octad under the action of PSL(2,23)

-- 759 blocks ( (24 `choose` 5) `div` (8 `choose` 5) )

-- Automorphism group is M24


-- |The Steiner system S(4,7,23), with 253 blocks, whose automorphism group is M23

s_4_7_23 :: Design Integer
s_4_7_23 :: Design Integer
s_4_7_23 = Design Integer -> Integer -> Design Integer
forall t. Ord t => Design t -> t -> Design t
derivedDesign Design Integer
s_5_8_24 (-1)
-- 253 blocks ( (23 `choose` 4) `div` (7 `choose` 4) )

-- Automorphism group is M23


-- |The Steiner system S(3,6,22), with 77 blocks, whose automorphism group is M22

s_3_6_22 :: Design Integer
s_3_6_22 :: Design Integer
s_3_6_22 = Design Integer -> Integer -> Design Integer
forall t. Ord t => Design t -> t -> Design t
derivedDesign Design Integer
s_4_7_23 0
-- 77 blocks

-- Automorphism group is M22


-- Derived design of s_3_6_22 is PG(2,F4)



-- An alternative construction

s_5_8_24' :: Design Integer
s_5_8_24' = [Integer] -> [[Integer]] -> Design Integer
forall a. [a] -> [[a]] -> Design a
D [Integer]
xs [[Integer]]
bs where
    xs :: [Integer]
xs = [1..24]
    bs :: [[Integer]]
bs = [[Integer]] -> [[Integer]] -> [[Integer]]
forall a. Ord a => [[a]] -> [[a]] -> [[a]]
sift [] (Int -> [Integer] -> [[Integer]]
forall a. Int -> [a] -> [[a]]
combinationsOf 8 [Integer]
xs)
    sift :: [[a]] -> [[a]] -> [[a]]
sift ls :: [[a]]
ls (r :: [a]
r:rs :: [[a]]
rs) = if ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=4) (Int -> Bool) -> ([a] -> Int) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [[a]
r [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
`intersect` [a]
l | [a]
l <- [[a]]
ls]
                     then [a]
r [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]] -> [[a]] -> [[a]]
sift ([a]
r[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
ls) [[a]]
rs 
                     else [[a]] -> [[a]] -> [[a]]
sift [[a]]
ls [[a]]
rs
    sift ls :: [[a]]
ls [] = []


-- Could test that m22sgs are all designAuts of s_3_6_22



-- S(5,6,12) and M12


alphaL2_11 :: Permutation Integer
alphaL2_11 = [[Integer]] -> Permutation Integer
forall a. Ord a => [[a]] -> Permutation a
p [[-1],[0,1,2,3,4,5,6,7,8,9,10]]          -- t -> t+1

betaL2_11 :: Permutation Integer
betaL2_11  = [[Integer]] -> Permutation Integer
forall a. Ord a => [[a]] -> Permutation a
p [[-1],[0],[1,3,9,5,4],[2,6,7,10,8]]      -- t -> 3*t

gammaL2_11 :: Permutation Integer
gammaL2_11 = [[Integer]] -> Permutation Integer
forall a. Ord a => [[a]] -> Permutation a
p [[-1,0],[1,10],[2,5],[3,7],[4,8],[6,9]]  -- t -> -1/t


l2_11 :: [Permutation Integer]
l2_11 = [Permutation Integer
alphaL2_11, Permutation Integer
betaL2_11, Permutation Integer
gammaL2_11]

deltaM12 :: Permutation Integer
deltaM12 = [[Integer]] -> Permutation Integer
forall a. Ord a => [[a]] -> Permutation a
p [[-1],[0],[1],[2,10],[3,4],[5,9],[6,7],[8]]
-- Conway&Sloane p271, 327


hexad :: [Integer]
hexad = [0,1,3,4,5,9]
-- the squares (quadratic residues) in F11

-- http://en.wikipedia.org/wiki/Steiner_system


-- |The Steiner system S(5,6,12), with 132 blocks, whose automorphism group is M12

s_5_6_12 :: Design Integer
s_5_6_12 :: Design Integer
s_5_6_12 = ([Integer], [[Integer]]) -> Design Integer
forall a. Ord a => ([a], [[a]]) -> Design a
design ([-1..10], [Integer]
hexad [Integer] -> [Permutation Integer] -> [[Integer]]
forall a. Ord a => [a] -> [Permutation a] -> [[a]]
-^^ [Permutation Integer]
l2_11)
-- S(5,6,12) constructed as the image of a single hexad under the action of PSL(2,11)

-- 132 blocks ( (12 `choose` 5) `div` (6 `choose` 5) )

-- Automorphism group is M12


-- |The Steiner system S(4,5,11), with 66 blocks, whose automorphism group is M11

s_4_5_11 :: Design Integer
s_4_5_11 :: Design Integer
s_4_5_11 = Design Integer -> Integer -> Design Integer
forall t. Ord t => Design t -> t -> Design t
derivedDesign Design Integer
s_5_6_12 (-1)
-- 66 blocks

-- Automorphism group is M11


-- |Generators for the Mathieu group M12, a finite simple group of order 95040

m12 :: [Permutation Integer]
m12 :: [Permutation Integer]
m12 = [Permutation Integer
alphaL2_11, Permutation Integer
betaL2_11, Permutation Integer
gammaL2_11, Permutation Integer
deltaM12]

-- |A strong generating set for the Mathieu group M12, a finite simple group of order 95040

m12sgs :: [Permutation Integer]
m12sgs :: [Permutation Integer]
m12sgs = [Permutation Integer] -> [Permutation Integer]
forall a. (Ord a, Show a) => [Permutation a] -> [Permutation a]
sgs [Permutation Integer]
m12
-- order 95040


-- |A strong generating set for the Mathieu group M11, a finite simple group of order 7920

m11sgs :: [Permutation Integer]
m11sgs :: [Permutation Integer]
m11sgs = (Permutation Integer -> Bool)
-> [Permutation Integer] -> [Permutation Integer]
forall a. (a -> Bool) -> [a] -> [a]
filter (\g :: Permutation Integer
g -> (-1)Integer -> Permutation Integer -> Integer
forall a. Ord a => a -> Permutation a -> a
.^Permutation Integer
g Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -1) [Permutation Integer]
m12sgs
-- order 7920



{-
-- WITT DESIGNS
-- S(5,8,24) AND S(5,6,12)

-- Let D be a square 2-design.
-- An n-arc is a set of n points of D, no three of which are contained in a block
arcs n (D xs bs) = map reverse $ dfs n [] xs where
    dfs 0 ys _ = [ys]
    dfs i ys xs = concat [dfs (i-1) (x:ys) (dropWhile (<=x) xs) | x <- xs, isCompatible (x:ys)]
    isCompatible ys = all ((<=2) . length) [ys `L.intersect` b | b <- bs]

tangents (D xs bs) arc = [b | b <- bs, length (arc `L.intersect` b) == 1]

-- !! NOT QUITE AS EXPECTED
-- Cameron van Lint implies that ovals should have n = 1+(k-1)/lambda, whereas I'm finding that they're one bigger than that
-- eg length $ ovals $ ag2 f3 should be 54
-- But ag2 f3 isn't a *square* design
ovals d =
    let Just (_,k,lambda) = tDesignParams 2 d
        (q,r) = (k-1) `quotRem` lambda
        n = 2+q -- == 1+(k-1)/lambda
    in if r == 0
       then [arc | arc <- arcs n d, arc == L.sort (concat $ map (L.intersect arc) $ tangents d arc)] -- each point has a unique tangent
       else []

hyperovals d =
    let Just (_,k,lambda) = tDesignParams 2 d
        (q,r) = k `quotRem` lambda
        n = 1+q -- == 1+k/lambda
    in if r == 0
       then filter (null . tangents d) $ arcs n d
       else []

-- Cameron & van Lint, p22
-- s_5_8_24 = [length (intersect (head h) (head s)) | h <- [h1,h2,h3], s <- [s1,s2,s3]] where
s_5_8_24 = design (points,lines) where
    points = map Left xs ++ map Right [1,2,3]
    lines = [map Left b ++ map Right [1,2,3] | b <- bs] ++ -- line plus three points at infinity
            [map Left h ++ map Right [2,3] | h <- h1] ++ -- hyperoval plus two points at infinity
            [map Left h ++ map Right [1,3] | h <- h2] ++
            [map Left h ++ map Right [1,2] | h <- h3] ++
            [map Left s ++ map Right [1] | s <- s1] ++ -- Baer subplanes plus one point at infinity
            [map Left s ++ map Right [2] | s <- s2] ++
            [map Left s ++ map Right [3] | s <- s3] ++
            [map Left (l1 `symDiff` l2) | l1 <- bs, l2 <- bs, l1 < l2]
    d@(D xs bs) = pg2 f4
    hs = hyperovals d
    [h1,h2,h3] = evenClasses hs
    [s2,s1,s3] = oddClasses baerSubplanes -- we have to number the ss so that if h <- hi, s <- sj, then |h intersect s| is even <=> i == j
    evenClasses (h:hs) = let (ys,ns) = partition (even . length . L.intersect h) hs in (h:ys) : evenClasses ns
    evenClasses [] = []
    oddClasses (h:hs) = let (ys,ns) = partition (odd . length . L.intersect h) hs in (h:ys) : oddClasses ns
    oddClasses [] = []
    baerSubplanes = [s | s <- baerSubplanes', and [length (L.intersect s b) `elem` [1,3] | b <- bs] ] 
    baerSubplanes' = map reverse $ dfs 7 [] xs where
        dfs 0 ys _ = [ys]
        dfs i ys xs = concat [dfs (i-1) (x:ys) (dropWhile (<=x) xs) | x <- xs, isCompatible (x:ys)]
        isCompatible ys = all ((<=3) . length) [ys `L.intersect` b | b <- bs]
-}