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

module Math.Projects.MiniquaternionGeometry where

import Prelude hiding (  (<*), (*>) )

import qualified Data.List as L

import Math.Common.ListSet as LS
import Math.Core.Utils (combinationsOf)

import Math.Algebra.Field.Base
import Math.Combinatorics.FiniteGeometry (pnf, ispnf, orderPGL)
-- import Math.Combinatorics.Graph
import Math.Combinatorics.GraphAuts
import Math.Algebra.Group.PermutationGroup hiding (order)
import qualified Math.Algebra.Group.SchreierSims as SS
import Math.Algebra.Group.RandomSchreierSims
import Math.Combinatorics.Design as D
import Math.Algebra.LinearAlgebra -- ( (<.>), (<+>) )

import Math.Projects.ChevalleyGroup.Classical


-- Sources:
-- Miniquaternion Geometry, Room & Kirkpatrick
-- Survey of Non-Desarguesian Planes, Charles Weibel


-- F9, defined by adding sqrt of -1 to F3. (The Conway poly for F9 is not so convenient for us here)
data F9 = F9 F3 F3 deriving (F9 -> F9 -> Bool
(F9 -> F9 -> Bool) -> (F9 -> F9 -> Bool) -> Eq F9
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: F9 -> F9 -> Bool
$c/= :: F9 -> F9 -> Bool
== :: F9 -> F9 -> Bool
$c== :: F9 -> F9 -> Bool
Eq,Eq F9
Eq F9 =>
(F9 -> F9 -> Ordering)
-> (F9 -> F9 -> Bool)
-> (F9 -> F9 -> Bool)
-> (F9 -> F9 -> Bool)
-> (F9 -> F9 -> Bool)
-> (F9 -> F9 -> F9)
-> (F9 -> F9 -> F9)
-> Ord F9
F9 -> F9 -> Bool
F9 -> F9 -> Ordering
F9 -> F9 -> F9
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
min :: F9 -> F9 -> F9
$cmin :: F9 -> F9 -> F9
max :: F9 -> F9 -> F9
$cmax :: F9 -> F9 -> F9
>= :: F9 -> F9 -> Bool
$c>= :: F9 -> F9 -> Bool
> :: F9 -> F9 -> Bool
$c> :: F9 -> F9 -> Bool
<= :: F9 -> F9 -> Bool
$c<= :: F9 -> F9 -> Bool
< :: F9 -> F9 -> Bool
$c< :: F9 -> F9 -> Bool
compare :: F9 -> F9 -> Ordering
$ccompare :: F9 -> F9 -> Ordering
$cp1Ord :: Eq F9
Ord)

instance Show F9 where
    show :: F9 -> String
show (F9 0 0) = "0"
    show (F9 0 1) = "e"
    show (F9 0 2) = "-e"
    show (F9 1 0) = "1"
    show (F9 1 1) = "1+e"
    show (F9 1 2) = "1-e"
    show (F9 2 0) = "-1"
    show (F9 2 1) = "-1+e"
    show (F9 2 2) = "-1-e"

e :: F9
e = F3 -> F3 -> F9
F9 0 1 -- sqrt of -1

instance Num F9 where
    F9 a1 :: F3
a1 b1 :: F3
b1 + :: F9 -> F9 -> F9
+ F9 a2 :: F3
a2 b2 :: F3
b2 = F3 -> F3 -> F9
F9 (F3
a1F3 -> F3 -> F3
forall a. Num a => a -> a -> a
+F3
a2) (F3
b1F3 -> F3 -> F3
forall a. Num a => a -> a -> a
+F3
b2)
    F9 a1 :: F3
a1 b1 :: F3
b1 * :: F9 -> F9 -> F9
* F9 a2 :: F3
a2 b2 :: F3
b2 = F3 -> F3 -> F9
F9 (F3
a1F3 -> F3 -> F3
forall a. Num a => a -> a -> a
*F3
a2F3 -> F3 -> F3
forall a. Num a => a -> a -> a
-F3
b1F3 -> F3 -> F3
forall a. Num a => a -> a -> a
*F3
b2) (F3
a1F3 -> F3 -> F3
forall a. Num a => a -> a -> a
*F3
b2F3 -> F3 -> F3
forall a. Num a => a -> a -> a
+F3
a2F3 -> F3 -> F3
forall a. Num a => a -> a -> a
*F3
b1)
    negate :: F9 -> F9
negate (F9 a :: F3
a b :: F3
b) = F3 -> F3 -> F9
F9 (F3 -> F3
forall a. Num a => a -> a
negate F3
a) (F3 -> F3
forall a. Num a => a -> a
negate F3
b)
    fromInteger :: Integer -> F9
fromInteger n :: Integer
n = F3 -> F3 -> F9
F9 (Integer -> F3
forall a. Num a => Integer -> a
fromInteger Integer
n) 0

f9 :: [F9]
f9 = [F3 -> F3 -> F9
F9 F3
a F3
b | F3
a <- [F3]
f3, F3
b <- [F3]
f3]

w :: F9
w = 1F9 -> F9 -> F9
forall a. Num a => a -> a -> a
-F9
e -- a primitive element - generates the multiplicative group

conj :: F9 -> F9
conj (F9 a :: F3
a b :: F3
b) = F3 -> F3 -> F9
F9 F3
a (-F3
b)
-- This is just the Frobenius aut x -> x^3

norm :: F9 -> F3
norm (F9 a :: F3
a b :: F3
b) = F3
aF3 -> Integer -> F3
forall a b. (Num a, Integral b) => a -> b -> a
^2 F3 -> F3 -> F3
forall a. Num a => a -> a -> a
+ F3
bF3 -> Integer -> F3
forall a b. (Num a, Integral b) => a -> b -> a
^2
-- == x * conj x

instance Fractional F9 where
    recip :: F9 -> F9
recip x :: F9
x@(F9 a :: F3
a b :: F3
b) = F3 -> F3 -> F9
F9 (F3
aF3 -> F3 -> F3
forall a. Fractional a => a -> a -> a
/F3
n) (-F3
bF3 -> F3 -> F3
forall a. Fractional a => a -> a -> a
/F3
n) where n :: F3
n = F9 -> F3
norm F9
x

