Skip to main content
4 of 5
Finished testing case 8

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 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