Find and print all 35 Hexominoes

Poly.purs

module Main where

import Prelude
import Control.Plus (empty)
import Data.Array as A
import Data.Set as S
import Control.Monad.Eff.Console (log)
import Data.Foldable (minimum, maximum)
import Data.Maybe (fromMaybe)
import Data.String (joinWith, fromCharArray)

data Cell = Cell { x :: Int, y :: Int }
type Poly = S.Set Cell

instance eqCell :: Eq Cell where
  eq (Cell a) (Cell b) = a.x == b.x && a.y == b.y

instance ordCell :: Ord Cell where
  compare (Cell a) (Cell b) = case compare a.x b.x of
    LT -> LT
    GT -> GT
    EQ -> compare a.y b.y

instance showCell :: Show Cell where
  show (Cell c) = "(" <> (show c.x) <> "," <> (show c.y) <> ")"

monomino :: Poly
monomino = S.singleton $ Cell { x: 0, y: 0 }

pmap :: forall a . (Ord a) => (Int -> Int -> a) -> Poly -> S.Set a
pmap f = S.map \(Cell c) -> f c.x c.y

trim :: Poly -> Poly
trim p = let
  leastX = fromMaybe 0 (minimum $ pmap (\x _ -> x) p)
  leastY = fromMaybe 0 (minimum $ pmap (\_ y -> y) p) in
  pmap (\x y -> Cell { x: x - leastX, y: y - leastY }) p

addCell :: Poly -> Cell -> Poly
addCell p c = S.union p (S.singleton c)

rotate90 :: Poly -> Poly
rotate90 = pmap \x y -> Cell { x: -y, y: x }

rotate180 :: Poly -> Poly
rotate180 = pmap \x y -> Cell { x: -x, y: -y }

rotate270 :: Poly -> Poly
rotate270 = pmap \x y -> Cell { x: y, y: -x }

reflect :: Poly -> Poly
reflect = pmap \x y -> Cell { x: -x, y: y }

rotationsAndReflections :: Poly -> S.Set Poly
rotationsAndReflections p =
  let p' = reflect p in
  S.map trim $ S.fromFoldable [
    p,
    rotate90 p,
    rotate180 p,
    rotate270 p,
    p',
    rotate90 p',
    rotate180 p',
    rotate270 p'
  ]

canonical :: Poly -> Poly
canonical p = fromMaybe p (minimum $ rotationsAndReflections p)

adjacentCells :: Cell -> Array Cell
adjacentCells (Cell c) = [
  Cell { x: c.x - 1, y: c.y },
  Cell { x: c.x + 1, y: c.y },
  Cell { x: c.x, y: c.y -1 },
  Cell { x: c.x, y: c.y + 1 }
]

uniq :: forall a . Ord a => Array a -> Array a
uniq = A.fromFoldable <<< S.fromFoldable

extend :: Poly -> Array Poly
extend p = let
  allAdjacent = uniq $ do
    cell <- A.fromFoldable p
    adjacent <- adjacentCells cell
    if (S.member adjacent p)
      then empty
      else pure adjacent in
  uniq $ map (canonical <<< (addCell p)) allAdjacent

rank :: Int -> Array Poly
rank 0 = []
rank 1 = [monomino]
rank n = uniq $ do
  poly <- rank (n - 1)
  extend poly

showPoly :: Poly -> String
showPoly p = let
  width = fromMaybe 0 (maximum $ pmap (\x _ -> x) p)
  height = fromMaybe 0 (maximum $ pmap (\_ y -> y) p)
  xs = A.range 0 width
  ys = A.range 0 height
  row = \y -> fromCharArray $ map (\x -> if S.member (Cell { x: x, y: y }) p then 'x' else ' ') xs in
  joinWith "\n" $ map row ys

main = do
  log $ joinWith "\n\n" $ map showPoly (rank 6)