Return to Answer

I wrote the following Haskell program which generates polyplets of size n and checks them for vanishing cases. Currently it ignores the symmetries of possible solutions.

data Polyplet = Polyplet {
 members :: [(Int,Int)]
}

instance Eq Polyplet where
 (Polyplet a) == (Polyplet b) = filter(`notElem`a)b ++ filter(`notElem`b)a == []
 
(Polyplet a) ! (Polyplet b) = filter(`notElem`a)b ++ filter(`notElem`b)a == []

instance Show Polyplet where
 show (Polyplet p) = unlines [[if elem (x,y) p then '*' else ' '|x<-rangify[x|(x,_)<-p]]|y<-rangify[y|(_,y)<-p]]

children :: Polyplet -> [Polyplet]
children polyplet@(Polyplet p) = [zero $ Polyplet $ c : p | c <- uniquify $ allDeads polyplet] 

zero :: Polyplet -> Polyplet
zero (Polyplet p) = do
 let mx = minimum [x|(x,_)<-p];
 let my = minimum [y|(_,y)<-p];
 Polyplet[(x-mx,y-my)|(x,y)<-p];

rangify l = [minimum l..maximum l]

deadsAt :: Polyplet -> (Int,Int) -> [(Int,Int)]
deadsAt (Polyplet p) x = filter(`notElem`p) $ adjacents x 

allDeads :: Polyplet -> [(Int,Int)]
allDeads polyplet@(Polyplet p) = uniquify $ p >>= deadsAt polyplet

uniquify :: (Eq a) => [a] -> [a]
uniquify u = [a|(a,b) <- zip u [0..],notElem a $ take b u]

adjacents :: (Int,Int) -> [(Int,Int)]
adjacents (a,b) = [(a+x,b+y)|x<-[-1..1],y<-[-1..1],(x,y)/=(0,0)]

sizeNpolyplets :: Int -> [Polyplet]
sizeNpolyplets 1 = [Polyplet [(0,0)]]
sizeNpolyplets n = uniquify $ sizeNpolyplets (n-1) >>= children

vanishing :: Polyplet -> Bool
vanishing polyplet@(Polyplet p) = all ((`notElem`[5,6]).length.deadsAt polyplet) p && all ((/=5).length.deadsAt polyplet) (allDeads polyplet)

Try it online!

You can envoke it like so in ghci

mapM_ print $ filter vanishing $ sizeNpolyplets 7

This will make a nice little ascii diagram of the found polyplets. If you want the raw data you can use

mapM_ (print.members) $ filter vanishing $ sizeNpolyplets 7

instead.

The program is not very fast but I have been able to confirm that there are no solutions of size $2\leq n\leq 8$ using my laptop. Perhaps better techniques/more powerful computers can exhaust larger cases.

Here is an alternative version of the program that takes into account symmetry when calculating values. It may be slower than the above implementation especially for smaller inputs.

data Polyplet = Polyplet {
 members :: [(Int,Int)]
}

eq :: (Eq a) => [a] -> [a] -> Bool
eq [] [] = True
eq a []  = False
eq [] b  = False
eq (t:a) b = eq a (filter (/=t) b)

instance Eq Polyplet where
 (Polyplet a) == (Polyplet b) = any (eq a) [zero $ f $ g $ b|f<-[id,syma,syma.syma,syma.syma.syma],g<-[id,symb]]

syma p = [(b,-a)|(a,b)<-p] 
symb p = [(-a,b)|(a,b)<-p]
 
instance Show Polyplet where
 show (Polyplet p) = unlines [[if elem (x,y) p then '*' else ' '|x<-rangify[x|(x,_)<-p]]|y<-rangify[y|(_,y)<-p]]

children :: Polyplet -> [Polyplet]
children polyplet@(Polyplet p) = [Polyplet $ zero $ c : p | c <- uniquify $ allDeads polyplet] 

zero :: [(Int,Int)] -> [(Int,Int)]
zero p = do
 let mx = minimum [x|(x,_)<-p];
 let my = minimum [y|(_,y)<-p];
 [(x-mx,y-my)|(x,y)<-p];

rangify l = [minimum l..maximum l]

deadsAt :: Polyplet -> (Int,Int) -> [(Int,Int)]
deadsAt (Polyplet p) x = filter(`notElem`p) $ adjacents x 

