exchangealgebra-0.5.1.0: src/ExchangeAlgebra/Algebra/Transfer.hs
{- |
Module : ExchangeAlgebra.Algebra.Transfer
Copyright : (c) Kaya Akagi. 2018-2026
Maintainer : yakagika@icloud.com
Released under the OWL license
Legacy rewriting transfers. New code should use
"ExchangeAlgebra.Algebra.Transfer.Rule" for data-defined rules and entries
that are added to the ledger (Definition 9).
Compatibility assumptions: P1, source patterns share wildcard positions;
P2, source patterns do not overlap; P3, ledger bases have no wildcards;
P4, axes are not nested tuples; P5, transformed values are nonzero.
Mixed wildcard positions can make the legacy tree lookup miss matching
entries even for disjoint rules. Overlap priority is unspecified, and
matching is symmetric (ledger wildcards also match concrete patterns).
These known limitations are preserved for compatibility.
Use "ExchangeAlgebra.Algebra.Transfer.Rule" for one-way source matching.
Package for Exchange Algebra defined by Hiroshi Deguchi.
Exchange Algebra is an algebraic description of bookkeeping systems.
Details are below.
<https://www.springer.com/gp/book/9784431209850>
<https://repository.kulib.kyoto-u.ac.jp/dspace/bitstream/2433/82987/1/0809-7.pdf>
-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PostfixOperators #-}
module ExchangeAlgebra.Algebra.Transfer
( Size
, TransTable
, isNullTable
, transfer
, table
, TransTableParts
, (.->)
, (|%)
, createTransfer
, incomeSummaryAccount
, netIncomeTransfer
, grossProfitTransfer
, ordinaryProfitTransfer
, retainedEarningTransfer
, finalStockTransferStep
, finalStockTransfer
) where
import ExchangeAlgebra.Algebra.Transfer.Rule (ClosingSide(..), closingSide)
import qualified ExchangeAlgebra.Algebra as EA
import ExchangeAlgebra.Algebra
import Text.Show.Unicode ( ushow)
import GHC.Exts ( reallyUnsafePtrEquality#
, isTrue#
, lazy)
import Data.Semigroup ( Semigroup(stimes)
, stimesIdempotentMonoid)
import qualified Data.Foldable as Foldable
import Data.Bits ( shiftL
, shiftR)
import qualified Data.HashMap.Strict as HM
import Utils.Containers.Internal.StrictPair
------------------------------------------------------------------
-- * Core computation
------------------------------------------------------------------
-- ** Transfer transformation
type Size = Int
-- | Transfer transformation table
-- Legacy API: new code should use "ExchangeAlgebra.Algebra.Transfer.Rule".
-- See the module header for compatibility assumptions P1-P5 and known lookup limitations.
data TransTable n b where
NullTable :: (HatVal n, HatBaseClass b) => TransTable n b
TransTable :: (HatVal n, HatBaseClass b)
=> { _size :: Size
, _before :: b {- ^ Base before transformation -}
, _transFunc :: (n -> n) {- ^ Value transformation function -}
, _after :: b {- ^ Base after transformation -}
, _left :: TransTable n b
, _right :: TransTable n b }
-> TransTable n b
-- | Tests whether the transfer table is empty.
--
-- Complexity: O(1)
{-# INLINE isNullTable #-}
isNullTable :: TransTable n b -> Bool
isNullTable NullTable = True
isNullTable _ = False
instance (HatBaseClass b) => Show (TransTable n b) where
show NullTable = "[]"
show (TransTable _ b _ a l r) = "[(" ++ ushow b
++ ","
++ ushow a
++ ",<function>)"
++ (if isNullTable l then "" else "," ++ (Prelude.tail. Prelude.init .ushow) l)
++ (if isNullTable r then "" else "," ++ (Prelude.tail. Prelude.init .ushow) r)
++ "]"
instance (HatVal n,HatBaseClass b) => Semigroup (TransTable n b) where
(<>) = union
stimes = stimesIdempotentMonoid
instance (HatVal n, HatBaseClass b) => Monoid (TransTable n b) where
mempty = NullTable
mconcat = unions
mappend = (<>)
{-# INLINE union #-}
union ::(HatBaseClass b) => TransTable n b -> TransTable n b -> TransTable n b
union t1 NullTable = t1
union NullTable t2 = t2
union t1 (TransTable _ b f a NullTable NullTable) = insertR b f a t1
union (TransTable _ b f a NullTable NullTable) t2 = insert b f a t2
union t1@(TransTable _ b1 f1 a1 l1 r1) t2 = case split b1 t2 of
(l2, r2) | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1
| otherwise -> link b1 f1 a1 l1l2 r1r2
where !l1l2 = union l1 l2
!r1r2 = union r1 r2
{-# INLINE link #-}
link :: (HatVal n, HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b -> TransTable n b
link kx fx x NullTable r = insertMin kx fx x r
link kx fx x l NullTable = insertMax kx fx x l
link kx fx x l@(TransTable sizeL ky fy y ly ry) r@(TransTable sizeR kz fz z lz rz)
| delta*sizeL < sizeR = balanceL kz fz z (link kx fx x l lz) rz
| delta*sizeR < sizeL = balanceR ky fy y ly (link kx fx x ry r)
| otherwise = bin kx fx x l r
{-# INLINE bin #-}
bin :: (HatVal n, HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b -> TransTable n b
bin k f x l r
= TransTable (size l + size r + 1) k f x l r
{-# INLINE split #-}
split :: (HatBaseClass b) => b -> TransTable n b -> (TransTable n b, TransTable n b)
split !k0 t0 = toPair $ go k0 t0
where
go k t =
case t of
NullTable -> NullTable :*: NullTable
TransTable _ kx fx x l r -> case compareElement k kx of
LT -> let (lt :*: gt) = go k l in lt :*: link kx fx x gt r
GT -> let (lt :*: gt) = go k r in link kx fx x l lt :*: gt
EQ -> (l :*: r)
{-# INLINE insertMax #-}
insertMax,insertMin :: (HatVal n, HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b
insertMax kx fx x t
= case t of
NullTable -> singleton kx fx x
TransTable _ ky fy y l r
-> balanceR ky fy y l (insertMax kx fx x r)
{-# INLINE insertMin #-}
insertMin kx fx x t
= case t of
NullTable -> singleton kx fx x
TransTable _ ky fy y l r
-> balanceL ky fy y (insertMin kx fx x l) r
{-# INLINE unions #-}
unions :: (HatVal n, Foldable f, HatBaseClass b) => f (TransTable n b) -> TransTable n b
unions ts = Foldable.foldl' union NullTable ts
{-# INLINE size #-}
size :: (HatBaseClass b) => TransTable n b -> Size
size NullTable = 0
size (TransTable s _ _ _ _ _) = s
-- | transfer
-- Legacy API: new code should use "ExchangeAlgebra.Algebra.Transfer.Rule".
-- See the module header for compatibility assumptions P1-P5 and known lookup limitations.
-- Transfer transformation replaces the bases of algebra elements with other bases.
-- The values of the transformed entries remain unchanged. For example, given an algebra element a:
-- a = 6^ < e1 > +2 < e2 > +2 < e3 > +4 < e4 > +5^ < e5 > and the following transformation definition t:
-- ( from) < e1 > -> (to) < eA >
-- ( from) < e2 > -> (to) < eA >
-- ( from) < e3 > -> (to) < eA >
-- The transformation result r is as follows:
-- r = 6^ < e1 > +2 < e2 > +2 < e3 > +4 < e4 > +5^ < e5 >
-- + 6 < e 1 > + 6 ^ < e A >
-- + 2 ^ < e 2 > + 2 < e A >
-- + 2 ^ < e 3 > + 2 < e A >
-- = 6 ^ < e 1 > + 2 < e 2 > + 2 < e 3 > + 4 < e 4 > + 5 ^ < e 5 >
-- = 6 ^ < e 1 > + 2 < e 2 > + 2 < e 3 > + 4 < e 4 > + 5 ^ < e 5 >
-- + 6 < e 1 > + 6 ^ < e A > + 2 ^ < e 2 > + 4 < e A > + 2 ^ < e 3 >
--
--
-- >>> type Test = Alg Double (HatBase (AccountTitles, CountUnit))
-- >>> x = 1:@Hat:<(Cash,Yen) .+ 1:@Not:<(Products,Amount) :: Test
-- >>> y = 2:@Not:<(Cash,Yen) .+ 2:@Hat:<(Deposits,Yen) :: Test
-- >>> transfer (x .+ y) $ table $ Not:<(Products,Amount) :-> Not:<(Products,Yen) |% id ++ Hat:<(Products,Amount) :-> Hat:<(Products,Yen) |% id
-- 1.00:@Hat:<(Cash,Yen) .+ 2.00:@Not:<(Cash,Yen) .+ 2.00:@Hat:<(Deposits,Yen) .+ 1.00:@Not:<(Products,Yen)
--
-- Wildcards match but are not transformed
-- >>> type Test = Alg Double (HatBase (AccountTitles, CountUnit))
-- >>> x = 1:@Hat:<(Cash,Yen) .+ 1:@Not:<(Products,Amount) :: Test
-- >>> y = 2:@Not:<(Cash,Yen) .+ 2:@Hat:<(Deposits,Yen) :: Test
-- >>> transfer (x .+ y) $ table $ HatNot:<(Products,Amount) :-> HatNot:<(Products,Yen) |% id
-- 1.00:@Hat:<(Cash,Yen) .+ 2.00:@Not:<(Cash,Yen) .+ 2.00:@Hat:<(Deposits,Yen) .+ 1.00:@Not:<(Products,Yen)
--
-- >>> instance Element Int where wildcard = -1
-- >>> type Test = Alg Double (HatBase (AccountTitles, Int,CountUnit))
-- >>> x = 1:@Hat:<(Cash,(.#),Yen) .+ 1:@Not:<(Products,1,Yen) :: Test
-- >>> transfer x $ table $ HatNot:<((.#),(.#),Yen) :-> HatNot:<((.#),(.#),Amount) |% id
-- 1.00:@Hat:<(Cash,-1,Amount) .+ 1.00:@Not:<(Products,1,Amount)
data IndexedRule n b
= IndexedUnique !b !(n -> n) !b
| IndexedAmbiguous
data TransferIndex n b = TransferIndex
{ tiTree :: !(TransTable n b)
, tiByHatTitle :: !(HM.HashMap (Hat, AccountTitles) (IndexedRule n b))
}
{-# INLINE transferWithResolver #-}
transferWithResolver :: (HatVal n, HatBaseClass b)
=> (b -> Maybe ((n -> n), b))
-> Alg n b
-> Alg n b
transferWithResolver resolve = EA.map step
where
step (v :@ hb) = case resolve hb of
Nothing -> v :@ hb
Just (f, hb') ->
let !v' = f v
in if isZeroValue v'
then Zero
else v' :@ hb'
step x = x
{-# INLINE resolveByTree #-}
resolveByTree :: (HatVal n, HatBaseClass b)
=> TransTable n b
-> b
-> Maybe ((n -> n), b)
resolveByTree NullTable _ = Nothing
resolveByTree (TransTable _ hb2 f a l r) hb1
| hb1 ./= hb2 = case compareElement hb1 hb2 of
LT -> resolveByTree l hb1
GT -> resolveByTree r hb1
EQ -> error $ "transfer: " ++ show hb1 ++ "," ++ show hb2
| otherwise = Just (f, ignoreWildcard hb1 a)
{-# INLINE ruleEntries #-}
ruleEntries :: TransTable n b -> [(b, n -> n, b)]
ruleEntries NullTable = []
ruleEntries (TransTable _ b f a l r) =
ruleEntries l ++ ((b, f, a) : ruleEntries r)
{-# INLINE baseKey #-}
baseKey :: (ExBaseClass b) => b -> Maybe (Hat, AccountTitles)
baseKey b
| isWildcard h = Nothing
| haveWildcard at = Nothing
| otherwise = Just (h, at)
where
h = hat b
at = getAccountTitle b
buildTransferIndex :: (HatVal n, ExBaseClass b) => TransTable n b -> TransferIndex n b
buildTransferIndex t =
TransferIndex t $
Foldable.foldl' addRule HM.empty (ruleEntries t)
where
addRule acc (before, f, after) =
case baseKey before of
Nothing -> acc
Just k ->
HM.alter
(\entry -> case entry of
Nothing -> Just (IndexedUnique before f after)
Just _ -> Just IndexedAmbiguous
)
k
acc
{-# INLINE resolveByIndex #-}
resolveByIndex :: (HatVal n, ExBaseClass b)
=> TransferIndex n b
-> b
-> Maybe ((n -> n), b)
resolveByIndex idx hb =
case baseKey hb >>= (`HM.lookup` tiByHatTitle idx) of
Just (IndexedUnique before f after)
| hb .== before -> Just (f, ignoreWildcard hb after)
| otherwise -> resolveByTree (tiTree idx) hb
_ -> resolveByTree (tiTree idx) hb
-- | Legacy rewriting transfer. New code should use
-- "ExchangeAlgebra.Algebra.Transfer.Rule" to generate additional entries.
-- See the module header for P1-P5 and the mixed-wildcard lookup limitation.
{-# INLINE transfer #-}
transfer :: (HatVal n, HatBaseClass b) => Alg n b -> TransTable n b -> Alg n b
transfer alg NullTable = alg
transfer alg tt = transferWithResolver (resolveByTree tt) alg
{-# INLINE singleton #-}
singleton :: (HatVal n,HatBaseClass b) => b ->(n -> n) -> b -> TransTable n b
singleton before f after = TransTable 1 before f after NullTable NullTable
{-# INLINE insert #-}
insert :: (HatVal n,HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b
insert b = go b b
where
{-# INLINE go #-}
go :: (HatVal n,HatBaseClass b) => b -> b -> (n -> n) -> b -> TransTable n b -> TransTable n b
go orig !_ f x NullTable = singleton (lazy orig) f x
go orig !bx fx x t@(TransTable sy by fy y l r) =
case compareElement bx by of
LT | l' `ptrEq` l -> t
| otherwise -> balanceL by fy y l' r
where !l' = go orig bx fx x l
GT | r' `ptrEq` r -> t
| otherwise -> balanceR by fy y l r'
where !r' = go orig bx fx x r
EQ | x `ptrEq` y && (lazy orig `seq` (orig `ptrEq` by)) -> t
| otherwise -> TransTable sy (lazy orig) fx x l r
{-# INLINE insertR #-}
insertR :: (HatVal n,HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b
insertR kx0 = go kx0 kx0
where
{-# INLINE go #-}
go :: (HatVal n,HatBaseClass b) => b -> b -> (n -> n) -> b -> TransTable n b -> TransTable n b
go orig !_ fx ax NullTable = singleton (lazy orig) fx ax
go orig !bx fx ax t@(TransTable _ by fy ay l r) =
case compareElement bx by of
LT | l' `ptrEq` l -> t
| otherwise -> balanceL by fy ay l' r
where !l' = go orig bx fx ax l
GT | r' `ptrEq` r -> t
| otherwise -> balanceR by fy ay l r'
where !r' = go orig bx fx ax r
EQ -> t
-- NB. The unused\/unexported 'updateFunction' helper (update the transformation
-- function in the table) was removed as dead code; reintroduce from history if a
-- function-update operation on 'TransTable' is needed.
{-# INLINE ptrEq #-}
ptrEq :: a -> a -> Bool
ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)
delta = 3
ratio = 2
balanceL :: (HatVal n, HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b -> TransTable n b
balanceL b f a l r = case r of
NullTable -> case l of
NullTable -> TransTable 1 b f a NullTable NullTable
(TransTable _ _ _ _ NullTable NullTable)
-> TransTable 2 b f a l NullTable
(TransTable _ lb lf la NullTable (TransTable _ lrb lrf lra _ _))
-> TransTable 3 lrb lrf lra (TransTable 1 lb lf la NullTable NullTable) (TransTable 1 b f a NullTable NullTable)
(TransTable _ lb lf la ll@(TransTable _ _ _ _ _ _) NullTable)
-> TransTable 3 lb lf la ll (TransTable 1 b f a NullTable NullTable)
(TransTable ls lb lf la ll@(TransTable lls _ _ _ _ _) lr@(TransTable lrs lrb lrf lra lrl lrr))
| lrs < ratio*lls -> TransTable (1+ls) lb lf la ll (TransTable (1+lrs) b f a lr NullTable)
| otherwise -> TransTable (1+ls) lrb lrf lra (TransTable (1+lls+size lrl) lb lf la ll lrl) (TransTable (1+size lrr) b f a lrr NullTable)
(TransTable rs _ _ _ _ _) -> case l of
NullTable -> TransTable (1+rs) b f a NullTable r
(TransTable ls lb lf la ll lr)
| ls > delta*rs -> case (ll, lr) of
(TransTable lls _ _ _ _ _, TransTable lrs lrb lrf lra lrl lrr)
| lrs < ratio*lls -> TransTable (1+ls+rs) lb lf la ll (TransTable (1+rs+lrs) b f a lr r)
| otherwise -> TransTable (1+ls+rs) lrb lrf lra (TransTable (1+lls+size lrl) lb lf la ll lrl) (TransTable (1+rs+size lrr) b f a lrr r)
(_, _) -> error "Failure in Data.Map.balanceL"
| otherwise -> TransTable (1+ls+rs) b f a l r
balanceR :: (HatVal n, HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b -> TransTable n b
balanceR b f a l r = case l of
NullTable -> case r of
NullTable
-> TransTable 1 b f a NullTable NullTable -- Leaf nodes are Null
(TransTable _ _ _ _ NullTable NullTable)
-> TransTable 2 b f a NullTable r
(TransTable _ rb rf ra NullTable rr@(TransTable _ _ _ _ _ _))
-> TransTable 3 rb rf ra (TransTable 1 b f a NullTable NullTable) rr
(TransTable _ rb rf ra (TransTable _ rlb rlf rla _ _) NullTable)
-> TransTable 3 rlb rlf rla (TransTable 1 b f a NullTable NullTable) (TransTable 1 rb rf ra NullTable NullTable)
(TransTable rs rb rf ra rl@(TransTable rls rlb rlf rla rll rlr) rr@(TransTable rrs _ _ _ _ _))
| rls < ratio*rrs -> TransTable (1+rs) rb rf ra (TransTable (1+rls) b f a NullTable rl) rr
| otherwise -> TransTable (1+rs) rlb rlf rla (TransTable (1+size rll) b f a NullTable rll) (TransTable (1+rrs+size rlr) rb rf ra rlr rr)
(TransTable ls _ _ _ _ _) -> case r of
NullTable -> TransTable (1+ls) b f a l NullTable
(TransTable rs rb rf ra rl rr)
| rs > delta*ls -> case (rl, rr) of
(TransTable rls rlb rlf rla rll rlr, TransTable rrs _ _ _ _ _)
| rls < ratio*rrs -> TransTable (1+ls+rs) rb rf ra (TransTable (1+ls+rls) b f a l rl) rr
| otherwise -> TransTable (1+ls+rs) rlb rlf rla (TransTable (1+ls+size rll) b f a l rll) (TransTable (1+rrs+size rlr) rb rf ra rlr rr)
(_, _) -> error "Failure in Data.Map.balanceR"
| otherwise -> TransTable (1+ls+rs) b f a l r
-- NB. The unused\/unexported 'lookup' helper (point lookup on 'TransTable') was
-- removed as dead code; reintroduce from history if needed.
-- | make TransTable from list
--
-- >>> ExchangeAlgebra.Algebra.Transfer.fromList [(Hat:<(Cash),Hat:<(Building),(id :: Double -> Double) ),(Not:<(Building),Not:<(Cash),id)]
-- [(Hat:<Cash,Hat:<Building,<function>),(Not:<Building,Not:<Cash,<function>)]
fromList :: (HatVal n, HatBaseClass b) => [(b,b,(n -> n))] -> TransTable n b
fromList [] = NullTable
fromList [(b1,a1, f1)] = a1 `seq` TransTable 1 b1 f1 a1 NullTable NullTable
fromList ((b1,a1, f1) : xs0) | not_ordered b1 xs0 = a1 `seq` fromList' (TransTable 1 b1 f1 a1 NullTable NullTable) xs0
| otherwise = a1 `seq` go (1::Int) (TransTable 1 b1 f1 a1 NullTable NullTable) xs0
where
{-# INLINE not_ordered #-}
not_ordered _ [] = False
not_ordered kx ((ky, _, _) : _) = kx >= ky
{-# INLINE fromList' #-}
fromList' t0 xs = Foldable.foldl' ins t0 xs
where ins t (k,x,f) = insert k f x t
{-# INLINE go #-}
go !_ t [] = t
go _ t [(kx, x, fx)] = x `seq` insertMax kx fx x t
go s l xs@((kx, x, fx) : xss) | not_ordered kx xss = fromList' l xs
| otherwise = case create s xss of
(r, ys, []) -> x `seq` go (s `shiftL` 1) (link kx fx x l r) ys
(r, _, ys) -> x `seq` fromList' (link kx fx x l r) ys
{-# INLINE create #-}
create _ [] = (NullTable, [], [])
create s xs@(xp : xss)
| s == 1 = case xp of (kx, x, fx) | not_ordered kx xss -> x `seq` (TransTable 1 kx fx x NullTable NullTable, [], xss)
| otherwise -> x `seq` (TransTable 1 kx fx x NullTable NullTable, xss, [])
| otherwise = case create (s `shiftR` 1) xs of
res@(_, [], _) -> res
(l, [(ky, y, fy)], zs) -> y `seq` (insertMax ky fy y l, [], zs)
(l, ys@((ky, y, fy):yss), _) | not_ordered ky yss -> (l, [], ys)
| otherwise -> case create (s `shiftR` 1) yss of
(r, zs, ws) -> y `seq` (link ky fy y l r, zs, ws)
-- | make TransTable from list
-- Legacy API: new code should use "ExchangeAlgebra.Algebra.Transfer.Rule".
-- See the module header for compatibility assumptions P1-P5 and known lookup limitations.
-- same as fromList
-- >>> table $ Hat:<(Cash) :-> Hat:<(Building) |% (id :: Double -> Double) ++ Hat:<(Building) :-> Hat:<(Cash) |% id
-- [(Hat:<Cash,Hat:<Building,<function>),(Hat:<Building,Hat:<Cash,<function>)]
{-# INLINE table #-}
table :: (HatVal n, HatBaseClass b) => [(b,b,(n -> n))] -> TransTable n b
table = ExchangeAlgebra.Algebra.Transfer.fromList
-- | A part of a transfer rule. Represents a source-to-target base pair in @from :-> to@ form.
data TransTableParts b where
(:->) :: (HatBaseClass b) => b -> b -> TransTableParts b
-- | Transfer rule construction operator. @from .-> to@ produces a 'TransTableParts'.
--
-- Complexity: O(1)
{-# INLINE (.->) #-}
(.->) :: (HatBaseClass b) => b -> b -> TransTableParts b
(.->) b1 b2 = b1 :-> b2
instance (HatBaseClass b) => Show (TransTableParts b) where
show (b1 :-> b2) = show b1 ++ " :-> " ++ show b2
-- | Syntax to make list for makeList
--
-- >>> fmap (\(b, a, _) -> (b, a)) $ Hat:<(Yen,Cash):-> Hat:<(Yen,Building) |% (id :: Double -> Double) ++ Not:<(Yen,Building) :-> Not:<(Yen, Cash) |% id
-- [(Hat:<(Yen,Cash),Hat:<(Yen,Building)),(Not:<(Yen,Building),Not:<(Yen,Cash))]
{-# INLINE (|%) #-}
(|%) :: (HatVal n, HatBaseClass b) => TransTableParts b -> (n -> n) -> [(b,b,(n -> n))]
(|%) (b1 :-> b2) f = [(b1,b2,f)]
infixr 8 .->
infixr 8 :->
infixr 7 |%
-- NB. A universal @instance (HatVal n) => Show (n -> n)@ used to live here for
-- the sake of showing raw rule-list tuples in one doctest. It leaked a function
-- Show instance into every downstream module, so it was removed (design-review
-- C5); 'TransTable''s own 'Show' prints @<function>@ without it.
-- | Build an indexed fast transfer function from a list of transfer rules.
-- Legacy API: new code should use "ExchangeAlgebra.Algebra.Transfer.Rule".
-- See the module header for compatibility assumptions P1-P5 and known lookup limitations.
-- More efficient than @transfer@ when repeatedly applying the same TransTable.
--
-- Complexity: Build O(r log r) (r = number of rules); apply O(s) (s = number of entries)
createTransfer :: (HatVal n, ExBaseClass b) => [(b,b,(n -> n))] -> (Alg n b -> Alg n b)
createTransfer tt =
let !tb = table tt
!idx = buildTransferIndex tb
in \ts -> transferWithResolver (resolveByIndex idx) ts
-- * Closing transfer entries
-- | Income Summary Account: compute net income for the current period.
-- Legacy API: new code should use "ExchangeAlgebra.Algebra.Transfer.Rule".
-- See the module header for compatibility assumptions P1-P5 and known lookup limitations.
-- When the ledger is balanced (credit == debit, net income is zero), @diffRL@
-- reports the wildcard v'Side'; in that case the input is returned unchanged
-- (balanced ledger = identity; appending a zero posting is not added).
-- The result contains a legacy NetIncome/NetLoss balancing coordinate and is
-- an intermediate closing state, not input for reporting presentation. New
-- reporting code should derive the result from a validated before-closing
-- trial balance with "ExchangeAlgebra.Reporting.Metric".
-- This legacy API adds an entry whose non-account axes are wildcards: those
-- ledger wildcards mean the axes do not apply, rather than matching patterns.
incomeSummaryAccount :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b
incomeSummaryAccount alg = let (dc,diff) = diffRL alg
in case dc of
Credit -> alg .+ (diff :@ (toNot wildcard) .~ NetIncome)
Debit -> alg .+ (diff :@ (toNot wildcard) .~ NetLoss)
Side -> alg
-- | Net income transfer. Transfers NetIncome/NetLoss to RetainedEarnings.
-- Legacy API: new code should use "ExchangeAlgebra.Algebra.Transfer.Rule".
-- See the module header for compatibility assumptions P1-P5 and known lookup limitations.
--
-- Complexity: O(s) (s = total number of scalar entries)
netIncomeTransfer :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b
netIncomeTransfer = createTransfer
$ (toNot wildcard) .~ NetIncome :-> (toNot wildcard) .~ RetainedEarnings |% id
++ (toHat wildcard) .~ NetIncome :-> (toHat wildcard) .~ RetainedEarnings |% id
++ (toNot wildcard) .~ NetLoss :-> (toHat wildcard) .~ RetainedEarnings |% id
++ (toHat wildcard) .~ NetLoss :-> (toNot wildcard) .~ RetainedEarnings |% id
-- ** Journalizing
-- | Historical SNA/simulation transfer to the legacy GrossProfit coordinate.
-- Legacy API: new code should use "ExchangeAlgebra.Algebra.Transfer.Rule".
-- See the module header for compatibility assumptions P1-P5 and known lookup limitations.
-- Consolidates Sales, Purchases, WageExpenditure, Depreciation, and ValueAdded.
-- This fixed list is not a JGAAP gross-profit definition: it excludes
-- SalesCost and MerchandiseInventory. New statement reporting should use
-- "ExchangeAlgebra.Reporting.Metric" and
-- "ExchangeAlgebra.Reporting.Presentation" instead.
--
-- Complexity: O(s) (s = total number of scalar entries)
grossProfitTransfer :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b
grossProfitTransfer
= createTransfer
$ (toNot wildcard) .~ WageExpenditure :-> (toHat wildcard) .~ GrossProfit |% id
++ (toHat wildcard) .~ WageExpenditure :-> (toNot wildcard) .~ GrossProfit |% id
------------------------------------------------------------------
++ (toNot wildcard) .~ Depreciation :-> (toHat wildcard) .~ GrossProfit |% id
++ (toHat wildcard) .~ Depreciation :-> (toNot wildcard) .~ GrossProfit |% id
------------------------------------------------------------------
++ (toNot wildcard) .~ ValueAdded :-> (toNot wildcard) .~ GrossProfit |% id
++ (toHat wildcard) .~ ValueAdded :-> (toHat wildcard) .~ GrossProfit |% id
------------------------------------------------------------------
++ (toNot wildcard) .~ Sales :-> (toNot wildcard) .~ GrossProfit |% id
++ (toHat wildcard) .~ Sales :-> (toHat wildcard) .~ GrossProfit |% id
------------------------------------------------------------------
++ (toNot wildcard) .~ Purchases :-> (toHat wildcard) .~ GrossProfit |% id
++ (toHat wildcard) .~ Purchases :-> (toNot wildcard) .~ GrossProfit |% id
-- | Historical SNA/simulation transfer to the legacy OrdinaryProfit
-- Legacy API: new code should use "ExchangeAlgebra.Algebra.Transfer.Rule".
-- See the module header for compatibility assumptions P1-P5 and known lookup limitations.
-- coordinate. Its fixed list predates the JCCI vocabulary and is not a
-- complete JGAAP ordinary-profit definition. New statement reporting should
-- use the typed reporting metric API instead.
--
-- >>> type Test = Alg Double (HatBase (CountUnit, AccountTitles))
-- >>> x = 2279.0:@Not:<(Yen,Depreciation) .+ 500475.0:@Not:<(Yen,InterestEarned) :: Test
-- >>> ordinaryProfitTransfer x
-- 2279.00:@Hat:<(Yen,OrdinaryProfit) .+ 500475.00:@Not:<(Yen,OrdinaryProfit)
ordinaryProfitTransfer :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b
ordinaryProfitTransfer
= createTransfer
$ (toNot wildcard) .~ GrossProfit :-> (toNot wildcard) .~ OrdinaryProfit |% id
++ (toHat wildcard) .~ GrossProfit :-> (toHat wildcard) .~ OrdinaryProfit |% id
------------------------------------------------------------------
++ (toNot wildcard) .~ InterestEarned :-> (toNot wildcard) .~ OrdinaryProfit |% id
++ (toHat wildcard) .~ InterestEarned :-> (toHat wildcard) .~ OrdinaryProfit |% id
------------------------------------------------------------------
++ (toNot wildcard) .~ InterestExpense :-> (toHat wildcard) .~ OrdinaryProfit |% id
++ (toHat wildcard) .~ InterestExpense :-> (toNot wildcard) .~ OrdinaryProfit |% id
------------------------------------------------------------------
++ (toNot wildcard) .~ SubsidyIncome :-> (toNot wildcard) .~ OrdinaryProfit |% id
++ (toHat wildcard) .~ SubsidyIncome :-> (toHat wildcard) .~ OrdinaryProfit |% id
------------------------------------------------------------------
++ (toNot wildcard) .~ TaxesExpense :-> (toHat wildcard) .~ OrdinaryProfit |% id
++ (toHat wildcard) .~ TaxesExpense :-> (toNot wildcard) .~ OrdinaryProfit |% id
-- Government
++ (toNot wildcard) .~ TaxesRevenue :-> (toNot wildcard) .~ OrdinaryProfit |% id
++ (toHat wildcard) .~ TaxesRevenue :-> (toHat wildcard) .~ OrdinaryProfit |% id
------------------------------------------------------------------
++ (toNot wildcard) .~ CentralBankPaymentIncome :-> (toNot wildcard) .~ OrdinaryProfit |% id
++ (toHat wildcard) .~ CentralBankPaymentIncome :-> (toHat wildcard) .~ OrdinaryProfit |% id
------------------------------------------------------------------
++ (toNot wildcard) .~ Depreciation :-> (toHat wildcard) .~ OrdinaryProfit |% id
++ (toHat wildcard) .~ Depreciation :-> (toNot wildcard) .~ OrdinaryProfit |% id
------------------------------------------------------------------
++ (toNot wildcard) .~ WageExpenditure :-> (toHat wildcard) .~ OrdinaryProfit |% id
++ (toHat wildcard) .~ WageExpenditure :-> (toNot wildcard) .~ OrdinaryProfit |% id
------------------------------------------------------------------
++ (toNot wildcard) .~ SubsidyExpense :-> (toHat wildcard) .~ OrdinaryProfit |% id
++ (toHat wildcard) .~ SubsidyExpense :-> (toNot wildcard) .~ OrdinaryProfit |% id
------------------------------------------------------------------
-- Household
++ (toNot wildcard) .~ WageEarned :-> (toNot wildcard) .~ OrdinaryProfit |% id
++ (toHat wildcard) .~ WageEarned :-> (toHat wildcard) .~ OrdinaryProfit |% id
------------------------------------------------------------------
++ (toNot wildcard) .~ ConsumptionExpenditure :-> (toHat wildcard) .~ OrdinaryProfit |% id
++ (toHat wildcard) .~ ConsumptionExpenditure :-> (toNot wildcard) .~ OrdinaryProfit |% id
-- CentralBank
++ (toNot wildcard) .~ CentralBankPaymentExpense :-> (toHat wildcard) .~ OrdinaryProfit |% id
++ (toHat wildcard) .~ CentralBankPaymentExpense :-> (toNot wildcard) .~ OrdinaryProfit |% id
-- | Transfer to Retained Earnings.
-- Legacy API: new code should use "ExchangeAlgebra.Algebra.Transfer.Rule".
-- See the module header for compatibility assumptions P1-P5 and known lookup limitations.
-- Transfers OrdinaryProfit to RetainedEarnings.
--
-- Complexity: O(s) (s = total number of scalar entries)
retainedEarningTransfer :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b
retainedEarningTransfer
= createTransfer
$ (toNot wildcard) .~ OrdinaryProfit :-> (toNot wildcard) .~ RetainedEarnings |% id
++ (toHat wildcard) .~ OrdinaryProfit :-> (toHat wildcard) .~ RetainedEarnings |% id
data FinalStockSide
= FinalStockKeep
| FinalStockFlip
-- | Legacy private adapter for the public PIMO-aware closing classification.
{-# INLINE finalStockRule #-}
finalStockRule :: AccountTitles -> Maybe FinalStockSide
finalStockRule title = case closingSide title of
Nothing -> Nothing
Just ClosingKeep -> Just FinalStockKeep
Just ClosingFlip -> Just FinalStockFlip
-- | Internal step of the final stock transfer from income statement to retained earnings.
-- Legacy API: new code should use "ExchangeAlgebra.Algebra.Transfer.Rule".
-- See the module header for compatibility assumptions P1-P5 and known lookup limitations.
-- Cost accounts are transferred to RetainedEarnings with Hat/Not flipped;
-- revenue accounts are transferred to RetainedEarnings as-is. The registry's
-- explicit 'NoClose' policy permanently exempts the balancing aggregates
-- 'NetIncome'\/'NetLoss': their division encodes the P\/L presentation side,
-- so this division-derived rule would invert their transfer sign — their
-- closing is owned by the dedicated net-income transfer in this module.
--
-- Complexity: O(s) (s = total number of scalar entries)
{-# INLINE finalStockTransferStep #-}
finalStockTransferStep :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b
finalStockTransferStep = EA.map go
where
go (v :@ hb) = case finalStockRule (getAccountTitle hb) of
Nothing -> v :@ hb
Just FinalStockKeep ->
v :@ setAccountTitle hb RetainedEarnings
Just FinalStockFlip ->
v :@ setAccountTitle (revHat hb) RetainedEarnings
go x = x
-- | Final Stock Transfer (closing entries).
-- Legacy API: new code should use "ExchangeAlgebra.Algebra.Transfer.Rule".
-- See the module header for compatibility assumptions P1-P5 and known lookup limitations.
-- Transfers registry-eligible cost and revenue accounts to RetainedEarnings
-- and cancels via the bar operation.
--
-- Complexity: O(s) (s = total number of scalar entries)
finalStockTransfer ::(HatVal n, ExBaseClass b) => Alg n b -> Alg n b
finalStockTransfer = (.-) . finalStockTransferStep