From 8c24464a4bd0a486cd0ddf846d3b5a323a7aaa9a Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 4 Oct 2015 20:48:32 +0200 Subject: Using incomes to compute a fair computation to designate the payer --- src/client/Model/Date.elm | 15 ++++ src/client/Model/Income.elm | 76 +++++++++++++++++ src/client/Model/Payer.elm | 129 +++++++++++++++++++++++++++++ src/client/Model/Payers.elm | 59 ------------- src/client/Model/Payment.elm | 4 +- src/client/Model/User.elm | 4 +- src/client/Model/View/LoggedIn/Account.elm | 43 +++++++--- src/client/Model/View/LoggedInView.elm | 10 +-- 8 files changed, 260 insertions(+), 80 deletions(-) create mode 100644 src/client/Model/Date.elm create mode 100644 src/client/Model/Income.elm create mode 100644 src/client/Model/Payer.elm delete mode 100644 src/client/Model/Payers.elm (limited to 'src/client/Model') diff --git a/src/client/Model/Date.elm b/src/client/Model/Date.elm new file mode 100644 index 0000000..1c56de4 --- /dev/null +++ b/src/client/Model/Date.elm @@ -0,0 +1,15 @@ +module Model.Date + ( timeDecoder + , dateDecoder + ) where + +import Date as Date exposing (Date) +import Time exposing (Time) + +import Json.Decode as Json exposing (..) + +timeDecoder : Decoder Time +timeDecoder = Json.map Date.toTime dateDecoder + +dateDecoder : Decoder Date +dateDecoder = customDecoder string Date.fromString diff --git a/src/client/Model/Income.elm b/src/client/Model/Income.elm new file mode 100644 index 0000000..ce30772 --- /dev/null +++ b/src/client/Model/Income.elm @@ -0,0 +1,76 @@ +module Model.Income + ( Income + , incomeDecoder + , incomeDefinedForAll + , cumulativeIncomesSince + ) where + +import Json.Decode as Json exposing ((:=)) +import Time exposing (Time, hour) +import List exposing (..) + +import Model.Date exposing (timeDecoder) +import Model.User exposing (UserId) + +import Utils.Maybe exposing (isJust, catMaybes, maybeToList) + +type alias Income = + { creation : Time + , amount : Int + } + +incomeDecoder : Json.Decoder Income +incomeDecoder = + Json.object2 Income + ("creation" := timeDecoder) + ("amount" := Json.int) + +incomeDefinedForAll : List (UserId, List Income) -> Maybe Time +incomeDefinedForAll usersIncomes = + let firstIncomes = map (head << sortBy .creation << snd) usersIncomes + in if all isJust firstIncomes + then head << reverse << List.sort << map .creation << catMaybes <| firstIncomes + else Nothing + +cumulativeIncomesSince : Time -> Time -> (List Income) -> Int +cumulativeIncomesSince currentTime since incomes = + cumulativeIncome currentTime (getOrderedIncomesSince since incomes) + +getOrderedIncomesSince : Time -> List Income -> List Income +getOrderedIncomesSince time incomes = + let mbStarterIncome = getIncomesAt time incomes + orderedIncomesSince = filter (\income -> income.creation >= time) incomes + in (maybeToList mbStarterIncome) ++ orderedIncomesSince + +getIncomesAt : Time -> List Income -> Maybe Income +getIncomesAt time incomes = + case incomes of + [x] -> + if x.creation < time + then Just { creation = time, amount = x.amount } + else Nothing + x1 :: x2 :: xs -> + if x1.creation < time && x2.creation > time + then Just { creation = time, amount = x2.amount } + else getIncomesAt time (x2 :: xs) + [] -> + Nothing + +cumulativeIncome : Time -> List Income -> Int +cumulativeIncome currentTime incomes = + getIncomesWithDuration (incomes ++ [{ creation = currentTime, amount = 0 }]) + |> map durationIncome + |> sum + +getIncomesWithDuration : List Income -> List (Float, Int) +getIncomesWithDuration incomes = + case incomes of + (income1 :: income2 :: xs) -> + (income2.creation - income1.creation, income1.amount) :: (getIncomesWithDuration (income2 :: xs)) + _ -> + [] + +durationIncome : (Float, Int) -> Int +durationIncome (duration, income) = + duration * toFloat income / (hour * 24 * 365 / 12) + |> truncate diff --git a/src/client/Model/Payer.elm b/src/client/Model/Payer.elm new file mode 100644 index 0000000..af475bb --- /dev/null +++ b/src/client/Model/Payer.elm @@ -0,0 +1,129 @@ +module Model.Payer + ( Payers + , Payer + , ExceedingPayer + , payersDecoder + , updatePayers + , getOrderedExceedingPayers + ) where + +import Json.Decode as Json exposing (..) +import Dict exposing (..) +import List +import Maybe +import Time exposing (Time) + +import Model.User exposing (UserId, userIdDecoder) +import Model.Income exposing (..) + +import Utils.Dict exposing (mapValues) +import Utils.Maybe exposing (isJust) + +type alias Payers = Dict UserId Payer + +type alias Payer = + { preIncomePaymentSum : Int + , postIncomePaymentSum : Int + , incomes : List Income + } + +payersDecoder : Decoder Payers +payersDecoder = Json.map Dict.fromList (list payerDecoder) + +payerDecoder : Decoder (UserId, Payer) +payerDecoder = + object2 (,) + ("userId" := userIdDecoder) + (object3 Payer + ("preIncomePaymentSum" := int) + ("postIncomePaymentSum" := int) + ("incomes" := list incomeDecoder)) + +updatePayers : Payers -> UserId -> Time -> Int -> Payers +updatePayers payers userId creation amountDiff = + payers + |> Dict.update userId (\mbPayer -> + case mbPayer of + Just payer -> + let postIncome = + incomeDefinedForAll (Dict.toList << mapValues .incomes <| payers) + |> Maybe.map (\date -> creation > date) + |> Maybe.withDefault False + in if postIncome + then + Just { payer | postIncomePaymentSum <- payer.postIncomePaymentSum + amountDiff } + else + Just { payer | preIncomePaymentSum <- payer.preIncomePaymentSum + amountDiff } + Nothing -> + Nothing + ) + +type alias ExceedingPayer = + { userId : UserId + , amount : Int + } + +getOrderedExceedingPayers : Time -> Payers -> List ExceedingPayer +getOrderedExceedingPayers currentTime payers = + let mbIncomeDefinedForAll = incomeDefinedForAll (Dict.toList << mapValues .incomes <| payers) + exceedingPayersOnPreIncome = + payers + |> mapValues .preIncomePaymentSum + |> Dict.toList + |> exceedingPayersFromAmounts + in case mbIncomeDefinedForAll of + Just since -> + let postPaymentPayers = + payers + |> mapValues (getPostPaymentPayer currentTime since) + mbMaxRatio = + postPaymentPayers + |> Dict.toList + |> List.map (.ratio << snd) + |> List.maximum + in case mbMaxRatio of + Just maxRatio -> + postPaymentPayers + |> mapValues (getFinalDiff maxRatio) + |> Dict.toList + |> exceedingPayersFromAmounts + Nothing -> + exceedingPayersOnPreIncome + Nothing -> + exceedingPayersOnPreIncome + +exceedingPayersFromAmounts : List (UserId, Int) -> List ExceedingPayer +exceedingPayersFromAmounts userAmounts = + let mbMinAmount = List.minimum << List.map snd <| userAmounts + in case mbMinAmount of + Nothing -> + [] + Just minAmount -> + userAmounts + |> List.map (\userAmount -> + { userId = fst userAmount + , amount = snd userAmount - minAmount + } + ) + |> List.filter (\payer -> payer.amount > 0) + +type alias PostPaymentPayer = + { preIncomePaymentSum : Int + , cumulativeIncome : Int + , ratio : Float + } + +getPostPaymentPayer : Time -> Time -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + let cumulativeIncome = cumulativeIncomesSince currentTime since payer.incomes + in { preIncomePaymentSum = payer.preIncomePaymentSum + , cumulativeIncome = cumulativeIncome + , ratio = toFloat payer.postIncomePaymentSum / toFloat cumulativeIncome + } + +getFinalDiff : Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + -1 * (maxRatio - payer.ratio) * toFloat payer.cumulativeIncome + |> truncate + in postIncomeDiff + payer.preIncomePaymentSum diff --git a/src/client/Model/Payers.elm b/src/client/Model/Payers.elm deleted file mode 100644 index 983e7b3..0000000 --- a/src/client/Model/Payers.elm +++ /dev/null @@ -1,59 +0,0 @@ -module Model.Payers - ( Payers - , ExceedingPayer - , payersDecoder - , updatePayers - , getOrderedExceedingPayers - ) where - -import Json.Decode as Json exposing (..) -import Dict exposing (..) -import List -import Maybe - -import Model.User exposing (UserId, userIdDecoder) - -type alias Payers = Dict UserId Int - -payersDecoder : Decoder Payers -payersDecoder = Json.map Dict.fromList (list payerDecoder) - -payerDecoder : Decoder (UserId, Int) -payerDecoder = - object2 (,) - ("userId" := userIdDecoder) - ("totalPayment" := int) - -updatePayers : Payers -> UserId -> Int -> Payers -updatePayers payers userId amountDiff = - Dict.update - userId - (\mbAmount -> - case mbAmount of - Just amount -> Just (amount + amountDiff) - Nothing -> Nothing - ) - payers - -type alias ExceedingPayer = - { userId : UserId - , amount : Int - } - -getOrderedExceedingPayers : Payers -> List ExceedingPayer -getOrderedExceedingPayers payers = - let orderedPayers = - Dict.toList payers - |> List.map (\(userId, amount) -> ExceedingPayer userId amount) - |> List.sortBy .amount - maybeMinAmount = - List.head orderedPayers - |> Maybe.map .amount - in case maybeMinAmount of - Just minAmount -> - orderedPayers - |> List.map (\payer -> { payer | amount <- payer.amount - minAmount }) - |> List.filter (\payer -> payer.amount /= 0) - |> List.reverse - Nothing -> - [] diff --git a/src/client/Model/Payment.elm b/src/client/Model/Payment.elm index 1f1c4ed..c4a8963 100644 --- a/src/client/Model/Payment.elm +++ b/src/client/Model/Payment.elm @@ -11,6 +11,7 @@ import Date exposing (..) import Json.Decode as Json exposing ((:=)) import Model.User exposing (UserId, userIdDecoder) +import Model.Date exposing (dateDecoder) perPage : Int perPage = 8 @@ -41,6 +42,3 @@ paymentDecoder = paymentIdDecoder : Json.Decoder PaymentId paymentIdDecoder = Json.int - -dateDecoder : Json.Decoder Date -dateDecoder = Json.customDecoder Json.string Date.fromString diff --git a/src/client/Model/User.elm b/src/client/Model/User.elm index b0d62a6..1412913 100644 --- a/src/client/Model/User.elm +++ b/src/client/Model/User.elm @@ -25,7 +25,9 @@ usersDecoder = Json.map Dict.fromList (Json.list userWithIdDecoder) userWithIdDecoder : Json.Decoder (UserId, User) userWithIdDecoder = - userDecoder `Json.andThen` (\user -> Json.map (\id -> (id, user)) ("id" := userIdDecoder)) + Json.object2 (,) + ("id" := userIdDecoder) + userDecoder userDecoder : Json.Decoder User userDecoder = diff --git a/src/client/Model/View/LoggedIn/Account.elm b/src/client/Model/View/LoggedIn/Account.elm index 7f0fbe3..ab37b81 100644 --- a/src/client/Model/View/LoggedIn/Account.elm +++ b/src/client/Model/View/LoggedIn/Account.elm @@ -3,36 +3,57 @@ module Model.View.LoggedIn.Account , IncomeEdition , initAccount , initIncomeEdition + , getCurrentIncome , validateIncome ) where import Result as Result exposing (Result(..)) +import Dict import Utils.Validation exposing (..) +import Utils.Dict exposing (mapValues) import Model.Translations exposing (..) -import Model.Payers exposing (..) +import Model.Payer exposing (..) +import Model.User exposing (UserId) type alias Account = - { payers : Payers - , income : Maybe Int + { me : UserId + , payers : Payers , visibleDetail : Bool , incomeEdition : Maybe IncomeEdition } +initAccount : UserId -> Payers -> Account +initAccount me payers = + { me = me + , payers = + payers + |> mapValues + (\payer -> + { payer | incomes <- List.sortBy .creation payer.incomes } + ) + , visibleDetail = False + , incomeEdition = Nothing + } + +getCurrentIncome : Account -> Maybe Int +getCurrentIncome account = + case Dict.get account.me account.payers of + Just payer -> + payer.incomes + |> List.sortBy .creation + |> List.reverse + |> List.head + |> Maybe.map .amount + Nothing -> + Nothing + type alias IncomeEdition = { income : String , error : Maybe String } -initAccount : Payers -> Maybe Int -> Account -initAccount payers income = - { payers = payers - , income = income - , visibleDetail = False - , incomeEdition = Nothing - } - initIncomeEdition : Int -> IncomeEdition initIncomeEdition income = { income = toString income diff --git a/src/client/Model/View/LoggedInView.elm b/src/client/Model/View/LoggedInView.elm index 12a7294..122c4be 100644 --- a/src/client/Model/View/LoggedInView.elm +++ b/src/client/Model/View/LoggedInView.elm @@ -5,7 +5,7 @@ module Model.View.LoggedInView import Model.User exposing (Users, UserId) import Model.Payment exposing (Payments) -import Model.Payers exposing (Payers) +import Model.Payer exposing (Payers) import Model.View.LoggedIn.Add exposing (..) import Model.View.LoggedIn.Edition exposing (..) import Model.View.LoggedIn.Monthly exposing (..) @@ -13,7 +13,6 @@ import Model.View.LoggedIn.Account exposing (..) type alias LoggedInView = { users : Users - , me : UserId , add : AddPayment , monthly : Monthly , account : Account @@ -23,13 +22,12 @@ type alias LoggedInView = , currentPage : Int } -initLoggedInView : Users -> UserId -> Payments -> Payments -> Int -> Payers -> Maybe Int -> LoggedInView -initLoggedInView users me monthlyPayments payments paymentsCount payers income = +initLoggedInView : Users -> UserId -> Payments -> Payments -> Int -> Payers -> LoggedInView +initLoggedInView users me monthlyPayments payments paymentsCount payers = { users = users - , me = me , add = initAddPayment Punctual , monthly = initMonthly monthlyPayments - , account = initAccount payers income + , account = initAccount me payers , payments = payments , paymentsCount = paymentsCount , paymentEdition = Nothing -- cgit v1.2.3