allDeads :: Polyplet -> [(Int,Int)]
allDeads polyplet@(Polyplet p) = uniquify $ p >>= deadsAt polyplet

uniquify :: (Eq a) => [a] -> [a]
uniquify u = [a|(a,b) <- zip u [0..],notElem a $ take b u]

adjacents :: (Int,Int) -> [(Int,Int)]
adjacents (a,b) = [(a+x,b+y)|x<-[-1..1],y<-[-1..1],(x,y)/=(0,0)]

sizeNpolyplets :: Int -> [Polyplet]
sizeNpolyplets 1 = [Polyplet [(0,0)]]
sizeNpolyplets n = uniquify $ sizeNpolyplets (n-1) >>= children

noChildren :: Polyplet -> Bool
noChildren polyplet@(Polyplet p) = all ((/=5).length.deadsAt polyplet) (allDeads polyplet)

noSurvivors :: Polyplet -> Bool
noSurvivors polyplet@(Polyplet p) = all ((`notElem`[5,6]).length.deadsAt polyplet) p

vanishing :: Polyplet -> Bool
vanishing p = noChildren p && noSurvivors p

I wrote the following Haskell program which generates finds vanishing polyplets.

data Polyplet = Polyplet {
 members :: [(Int,Int)],
 nonmembers :: [(Int,Int)]
} deriving Show

eq :: (Eq a) => [a] -> [a] -> Bool
eq [] [] = True
eq a []  = False
eq [] b  = False
eq (t:a) b = eq a (filter (/=t) b)

instance Eq Polyplet where
 (Polyplet a _) == (Polyplet b _) = any (eq a) [zero $ f $ g $ b|f<-[id,syma,syma.syma,syma.syma.syma],g<-[id,symb]]

syma p = [(b,-a)|(a,b)<-p] 
symb p = [(-a,b)|(a,b)<-p]

size :: Polyplet -> Int
size (Polyplet p _) = length p

zero :: [(Int,Int)] -> [(Int,Int)]
zero p = do
 let mx = minimum [x|(x,_)<-p];
 let my = minimum [y|(_,y)<-p];
 [(x-mx,y-my)|(x,y)<-p];

zeroPolyplet :: Polyplet -> Polyplet
zeroPolyplet (Polyplet p np) = do
 let mx = minimum [x|(x,_)<-p];
 let my = minimum [y|(_,y)<-p];
 Polyplet [(x-mx,y-my)|(x,y)<-p] [(x-mx,y-my)|(x,y)<-np]

rangify l = [minimum l..maximum l]

deadsAt :: Polyplet -> (Int,Int) -> [(Int,Int)]
deadsAt (Polyplet p _) x = filter(`notElem`p) $ adjacents x  

-- Maybe rename? --
allDeads :: Polyplet -> [(Int,Int)]
allDeads polyplet@(Polyplet p np) = uniquify $ filter (`notElem` np) $ p >>= deadsAt polyplet 

maxLive :: Polyplet -> (Int,Int) -> Int
maxLive (Polyplet _ np) x = sum [1|u<-adjacents x,notElem u np]

minLive :: Polyplet -> (Int,Int) -> Int
minLive (Polyplet p _) x = 8 - sum [1|u<-adjacents x,notElem u p]

-- Could this be made faster? --
uniquify :: (Eq a) => [a] -> [a]
uniquify u = [a|(a,b) <- zip u [0..],notElem a $ take b u]

adjacents :: (Int,Int) -> [(Int,Int)]
adjacents (a,b) = [(a+x,b+y)|x<-[-1..1],y<-[-1..1],(x,y)/=(0,0)]

forbiddenMinor :: Polyplet -> Bool
forbiddenMinor polyplet@(Polyplet p np) = [1|lCell<-p,maxLive polyplet lCell<4,minLive polyplet lCell>1] ++ [1|dCell<-np,maxLive polyplet dCell == 3,minLive polyplet dCell == 3] == []

partitions :: (Num a,Eq a) => a -> [b] -> [([b],[b])]
partitions _ [] = [([],[])]
partitions 0 x  = [([],x)]
partitions n (x:xs) = (map (\(a,b) -> (x:a,b)) $ partitions (n-1) xs) ++ (map (\(a,b) -> (a,x:b)) $ partitions n xs)

