{-# LANGUAGE DeriveGeneric #-}

-- |
-- Copyright   : Anders Claesson 2014-2016
-- Maintainer  : Anders Claesson <anders.claesson@gmail.com>
--

-- TODO: Generalize interface and share with Sym.Perm.Pattern

module Sym.Perm.MeshPattern
    ( MeshPattern (..)
    , Mesh
    , Box
    , mkPattern
    , pattern
    , mesh
    , cols
    , rows
    , col
    , row
    , box
    , copiesOf
    , contains
    , avoids
    , avoidsAll
    , avoiders
    , kVincular
    , vincular
    , bivincular
    , meshPatterns
    ) where

import Data.List hiding (union)
import Sym.Internal.Size
import Sym.Perm
import Sym.Internal.SubSeq
import Data.Set (Set)
import qualified Data.Set as Set
import Sym.Internal.Util

-- | A mesh is a, possibly empty, set of shaded boxes.
type Mesh = Set Box

-- | A box is represented by the coordinates of its southwest corner.
type Box  = (Int, Int)

type Point = (Int, Int)
type PermTwoLine = [Point]

data MeshPattern = MP
    { MeshPattern -> Perm
getPerm :: Perm
    , MeshPattern -> Mesh
getMesh :: Mesh
    } deriving (Int -> MeshPattern -> ShowS
[MeshPattern] -> ShowS
MeshPattern -> String
(Int -> MeshPattern -> ShowS)
-> (MeshPattern -> String)
-> ([MeshPattern] -> ShowS)
-> Show MeshPattern
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MeshPattern -> ShowS
showsPrec :: Int -> MeshPattern -> ShowS
$cshow :: MeshPattern -> String
show :: MeshPattern -> String
$cshowList :: [MeshPattern] -> ShowS
showList :: [MeshPattern] -> ShowS
Show, MeshPattern -> MeshPattern -> Bool
(MeshPattern -> MeshPattern -> Bool)
-> (MeshPattern -> MeshPattern -> Bool) -> Eq MeshPattern
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MeshPattern -> MeshPattern -> Bool
== :: MeshPattern -> MeshPattern -> Bool
$c/= :: MeshPattern -> MeshPattern -> Bool
/= :: MeshPattern -> MeshPattern -> Bool
Eq, Eq MeshPattern
Eq MeshPattern =>
(MeshPattern -> MeshPattern -> Ordering)
-> (MeshPattern -> MeshPattern -> Bool)
-> (MeshPattern -> MeshPattern -> Bool)
-> (MeshPattern -> MeshPattern -> Bool)
-> (MeshPattern -> MeshPattern -> Bool)
-> (MeshPattern -> MeshPattern -> MeshPattern)
-> (MeshPattern -> MeshPattern -> MeshPattern)
-> Ord MeshPattern
MeshPattern -> MeshPattern -> Bool
MeshPattern -> MeshPattern -> Ordering
MeshPattern -> MeshPattern -> MeshPattern
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
$ccompare :: MeshPattern -> MeshPattern -> Ordering
compare :: MeshPattern -> MeshPattern -> Ordering
$c< :: MeshPattern -> MeshPattern -> Bool
< :: MeshPattern -> MeshPattern -> Bool
$c<= :: MeshPattern -> MeshPattern -> Bool
<= :: MeshPattern -> MeshPattern -> Bool
$c> :: MeshPattern -> MeshPattern -> Bool
> :: MeshPattern -> MeshPattern -> Bool
$c>= :: MeshPattern -> MeshPattern -> Bool
>= :: MeshPattern -> MeshPattern -> Bool
$cmax :: MeshPattern -> MeshPattern -> MeshPattern
max :: MeshPattern -> MeshPattern -> MeshPattern
$cmin :: MeshPattern -> MeshPattern -> MeshPattern
min :: MeshPattern -> MeshPattern -> MeshPattern
Ord)

instance Size MeshPattern where
    size :: MeshPattern -> Int
size = Perm -> Int
forall a. Size a => a -> Int
size (Perm -> Int) -> (MeshPattern -> Perm) -> MeshPattern -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MeshPattern -> Perm
getPerm

mkPattern :: Ord a => [a] -> MeshPattern
mkPattern :: forall a. Ord a => [a] -> MeshPattern
mkPattern [a]
w = Perm -> Mesh -> MeshPattern
MP ([a] -> Perm
forall a. Ord a => [a] -> Perm
mkPerm [a]
w) Mesh
forall a. Set a
Set.empty

pattern :: Perm -> MeshPattern
pattern :: Perm -> MeshPattern
pattern Perm
w = Perm -> Mesh -> MeshPattern
MP Perm
w Mesh
forall a. Set a
Set.empty

mesh :: [Box] -> MeshPattern -> MeshPattern
mesh :: [Box] -> MeshPattern -> MeshPattern
mesh [Box]
r (MP Perm
w Mesh
s) = Perm -> Mesh -> MeshPattern
MP Perm
w (Mesh -> MeshPattern) -> (Mesh -> Mesh) -> Mesh -> MeshPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mesh -> Mesh -> Mesh
forall a. Ord a => Set a -> Set a -> Set a
Set.union Mesh
s (Mesh -> MeshPattern) -> Mesh -> MeshPattern
forall a b. (a -> b) -> a -> b
$ [Box] -> Mesh
forall a. Ord a => [a] -> Set a
Set.fromList [Box]
r

cols :: [Int] -> MeshPattern -> MeshPattern
cols :: [Int] -> MeshPattern -> MeshPattern
cols [Int]
xs p :: MeshPattern
p@(MP Perm
w Mesh
_) = [Box] -> MeshPattern -> MeshPattern
mesh [ (Int
x,Int
y) | Int
y <- [Int
0..Perm -> Int
forall a. Size a => a -> Int
size Perm
w], Int
x <- [Int]
xs ] MeshPattern
p

rows :: [Int] -> MeshPattern -> MeshPattern
rows :: [Int] -> MeshPattern -> MeshPattern
rows [Int]
ys p :: MeshPattern
p@(MP Perm
w Mesh
_) = [Box] -> MeshPattern -> MeshPattern
mesh [ (Int
x,Int
y) | Int
x <- [Int
0..Perm -> Int
forall a. Size a => a -> Int
size Perm
w], Int
y <- [Int]
ys ] MeshPattern
p

col :: Int -> MeshPattern -> MeshPattern
col :: Int -> MeshPattern -> MeshPattern
col Int
y = [Int] -> MeshPattern -> MeshPattern
cols [Int
y]

row :: Int -> MeshPattern -> MeshPattern
row :: Int -> MeshPattern -> MeshPattern
row Int
x = [Int] -> MeshPattern -> MeshPattern
rows [Int
x]

box :: Box -> MeshPattern -> MeshPattern
box :: Box -> MeshPattern -> MeshPattern
box Box
xy = [Box] -> MeshPattern -> MeshPattern
mesh [Box
xy]

kVincular :: Int -> Perm -> [MeshPattern]
kVincular :: Int -> Perm -> [MeshPattern]
kVincular Int
k Perm
w = (([Int] -> MeshPattern -> MeshPattern)
-> MeshPattern -> [Int] -> MeshPattern
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Int] -> MeshPattern -> MeshPattern
cols (Perm -> MeshPattern
pattern Perm
w) ([Int] -> MeshPattern) -> (Perm -> [Int]) -> Perm -> MeshPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Perm -> [Int]
toList) (Perm -> MeshPattern) -> [Perm] -> [MeshPattern]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ((Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Perm -> Int
forall a. Size a => a -> Int
size Perm
w) Int -> Int -> [Perm]
`choose` Int
k)

