土法记账

Zhang.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Zhang where

import Control.Monad (forM_)
import Data.Function (on)
import Data.List (maximumBy, minimumBy, (\\))
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Text.Printf (printf)

readNames :: T.Text -> [T.Text]
readNames = T.split (== ',')

readAndCheckNames :: [T.Text] -> T.Text -> [T.Text]
readAndCheckNames knownNames raw
  | ns <- readNames raw,
    all (`elem` knownNames) ns =
      ns
  | otherwise = error "Unknown name"

settle :: M.Map T.Text (Double, [T.Text], [T.Text]) -> [T.Text]
settle core = f ((\(c, (x, _, _)) -> (c, x)) <$> M.toList core) []
  where
    f [] tx = tx
    f xs tx = if null creditors || null debtors then tx else f xs' tx'
      where
        creditors = filter ((> 0) . snd) xs
        debtors = filter ((< 0) . snd) xs
        maxCreditor@(cName, cAmount) = maximumBy (compare `on` snd) creditors
        maxDebtor@(dName, dAmount) = minimumBy (compare `on` snd) debtors
        txAmount = min cAmount (-dAmount)
        tx' = tx <> [T.unwords [dName, "应付", cName, "", T.pack $ showAmount txAmount]]
        rest = xs \\ [maxCreditor, maxDebtor]
        xs' = rest <> [(cName, cAmount - txAmount), (dName, dAmount + txAmount)]

toCounter :: (Ord a) => [a] -> M.Map a Int
toCounter = M.fromListWith (+) . map (,1)

showAmount :: Double -> String
showAmount = printf "%.2f"

main :: IO ()
main = do
  (rn : rts) <-
    filter (not . T.null)
      . filter (not . T.isPrefixOf "#")
      . T.lines
      <$> T.readFile "zhang.txt"
  let allNames = readNames rn
      core =
        foldr
          ( \rawT m ->
              case T.split (== ' ') rawT of
                [ creditor,
                  read . T.unpack -> amount :: Double,
                  readAndCheckNames allNames -> debtors,
                  note
                  ]
                    | sAmount <- amount / fromIntegral (length debtors),
                      cDebtors <- M.toList $ toCounter debtors ->
                        foldr
                          ( \(d, cd) ->
                              let tm = fromIntegral cd * sAmount
                               in M.adjust
                                    ( \(x, t1, t2) ->
                                        ( x - tm,
                                          t1,
                                          t2
                                            <> [ "欠了 "
                                                   <> T.pack (showAmount tm)
                                                   <> "("
                                                   <> ( if cd == 1
                                                          then ""
                                                          else T.pack (show cd) <> "x"
                                                      )
                                                   <> note
                                                   <> "), 由 "
                                                   <> creditor
                                                   <> " 代付"
                                                 | creditor /= d
                                               ]
                                        )
                                    )
                                    d
                          )
                          ( M.adjust
                              ( \(x, t1, t2) ->
                                  ( x + amount,
                                    t1
                                      <> [ "付了 "
                                             <> T.pack (showAmount amount)
                                             <> "("
                                             <> note
                                             <> ") 分给 "
                                             <> T.intercalate
                                               ","
                                               [ if cd == 1
                                                   then d
                                                   else d <> "(" <> T.pack (show cd) <> "x)"
                                                 | (d, cd) <- cDebtors
                                               ]
                                         ],
                                    t2
                                  )
                              )
                              creditor
                              m
                          )
                          cDebtors
                gg -> error $ "Unable to parse " <> show gg
          )
          (M.fromList [(n, (0.0, [], [])) | n <- allNames])
          rts
  T.putStrLn "-------------------------------"
  T.putStrLn "付款:"
  forM_ allNames $ \n -> T.putStrLn $ n <> ":\n" <> T.pack (T.unpack $ T.unlines $ (\(_, x, _) -> x) (core M.! n))
  T.putStrLn "-------------------------------"
  T.putStrLn "欠款:"
  forM_ allNames $ \n -> T.putStrLn $ n <> ":\n" <> T.pack (T.unpack $ T.unlines $ (\(_, _, x) -> x) (core M.! n))
  T.putStrLn "-------------------------------"
  T.putStrLn "合计:"
  forM_ allNames $ \n -> T.putStrLn $ n <> ": " <> T.pack (showAmount $ (\(x, _, _) -> x) (core M.! n))
  T.putStrLn "-------------------------------"
  T.putStrLn "结算:"
  T.putStrLn $ T.unlines $ settle core
  T.putStrLn "-------------------------------"

zhang.txt

# 所有人名字
Alice,Bob,Charle
# 付款人 金额 分给谁 备注
Alice 5 Alice,Bob 蛋糕
Bob 3 Carle 酸枣
Charle 2 Alice,Bob 雪饼