subPolyplets :: Int -> Polyplet -> [Polyplet]
subPolyplets max polyplet@(Polyplet p np) = [Polyplet (addingLive ++ p) (addingDead ++ np)|(addingLive,addingDead) <- init $ partitions max $ allDeads polyplet]

zipCat :: [[a]] -> [[a]] -> [[a]]
zipCat [] b = b
zipCat a [] = a
zipCat (a:as) (b:bs) = (a ++ b): zipCat as bs

regroup :: [Polyplet] -> [[Polyplet]]
regroup [] = []
regroup (x:xs) = zipCat (regroup xs) $ replicate (length (members x) - 1) [] ++ [[x]]

fillPolyplets :: Int -> Int -> [[Polyplet]]
fillPolyplets 1 n = [Polyplet [(0,0)] []] : replicate (n-1) []
fillPolyplets x n = do
 let previous = fillPolyplets (x-1) n
 zipCat previous $ map (filter forbiddenMinor . uniquify . map zeroPolyplet) $ regroup $ (previous !! (x-2)) >>= subPolyplets (n-x+1)

vanishing :: Polyplet -> Bool
vanishing polyplet@(Polyplet p np) = all ((`notElem`[5,6]).length.deadsAt polyplet) p && all ((/=5).length.deadsAt polyplet) (allDeads polyplet ++ np)

getVanishingPolyplets :: Int -> [Polyplet]
getVanishingPolyplets n = fillPolyplets n n >>= (filter vanishing)

Try it online!

You can envoke it like so in ghci

mapM_ (print.members) $ getVanishingPolyplets 7

The program is not very fast but I have been able to get a complete classification for vanishing polyplets of size $n \leq 12$. Perhaps better techniques/more powerful computers can exhaust larger cases.

Here are the results of running it on $n=12$:

$$ \substack{ \displaystyle{◻◻◻} \cr \displaystyle{◻◼◻} \cr \displaystyle{◻◻◻} \cr } \quad \quad \quad \substack{ \displaystyle{◻◻◻◻} \cr \displaystyle{◻◼◼◻} \cr \displaystyle{◻◻◻◻} \cr } \quad \quad \quad \substack{ \displaystyle{◻◻◻◻} \cr \displaystyle{◻◻◼◻} \cr \displaystyle{◻◼◻◻} \cr \displaystyle{◻◻◻◻} \cr } \quad \quad \quad \substack{ \displaystyle{◻◻◻◻◻◻◻} \cr \displaystyle{◻◻◻◼◻◻◻} \cr \displaystyle{◻◻◻◼◻◻◻} \cr \displaystyle{◻◼◼◼◼◼◻} \cr \displaystyle{◻◻◻◼◻◻◻} \cr \displaystyle{◻◻◻◼◻◻◻} \cr \displaystyle{◻◻◻◻◻◻◻} \cr } \quad \quad \quad \substack{ \displaystyle{◻◻◻◻◻◻◻} \cr \displaystyle{◻◻◻◻◼◻◻} \cr \displaystyle{◻◼◻◼◻◻◻} \cr \displaystyle{◻◻◼◼◼◻◻} \cr \displaystyle{◻◻◻◼◻◼◻} \cr \displaystyle{◻◻◼◻◻◻◻} \cr \displaystyle{◻◻◻◻◻◻◻} \cr } $$ $$ \substack{ \displaystyle{◻◻◻◻◻◻◻◻} \cr \displaystyle{◻◻◻◼◼◻◻◻} \cr \displaystyle{◻◼◼◼◼◼◼◻} \cr \displaystyle{◻◻◻◼◼◻◻◻} \cr \displaystyle{◻◻◻◻◻◻◻◻} \cr } \quad \quad \quad \substack{ \displaystyle{◻◻◻◻◻◻◻◻} \cr \displaystyle{◻◻◻◼◻◻◻◻} \cr \displaystyle{◻◻◻◻◼◻◻◻} \cr \displaystyle{◻◻◻◼◼◼◼◻} \cr \displaystyle{◻◼◼◼◼◻◻◻} \cr \displaystyle{◻◻◻◼◻◻◻◻} \cr \displaystyle{◻◻◻◻◼◻◻◻} \cr \displaystyle{◻◻◻◻◻◻◻◻} \cr } \quad \quad \quad \substack{ \displaystyle{◻◻◻◻◻◻◻◻} \cr \displaystyle{◻◻◻◼◻◻◻◻} \cr \displaystyle{◻◻◻◻◼◻◻◻} \cr \displaystyle{◻◻◻◼◼◼◼◻} \cr \displaystyle{◻◼◼◼◼◻◻◻} \cr \displaystyle{◻◻◻◼◻◻◻◻} \cr \displaystyle{◻◻◻◼◻◻◻◻} \cr \displaystyle{◻◻◻◻◻◻◻◻} \cr } \quad \quad \quad \substack{ \displaystyle{◻◻◻◻◻◻◻◻} \cr \displaystyle{◻◻◻◻◼◻◻◻} \cr \displaystyle{◻◻◻◻◼◻◻◻} \cr \displaystyle{◻◻◻◼◼◼◼◻} \cr \displaystyle{◻◼◼◼◼◻◻◻} \cr \displaystyle{◻◻◻◼◻◻◻◻} \cr \displaystyle{◻◻◻◼◻◻◻◻} \cr \displaystyle{◻◻◻◻◻◻◻◻} \cr } $$