vincular :: Perm -> [MeshPattern]
vincular :: Perm -> [MeshPattern]
vincular Perm
w = [Int
0..Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Perm -> Int
forall a. Size a => a -> Int
size Perm
w] [Int] -> (Int -> [MeshPattern]) -> [MeshPattern]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int -> Perm -> [MeshPattern]) -> Perm -> Int -> [MeshPattern]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Perm -> [MeshPattern]
kVincular Perm
w

bivincular :: Perm -> [MeshPattern]
bivincular :: Perm -> [MeshPattern]
bivincular Perm
w =
    [ (Either Int Int
 -> (MeshPattern -> MeshPattern) -> MeshPattern -> MeshPattern)
-> (MeshPattern -> MeshPattern)
-> [Either Int Int]
-> MeshPattern
-> MeshPattern
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((MeshPattern -> MeshPattern)
-> (MeshPattern -> MeshPattern) -> MeshPattern -> MeshPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((MeshPattern -> MeshPattern)
 -> (MeshPattern -> MeshPattern) -> MeshPattern -> MeshPattern)
-> (Either Int Int -> MeshPattern -> MeshPattern)
-> Either Int Int
-> (MeshPattern -> MeshPattern)
-> MeshPattern
-> MeshPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> MeshPattern -> MeshPattern)
-> (Int -> MeshPattern -> MeshPattern)
-> Either Int Int
-> MeshPattern
-> MeshPattern
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Int -> MeshPattern -> MeshPattern
col Int -> MeshPattern -> MeshPattern
row) MeshPattern -> MeshPattern
forall a. a -> a
id [Either Int Int]
c (MeshPattern -> MeshPattern) -> MeshPattern -> MeshPattern
forall a b. (a -> b) -> a -> b
$ Perm -> MeshPattern
pattern Perm
w | [Either Int Int]
c <- [[Either Int Int]]
choices ]
  where
    choices :: [[Either Int Int]]
