Return to Revisions

Since it looks like no one else has tried programmatic search I thought I'd give it a try.

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.