チェスのナイトが盤面の端から端まで特定の手数で移動する経路をすべて求める。
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