--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.Combinatorial.Util
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Some basic types, mostly strict triples and pairs.
--
--------------------------------------------------------------------------------
module HGeometry.Combinatorial.Util where

import           Control.DeepSeq
import           Control.Lens
import qualified Data.Foldable as F
import qualified Data.List as List
import           GHC.Generics (Generic)
import           Linear.V2 (V2(..))
import           Linear.V3 (V3(..))

--------------------------------------------------------------------------------
-- * Strict Triples

-- |  strict triple
data STR a b c = STR !a !b !c deriving (Int -> STR a b c -> ShowS
[STR a b c] -> ShowS
STR a b c -> String
(Int -> STR a b c -> ShowS)
-> (STR a b c -> String)
-> ([STR a b c] -> ShowS)
-> Show (STR a b c)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b c. (Show a, Show b, Show c) => Int -> STR a b c -> ShowS
forall a b c. (Show a, Show b, Show c) => [STR a b c] -> ShowS
forall a b c. (Show a, Show b, Show c) => STR a b c -> String
$cshowsPrec :: forall a b c. (Show a, Show b, Show c) => Int -> STR a b c -> ShowS
showsPrec :: Int -> STR a b c -> ShowS
$cshow :: forall a b c. (Show a, Show b, Show c) => STR a b c -> String
show :: STR a b c -> String
$cshowList :: forall a b c. (Show a, Show b, Show c) => [STR a b c] -> ShowS
showList :: [STR a b c] -> ShowS
Show,STR a b c -> STR a b c -> Bool
(STR a b c -> STR a b c -> Bool)
-> (STR a b c -> STR a b c -> Bool) -> Eq (STR a b c)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b c. (Eq a, Eq b, Eq c) => STR a b c -> STR a b c -> Bool
$c== :: forall a b c. (Eq a, Eq b, Eq c) => STR a b c -> STR a b c -> Bool
== :: STR a b c -> STR a b c -> Bool
$c/= :: forall a b c. (Eq a, Eq b, Eq c) => STR a b c -> STR a b c -> Bool
/= :: STR a b c -> STR a b c -> Bool
Eq,Eq (STR a b c)
Eq (STR a b c) =>
(STR a b c -> STR a b c -> Ordering)
-> (STR a b c -> STR a b c -> Bool)
-> (STR a b c -> STR a b c -> Bool)
-> (STR a b c -> STR a b c -> Bool)
-> (STR a b c -> STR a b c -> Bool)
-> (STR a b c -> STR a b c -> STR a b c)
-> (STR a b c -> STR a b c -> STR a b c)
-> Ord (STR a b c)
STR a b c -> STR a b c -> Bool
STR a b c -> STR a b c -> Ordering
STR a b c -> STR a b c -> STR a b c
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 b c. (Ord a, Ord b, Ord c) => Eq (STR a b c)
forall a b c.
(Ord a, Ord b, Ord c) =>
STR a b c -> STR a b c -> Bool
forall a b c.
(Ord a, Ord b, Ord c) =>
STR a b c -> STR a b c -> Ordering
forall a b c.
(Ord a, Ord b, Ord c) =>
STR a b c -> STR a b c -> STR a b c
$ccompare :: forall a b c.
(Ord a, Ord b, Ord c) =>
STR a b c -> STR a b c -> Ordering
compare :: STR a b c -> STR a b c -> Ordering
$c< :: forall a b c.
(Ord a, Ord b, Ord c) =>
STR a b c -> STR a b c -> Bool
< :: STR a b c -> STR a b c -> Bool
$c<= :: forall a b c.
(Ord a, Ord b, Ord c) =>
STR a b c -> STR a b c -> Bool
<= :: STR a b c -> STR a b c -> Bool
$c> :: forall a b c.
(Ord a, Ord b, Ord c) =>
STR a b c -> STR a b c -> Bool
> :: STR a b c -> STR a b c -> Bool
$c>= :: forall a b c.
(Ord a, Ord b, Ord c) =>
STR a b c -> STR a b c -> Bool
>= :: STR a b c -> STR a b c -> Bool
$cmax :: forall a b c.
(Ord a, Ord b, Ord c) =>
STR a b c -> STR a b c -> STR a b c
max :: STR a b c -> STR a b c -> STR a b c
$cmin :: forall a b c.
(Ord a, Ord b, Ord c) =>
STR a b c -> STR a b c -> STR a b c
min :: STR a b c -> STR a b c -> STR a b c
Ord,(forall a b. (a -> b) -> STR a b a -> STR a b b)
-> (forall a b. a -> STR a b b -> STR a b a) -> Functor (STR a b)
forall a b. a -> STR a b b -> STR a b a
forall a b. (a -> b) -> STR a b a -> STR a b b
forall a b a b. a -> STR a b b -> STR a b a
forall a b a b. (a -> b) -> STR a b a -> STR a b b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b a b. (a -> b) -> STR a b a -> STR a b b
fmap :: forall a b. (a -> b) -> STR a b a -> STR a b b
$c<$ :: forall a b a b. a -> STR a b b -> STR a b a
<$ :: forall a b. a -> STR a b b -> STR a b a
Functor,(forall x. STR a b c -> Rep (STR a b c) x)
-> (forall x. Rep (STR a b c) x -> STR a b c)
-> Generic (STR a b c)
forall x. Rep (STR a b c) x -> STR a b c
forall x. STR a b c -> Rep (STR a b c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b c x. Rep (STR a b c) x -> STR a b c
forall a b c x. STR a b c -> Rep (STR a b c) x
$cfrom :: forall a b c x. STR a b c -> Rep (STR a b c) x
from :: forall x. STR a b c -> Rep (STR a b c) x
$cto :: forall a b c x. Rep (STR a b c) x -> STR a b c
to :: forall x. Rep (STR a b c) x -> STR a b c
Generic)

instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (STR a b c) where
  (STR a
a b
b c
c) <> :: STR a b c -> STR a b c -> STR a b c
<> (STR a
d b
e c
f) = a -> b -> c -> STR a b c
forall a b c. a -> b -> c -> STR a b c
STR (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
d) (b
b b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
e) (c
c c -> c -> c
forall a. Semigroup a => a -> a -> a
<> c
f)

instance (Semigroup a, Semigroup b, Semigroup c
         , Monoid a, Monoid b, Monoid c) => Monoid (STR a b c) where
  mempty :: STR a b c
mempty = a -> b -> c -> STR a b c
forall a b c. a -> b -> c -> STR a b c
STR a
forall a. Monoid a => a
mempty b
forall a. Monoid a => a
mempty c
forall a. Monoid a => a
mempty
  mappend :: STR a b c -> STR a b c -> STR a b c
mappend = STR a b c -> STR a b c -> STR a b c
forall a. Semigroup a => a -> a -> a
(<>)

instance (NFData a, NFData b, NFData c) => NFData (STR a b c)

instance Field1 (STR a b c) (STR d b c) a d where
  _1 :: Lens (STR a b c) (STR d b c) a d
_1 = (STR a b c -> a)
-> (STR a b c -> d -> STR d b c)
-> Lens (STR a b c) (STR d b c) a d
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(STR a
a b
_ c
_) -> a
a) (\(STR a
_ b
b c
c) d
d -> d -> b -> c -> STR d b c
forall a b c. a -> b -> c -> STR a b c
STR d
d b
b c
c)

