tsuri-master.hs

{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}

import Data.List as L
import Data.Heap as H

import Control.Parallel
import Control.Parallel.Strategies
import Control.DeepSeq


type Moneys = [Int]
type Units = Moneys
type Amount = Int


units :: Units
units = [1000, 500, 100, 50, 10, 5, 1]

items :: [Amount]
items = [56,46,71,93,84,76,98,58,129,80]
-- items = [98,87,76,65,54]

initial :: Moneys
initial = [1, 0, 0, 0, 0, 0, 0]


total :: Moneys -> Amount
total = sum . zipWith (*) units


change :: Amount -> Moneys
change back = change' back units
  where
    change' :: Amount -> Units -> Moneys
    change' back [1] = [back]
    change' back (u:us) =
      let (d, m) = back `divMod` u
      in d : change' m us


pay :: Amount -> Moneys -> Moneys
pay cost wallet= moneys
  where
    Left moneys = pay' cost units wallet

    pay' :: Amount -> Units -> Moneys -> Either Moneys Moneys
    pay' cost [1] [i] | cost <= i = Left [i]
                      | otherwise = Right [0]
    pay' cost (u:us) (w:ws) =
      let (d, m) = cost `divMod` u
          (d', p) = case pay' m us ws of
                      Left p -> (d, p)
                      Right p -> (d + 1, p)
      in if d' <= w then Left (d':p)
                    else Right (0:p)


buy :: Moneys -> Int -> (Moneys, Moneys)
buy wallet cost = (pay', change')
  where
    pay' = pay cost wallet
    change' = change $ total pay' - cost


data Path = Path {
    time :: Int,
    path :: [(Int, Moneys)],
    wallet :: Moneys
  } deriving Show

instance NFData Path where
  rnf (Path time path wallet) = time `pseq` rnf  path `pseq` rnf wallet

step :: Path -> Int -> Path
step (Path t path w) item = Path (t+sum c) ((item, p):path) wallet
  where
    (p, c) = buy w (items !! item)
    wallet = zipWith3 (\a b c -> a - b + c) w p c


data Policy

instance HeapItem Policy Path where
     newtype Prio Policy Path = Pri Int deriving (Eq, Ord)
     type    Val  Policy Path = ([(Int, Moneys)], Moneys)
     split (Path t p w)       = (Pri t, (p, w))
     merge (Pri t, (p, w))   = Path t p w


loop :: Heap Policy Path -> Path
loop heap | length rest == 0 = top
          | otherwise = loop $ L.foldr H.insert heap' next

  where
    Just (top@(Path _ p _), heap') = view heap
    list = [0..length items - 1]
    need = (`notElem` (map fst p))
    rest = L.filter need list
    next = top `pseq` parMap rdeepseq (step top) rest


result = loop $ singleton $ Path 0 [] initial

pretty (item, monneys) =
  show item ++ " " ++
  intercalate " " (map show monneys)

main = do
  let answer = reverse $ path result
      t = time result

  mapM_ (putStrLn.pretty) answer
  putStrLn $ "-- " ++ show t ++ "min."