All of these were previously found by others, however now we can be certain that there are no other vanishing polyplets of size less than $12$ that we are unaware of.

There also seems to be an issue that some polyplets show up in the output more times than they should. I think this is a problem with the way I handle symmetries but I can't nail it down for sure. Fixing this problem would probably make things considerably faster.

The program is not very fast but I have been able to confirm that there are no solutions of size $2\leq n\leq 7$ using my laptop. Perhaps better techniques/more powerful computers can exhaust larger cases.

The program is not very fast but I have been able to confirm that there are no solutions of size $2\leq n\leq 8$ using my laptop. Perhaps better techniques/more powerful computers can exhaust larger cases.

Here is an alternative version of the program that takes into account symmetry when calculating values. It may be slower than the above implementation especially for smaller inputs.

data Polyplet = Polyplet {
 members :: [(Int,Int)]
}

eq :: (Eq a) => [a] -> [a] -> Bool
eq [] [] = True
eq a []  = False
eq [] b  = False
eq (t:a) b = eq a (filter (/=t) b)

instance Eq Polyplet where
 (Polyplet a) == (Polyplet b) = any (eq a) [zero $ f $ g $ b|f<-[id,syma,syma.syma,syma.syma.syma],g<-[id,symb]]

syma p = [(b,-a)|(a,b)<-p] 
symb p = [(-a,b)|(a,b)<-p]
 
instance Show Polyplet where
 show (Polyplet p) = unlines [[if elem (x,y) p then '*' else ' '|x<-rangify[x|(x,_)<-p]]|y<-rangify[y|(_,y)<-p]]

children :: Polyplet -> [Polyplet]
children polyplet@(Polyplet p) = [Polyplet $ zero $ c : p | c <- uniquify $ allDeads polyplet] 

zero :: [(Int,Int)] -> [(Int,Int)]
zero p = do
 let mx = minimum [x|(x,_)<-p];
 let my = minimum [y|(_,y)<-p];
 [(x-mx,y-my)|(x,y)<-p];

rangify l = [minimum l..maximum l]

deadsAt :: Polyplet -> (Int,Int) -> [(Int,Int)]
deadsAt (Polyplet p) x = filter(`notElem`p) $ adjacents x 

allDeads :: Polyplet -> [(Int,Int)]
allDeads polyplet@(Polyplet p) = uniquify $ p >>= deadsAt polyplet

uniquify :: (Eq a) => [a] -> [a]
uniquify u = [a|(a,b) <- zip u [0..],notElem a $ take b u]

adjacents :: (Int,Int) -> [(Int,Int)]
adjacents (a,b) = [(a+x,b+y)|x<-[-1..1],y<-[-1..1],(x,y)/=(0,0)]

sizeNpolyplets :: Int -> [Polyplet]
sizeNpolyplets 1 = [Polyplet [(0,0)]]
sizeNpolyplets n = uniquify $ sizeNpolyplets (n-1) >>= children

noChildren :: Polyplet -> Bool
noChildren polyplet@(Polyplet p) = all ((/=5).length.deadsAt polyplet) (allDeads polyplet)

noSurvivors :: Polyplet -> Bool
noSurvivors polyplet@(Polyplet p) = all ((`notElem`[5,6]).length.deadsAt polyplet) p

vanishing :: Polyplet -> Bool
vanishing p = noChildren p && noSurvivors p