1 module Solution (solve) where
    2 
    3 import Board
    4 import Move
    5 import List (sortBy)
    6 
    7 solve :: Board -> Colour -> Int -> String
    8 solve bd c n = showResult (solution bd c (2*n-1))
    9 
   10 data Solution = Solution MoveInFull [(MoveInFull,Solution)]
   11 
   12 solution :: Board -> Colour -> Int -> Maybe Solution
   13 solution bd c n | n > 0 = 
   14         let mds = moveDetailsFor c bd in
   15         foldr solnOr Nothing mds
   16         where
   17         solnOr (mif,b) other =
   18                 let rsm = replies b (opponent c) (n-1) in
   19                 case rsm of
   20                 Nothing -> other
   21                 Just [] -> if kingincheck (opponent c) b then
   22                                 Just (Solution mif [])
   23                            else other
   24                 Just rs -> Just (Solution mif rs)
   25 
   26 replies :: Board -> Colour -> Int -> Maybe [(MoveInFull, Solution)]
   27 replies bd c n | n==0 = if null mds then Just [] else Nothing
   28                | n>0  =
   29         foldr solnAnd (Just []) mds
   30         where
   31         mds = moveDetailsFor c bd
   32         solnAnd (mif,b) rest =
   33                 let sm = solution b (opponent c) (n-1) in
   34                 case sm of
   35                 Nothing -> Nothing
   36                 Just s ->  case rest of
   37                                 Nothing -> Nothing
   38                                 Just ms -> Just ((mif,s):ms)
   39 
   40 showResult Nothing = "No solution!\n"
   41 showResult (Just s) = showSoln (compact s) 1
   42 
   43 data Soln = Soln MoveInFull [([MoveInFull],Soln)] deriving (Eq,Ord)
   44 
   45 compact :: Solution -> Soln
   46 compact (Solution mif rs) = Soln mif (foldr insertCompact [] rs)
   47 
   48 insertCompact (mif,s) = ic
   49         where
   50         ic [] = [([mif],cs)]
   51         ic crs@((mifs,cs'):etc) =
   52                 case compare (showSoln cs 1) (showSoln cs' 1) of
   53                 LT -> ([mif], cs) : crs
   54                 EQ -> (insert mif mifs,cs) : etc
   55                 GT -> (mifs,cs') : ic etc
   56         cs = compact s
   57         insert x [] = [x]
   58         insert x (y:ys) = case compare x y of
   59                           GT -> y : insert x ys
   60                           _  -> x : y : ys
   61 
   62 showSoln (Soln mif rs) n =
   63         show n ++ ". " ++ showMoveInFull mif ++
   64         ( case rs of
   65           []        -> "++\n"
   66           [(mifs,s)] -> ", " ++
   67                         ( if length mifs > 1 then "..." else showMoves mifs) ++
   68                         "; " ++ showSoln s (n+1)
   69           _         -> ",\n" ++ showReplies (sortBy cmpLen rs) n )
   70         where
   71         cmpLen (xs,_) (ys,_) = compare (length xs) (length ys)
   72 
   73 showReplies [] n = ""
   74 showReplies ((mifs,s):rs) n =
   75         tab n ++ "if " ++
   76         ( if null rs && length mifs > 1 then "others"
   77           else showMoves mifs ) ++ "; " ++
   78         showSoln s (n+1) ++ showReplies rs n
   79 
   80 tab :: Int -> String
   81 tab n = take n (repeat '\t')