instance FiniteField F9 where
    basisFq :: F9 -> [F9]
basisFq _ = [1,F9
e]


-- J9, or Q, defined by modifying the multiplication in F9
data J9 = J9 F9 deriving (J9 -> J9 -> Bool
(J9 -> J9 -> Bool) -> (J9 -> J9 -> Bool) -> Eq J9
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: J9 -> J9 -> Bool
$c/= :: J9 -> J9 -> Bool
== :: J9 -> J9 -> Bool
$c== :: J9 -> J9 -> Bool
Eq,Eq J9
Eq J9 =>
(J9 -> J9 -> Ordering)
-> (J9 -> J9 -> Bool)
-> (J9 -> J9 -> Bool)
-> (J9 -> J9 -> Bool)
-> (J9 -> J9 -> Bool)
-> (J9 -> J9 -> J9)
-> (J9 -> J9 -> J9)
-> Ord J9
J9 -> J9 -> Bool
J9 -> J9 -> Ordering
J9 -> J9 -> J9
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
min :: J9 -> J9 -> J9
$cmin :: J9 -> J9 -> J9
max :: J9 -> J9 -> J9
$cmax :: J9 -> J9 -> J9
>= :: J9 -> J9 -> Bool
$c>= :: J9 -> J9 -> Bool
> :: J9 -> J9 -> Bool
$c> :: J9 -> J9 -> Bool
<= :: J9 -> J9 -> Bool
$c<= :: J9 -> J9 -> Bool
< :: J9 -> J9 -> Bool
$c< :: J9 -> J9 -> Bool
compare :: J9 -> J9 -> Ordering
$ccompare :: J9 -> J9 -> Ordering
$cp1Ord :: Eq J9
Ord)

instance Show J9 where
    show :: J9 -> String
show (J9 (F9 0 0)) = "0"
    show (J9 (F9 0 1)) = "-j"
    show (J9 (F9 0 2)) = "j"
    show (J9 (F9 1 0)) = "1"
    show (J9 (F9 1 1)) = "-k"
    show (J9 (F9 1 2)) = "i"
    show (J9 (F9 2 0)) = "-1"
    show (J9 (F9 2 1)) = "-i"
    show (J9 (F9 2 2)) = "k"

squaresF9 :: [F9]
squaresF9 = [1,F9
wF9 -> Integer -> F9
forall a b. (Num a, Integral b) => a -> b -> a
^2,F9
wF9 -> Integer -> F9
forall a b. (Num a, Integral b) => a -> b -> a
^4,F9
wF9 -> Integer -> F9
forall a b. (Num a, Integral b) => a -> b -> a
^6] -- and 0, but not needed here

instance Num J9 where
    J9 x :: F9
x + :: J9 -> J9 -> J9
+ J9 y :: F9
y = F9 -> J9
J9 (F9
xF9 -> F9 -> F9
forall a. Num a => a -> a -> a
+F9
y)
    0 * :: J9 -> J9 -> J9
* _ = 0
    _ * 0 = 0
    J9 x :: F9
x * J9 y :: F9
y =
        if F9
y F9 -> [F9] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [F9]
squaresF9
        then F9 -> J9
J9 (F9
xF9 -> F9 -> F9
forall a. Num a => a -> a -> a
*F9
y)
        else F9 -> J9
J9 (F9 -> F9
conj F9
x F9 -> F9 -> F9
forall a. Num a => a -> a -> a
* F9
y)
    negate :: J9 -> J9
negate (J9 x :: F9
x) = F9 -> J9
J9 (F9 -> F9
forall a. Num a => a -> a
negate F9
x)
    fromInteger :: Integer -> J9
fromInteger n :: Integer
n = F9 -> J9
J9 (Integer -> F9
forall a. Num a => Integer -> a
fromInteger Integer
n)

i :: J9
i = F9 -> J9
J9 F9
w
j :: J9
j = F9 -> J9
J9 (F9
wF9 -> Integer -> F9
forall a b. (Num a, Integral b) => a -> b -> a
^6) -- == i-1
k :: J9
k = F9 -> J9
J9 (F9
wF9 -> Integer -> F9
forall a b. (Num a, Integral b) => a -> b -> a
^7) -- == i+1

j9 :: [J9]
j9 = [F9 -> J9
J9 F9
x | F9
x <- [F9]
f9]


-- the aut of J9 that sends i to x
autJ9 :: J9 -> Permutation J9
autJ9 x :: J9
x = [(J9, J9)] -> Permutation J9
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [ (J9
aJ9 -> J9 -> J9
forall a. Num a => a -> a -> a
+J9
bJ9 -> J9 -> J9
forall a. Num a => a -> a -> a
*J9
i, J9
aJ9 -> J9 -> J9
forall a. Num a => a -> a -> a
+J9
bJ9 -> J9 -> J9
forall a. Num a => a -> a -> a
*J9
x) | J9
a <- [0,1,-1], J9
b <- [1,-1] ]

autA :: Permutation J9
autA = J9 -> Permutation J9
autJ9 (-J9
i) -- sends i -> -i
autB :: Permutation J9
autB = J9 -> Permutation J9
autJ9 (-J9
k) -- sends j -> -j
autC :: Permutation J9
autC = J9 -> Permutation J9
autJ9 (-J9
j) -- sends k -> -k

autsJ9 :: [Permutation J9]
autsJ9 = [Permutation J9
autA, Permutation J9
autC]
-- these two auts generate the group, which is isomorphic to S3
-- indeed, the auts permute the pairs {i,-i}, {j,-j}, {k,-k}


conj' :: J9 -> J9
conj' (J9 x :: F9
x) = F9 -> J9
J9 (F9 -> F9
conj F9
x)
-- Note that conj' x == x .^ autB


