From bab2c30addf8aaed85675e2b7f7b15c97c426f74 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 15:00:07 +0100 Subject: Add exceeding payer block --- common/common.cabal | 1 + common/src/Common/Model.hs | 1 + common/src/Common/Model/Payer.hs | 198 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 200 insertions(+) create mode 100644 common/src/Common/Model/Payer.hs (limited to 'common') diff --git a/common/common.cabal b/common/common.cabal index e4a9c59..7eadb49 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -47,6 +47,7 @@ Library Common.Model.Income Common.Model.Init Common.Model.InitResult + Common.Model.Payer Common.Model.Payment Common.Model.PaymentCategory Common.Model.SignIn diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 20e86c1..cb38b2f 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -12,6 +12,7 @@ import Common.Model.Frequency as X import Common.Model.Income as X import Common.Model.Init as X import Common.Model.InitResult as X +import Common.Model.Payer as X import Common.Model.Payment as X import Common.Model.PaymentCategory as X import Common.Model.SignIn as X diff --git a/common/src/Common/Model/Payer.hs b/common/src/Common/Model/Payer.hs new file mode 100644 index 0000000..d09dbf6 --- /dev/null +++ b/common/src/Common/Model/Payer.hs @@ -0,0 +1,198 @@ +module Common.Model.Payer + ( getExceedingPayers + , ExceedingPayer(..) + ) where + +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import Data.Time (NominalDiffTime, UTCTime (..)) +import qualified Data.Time as Time + +import Common.Model.Income (Income (..)) +import Common.Model.Payment (Payment (..)) +import Common.Model.User (User (..), UserId) + +data Payer = Payer + { _payer_userId :: UserId + , _payer_preIncomePayments :: Int + , _payer_postIncomePayments :: Int + , _payer_incomes :: [Income] + } + +data PostPaymentPayer = PostPaymentPayer + { _postPaymentPayer_userId :: UserId + , _postPaymentPayer_preIncomePayments :: Int + , _postPaymentPayer_cumulativeIncome :: Int + , _postPaymentPayer_ratio :: Float + } + +data ExceedingPayer = ExceedingPayer + { _exceedingPayer_userId :: UserId + , _exceedingPayer_amount :: Int + } deriving (Show) + +getExceedingPayers :: UTCTime -> [User] -> [Income] -> [Payment] -> [ExceedingPayer] +getExceedingPayers currentTime users incomes payments = + let userIds = map _user_id users + payers = getPayers currentTime userIds incomes payments + exceedingPayersOnPreIncome = + exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers + mbSince = useIncomesFrom userIds incomes payments + in case mbSince of + Just since -> + let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers + mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) + $ postPaymentPayers + Nothing -> + exceedingPayersOnPreIncome + _ -> + exceedingPayersOnPreIncome + +useIncomesFrom :: [UserId] -> [Income] -> [Payment] -> Maybe UTCTime +useIncomesFrom userIds incomes payments = + let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments + mbIncomeTime = incomeDefinedForAll userIds incomes + in case (firstPaymentTime, mbIncomeTime) of + (Just t1, Just t2) -> Just (max t1 t2) + _ -> Nothing + +paymentTime :: Payment -> UTCTime +paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date + +getPayers :: UTCTime -> [UserId] -> [Income] -> [Payment] -> [Payer] +getPayers currentTime userIds incomes payments = + let incomesDefined = incomeDefinedForAll userIds incomes + in flip map userIds (\userId -> Payer + { _payer_userId = userId + , _payer_preIncomePayments = + totalPayments + (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) + userId + payments + , _payer_postIncomePayments = + totalPayments + (\p -> + case incomesDefined of + Nothing -> False + Just t -> paymentTime p >= t + ) + userId + payments + , _payer_incomes = filter ((==) userId . _income_userId) incomes + } + ) + +exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] +exceedingPayersFromAmounts userAmounts = + case mbMinAmount of + Nothing -> + [] + Just minAmount -> + filter (\payer -> _exceedingPayer_amount payer > 0) + . map (\userAmount -> + ExceedingPayer + { _exceedingPayer_userId = fst userAmount + , _exceedingPayer_amount = snd userAmount - minAmount + } + ) + $ userAmounts + where mbMinAmount = safeMinimum . map snd $ userAmounts + +getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + PostPaymentPayer + { _postPaymentPayer_userId = _payer_userId payer + , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer + , _postPaymentPayer_cumulativeIncome = cumulativeIncome + , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral cumulativeIncome) + } + where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer) + +getFinalDiff :: Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer) + in postIncomeDiff + _postPaymentPayer_preIncomePayments payer + +incomeDefinedForAll :: [UserId] -> [Income] -> Maybe UTCTime +incomeDefinedForAll userIds incomes = + let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds + firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes + in if all Maybe.isJust firstIncomes + then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes + else Nothing + +cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int +cumulativeIncomesSince currentTime since incomes = + getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) + +getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] +getOrderedIncomesSince time incomes = + let mbStarterIncome = getIncomeAt time incomes + orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes + in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince + +getIncomeAt :: UTCTime -> [Income] -> Maybe Income +getIncomeAt time incomes = + case incomes of + [x] -> + if incomeTime x < time + then Just $ x { _income_date = utctDay time } + else Nothing + x1 : x2 : xs -> + if incomeTime x1 < time && incomeTime x2 >= time + then Just $ x1 { _income_date = utctDay time } + else getIncomeAt time (x2 : xs) + [] -> + Nothing + +getCumulativeIncome :: UTCTime -> [Income] -> Int +getCumulativeIncome currentTime incomes = + sum + . map durationIncome + . getIncomesWithDuration currentTime + . List.sortOn incomeTime + $ incomes + +getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] +getIncomesWithDuration currentTime incomes = + case incomes of + [] -> + [] + [income] -> + [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] + (income1 : income2 : xs) -> + (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) + +incomeTime :: Income -> UTCTime +incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date + +durationIncome :: (NominalDiffTime, Int) -> Int +durationIncome (duration, income) = + truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) + +nominalDay :: NominalDiffTime +nominalDay = 86400 + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x : _) = Just x + +safeMinimum :: (Ord a) => [a] -> Maybe a +safeMinimum [] = Nothing +safeMinimum xs = Just . minimum $ xs + +safeMaximum :: (Ord a) => [a] -> Maybe a +safeMaximum [] = Nothing +safeMaximum xs = Just . maximum $ xs + +totalPayments :: (Payment -> Bool) -> UserId -> [Payment] -> Int +totalPayments paymentFilter userId payments = + sum + . map _payment_cost + . filter (\payment -> paymentFilter payment && _payment_user payment == userId) + $ payments -- cgit v1.2.3