Simple haskell program to find polyominoes or polyplets of up to N bits.

Polyominoes.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Polyominoes (Polyominoes, findPolyominoes, findPolyplets) where

import Data.HashSet (HashSet)
import qualified Data.HashSet as HS
import Data.List (nub, intercalate)

type Polyomino = HashSet (Int, Int)

instance {-# OVERLAPPING #-} Eq Polyomino where
  -- |Check two polyominoes for equality.
  (==) p1 p2 =
    let rotations = map (rotatePolyomino p2) [AZero, AHalfPi, APi, AThreeHalvesPi]
        flipped = map flipPolyominoX rotations ++
                  map flipPolyominoY rotations ++
                  map (flipPolyominoX . flipPolyominoY) rotations
    -- You can use `flipped` to check for free polyominoes, `rotations` for one-sided polyminoes, or
    -- just `[p2]` for fixed polyominoes.
    in any (\p -> all (`elem` p) p1) flipped

instance {-# OVERLAPPING #-} Show Polyomino where
  -- |Utility function to show a polyomino.
  show p =
    let p' = HS.toList p
        xs = map fst p'
        ys = map snd p'
    in intercalate "\n"
       [[ if (x, y) `elem` p
          then 'X'
          else ' '
        | x <- [minimum xs .. maximum xs]]
       | y <- [minimum ys .. maximum ys]]

-- |Find polyominoes of N bits.
findPolyominoes :: Integer -> [Polyomino]
findPolyominoes = findWithNeighborhood $ \(x, y) -> [ (x-1, y), (x+1, y), (x, y-1), (x, y+1) ]

-- |Find polyplets of N bits.
findPolyplets :: Integer -> [Polyomino]
findPolyplets = findWithNeighborhood $ \(x, y) ->
  [ (x-1, y-1), (x, y-1), (x+1, y-1)
  , (x-1, y),             (x+1, y)
  , (x-1, y+1), (x, y+1), (x+1, y+1) ]

-- |Find all shapes whose "stones" are connected by the provided 'neighborhood' of N bits.
findWithNeighborhood :: ((Int, Int) -> [(Int, Int)]) -> Integer -> [Polyomino]
findWithNeighborhood _ 1 = pure $ HS.singleton (0, 0)
findWithNeighborhood neighborhood n =
  -- Concat all the polyominoes into a flat list and filter out all non-unique ones.
  nub $ map canonizeOrigin $ concat
  [ -- For each cell in each less-area polyomino, find all the cells that can be made adjacent to it
    -- according to the provided neighborhood without overlapping, creating larger-area polyomioes.
    let neighbors = filter (`notElem` p) $ concatMap neighborhood p
    in [ HS.insert neighbor p | neighbor <- neighbors ]
  | p <- findPolyominoes (n - 1) ]

-- |Make all polyominos share the same origin.
canonizeOrigin :: Polyomino -> Polyomino
canonizeOrigin p =
  let p' = HS.toList p
      minx = minimum $ map fst p'
      miny = maximum $ map snd p'
  in HS.map (\(x, y) -> (x-minx, y-miny)) p

rotatePolyomino :: Polyomino -> Angle -> Polyomino
rotatePolyomino p theta =
  canonizeOrigin $ HS.map (rotateBy theta) p

flipPolyominoX, flipPolyominoY :: Polyomino -> Polyomino
flipPolyominoX = canonizeOrigin . HS.map (\(x, y) -> (-x, y))
flipPolyominoY = canonizeOrigin . HS.map (\(x, y) -> (x, -y))

-- |Right angles.
data Angle = AZero | AHalfPi | APi | AThreeHalvesPi

-- |Exact integer trigonometry.
iSin, iCos :: Angle -> Int
iSin AZero = 0
iSin AHalfPi = 1
iSin APi = 0
iSin AThreeHalvesPi = -1

iCos AZero = 1
iCos AHalfPi = 0
iCos APi = -1
iCos AThreeHalvesPi = 0

-- |Rotate a point by an 'Angle' around (0, 0).
rotateBy :: Angle -> (Int, Int) -> (Int, Int)
rotateBy theta (x, y) =
  (x * iCos theta - y * iSin theta,
   x * iSin theta + y * iCos theta)