{- |
Description: Knight's tour
Copyright: Copyright (C) 2024 Yoo Chung
License: GPL-3.0-or-later
Maintainer: dev@chungyc.org

Some solutions to "Problems.P91" of Ninety-Nine Haskell "Problems".
-}
module Solutions.P91 (knightsTour,closedKnightsTour) where

import           Data.List  (sortOn)
import           Data.Maybe (mapMaybe)
import           Data.Set   (Set)
import qualified Data.Set   as Set

-- | Returns a knight's tour ending at a particular square.
-- Represents the squares by their coordinates with
-- the tuple \((x,y)\), where \(1 \leq x \leq N\) and \(1 \leq y \leq N\).
-- A tour will be a list of these tuples of length \(N \times N\).
knightsTour :: Int -> (Int,Int) -> Maybe [(Int,Int)]
knightsTour :: Int -> (Int, Int) -> Maybe [(Int, Int)]
knightsTour Int
n (Int, Int)
pos
  | Bool -> Bool
not Bool
legalEnd = Maybe [(Int, Int)]
forall a. Maybe a
Nothing
  | Bool
otherwise    = Int -> [(Int, Int)] -> Set (Int, Int) -> Maybe [(Int, Int)]
tour Int
n [(Int, Int)
pos] (Set (Int, Int) -> Maybe [(Int, Int)])
-> Set (Int, Int) -> Maybe [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> Set (Int, Int)
forall a. Ord a => [a] -> Set a
Set.fromList [(Int
x,Int
y) | Int
x <- [Int
1..Int
n], Int
y <- [Int
1..Int
n], (Int
x,Int
y) (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Int, Int)
pos]
  where legalEnd :: Bool
legalEnd = Int -> (Int, Int) -> Bool
isLegalPosition Int
n (Int, Int)
pos

tour :: Int -> [(Int,Int)] -> Set (Int,Int) -> Maybe [(Int,Int)]
tour :: Int -> [(Int, Int)] -> Set (Int, Int) -> Maybe [(Int, Int)]
tour Int
_ [] Set (Int, Int)
_ = Maybe [(Int, Int)]
forall a. Maybe a
Nothing
tour Int
n path :: [(Int, Int)]
path@((Int, Int)
p:[(Int, Int)]
_) Set (Int, Int)
remaining
  | Set (Int, Int) -> Bool
forall a. Set a -> Bool
Set.null Set (Int, Int)
remaining = [(Int, Int)] -> Maybe [(Int, Int)]
forall a. a -> Maybe a
Just [(Int, Int)]
path
  | [(Int, Int)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Int)]
next          = Maybe [(Int, Int)]
forall a. Maybe a
Nothing
  | Bool
otherwise          = Maybe [(Int, Int)]
path'
  where path' :: Maybe [(Int, Int)]
path' | [] <- [Maybe [(Int, Int)]]
paths = Maybe [(Int, Int)]
forall a. Maybe a
Nothing
              | (Maybe [(Int, Int)]
ps:[Maybe [(Int, Int)]]
_) <- [Maybe [(Int, Int)]]
paths  = Maybe [(Int, Int)]
ps
        paths :: [Maybe [(Int, Int)]]
paths = ([(Int, Int)] -> Maybe [(Int, Int)])
-> [[(Int, Int)]] -> [Maybe [(Int, Int)]]
forall a b. (a -> b) -> [a] -> [b]
map [(Int, Int)] -> Maybe [(Int, Int)]
forall a. a -> Maybe a
Just ([[(Int, Int)]] -> [Maybe [(Int, Int)]])
-> [[(Int, Int)]] -> [Maybe [(Int, Int)]]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Maybe [(Int, Int)])
-> [(Int, Int)] -> [[(Int, Int)]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Int, Int)
pos -> Int -> [(Int, Int)] -> Set (Int, Int) -> Maybe [(Int, Int)]
tour Int
n ((Int, Int)
pos(Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:[(Int, Int)]
path) (Set (Int, Int) -> Maybe [(Int, Int)])
-> Set (Int, Int) -> Maybe [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
Set.delete (Int, Int)
pos Set (Int, Int)
remaining) [(Int, Int)]
next
        -- Apply Warnsdorff's heuristic.
        next :: [(Int, Int)]
next = ((Int, Int) -> Int) -> [(Int, Int)] -> [(Int, Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(Int, Int)
pos -> Set (Int, Int) -> (Int, Int) -> Int
availableMoves ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
Set.delete (Int, Int)
pos Set (Int, Int)
remaining) (Int, Int)
pos) ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ Set (Int, Int) -> (Int, Int) -> [(Int, Int)]
nextMoves Set (Int, Int)
remaining (Int, Int)
p

nextMoves :: Set (Int,Int) -> (Int,Int) -> [(Int,Int)]
nextMoves :: Set (Int, Int) -> (Int, Int) -> [(Int, Int)]
nextMoves Set (Int, Int)
remaining (Int
x,Int
y) = ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Int, Int)
remaining) ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$
  [(Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
xd,Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
yd) | Int
xd <- [Int
1,-Int
1], Int
yd <- [Int
2,-Int
2]] [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++ [(Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
xd,Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
yd) | Int
xd <- [Int
2,-Int
2], Int
yd <- [Int
1,-Int
1]]

availableMoves :: Set (Int,Int) -> (Int,Int) -> Int
availableMoves :: Set (Int, Int) -> (Int, Int) -> Int
availableMoves Set (Int, Int)
remaining (Int, Int)
pos = [(Int, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Int, Int)] -> Int) -> [(Int, Int)] -> Int
forall a b. (a -> b) -> a -> b
$ Set (Int, Int) -> (Int, Int) -> [(Int, Int)]
nextMoves Set (Int, Int)
remaining (Int, Int)
pos