choices = [Either Int Int] -> [[Either Int Int]]
powerset' ([Either Int Int] -> [[Either Int Int]])
-> [Either Int Int] -> [[Either Int Int]]
forall a b. (a -> b) -> a -> b
$ [Int
0..Perm -> Int
forall a. Size a => a -> Int
size Perm
w] [Int] -> (Int -> [Either Int Int]) -> [Either Int Int]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
z -> [Int -> Either Int Int
forall a b. a -> Either a b
Left Int
z, Int -> Either Int Int
forall a b. b -> Either a b
Right Int
z]
    powerset' :: [Either Int Int] -> [[Either Int Int]]
powerset' = (Set (Either Int Int) -> [Either Int Int])
-> [Set (Either Int Int)] -> [[Either Int Int]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Set (Either Int Int) -> [Either Int Int]
forall a. Set a -> [a]
Set.toList ([Set (Either Int Int)] -> [[Either Int Int]])
-> ([Either Int Int] -> [Set (Either Int Int)])
-> [Either Int Int]
-> [[Either Int Int]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Either Int Int) -> [Set (Either Int Int)]
forall a. Ord a => Set a -> [Set a]
powerset (Set (Either Int Int) -> [Set (Either Int Int)])
-> ([Either Int Int] -> Set (Either Int Int))
-> [Either Int Int]
-> [Set (Either Int Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Int Int] -> Set (Either Int Int)
forall a. Ord a => [a] -> Set a
Set.fromList

fullMesh :: Int -> Mesh
fullMesh :: Int -> Mesh
fullMesh Int
n = let zs :: [Int]
zs = [Int
0..Int
n] in [Box] -> Mesh
forall a. Ord a => [a] -> Set a
Set.fromList [ (Int
x,Int
y) | Int
x <- [Int]
zs, Int
y <- [Int]
zs ]

meshPatterns :: Perm -> [MeshPattern]
meshPatterns :: Perm -> [MeshPattern]
meshPatterns Perm
w = [ Perm -> Mesh -> MeshPattern
MP Perm
w Mesh
r | Mesh
r <- Mesh -> [Mesh]
forall a. Ord a => Set a -> [Set a]
powerset (Int -> Mesh
fullMesh (Perm -> Int
forall a. Size a => a -> Int
size Perm
w)) ]

match' :: MeshPattern -> PermTwoLine -> PermTwoLine -> Bool
match' :: MeshPattern -> [Box] -> [Box] -> Bool
match' (MP Perm
u Mesh
r) [Box]
v [Box]
w =
    [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ ([Int]
u2[Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
==[Int]
v2) Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int -> Bool
f Int
i Int
j Int
x Int
y | (Int
i,Int
j) <- Mesh -> [Box]
forall a. Set a -> [a]
Set.toList Mesh
r, (Int
x,Int
y) <- [Box]
w ]
  where
    ([Int]
v1, [Int]
v2) = [Box] -> ([Int], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip [Box]
v
    m :: Int
m  = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Box] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Box]
w
    xs :: [Int]
xs = Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
v1 [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
m]
    ys :: [Int]
ys = Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort [Int]
v2 [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
m]
    u2 :: [Int]
u2 = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (([Int]
ys[Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!!) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) (Perm -> [Int]
toList Perm
u)
    f :: Int -> Int -> Int -> Int -> Bool
f Int
i Int
j Int
x Int
y = [Int]
xs[Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!!Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
x Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Int]
xs[Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!!(Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Bool -> Bool -> Bool
&& [Int]
ys[Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!!Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
y Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Int]
ys[Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!!(Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

-- | @match p w m@ determines whether the subword in @w@ specified by
-- @m@ is an occurrence of @p@.
match :: MeshPattern -> Perm -> SubSeq -> Bool
match :: MeshPattern -> Perm -> Perm -> Bool
match MeshPattern
p Perm
w Perm
m = MeshPattern -> [Box] -> [Box] -> Bool
match' MeshPattern
p [Box]
v [Box]
w'
  where
    w' :: [Box]
w' = Perm -> [Box]
twoLine Perm
w
    v :: [Box]
v  = [ Box
pt | pt :: Box
pt@(Int
x,Int
_) <- [Box]
w', Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Perm -> [Int]
toList Perm
m ]

twoLine :: Perm -> PermTwoLine
twoLine :: Perm -> [Box]
twoLine = [Int] -> [Int] -> [Box]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] ([Int] -> [Box]) -> (Perm -> [Int]) -> Perm -> [Box]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ([Int] -> [Int]) -> (Perm -> [Int]) -> Perm -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Perm -> [Int]
toList

-- | @copiesOf p w@ is the list of sets that represent copies of @p@ in @w@.
copiesOf :: MeshPattern -> Perm -> [SubSeq]
copiesOf :: MeshPattern -> Perm -> [Perm]
copiesOf MeshPattern
p Perm
w = (Perm -> Bool) -> [Perm] -> [Perm]
forall a. (a -> Bool) -> [a] -> [a]
filter (MeshPattern -> Perm -> Perm -> Bool
match MeshPattern
p Perm
w) ([Perm] -> [Perm]) -> [Perm] -> [Perm]
forall a b. (a -> b) -> a -> b
$ Perm -> Int
forall a. Size a => a -> Int
size Perm
w Int -> Int -> [Perm]
`choose` MeshPattern -> Int
forall a. Size a => a -> Int
size MeshPattern
p
{-# INLINE copiesOf #-}

-- | @w `contains` p@ is a predicate determining if @w@ contains the pattern @p@.
contains :: Perm -> MeshPattern -> Bool
Perm
w contains :: Perm -> MeshPattern -> Bool
`contains` MeshPattern
p = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Perm
w Perm -> MeshPattern -> Bool
`avoids` MeshPattern
p

-- | @w `avoids` p@ is a predicate determining if @w@ avoids the pattern @p@.
avoids :: Perm -> MeshPattern -> Bool
Perm
w avoids :: Perm -> MeshPattern -> Bool
`avoids` MeshPattern
p = [Perm] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Perm] -> Bool) -> [Perm] -> Bool
forall a b. (a -> b) -> a -> b
$ MeshPattern -> Perm -> [Perm]
copiesOf MeshPattern
p Perm
w

-- | @w `avoidsAll` ps@ is a predicate determining if @w@ avoids the patterns @ps@.
avoidsAll :: Perm -> [MeshPattern] -> Bool
Perm
w avoidsAll :: Perm -> [MeshPattern] -> Bool
`avoidsAll` [MeshPattern]
ps = (MeshPattern -> Bool) -> [MeshPattern] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Perm
w Perm -> MeshPattern -> Bool
`avoids`) [MeshPattern]
ps

-- | @avoiders ps ws@ is the list of permutations in @ws@ avoiding the
-- patterns in @ps@.
avoiders :: [MeshPattern] -> [Perm] -> [Perm]
avoiders :: [MeshPattern] -> [Perm] -> [Perm]
avoiders [MeshPattern]
ps [Perm]
ws = ([Perm] -> MeshPattern -> [Perm])
-> [Perm] -> [MeshPattern] -> [Perm]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((MeshPattern -> [Perm] -> [Perm])
-> [Perm] -> MeshPattern -> [Perm]
forall a b c. (a -> b -> c) -> b -> a -> c
flip MeshPattern -> [Perm] -> [Perm]
avoiders1) [Perm]
ws [MeshPattern]
ps

-- @avoiders1 p ws@ is the list of permutations in @ws@ avoiding the
-- pattern @p@.
avoiders1 :: MeshPattern -> [Perm] -> [Perm]
avoiders1 :: MeshPattern -> [Perm] -> [Perm]
avoiders1 MeshPattern
_ [] = []
avoiders1 MeshPattern
q vs :: [Perm]
vs@(Perm
v:[Perm]
_) = (Perm -> Bool) -> [Perm] -> [Perm]
forall a. (a -> Bool) -> [a] -> [a]
filter Perm -> Bool
avoids_q [Perm]
us [Perm] -> [Perm] -> [Perm]
forall a. [a] -> [a] -> [a]
++ (Perm -> Bool) -> [Perm] -> [Perm]
forall a. (a -> Bool) -> [a] -> [a]
filter (Perm -> MeshPattern -> Bool
`avoids` MeshPattern
q) [Perm]
ws
    where
      n :: Int
n = Perm -> Int
forall a. Size a => a -> Int
size Perm
v
      k :: Int
k = MeshPattern -> Int
forall a. Size a => a -> Int
size MeshPattern
q
      ([Perm]
us, [Perm]
ws) = (Perm -> Bool) -> [Perm] -> ([Perm], [Perm])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\Perm
u -> Perm -> Int
forall a. Size a => a -> Int
size Perm
u Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n) [Perm]
vs
      xs :: [Perm]
xs = Int
n Int -> Int -> [Perm]
`choose` Int
k
      avoids_q :: Perm -> Bool
avoids_q Perm
u = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Perm -> Bool) -> [Perm] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (MeshPattern -> Perm -> Perm -> Bool
match MeshPattern
q Perm
u) [Perm]
xs