isAut :: [a] -> (a -> a) -> Bool
isAut k :: [a]
k sigma :: a -> a
sigma = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [a -> a
sigma a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
sigma a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> a
sigma (a
xa -> a -> a
forall a. Num a => a -> a -> a
+a
y) | a
x <- [a]
k, a
y <- [a]
k]
             Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [a -> a
sigma a
x a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
sigma a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> a
sigma (a
xa -> a -> a
forall a. Num a => a -> a -> a
*a
y) | a
x <- [a]
k, a
y <- [a]
k]


isReal :: a -> Bool
isReal x :: a
x = a
x a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [0,1,-1]
isComplex :: J9 -> Bool
isComplex = Bool -> Bool
not (Bool -> Bool) -> (J9 -> Bool) -> J9 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. J9 -> Bool
forall a. (Eq a, Num a) => a -> Bool
isReal

instance Fractional J9 where
    recip :: J9 -> J9
recip 0 = String -> J9
forall a. HasCallStack => String -> a
error "J9.recip: 0"
    recip x :: J9
x | J9 -> Bool
forall a. (Eq a, Num a) => a -> Bool
isReal J9
x  = J9
x
            | Bool
otherwise = -J9
x

instance FiniteField J9 where
    basisFq :: J9 -> [J9]
basisFq _ = [1,J9
i,J9
j,J9
k]
    eltsFq :: J9 -> [J9]
eltsFq _ = [J9]
j9


-- PROJECTIVE PLANES

