puzzle.hs

-- solve Dudeney's 6 coins puzzle: https://boingboing.net/2018/05/03/coin-puzzle-how-do-you-make-a.html
-- start from 
--  O O O
-- O O O
-- finish with
--  O O
-- O   O
--  O O
-- in 3 moves, sliding coins; coins must finish touching 2 other coins.

-- changed this to use sets instead of lists, we're not savages. See previous revisions for the list variant.
import Data.Set (Set)
import qualified Data.Set as S

-- Ord because I use 'difference'
data Spot = Spot (Int,Int) deriving (Ord, Eq, Show)

-- see https://www.redblobgames.com/grids/hexagons/#conversions-axial for co-ordinate system
initial = S.fromList [Spot (0,0),Spot (1,0),Spot (2,0),Spot (1,-1),Spot (2,-1),Spot (3,-1)]

directions = [(0,-1),(-1,0),(-1,1),(0,1),(1,0),(1,-1)]
around (Spot (q,r)) = S.fromList [Spot (a+q,b+r)|(a,b)<-directions]

-- 'beside' could be done with arithmetic, but Set definition is neater.
beside p q = S.member p (around q)

-- a spot is 'reachable' if there are 2 adjacent gaps beside it.
reachable spot coins = any (\t->any (beside t) gaps) gaps
  where
  gaps = S.difference (around spot) coins

-- for all coins in a winning circle, one neighbour is the neighbour of all coins.
winning coins = all (\coin->any (\spot->around spot == coins) (around coin)) coins

moves coins = foldMap movesWith coins
  where
  -- all free spaces around the coins
  allMoves = S.difference (foldr1 S.union $ S.map around coins) coins
  movesWith coin = if reachable coin coins then doMoves else S.empty
    where
    doMoves = S.map (\s->S.insert s rest) $ S.filter canMoveTo allMoves
    rest = S.delete coin coins
    canMoveTo spot = reachable spot rest && touching2
      where
      touching2 = S.size(S.intersection rest (around spot))>1

-- find the 3 moves.
puzzle=[(move1,move2,move3)|move1<-S.toList$moves initial ,move2<-S.toList$moves move1,move3<-S.toList$moves move2,winning move3]