isLegalPosition :: Int -> (Int,Int) -> Bool
isLegalPosition :: Int -> (Int, Int) -> Bool
isLegalPosition Int
n (Int
x,Int
y) = Int -> Bool
inRange Int
x Bool -> Bool -> Bool
&& Int -> Bool
inRange Int
y
  where inRange :: Int -> Bool
inRange Int
z = Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
z Bool -> Bool -> Bool
&& Int
z Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n

-- | The same as 'knightsTour', except return a circular tour.
-- I.e., the knight must be able to jump from the last position in the tour to the first position in the tour.
-- Starts the tour from \((1,1)\).
closedKnightsTour :: Int -> Maybe [(Int,Int)]
closedKnightsTour :: Int -> Maybe [(Int, Int)]
closedKnightsTour Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3  = Maybe [(Int, Int)]
forall a. Maybe a
Nothing  -- Not enough room to jump anywhere.
  -- Only tours which end at (2,3) or (3,2) can move back to (1,1).
  -- Arbitrarily end at (2,3).
  | Bool
otherwise = Int -> [(Int, Int)] -> Set (Int, Int) -> Maybe [(Int, Int)]
closedTour Int
n [(Int
2,Int
3)] (Set (Int, Int) -> Maybe [(Int, Int)])
-> Set (Int, Int) -> Maybe [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> Set (Int, Int)
forall a. Ord a => [a] -> Set a
Set.fromList [(Int
x,Int
y) | Int
x <- [Int
1..Int
n], Int
y <- [Int
1..Int
n], (Int
x,Int
y) (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Int
2,Int
3)]

closedTour :: Int -> [(Int,Int)] -> Set (Int,Int) -> Maybe [(Int,Int)]
closedTour :: Int -> [(Int, Int)] -> Set (Int, Int) -> Maybe [(Int, Int)]
closedTour Int
_ [] Set (Int, Int)
_ = Maybe [(Int, Int)]
forall a. Maybe a
Nothing
closedTour Int
n path :: [(Int, Int)]
path@((Int, Int)
p:[(Int, Int)]
_) Set (Int, Int)
remaining
  | Set (Int, Int) -> Bool
forall a. Set a -> Bool
Set.null Set (Int, Int)
remaining = if (Int, Int)
p (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
1,Int
1) then [(Int, Int)] -> Maybe [(Int, Int)]
forall a. a -> Maybe a
Just [(Int, Int)]
path else Maybe [(Int, Int)]
forall a. Maybe a
Nothing
  | [(Int, Int)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Int)]
next          = Maybe [(Int, Int)]
forall a. Maybe a
Nothing
  | Bool
otherwise          = Maybe [(Int, Int)]
path'
  where path' :: Maybe [(Int, Int)]
path' | [] <- [Maybe [(Int, Int)]]
paths = Maybe [(Int, Int)]
forall a. Maybe a
Nothing
              | (Maybe [(Int, Int)]
ps:[Maybe [(Int, Int)]]
_) <- [Maybe [(Int, Int)]]
paths = Maybe [(Int, Int)]
ps
        paths :: [Maybe [(Int, Int)]]
paths = ([(Int, Int)] -> Maybe [(Int, Int)])
-> [[(Int, Int)]] -> [Maybe [(Int, Int)]]
forall a b. (a -> b) -> [a] -> [b]
map [(Int, Int)] -> Maybe [(Int, Int)]
forall a. a -> Maybe a
Just ([[(Int, Int)]] -> [Maybe [(Int, Int)]])
-> [[(Int, Int)]] -> [Maybe [(Int, Int)]]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Maybe [(Int, Int)])
-> [(Int, Int)] -> [[(Int, Int)]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Int, Int)
pos -> Int -> [(Int, Int)] -> Set (Int, Int) -> Maybe [(Int, Int)]
tour Int
n ((Int, Int)
pos(Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:[(Int, Int)]
path) (Set (Int, Int) -> Maybe [(Int, Int)])
-> Set (Int, Int) -> Maybe [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
Set.delete (Int, Int)
pos Set (Int, Int)
remaining) [(Int, Int)]
next
        next :: [(Int, Int)]
next = Set (Int, Int) -> (Int, Int) -> [(Int, Int)]
nextMoves Set (Int, Int)
remaining (Int, Int)
p