Uncrossed Knight's Tours

Knights.hs

module Knights where

import Control.Monad (guard)
import Data.Tree

type Point = (Int, Int)

prune :: Int -> Tree a -> Tree a
prune n _ | n < 1 = error "Can't prune to height < 1"
prune 1 (Node x _) = Node x []
prune n (Node x xs) = Node x (map (prune (n-1)) xs)

knightMoves :: [Point]
knightMoves = do
  a <- [-2,2]
  b <- [-1,1]
  [(a,b), (b,a)]

jumpsFrom :: Int -> Point -> [Point]
jumpsFrom n (x,y) = do
  (dx, dy) <- knightMoves
  let x' = x + dx
      y' = y + dy
  guard (x' >= 0 && y' >= 0 && x' < n && y' < n)
  pure (x', y')

tourTree :: Int -> [Point] -> Point -> Tree ([Point], Point)
tourTree n ps p =
  let nextMoves = filter (\p' -> not $ intersectsPath (p, p') ps) $ jumpsFrom n p
   in Node (ps, p) (map (tourTree n (ps ++ [p])) nextMoves)
height :: Tree a -> Int
height = foldTree (\_ xs -> maximum (0:xs) + 1)

ccw :: Point -> Point -> Point -> Bool
ccw (ax, ay) (bx, by) (cx, cy) = (cy - ay) * (bx - ax) > (by - ay) * (cx - ax)

intersect :: (Point, Point) -> (Point, Point) -> Bool
intersect (a,b) (c,d) = or ((==) <$> [a,b] <*> [c,d]) || (ccw a c d /= ccw b c d && ccw a b c /= ccw a b d)

intersectsPath :: (Point, Point) -> [Point] -> Bool
intersectsPath _ [] = False
intersectsPath _ [_] = False
intersectsPath segment (p:p':ps) = intersect segment (p, p') || intersectsPath segment (p':ps)

longestUncrossedPath :: Int -> Int
longestUncrossedPath n =
  let squares = (,) <$> [0..n-1] <*> [0..n-1]
      pieceLength = maximum $ map (height . tourTree n []) squares
   in pieceLength - 1