aboutsummaryrefslogtreecommitdiff
path: root/src/client/Model
diff options
context:
space:
mode:
Diffstat (limited to 'src/client/Model')
-rw-r--r--src/client/Model/Date.elm15
-rw-r--r--src/client/Model/Income.elm76
-rw-r--r--src/client/Model/Payer.elm129
-rw-r--r--src/client/Model/Payers.elm59
-rw-r--r--src/client/Model/Payment.elm4
-rw-r--r--src/client/Model/User.elm4
-rw-r--r--src/client/Model/View/LoggedIn/Account.elm43
-rw-r--r--src/client/Model/View/LoggedInView.elm10
8 files changed, 260 insertions, 80 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-31 08:26:07 +0000