instance Field2 (STR a b c) (STR a d c) b d where
  _2 :: Lens (STR a b c) (STR a d c) b d
_2 = (STR a b c -> b)
-> (STR a b c -> d -> STR a d c)
-> Lens (STR a b c) (STR a d c) b d
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(STR a
_ b
b c
_) -> b
b) (\(STR a
a b
_ c
c) d
d -> a -> d -> c -> STR a d c
forall a b c. a -> b -> c -> STR a b c
STR a
a d
d c
c)

instance Field3 (STR a b c) (STR a b d) c d where
  _3 :: Lens (STR a b c) (STR a b d) c d
_3 = (STR a b c -> c)
-> (STR a b c -> d -> STR a b d)
-> Lens (STR a b c) (STR a b d) c d
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(STR a
_ b
_ c
c) -> c
c) (\(STR a
a b
b c
_) d
d -> a -> b -> d -> STR a b d
forall a b c. a -> b -> c -> STR a b c
STR a
a b
b d
d)

--------------------------------------------------------------------------------

--------------------------------------------------------------------------------
-- | Strict Triple with all items the same
type Three = V3

-- | Pattern synonym for strict triples.
pattern Three :: a -> a -> a -> Three a
pattern $bThree :: forall a. a -> a -> a -> Three a
$mThree :: forall {r} {a}. Three a -> (a -> a -> a -> r) -> ((# #) -> r) -> r
Three a b c = V3 a b c
{-# COMPLETE Three #-}

-- | Generate All unique unordered triplets.
--
-- >>> mapM_ print $ uniqueTriplets "abcd"
-- V3 'a' 'b' 'c'
-- V3 'a' 'b' 'd'
-- V3 'a' 'c' 'd'
-- V3 'b' 'c' 'd'
uniqueTriplets                  :: Foldable f => f a -> [Three a]
uniqueTriplets :: forall (f :: * -> *) a. Foldable f => f a -> [Three a]
uniqueTriplets (f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList -> [a]
xs) =
  [ a -> a -> a -> Three a
forall a. a -> a -> a -> Three a
Three a
x a
y a
z | (a
x:[a]
ys) <- [a] -> [[a]]
forall a. [a] -> [[a]]
nonEmptyTails [a]
xs, Two a
y a
z <- [a] -> [Two a]
forall (f :: * -> *) a. Foldable f => f a -> [Two a]
uniquePairs [a]
ys]

--------------------------------------------------------------------------------
-- * Strict Pairs


-- | Strict pair
data SP a b = SP !a !b deriving (Int -> SP a b -> ShowS
[SP a b] -> ShowS
SP a b -> String
(Int -> SP a b -> ShowS)
-> (SP a b -> String) -> ([SP a b] -> ShowS) -> Show (SP a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> SP a b -> ShowS
forall a b. (Show a, Show b) => [SP a b] -> ShowS
forall a b. (Show a, Show b) => SP a b -> String
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> SP a b -> ShowS
showsPrec :: Int -> SP a b -> ShowS
$cshow :: forall a b. (Show a, Show b) => SP a b -> String
show :: SP a b -> String
$cshowList :: forall a b. (Show a, Show b) => [SP a b] -> ShowS
showList :: [SP a b] -> ShowS
Show,SP a b -> SP a b -> Bool
(SP a b -> SP a b -> Bool)
-> (SP a b -> SP a b -> Bool) -> Eq (SP a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => SP a b -> SP a b -> Bool
$c== :: forall a b. (Eq a, Eq b) => SP a b -> SP a b -> Bool
== :: SP a b -> SP a b -> Bool
$c/= :: forall a b. (Eq a, Eq b) => SP a b -> SP a b -> Bool
/= :: SP a b -> SP a b -> Bool
Eq,Eq (SP a b)
Eq (SP a b) =>
(SP a b -> SP a b -> Ordering)
-> (SP a b -> SP a b -> Bool)
-> (SP a b -> SP a b -> Bool)
-> (SP a b -> SP a b -> Bool)
-> (SP a b -> SP a b -> Bool)
-> (SP a b -> SP a b -> SP a b)
-> (SP a b -> SP a b -> SP a b)
-> Ord (SP a b)
SP a b -> SP a b -> Bool
SP a b -> SP a b -> Ordering
SP a b -> SP a b -> SP a b
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 b. (Ord a, Ord b) => Eq (SP a b)
forall a b. (Ord a, Ord b) => SP a b -> SP a b -> Bool
forall a b. (Ord a, Ord b) => SP a b -> SP a b -> Ordering
forall a b. (Ord a, Ord b) => SP a b -> SP a b -> SP a b
$ccompare :: forall a b. (Ord a, Ord b) => SP a b -> SP a b -> Ordering
compare :: SP a b -> SP a b -> Ordering
$c< :: forall a b. (Ord a, Ord b) => SP a b -> SP a b -> Bool
< :: SP a b -> SP a b -> Bool
$c<= :: forall a b. (Ord a, Ord b) => SP a b -> SP a b -> Bool
<= :: SP a b -> SP a b -> Bool
$c> :: forall a b. (Ord a, Ord b) => SP a b -> SP a b -> Bool
> :: SP a b -> SP a b -> Bool
$c>= :: forall a b. (Ord a, Ord b) => SP a b -> SP a b -> Bool
>= :: SP a b -> SP a b -> Bool
$cmax :: forall a b. (Ord a, Ord b) => SP a b -> SP a b -> SP a b
max :: SP a b -> SP a b -> SP a b
$cmin :: forall a b. (Ord a, Ord b) => SP a b -> SP a b -> SP a b
min :: SP a b -> SP a b -> SP a b
Ord,(forall a b. (a -> b) -> SP a a -> SP a b)
-> (forall a b. a -> SP a b -> SP a a) -> Functor (SP a)
forall a b. a -> SP a b -> SP a a
forall a b. (a -> b) -> SP a a -> SP a b
forall a a b. a -> SP a b -> SP a a
forall a a b. (a -> b) -> SP a a -> SP a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a a b. (a -> b) -> SP a a -> SP a b
fmap :: forall a b. (a -> b) -> SP a a -> SP a b
$c<$ :: forall a a b. a -> SP a b -> SP a a
<$ :: forall a b. a -> SP a b -> SP a a
Functor,(forall x. SP a b -> Rep (SP a b) x)
-> (forall x. Rep (SP a b) x -> SP a b) -> Generic (SP a b)
forall x. Rep (SP a b) x -> SP a b
forall x. SP a b -> Rep (SP a b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (SP a b) x -> SP a b
forall a b x. SP a b -> Rep (SP a b) x
$cfrom :: forall a b x. SP a b -> Rep (SP a b) x
from :: forall x. SP a b -> Rep (SP a b) x
$cto :: forall a b x. Rep (SP a b) x -> SP a b
to :: forall x. Rep (SP a b) x -> SP a b
Generic)

instance (Semigroup a, Semigroup b) => Semigroup (SP a b) where
  (SP a
a b
b) <> :: SP a b -> SP a b -> SP a b
<> (SP a
c b
d) = a -> b -> SP a b
forall a b. a -> b -> SP a b
SP (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
c) (b
b b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
d)

instance (Semigroup a, Semigroup b, Monoid a, Monoid b) => Monoid (SP a b) where
  mempty :: SP a b
mempty = a -> b -> SP a b
forall a b. a -> b -> SP a b
SP a
forall a. Monoid a => a
mempty b
forall a. Monoid a => a
mempty
  mappend :: SP a b -> SP a b -> SP a b
mappend = SP a b -> SP a b -> SP a b
forall a. Semigroup a => a -> a -> a
(<>)

instance (NFData a, NFData b) => NFData (SP a b)


instance Field1 (SP a b) (SP c b) a c where
  _1 :: Lens (SP a b) (SP c b) a c
_1 = (SP a b -> a)
-> (SP a b -> c -> SP c b) -> Lens (SP a b) (SP c b) a c
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(SP a
a b
_) -> a
a) (\(SP a
_ b
b) c
c -> c -> b -> SP c b
forall a b. a -> b -> SP a b
SP c
c b
b)

instance Field2 (SP a b) (SP a c) b c where
  _2 :: Lens (SP a b) (SP a c) b c
_2 = (SP a b -> b)
-> (SP a b -> c -> SP a c) -> Lens (SP a b) (SP a c) b c
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(SP a
_ b
b) -> b
b) (\(SP a
a b
_) c
c -> a -> c -> SP a c
forall a b. a -> b -> SP a b
SP a
a c
c)

instance Bifunctor SP where
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> SP a c -> SP b d
bimap a -> b
f c -> d
g (SP a
a c
b) = b -> d -> SP b d
forall a b. a -> b -> SP a b
SP (a -> b
f a
a) (c -> d
g c
b)

--------------------------------------------------------------------------------
-- | * Strict pair whose elements are of the same type.

-- | Strict pair with both items the same
type Two = V2

-- | Pattern synonym for strict pairs.
pattern Two :: a -> a -> Two a
pattern $bTwo :: forall a. a -> a -> Two a
$mTwo :: forall {r} {a}. Two a -> (a -> a -> r) -> ((# #) -> r) -> r
Two a b = V2 a b
{-# COMPLETE Two #-}

-- | Given a list xs, generate all unique (unordered) pairs.
--
-- >>> mapM_ print $ uniquePairs "abcde"
-- V2 'a' 'b'
-- V2 'a' 'c'
-- V2 'a' 'd'
-- V2 'a' 'e'
-- V2 'b' 'c'
-- V2 'b' 'd'
-- V2 'b' 'e'
-- V2 'c' 'd'
-- V2 'c' 'e'
-- V2 'd' 'e'
uniquePairs                  :: Foldable f => f a -> [Two a]
uniquePairs :: forall (f :: * -> *) a. Foldable f => f a -> [Two a]
uniquePairs (f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList -> [a]
xs) = [ a -> a -> Two a
forall a. a -> a -> Two a
Two a
x a
y | (a
x:[a]
ys) <- [a] -> [[a]]
forall a. [a] -> [[a]]
nonEmptyTails [a]
xs, a
y <- [a]
ys ]

--------------------------------------------------------------------------------

-- | A version of List.tails in which we remove the emptylist
nonEmptyTails :: [a] -> [[a]]
nonEmptyTails :: forall a. [a] -> [[a]]
nonEmptyTails = [[a]] -> [[a]]
forall a. HasCallStack => [a] -> [a]
List.init ([[a]] -> [[a]]) -> ([a] -> [[a]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]]
forall a. [a] -> [[a]]
List.tails