ptsPG2 :: [a] -> [[a]]
ptsPG2 r :: [a]
r =  [ [0,0,1] ] [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [ [0,1,a
x] | a
x <- [a]
r ] [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [ [1,a
x,a
y] | a
x <- [a]
r, a
y <- [a]
r ]
-- if r is sorted, then so is the result

orthogonalLinesPG2 :: [[a]] -> [[[a]]]
orthogonalLinesPG2 xs :: [[a]]
xs = [[[a]]] -> [[[a]]]
forall a. Ord a => [a] -> [a]
L.sort [ [[a]
x | [a]
x <- [[a]]
xs, [a]
u [a] -> [a] -> a
forall a. Num a => [a] -> [a] -> a
<.> [a]
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 0] | [a]
u <- [[a]]
xs ]

rightLinesPG2 :: [t] -> [[[t]]]
rightLinesPG2 r :: [t]
r =
    [ [0,0,1] [t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
: [ [0,1,t
x] | t
x <- [t]
r] ] [[[t]]] -> [[[t]]] -> [[[t]]]
forall a. [a] -> [a] -> [a]
++ -- line at infinity
    [ [0,0,1] [t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
: [ [1,t
x,t
y] | t
y <- [t]
r] | t
x <- [t]
r ] [[[t]]] -> [[[t]]] -> [[[t]]]
forall a. [a] -> [a] -> [a]
++ -- vertical lines
    [ [0,1,t
a] [t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
: [ [1,t
x,t
y] | t
x <- [t]
r, t
y <- [t
xt -> t -> t
forall a. Num a => a -> a -> a
*t
at -> t -> t
forall a. Num a => a -> a -> a
+t
b] ] | t
a <- [t]
r, t
b <- [t]
r ] -- slope multiplies on the right
-- if r is sorted, then so is the result, and each line in the result

leftLinesPG2 :: [t] -> [[[t]]]
leftLinesPG2 r :: [t]
r =
    [ [0,0,1] [t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
: [ [0,1,t
x] | t
x <- [t]
r] ] [[[t]]] -> [[[t]]] -> [[[t]]]
forall a. [a] -> [a] -> [a]
++ -- line at infinity
    [ [0,0,1] [t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
: [ [1,t
x,t
y] | t
y <- [t]
r] | t
x <- [t]
r ] [[[t]]] -> [[[t]]] -> [[[t]]]
forall a. [a] -> [a] -> [a]
++ -- vertical lines
    [ [0,1,t
a] [t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
: [ [1,t
x,t
y] | t
x <- [t]
r, t
y <- [t
at -> t -> t
forall a. Num a => a -> a -> a
*t
xt -> t -> t
forall a. Num a => a -> a -> a
+t
b] ] | t
a <- [t]
r, t
b <- [t]
r ] -- slope multiplies on the left


-- Projective plane PG2(F9)
phi :: Design [F9]
phi = ([[F9]], [[[F9]]]) -> Design [F9]
forall a. Ord a => ([a], [[a]]) -> Design a
design ([[F9]]
xs,[[[F9]]]
bs) where
    xs :: [[F9]]
xs = [F9] -> [[F9]]
forall a. Num a => [a] -> [[a]]
ptsPG2 [F9]
f9
    bs :: [[[F9]]]
bs = [[F9]] -> [[[F9]]]
forall a. (Ord a, Num a) => [[a]] -> [[[a]]]
orthogonalLinesPG2 [[F9]]
xs -- L.sort [ [x | x <- xs, u <.> x == 0] | u <- xs ]

-- Then the collineations of phi consist of projective transformations,
-- together with a conjugacy collineation induced by the Frobenius aut

-- alternative construction of PG2(F9) - gives same result
phi' :: Design [F9]
phi' = ([[F9]], [[[F9]]]) -> Design [F9]
forall a. Ord a => ([a], [[a]]) -> Design a
design ([[F9]]
xs,[[[F9]]]
bs) where
    xs :: [[F9]]
xs = [F9] -> [[F9]]
forall a. Num a => [a] -> [[a]]
ptsPG2 [F9]
f9
    bs :: [[[F9]]]
bs = [F9] -> [[[F9]]]
forall t. Num t => [t] -> [[[t]]]
rightLinesPG2 [F9]
f9


collineationsPhi :: [Permutation [F9]]
collineationsPhi = Int -> [F9] -> [Permutation [F9]]
forall k. (FiniteField k, Ord k) => Int -> [k] -> [Permutation [k]]
l 3 [F9]
f9 [Permutation [F9]] -> [Permutation [F9]] -> [Permutation [F9]]
forall a. [a] -> [a] -> [a]
++ [Permutation [F9]
fieldAut] where
    D xs :: [[F9]]
xs bs :: [[[F9]]]
bs = Design [F9]
phi
    fieldAut :: Permutation [F9]
fieldAut = [([F9], [F9])] -> Permutation [F9]
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [ ([F9]
x , (F9 -> F9) -> [F9] -> [F9]
forall a b. (a -> b) -> [a] -> [b]
map F9 -> F9
conj [F9]
x) | [F9]
x <- [[F9]]
xs ]
-- in general, this would be PSigmaL(n,Fq), whereas we want PGammaL(n,Fq). However, for F9 they coincide.
-- order 84913920


liftToGraph :: Design a -> Permutation a -> Permutation (Either a [a])
liftToGraph (D xs :: [a]
xs bs :: [[a]]
bs) g :: Permutation a
g = [(Either a [a], Either a [a])] -> Permutation (Either a [a])
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(Either a [a], Either a [a])] -> Permutation (Either a [a]))
-> [(Either a [a], Either a [a])] -> Permutation (Either a [a])
forall a b. (a -> b) -> a -> b
$ [(a -> Either a [a]
forall a b. a -> Either a b
Left a
x, a -> Either a [a]
forall a b. a -> Either a b
Left (a
x a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
g)) | a
x <- [a]
xs] [(Either a [a], Either a [a])]
-> [(Either a [a], Either a [a])] -> [(Either a [a], Either a [a])]
forall a. [a] -> [a] -> [a]
++ [([a] -> Either a [a]
forall a b. b -> Either a b
Right [a]
b, [a] -> Either a [a]
forall a b. b -> Either a b
Right ([a]
b [a] -> Permutation a -> [a]
forall a. Ord a => [a] -> Permutation a -> [a]
-^ Permutation a
g)) | [a]
b <- [[a]]
bs]



-- This construction appears to produce a projective plane
-- (However, Room & Kirkpatrick point out that it's not really well-defined
-- - if we had chosen different quasi-homogeneous coords, we would have got different results)
-- However, it's not the same as either omega or omegaD below
omega0 :: Design [J9]
omega0 = ([[J9]], [[[J9]]]) -> Design [J9]
forall a. Ord a => ([a], [[a]]) -> Design a
design ([[J9]]
xs,[[[J9]]]
bs) where
    xs :: [[J9]]
xs = [J9] -> [[J9]]
forall a. Num a => [a] -> [[a]]
ptsPG2 [J9]
j9
    bs :: [[[J9]]]
bs = [[J9]] -> [[[J9]]]
forall a. (Ord a, Num a) => [[a]] -> [[[a]]]
orthogonalLinesPG2 [[J9]]
xs -- L.sort [ [x | x <- xs, u <.> x == 0] | u <- xs ]


-- Room & Kirkpatrick, p103
omega :: Design [J9]
omega = ([[J9]], [[[J9]]]) -> Design [J9]
forall a. Ord a => ([a], [[a]]) -> Design a
design ([[J9]]
xs,[[[J9]]]
bs) where
    xs :: [[J9]]
xs = [J9] -> [[J9]]
forall a. Num a => [a] -> [[a]]
ptsPG2 [J9]
j9
    bs :: [[[J9]]]
bs = [J9] -> [[[J9]]]
forall t. Num t => [t] -> [[[t]]]
rightLinesPG2 [J9]
j9

-- another construction that produces same result (but slower)
omega2 :: Design [J9]
omega2 = ([[J9]], [[[J9]]]) -> Design [J9]
forall a. Ord a => ([a], [[a]]) -> Design a
design ([[J9]]
xs,[[[J9]]]
bs) where
    xs :: [[J9]]
xs = [J9] -> [[J9]]
forall a. Num a => [a] -> [[a]]
ptsPG2 [J9]
j9
    bs :: [[[J9]]]
bs =  [ [[J9]]
l | [p :: [J9]
p,q :: [J9]
q] <- Int -> [[J9]] -> [[[J9]]]
forall a. Int -> [a] -> [[a]]
combinationsOf 2 [[J9]]
xs, [[J9]]
l <- [[J9] -> [J9] -> [[J9]]
line [J9]
p [J9]
q], [[J9]
p,[J9]
q] [[J9]] -> [[J9]] -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> [[J9]] -> [[J9]]
forall a. Int -> [a] -> [a]
take 2 [[J9]]
l]
    line :: [J9] -> [J9] -> [[J9]]
line p :: [J9]
p q :: [J9]
q = [[J9]] -> [[J9]]
forall a. Ord a => [a] -> [a]
toListSet ([[J9]] -> [[J9]]) -> [[J9]] -> [[J9]]
forall a b. (a -> b) -> a -> b
$ ([J9] -> Bool) -> [[J9]] -> [[J9]]
forall a. (a -> Bool) -> [a] -> [a]
filter [J9] -> Bool
forall a. (Eq a, Num a) => [a] -> Bool
ispnf [(J9
a J9 -> [J9] -> [J9]
forall a. Num a => a -> [a] -> [a]
*> [J9]
p) [J9] -> [J9] -> [J9]
forall a. Num a => [a] -> [a] -> [a]
<+> (J9
b J9 -> [J9] -> [J9]
forall a. Num a => a -> [a] -> [a]
*> [J9]
q) | J9
a <- [J9]
j9, J9
b <- [J9]
j9]


-- Room & Kirkpatrick, p107, p114
collineationsOmega :: [Permutation [J9]]
collineationsOmega =
    [Permutation [J9]
r]
 [Permutation [J9]] -> [Permutation [J9]] -> [Permutation [J9]]
forall a. [a] -> [a] -> [a]
++ [J9 -> J9 -> Permutation [J9]
s J9
rho J9
sigma | J9
rho <- [J9]
j9 [J9] -> [J9] -> [J9]
forall a. Ord a => [a] -> [a] -> [a]
\\ [0], J9
sigma <- [J9]
j9 [J9] -> [J9] -> [J9]
forall a. Ord a => [a] -> [a] -> [a]
\\ [0], J9
rho J9 -> J9 -> Bool
forall a. Eq a => a -> a -> Bool
== 1 Bool -> Bool -> Bool
|| J9
sigma J9 -> J9 -> Bool
forall a. Eq a => a -> a -> Bool
== 1]
 [Permutation [J9]] -> [Permutation [J9]] -> [Permutation [J9]]
forall a. [a] -> [a] -> [a]
++ [J9 -> J9 -> Permutation [J9]
t J9
delta J9
epsilon | J9
delta <- [J9]
j9, J9
epsilon <- [J9]
j9, J9
delta J9 -> J9 -> J9
forall a. Num a => a -> a -> a
* J9
epsilon J9 -> J9 -> Bool
forall a. Eq a => a -> a -> Bool
== 0] -- for generators sufficient to have only one non-zero
 [Permutation [J9]] -> [Permutation [J9]] -> [Permutation [J9]]
forall a. [a] -> [a] -> [a]
++ [Permutation [J9]
u]
 [Permutation [J9]] -> [Permutation [J9]] -> [Permutation [J9]]
forall a. [a] -> [a] -> [a]
++ [Permutation J9 -> Permutation [J9]
a Permutation J9
lambda | Permutation J9
lambda <- [Permutation J9]
autsJ9] where
    D xs :: [[J9]]
xs bs :: [[[J9]]]
bs = Design [J9]
omega
    fromMatrix :: [[J9]] -> Permutation [J9]
fromMatrix m :: [[J9]]
m = [([J9], [J9])] -> Permutation [J9]
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [ ([J9]
x, [J9] -> [J9]
forall a. (Eq a, Fractional a) => [a] -> [a]
pnf ([J9]
x [J9] -> [[J9]] -> [J9]
forall a. Num a => [a] -> [[a]] -> [a]
<*>> [[J9]]
m)) | [J9]
x <- [[J9]]
xs]
    r :: Permutation [J9]
r = [[J9]] -> Permutation [J9]
fromMatrix [[1,0,0],[0,0,1],[0,1,0]] -- reflect in the line x = y in the affine subplane
    s :: J9 -> J9 -> Permutation [J9]
s rho :: J9
rho sigma :: J9
sigma = [([J9], [J9])] -> Permutation [J9]
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([([J9], [J9])] -> Permutation [J9])
-> [([J9], [J9])] -> Permutation [J9]
forall a b. (a -> b) -> a -> b
$ [([1,J9
x,J9
y], [1,J9
xJ9 -> J9 -> J9
forall a. Num a => a -> a -> a
*J9
rho,J9
yJ9 -> J9 -> J9
forall a. Num a => a -> a -> a
*J9
sigma]) | J9
x <- [J9]
j9, J9
y <- [J9]
j9]
                           [([J9], [J9])] -> [([J9], [J9])] -> [([J9], [J9])]
forall a. [a] -> [a] -> [a]
++ [([0,1,J9
mu],[0,1,(J9 -> J9
forall a. Fractional a => a -> a
recip J9
rho)J9 -> J9 -> J9
forall a. Num a => a -> a -> a
*J9
muJ9 -> J9 -> J9
forall a. Num a => a -> a -> a
*J9
sigma]) | J9
mu <- [J9]
j9]
                           [([J9], [J9])] -> [([J9], [J9])] -> [([J9], [J9])]
forall a. [a] -> [a] -> [a]
++ [([0,0,1],[0,0,1])] -- leaves "Y" fixed
    -- fromMatrix [[1,0,0],[0,rho,0],[0,0,sigma]] -- scale x,y -> rho x, sigma y
    t :: J9 -> J9 -> Permutation [J9]
t delta :: J9
delta epsilon :: J9
epsilon = [[J9]] -> Permutation [J9]
fromMatrix [[1,J9
delta,J9
epsilon],[0,1,0],[0,0,1]] -- translation x,y -> x+delta, y+epsilon
    u :: Permutation [J9]
u = [([J9], [J9])] -> Permutation [J9]
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([([J9], [J9])] -> Permutation [J9])
-> [([J9], [J9])] -> Permutation [J9]
forall a b. (a -> b) -> a -> b
$ [([1,J9
x,J9
y], [1,J9
xJ9 -> J9 -> J9
forall a. Num a => a -> a -> a
+J9
y,J9
xJ9 -> J9 -> J9
forall a. Num a => a -> a -> a
-J9
y]) | J9
x <- [J9]
j9, J9
y <- [J9]
j9]
                           [([J9], [J9])] -> [([J9], [J9])] -> [([J9], [J9])]
forall a. [a] -> [a] -> [a]
++ [([0,1,J9
mu],[0,1,-J9
mu]) | J9
mu <- (J9 -> Bool) -> [J9] -> [J9]
forall a. (a -> Bool) -> [a] -> [a]
filter J9 -> Bool
isComplex [J9]
j9]
                           [([J9], [J9])] -> [([J9], [J9])] -> [([J9], [J9])]
forall a. [a] -> [a] -> [a]
++ [([0,1,0],[0,1,1]), ([0,1,1],[0,1,0]), ([0,1,-1],[0,0,1]), ([0,0,1],[0,1,-1])]
    -- fromMatrix [[1,0,0],[0,1,-1],[0,1,1]]
    a :: Permutation J9 -> Permutation [J9]
a lambda :: Permutation J9
lambda = [([J9], [J9])] -> Permutation [J9]
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [ ([J9]
x, (J9 -> J9) -> [J9] -> [J9]
forall a b. (a -> b) -> [a] -> [b]
map (J9 -> Permutation J9 -> J9
forall a. Ord a => a -> Permutation a -> a
.^ Permutation J9
lambda) [J9]
x) | [J9]
x <- [[J9]]
xs]
-- order 311040
-- (which means this is also the plane constructed in Weibel?)


-- dual plane of omega
omegaD :: Design [J9]
omegaD = ([[J9]], [[[J9]]]) -> Design [J9]
forall a. Ord a => ([a], [[a]]) -> Design a
design ([[J9]]
xs,[[[J9]]]
bs) where
    xs :: [[J9]]
xs = [J9] -> [[J9]]
forall a. Num a => [a] -> [[a]]
ptsPG2 [J9]
j9
    bs :: [[[J9]]]
bs = [J9] -> [[[J9]]]
forall t. Num t => [t] -> [[[t]]]
leftLinesPG2 [J9]
j9

omegaD1 :: Design Integer
omegaD1 = Design [[J9]] -> Design Integer
forall a1 a2. (Num a2, Enum a2, Ord a1) => Design a1 -> Design a2
D.to1n (Design [[J9]] -> Design Integer)
-> Design [[J9]] -> Design Integer
forall a b. (a -> b) -> a -> b
$ Design [J9] -> Design [[J9]]
forall t. Ord t => Design t -> Design [t]
dual Design [J9]
omega
-- need proof omega /~= omegaD

omegaD2 :: Design [J9]
omegaD2 = ([[J9]], [[[J9]]]) -> Design [J9]
forall a. Ord a => ([a], [[a]]) -> Design a
design ([[J9]]
xs,[[[J9]]]
bs) where
    xs :: [[J9]]
xs = [J9] -> [[J9]]
forall a. Num a => [a] -> [[a]]
ptsPG2 [J9]
j9
    bs :: [[[J9]]]
bs =  [ [[J9]]
l | [p :: [J9]
p,q :: [J9]
q] <- Int -> [[J9]] -> [[[J9]]]
forall a. Int -> [a] -> [[a]]
combinationsOf 2 [[J9]]
xs, [[J9]]
l <- [[J9] -> [J9] -> [[J9]]
line [J9]
p [J9]
q], [[J9]
p,[J9]
q] [[J9]] -> [[J9]] -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> [[J9]] -> [[J9]]
forall a. Int -> [a] -> [a]
take 2 [[J9]]
l]
    line :: [J9] -> [J9] -> [[J9]]
line p :: [J9]
p q :: [J9]
q = [[J9]] -> [[J9]]
forall a. Ord a => [a] -> [a]
toListSet ([[J9]] -> [[J9]]) -> [[J9]] -> [[J9]]
forall a b. (a -> b) -> a -> b
$ ([J9] -> Bool) -> [[J9]] -> [[J9]]
forall a. (a -> Bool) -> [a] -> [a]
filter [J9] -> Bool
forall a. (Eq a, Num a) => [a] -> Bool
ispnf [([J9]
p [J9] -> J9 -> [J9]
forall b. Num b => [b] -> b -> [b]
<* J9
a) [J9] -> [J9] -> [J9]
forall a. Num a => [a] -> [a] -> [a]
<+> ([J9]
q [J9] -> J9 -> [J9]
forall b. Num b => [b] -> b -> [b]
<* J9
b) | J9
a <- [J9]
j9, J9
b <- [J9]
j9]

us :: [b]
us <* :: [b] -> b -> [b]
<* x :: b
x = (b -> b) -> [b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b -> b -> b
forall a. Num a => a -> a -> a
*b
x) [b]
us


-- Room and Kirkpatrick p130
psi :: Design [J9]
psi = ([[J9]], [[[J9]]]) -> Design [J9]
forall a. Ord a => ([a], [[a]]) -> Design a
design ([[J9]]
xs,[[[J9]]]
bs) where
    xs :: [[J9]]
xs = [J9] -> [[J9]]
forall a. Num a => [a] -> [[a]]
ptsPG2 [J9]
j9
    isReal :: t a -> Bool
isReal x :: t a
x = (a -> Bool) -> t a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [0,1,-1]) t a
x
    xrs :: [[J9]]
xrs = [J9] -> [[J9]]
forall a. Num a => [a] -> [[a]]
ptsPG2 [0,1,-1] -- the thirteen real points, a copy of PG2(F3) within psi
    bs :: [[[J9]]]
bs = [[[J9]]] -> [[[J9]]]
forall a. Ord a => [a] -> [a]
toListSet [[J9] -> [J9] -> [[J9]]
line [J9]
p [J9]
q | [J9]
p <- [[J9]]
xrs, [J9]
q <- [[J9]]
xs, [J9]
q [J9] -> [J9] -> Bool
forall a. Eq a => a -> a -> Bool
/= [J9]
p]
    line :: [J9] -> [J9] -> [[J9]]
line p :: [J9]
p q :: [J9]
q = [[J9]] -> [[J9]]
forall a. Ord a => [a] -> [a]
L.sort ([[J9]] -> [[J9]]) -> [[J9]] -> [[J9]]
forall a b. (a -> b) -> a -> b
$ [J9]
p [J9] -> [[J9]] -> [[J9]]
forall a. a -> [a] -> [a]
: [[J9] -> [J9]
forall a. (Eq a, Fractional a) => [a] -> [a]
pnf ( ([J9]
p [J9] -> J9 -> [J9]
forall b. Num b => [b] -> b -> [b]
<* J9
a) [J9] -> [J9] -> [J9]
forall a. Num a => [a] -> [a] -> [a]
<+> [J9]
q) | J9
a <- [J9]
j9]


-- Room & Kirkpatrick p137
psi2 :: Design [J9]
psi2 = ([[J9]], [[[J9]]]) -> Design [J9]
forall a. Ord a => ([a], [[a]]) -> Design a
design ([[J9]]
xs,[[[J9]]]
bs) where
    xs :: [[J9]]
xs = [J9] -> [[J9]]
forall a. Num a => [a] -> [[a]]
ptsPG2 [J9]
j9
    bs :: [[[J9]]]
bs = [[[J9]]] -> [[[J9]]]
forall a. Ord a => [a] -> [a]
L.sort ([[[J9]]] -> [[[J9]]]) -> [[[J9]]] -> [[[J9]]]
forall a b. (a -> b) -> a -> b
$
         [ [0,0,1] [J9] -> [[J9]] -> [[J9]]
forall a. a -> [a] -> [a]
: [ [0,1,J9
x] | J9
x <- [J9]
j9] ] [[[J9]]] -> [[[J9]]] -> [[[J9]]]
forall a. [a] -> [a] -> [a]
++ -- line at infinity, z=0
         [ [0,0,1] [J9] -> [[J9]] -> [[J9]]
forall a. a -> [a] -> [a]
: [ [1,J9
kappa,J9
y] | J9
y <- [J9]
j9] | J9
kappa <- [J9]
j9 ] [[[J9]]] -> [[[J9]]] -> [[[J9]]]
forall a. [a] -> [a] -> [a]
++ -- vertical lines x = kappa
         [ [0,1,J9
m] [J9] -> [[J9]] -> [[J9]]
forall a. a -> [a] -> [a]
: [ [1,J9
x,J9
mJ9 -> J9 -> J9
forall a. Num a => a -> a -> a
*J9
xJ9 -> J9 -> J9
forall a. Num a => a -> a -> a
+J9
kappa] | J9
x <- [J9]
j9 ] | J9
m <- [0,1,-1], J9
kappa <- [J9]
j9 ] [[[J9]]] -> [[[J9]]] -> [[[J9]]]
forall a. [a] -> [a] -> [a]
++ -- lines with real slope
         [ [0,1,J9
kappa] [J9] -> [[J9]] -> [[J9]]
forall a. a -> [a] -> [a]
: [ [1,J9
x,J9
kappaJ9 -> J9 -> J9
forall a. Num a => a -> a -> a
*(J9
xJ9 -> J9 -> J9
forall a. Num a => a -> a -> a
-J9
r)J9 -> J9 -> J9
forall a. Num a => a -> a -> a
+J9
s] | J9
x <- [J9]
j9 ] | J9
r <- [0,1,-1], J9
s <- [0,1,-1], J9
kappa <- [J9]
j9 [J9] -> [J9] -> [J9]
forall a. Ord a => [a] -> [a] -> [a]
\\ [0,1,-1] ]
         -- lines with complex slope

-- Room & Kirkpatrick p134-6
collineationsPsi :: [Permutation [J9]]
collineationsPsi = [Permutation [J9]]
realProjectivities -- real transvections, generating real projectivities
                [Permutation [J9]] -> [Permutation [J9]] -> [Permutation [J9]]
forall a. [a] -> [a] -> [a]
++ [Permutation J9 -> Permutation [J9]
a Permutation J9
lambda | Permutation J9
lambda <- [Permutation J9]
autsJ9] where
    D xs :: [[J9]]
xs bs :: [[[J9]]]
bs = Design [J9]
psi
    n :: Integer
n = 3
    realTransvections :: [[[J9]]]
realTransvections = [Integer -> (Integer, Integer) -> J9 -> [[J9]]
forall b a.
(Enum b, Eq b, Num b, Num a) =>
b -> (b, b) -> a -> [[a]]
elemTransvection Integer
n (Integer
r,Integer
c) J9
l | Integer
r <- [1..Integer
n], Integer
c <- [1..Integer
n], Integer
r Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
c, J9
l <- [1]]
    realProjectivities :: [Permutation [J9]]
realProjectivities = [[([J9], [J9])] -> Permutation [J9]
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([([J9], [J9])] -> Permutation [J9])
-> [([J9], [J9])] -> Permutation [J9]
forall a b. (a -> b) -> a -> b
$ [([J9]
x, [J9] -> [J9]
forall a. (Eq a, Fractional a) => [a] -> [a]
pnf ([J9]
x [J9] -> [[J9]] -> [J9]
forall a. Num a => [a] -> [[a]] -> [a]
<*>> [[J9]]
m)) | [J9]
x <- [[J9]]
xs] | [[J9]]
m <- [[[J9]]]
realTransvections]
    a :: Permutation J9 -> Permutation [J9]
a lambda :: Permutation J9
lambda = [([J9], [J9])] -> Permutation [J9]
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [ ([J9]
x, (J9 -> J9) -> [J9] -> [J9]
forall a b. (a -> b) -> [a] -> [b]
map (J9 -> Permutation J9 -> J9
forall a. Ord a => a -> Permutation a -> a
.^ Permutation J9
lambda) [J9]
x) | [J9]
x <- [[J9]]
xs]
-- order 33696


-- The order of a projective plane
order :: Design a -> Int
order (D xs :: [a]
xs bs :: [[a]]
bs) = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[a]] -> [a]
forall a. [a] -> a
head [[a]]
bs) Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1

isProjectivePlane :: Design a -> Bool
isProjectivePlane pi :: Design a
pi = Design a -> Maybe (Int, (Int, Int, Int))
forall a. Eq a => Design a -> Maybe (Int, (Int, Int, Int))
designParams Design a
pi Maybe (Int, (Int, Int, Int))
-> Maybe (Int, (Int, Int, Int)) -> Bool
forall a. Eq a => a -> a -> Bool
== (Int, (Int, Int, Int)) -> Maybe (Int, (Int, Int, Int))
forall a. a -> Maybe a
Just (2,(Int
qInt -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^2Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
+1,Int
q,1))
    where q :: Int
q = Design a -> Int
forall a. Design a -> Int
order Design a
pi


collinear :: Design a -> t a -> Bool
collinear (D xs :: [a]
xs bs :: [[a]]
bs) ys :: t a
ys = (Bool -> Bool
not (Bool -> Bool) -> ([[a]] -> Bool) -> [[a]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[a]
b | [a]
b <- [[a]]
bs, (a -> Bool) -> t a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
b) t a
ys]

-- assume p1..4 are distinct
isQuadrangle :: Design a -> [a] -> Bool
isQuadrangle plane :: Design a
plane ps :: [a]
ps@[p1 :: a
p1,p2 :: a
p2,p3 :: a
p3,p4 :: a
p4] =
    ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Design a -> [a] -> Bool
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
Design a -> t a -> Bool
collinear Design a
plane) (Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
combinationsOf 3 [a]
ps)


concurrent :: Design a -> t (t a) -> Bool
concurrent (D xs :: [a]
xs bs :: [[a]]
bs) ls :: t (t a)
ls = (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [a
x | a
x <- [a]
xs, (t a -> Bool) -> t (t a) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a
x a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) t (t a)
ls]

isQuadrilateral :: Design a -> [t a] -> Bool
isQuadrilateral plane :: Design a
plane ls :: [t a]
ls@[l1 :: t a
l1,l2 :: t a
l2,l3 :: t a
l3,l4 :: t a
l4] =
    ([t a] -> Bool) -> [[t a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> ([t a] -> Bool) -> [t a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Design a -> [t a] -> Bool
forall (t :: * -> *) (t :: * -> *) a.
(Foldable t, Foldable t, Eq a) =>
Design a -> t (t a) -> Bool
concurrent Design a
plane) (Int -> [t a] -> [[t a]]
forall a. Int -> [a] -> [[a]]
combinationsOf 3 [t a]
ls)


isOval :: Design a -> [a] -> Bool
isOval pi :: Design a
pi ps :: [a]
ps = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Design a -> Int
forall a. Design a -> Int
order Design a
piInt -> Int -> Int
forall a. Num a => a -> a -> a
+1
            Bool -> Bool -> Bool
&& ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Design a -> [a] -> Bool
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
Design a -> t a -> Bool
collinear Design a
pi) (Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
combinationsOf 3 [a]
ps)

findOvals1 :: Design a -> [[a]]
findOvals1 pi :: Design a
pi = Int -> ([a], [a]) -> [[a]]
findOvals' 0 ([], Design a -> [a]
forall a. Design a -> [a]
points Design a
pi) where
    n :: Int
n = Design a -> Int
forall a. Design a -> Int
order Design a
pi
    findOvals' :: Int -> ([a], [a]) -> [[a]]
findOvals' i :: Int
i (ls :: [a]
ls,rs :: [a]
rs)
        | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1 = [[a] -> [a]
forall a. [a] -> [a]
reverse [a]
ls]
        | Bool
otherwise = (([a], [a]) -> [[a]]) -> [([a], [a])] -> [[a]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> ([a], [a]) -> [[a]]
findOvals' (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1))
                      [ (a
ra -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ls, [a]
rs') | r :: a
r:rs' :: [a]
rs' <- [a] -> [[a]]
forall a. [a] -> [[a]]
L.tails [a]
rs, ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Design a -> [a] -> Bool
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
Design a -> t a -> Bool
collinear Design a
pi) (([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
ra -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
combinationsOf 2 [a]
ls)) ]
-- if we have a function to quickly generate the line through two points,
-- then we just need to see whether the third point is on it, which is much faster than testing collinearity

findQuadrangles :: Design a -> [[a]]
findQuadrangles pi :: Design a
pi = Integer -> ([a], [a]) -> [[a]]
forall t. (Num t, Eq t) => t -> ([a], [a]) -> [[a]]
findQuadrangles' 0 ([], Design a -> [a]
forall a. Design a -> [a]
points Design a
pi) where
    findQuadrangles' :: t -> ([a], [a]) -> [[a]]
findQuadrangles' i :: t
i (ls :: [a]
ls,rs :: [a]
rs)
        | t
i t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== 4 = [[a] -> [a]
forall a. [a] -> [a]
reverse [a]
ls]
        | Bool
otherwise = (([a], [a]) -> [[a]]) -> [([a], [a])] -> [[a]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (t -> ([a], [a]) -> [[a]]
findQuadrangles' (t
it -> t -> t
forall a. Num a => a -> a -> a
+1))
                      [ (a
ra -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ls, [a]
rs') | r :: a
r:rs' :: [a]
rs' <- [a] -> [[a]]
forall a. [a] -> [[a]]
L.tails [a]
rs, ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Design a -> [a] -> Bool
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
Design a -> t a -> Bool
collinear Design a
pi) (([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
ra -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
combinationsOf 2 [a]
ls)) ]


findOvals :: Design a -> [[a]]
findOvals pi :: Design a
pi@(D xs :: [a]
xs bs :: [[a]]
bs) = Int -> ([a], [a]) -> [[a]] -> [[a]]
forall a. Ord a => Int -> ([a], [a]) -> [[a]] -> [[a]]
findOvals' 0 ([],[a]
xs) [[a]]
bs where
    n :: Int
n = Design a -> Int
forall a. Design a -> Int
order Design a
pi
    findOvals' :: Int -> ([a], [a]) -> [[a]] -> [[a]]
findOvals' i :: Int
i (ls :: [a]
ls,rs :: [a]
rs) bs :: [[a]]
bs
        | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1 = [[a] -> [a]
forall a. [a] -> [a]
reverse [a]
ls]
        | Bool
otherwise = [[[a]]] -> [[a]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                      [let rls :: [a]
rls = [a] -> [a]
forall a. [a] -> [a]
reverse (a
ra -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ls)
                           (notchords :: [[a]]
notchords, chords :: [[a]]
chords) = ([a] -> Bool) -> [[a]] -> ([[a]], [[a]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (\b :: [a]
b -> [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a]
rls [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
`LS.intersect` [a]
b) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2) [[a]]
bs
                           rs'' :: [a]
rs'' = ([a] -> [a] -> [a]) -> [a] -> [[a]] -> [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
(\\) [a]
rs' [[a]]
chords
                           -- if any line is already a chord, remove remaining points on it from further consideration
                       in Int -> ([a], [a]) -> [[a]] -> [[a]]
findOvals' (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) (a
ra -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ls, [a]
rs'') [[a]]
notchords
                       | r :: a
r:rs' :: [a]
rs' <- [a] -> [[a]]
forall a. [a] -> [[a]]
L.tails [a]
rs]

-- Todo:
-- Code that shows that phi is Desarguesian, and omega, omegaD and psi are not
{-
-- !! NOT WORKING
-- finds apparent counterexamples in phi too
findNonDesarguesian pi@(D xs bs) =
    [ [p,x,y,z,x',y',z',k,l,m] | p <- xs,
                                 x <- xs \\ [p],
                                 y <- xs \\ [p,x],
                                 z <- xs \\ [p,x,y],
                                 (not . collinear pi) [x,y,z],
                                 x' <- line p x \\ L.sort [p,x],
                                 y' <- line p y \\ L.sort [p,y],
                                 z' <- line p z \\ L.sort [p,z],
                                 (not . collinear pi) [x',y',z'],
                                 k <- line x y `intersect` line x' y', -- will only have one element
                                 l <- line x z `intersect` line x' z',
                                 m <- line y z `intersect` line y' z',
                                 (not . collinear pi) [k,l,m]  ]
    where line p q = head [b | b <- bs, p `elem` b, q `elem` b]
-}