Bucks.hs

module Main where

import Data.List hiding (insert)
import Data.Maybe
import Data.Set (Set, empty, member, insert)
import System.Environment

type Capacities = [Int]
type Amounts = [Int]
type Move = (Int, Int)
type Node = (Amounts, [Move])
type AmountsCache = Set Amounts

main :: IO ()
main = do (target:capacity) <- fmap (map read) $ getArgs
          putStrLn $ showAnswer $ solve target capacity

solve :: Int -> Capacities -> Maybe [Move]
solve target capacity@(full:empties) =
  if canBeSolved then bfs target capacity empty [initialNode] else Nothing
  where initialNode = (full:replicate (length capacity - 1) 0, [])
        canBeSolved = target <= full && mod target (foldl1 gcd capacity) == 0

bfs :: Int -> Capacities -> AmountsCache -> [Node] -> Maybe [Move]
bfs _ _ _ [] = Nothing
bfs target capacity cache nodes = case find isAnswer nodes of
  Just node -> Just (snd node)
  Nothing -> let (nodes', cache') = reduceNodes cache [] $ map transfer $ filter canTransfer candidates in
             bfs target capacity cache' nodes'

  where isAnswer (amounts, _) = elem target amounts
        candidates = [(n, i, j) | n <- nodes, i <- [0..(numBuckets - 1)], j <- [0..(numBuckets - 1)], i /= j]
        numBuckets = length capacity
        canTransfer ((amounts, _), i, j) = amounts!!i /= 0 && capacity!!j /= amounts!!j
        transfer ((amounts, moves), i, j) = (set i iAmount $ set j jAmount amounts, (i, j):moves)
          where (transAmount, iAmount, jAmount) = (min (amounts!!i) (capacity!!j - amounts!!j), amounts!!i - transAmount, amounts!!j + transAmount)
                set i x amounts = let (hd,(_:tl)) = splitAt i amounts in hd ++ (x:tl)

reduceNodes :: AmountsCache -> [Node] -> [Node] -> ([Node], AmountsCache)
reduceNodes cache nodes [] = (nodes, cache)
reduceNodes cache nodes ((n@(amounts, move)):rest) =
  if member amounts cache then reduceNodes cache nodes rest
                          else reduceNodes (insert amounts cache) (n:nodes) rest

showAnswer :: Maybe [Move] -> String
showAnswer Nothing = "No Answer"
showAnswer (Just moves) = show (length moves) ++ " moves:" ++ (concat $ map showMove moves)
  where showMove (i, j) = " " ++ show i ++ "->" ++ show j