さっそくGTAでDPの練習 ref: http://qiita.com/items/a372458d171e373285b1

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