チェスのナイトが盤面の端から端まで特定の手数で移動する経路をすべて求める。
typelevel-tensor と numeric-prelude も必要。
Knight.hs
#!/usr/bin/env runhaskell
{-# LANGUAGE NoImplicitPrelude, RecordWildCards #-}
{-# OPTIONS -Wall #-}
module Main where
import Data.Maybe
import Data.Tensor.TypeLevel
import GTA.Data.JoinList
import GTA.Core hiding (items)
import NumericPrelude
knightMoves :: [Vec2 Int]
knightMoves = [Vec :~ x :~ y | x <- [-2..2], y<-[-2..2], x^2 + y^2 == 5]
canMoveTo :: Vec2 Int -> Vec2 Int -> Bool
canMoveTo a b = (a - b) `elem` knightMoves
bdSize :: Int
bdSize = 8
maxStep :: Int
maxStep = 7
knightSeq' :: JoinList (Vec2 Int) -> Bool
knightSeq' = isJust . ws
where
ws Nil = Just Nothing
ws (Single r) = Just $ Just (r,r)
ws (x1 `Times` x2) = do
a1 <- ws x1
a2 <- ws x2
case (a1, a2) of
(Nothing, _) -> return a2
(_, Nothing) -> return a1
(Just (r0,r1),Just (r2,r3))
| canMoveTo r1 r2 -> return $ Just (r0,r3)
| otherwise -> Nothing
knightSeq :: (Maybe a -> Bool, JoinListAlgebra (Vec2 Int) (Maybe (Maybe (Vec2 Int, Vec2 Int))))
knightSeq = (isJust) <.> ws
where
ws = JoinListAlgebra{..} where
nil = Just Nothing
single r = Just $ Just (r,r)
x1 `times` x2 = do
a1 <- x1
a2 <- x2
case (a1, a2) of
(Nothing, _) -> return a2
(_, Nothing) -> return a1
(Just (r0,r1),Just (r2,r3))
| canMoveTo r1 r2 -> return $ Just (r0,r3)
| otherwise -> Nothing
knightSeq2 :: (Maybe a -> Bool, JoinListAlgebra (Vec2 Int, t) (Maybe (Maybe (Vec2 Int, Vec2 Int))))
knightSeq2 = (isJust) <.> ws
where
ws = JoinListAlgebra{..} where
nil = Just Nothing
single (r,_) = Just $ Just (r,r)
x1 `times` x2 = do
a1 <- x1
a2 <- x2
case (a1, a2) of
(Nothing, _) -> return a2
(_, Nothing) -> return a1
(Just (r0,r1),Just (r2,r3))
| canMoveTo r1 r2 -> return $ Just (r0,r3)
| otherwise -> Nothing
fromTo :: Eq a => a -> a -> (a1 -> a1, JoinListAlgebra (a, Int) Bool)
fromTo start goal = id <.> joken where
joken = JoinListAlgebra{..}
c1 `times` c2 = c1 && c2
single (r,n)
| n == 1 = start == r
| n == maxStep = goal == r
| otherwise = True
nil = True
main :: IO ()
main = do
putStr $ pprint2$ assigns [Vec :~ x :~ y| x<- [1..bdSize], y<-[1..bdSize]] [1..maxStep]
`filterBy` knightSeq2
`filterBy` fromTo (Vec :~ 1 :~ 1) (Vec :~ bdSize :~ bdSize)
`aggregateBy` result
return ()
pprint :: Bag (JoinList (Vec2 Int)) -> String
pprint (Bag xs) = unlines $ map (unwords . map (\ (Vec :~ x :~ y) -> show x ++ "," ++ show y) . dejoinize) xs
pprint2:: Bag (JoinList (Vec2 Int,Int)) -> String
pprint2(Bag xs) = unlines $ map (unwords . map (\ ((Vec :~ x :~ y),_) -> show x ++ "," ++ show y) . dejoinize) xs