diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,29 @@ # Changelog for ExchangeAlgebra +## 0.5.2.0 - 2026-09-23 + +### Added + +- `ExchangeAlgebra.Algebra.Exact` and `ExchangeAlgebra.Journal.Exact` provide + checked readouts that sum original postings exactly and round each output + once. The algebra API includes `normExact`, `barExact`, + `projNetNormExact`, `balanceMapByExact`, `netPairMapByExact`, + `postFromNetByExact`, `diffRLExact`, `balanceExact`, and + `accountBalancesExact`. Journal projections cancel within each note before + rounding the combined residual; other journal readouts aggregate notes. + `sumExact` and the accumulator operations also support scalar aggregation. + `ExactSum` supports `Double`, `MoneyDouble`, `NN.Double`, and `MoneyDecimal`. + `ExactSumError` reports non-finite or negative inputs and exact sums beyond + the finite range of the output type. Callers must handle the `Either` result. + +### Documentation + +- Mark the existing floating-point net and balance readouts as order-dependent + where they sum postings sequentially, and identify tolerance-based + cancellation. `netGross` and `relativeTo` document that their supplied gross + totals may already be rounded; use exact readouts on the original postings + upstream when exact balances are required. + ## 0.5.1.0 - 2026-09-23 ### Added diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -21,7 +21,7 @@ ```yaml # stack.yaml extra-deps: - - exchangealgebra-0.5.1.0 + - exchangealgebra-0.5.2.0 ``` ```yaml diff --git a/exchangealgebra.cabal b/exchangealgebra.cabal --- a/exchangealgebra.cabal +++ b/exchangealgebra.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: exchangealgebra -version: 0.5.1.0 +version: 0.5.2.0 synopsis: Exchange Algebra for bookkeeping and economic simulation description: Please see the README on GitHub at category: Accounting, Finance, Math @@ -84,6 +84,7 @@ ExchangeAlgebra.Algebra.Base.Account.Registry ExchangeAlgebra.Algebra.Base.Account.Types ExchangeAlgebra.Algebra.Base.Element + ExchangeAlgebra.Algebra.Exact ExchangeAlgebra.Algebra.Internal ExchangeAlgebra.Algebra.Readout.Net ExchangeAlgebra.Algebra.Transfer @@ -97,6 +98,7 @@ ExchangeAlgebra.Convert.Csv ExchangeAlgebra.Foundation ExchangeAlgebra.Journal + ExchangeAlgebra.Journal.Exact ExchangeAlgebra.Journal.Transfer ExchangeAlgebra.Journal.Transfer.Rule ExchangeAlgebra.Optimize @@ -191,8 +193,10 @@ main-is: SurfaceMain.hs other-modules: Surface.Accounting + Surface.Algebra.Exact Surface.Algebra.Readout.Net Surface.Foundation + Surface.Journal.Exact Surface.Render.Bookkeeping Surface.Render.Csv Surface.Render.Simulation @@ -231,6 +235,7 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Algebra.ExactSumSpec Algebra.ProjWildcardSpec Golden.WriteRows Transfer.RuleSpec diff --git a/src/ExchangeAlgebra/Algebra/Exact.hs b/src/ExchangeAlgebra/Algebra/Exact.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Algebra/Exact.hs @@ -0,0 +1,608 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | Checked readouts retain exact sums until each output is rounded once. +-- This additive accounting layer uses the algebra, value types, and account +-- balance representation; journal readouts build on it in +-- "ExchangeAlgebra.Journal.Exact". Start with the accumulator contract, then +-- read the algebra readouts for grouping and cancellation rules. +-- +-- Inputs must be finite and non-negative. Every intermediate aggregation unit +-- and output must be at most the largest finite value of its type. Errors are +-- sticky. Double outputs use nearest-even rounding and normalize negative zero. +-- For Double, MoneyDouble, and NN.Double, the same multiset of complete bases, +-- sides, and values gives bit-identical scalar outputs under reordering and +-- accumulator merging. Changing notes, compressing, or substituting rounded +-- partial totals is outside this guarantee, as are enumeration, Show, and Binary. +module ExchangeAlgebra.Algebra.Exact ( + -- * Accumulators + ExactSum(..) + , ExactSumError(..) + , netAccum + , sumExact + -- * Algebra readouts + , normExact + , barExact + , projNetNormExact + , balanceMapByExact + , netPairMapByExact + , postFromNetByExact + -- * Accounting readouts + , diffRLExact + , balanceExact + , accountBalancesExact + ) where + +import qualified Data.Decimal as Decimal +import qualified Data.Foldable as Foldable +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map.Strict as Map +import qualified Data.Sequence as Seq +import qualified Number.NonNegative as NN + +import ExchangeAlgebra.Algebra ( + Alg + , HatVal(..) + , foldEntries + , (.@) + , (.+) + ) +import qualified ExchangeAlgebra.Algebra as Algebra +import qualified ExchangeAlgebra.Algebra.Internal as Internal +import ExchangeAlgebra.Algebra.Base ( + AccountTitles + , ExBaseClass(..) + , Hat(..) + , HatBaseClass(..) + , Side(..) + ) +import ExchangeAlgebra.TrialBalance.Balance (AccountBalance(..)) +import ExchangeAlgebra.Value (MoneyDecimal(..), MoneyDouble(..)) + +-- * Accumulators + +-- | Checked summation failures. A failed accumulator cannot recover by netting. +data ExactSumError + = NonFiniteInput -- ^ An input is NaN or infinite. + | NegativeInput -- ^ An input is negative. + | SumOutOfRange -- ^ An exact aggregation exceeds the largest finite value. + deriving (Eq, Show) + +-- | Exact non-negative aggregation with signed intermediates confined to the state. +-- Floating instances require IEEE-754 nearest-even arithmetic. Decimal arithmetic +-- has no upper range bound. Each readout validates its aggregation units before +-- cancellation; invalid inputs and out-of-range sums produce sticky failures. +-- +-- == Laws +-- +-- For all four supplied instances, on valid states whose sums are in range, +-- merge is commutative and associative, and empty is its identity, observed +-- through the represented exact value. Netting returns the exact comparison +-- and absolute difference. No tolerance applies. For floating instances, +-- observing these laws through 'roundAccum' gives bit-identical values; +-- 'roundAccum' is not a homomorphism into floating-point addition. +class HatVal n => ExactSum n where + -- | State containing an exact non-negative value or a sticky failure. + data Accum n + + -- | The valid state representing zero. + emptyAccum :: Accum n + + -- | Add one finite non-negative input without rounding the represented sum. + -- Invalid input or an exact sum beyond the type's range makes the state fail. + addAccum :: n -> Accum n -> Accum n + + -- | Merge exact values without rounding, retaining failures from either input. + -- The merged exact value must fit the type's range. + mergeAccum :: Accum n -> Accum n -> Accum n + + -- | Validate both states, then return their exact comparison and absolute + -- difference without rounding. Even equal out-of-range sides fail. + netAccumState :: Accum n -> Accum n -> Either ExactSumError (Ordering, Accum n) + + -- | Round once to the value type, normalizing negative zero to positive zero. + -- The exact value, not its rounded result, must be in range. + roundAccum :: Accum n -> Either ExactSumError n + +-- | Non-overlapping Shewchuk partials in increasing magnitude, with no zero terms. +-- Both the elements and the spine are strict; signed values remain private. +data Partials + = NoPartials + | Partial !Double !Partials + +-- | Floating accumulator payload containing a checked scalar or expansion. +data FloatingState + = FloatingFailure !ExactSumError + | FloatingSingle !Double + | FloatingSum !Partials + +instance ExactSum Double where + data Accum Double = DoubleAccum !FloatingState + emptyAccum = DoubleAccum (FloatingSingle 0) + addAccum value (DoubleAccum state) = DoubleAccum (addFloating value state) + mergeAccum (DoubleAccum left) (DoubleAccum right) = + DoubleAccum (mergeFloating left right) + netAccumState (DoubleAccum left) (DoubleAccum right) = do + (direction, difference) <- netFloating left right + pure (direction, DoubleAccum difference) + roundAccum (DoubleAccum state) = roundFloating state + +instance ExactSum MoneyDouble where + data Accum MoneyDouble = MoneyDoubleAccum !(Accum Double) + emptyAccum = MoneyDoubleAccum emptyAccum + addAccum (MoneyDouble value) (MoneyDoubleAccum state) = + MoneyDoubleAccum (addAccum value state) + mergeAccum (MoneyDoubleAccum left) (MoneyDoubleAccum right) = + MoneyDoubleAccum (mergeAccum left right) + netAccumState (MoneyDoubleAccum left) (MoneyDoubleAccum right) = do + (direction, difference) <- netAccumState left right + pure (direction, MoneyDoubleAccum difference) + roundAccum (MoneyDoubleAccum state) = MoneyDouble <$> roundAccum state + +instance ExactSum NN.Double where + data Accum NN.Double = NonNegativeAccum !(Accum Double) + emptyAccum = NonNegativeAccum emptyAccum + addAccum value (NonNegativeAccum state) = + NonNegativeAccum (addAccum (NN.toNumber value) state) + mergeAccum (NonNegativeAccum left) (NonNegativeAccum right) = + NonNegativeAccum (mergeAccum left right) + netAccumState (NonNegativeAccum left) (NonNegativeAccum right) = do + (direction, difference) <- netAccumState left right + pure (direction, NonNegativeAccum difference) + roundAccum (NonNegativeAccum state) = NN.fromNumber <$> roundAccum state + +instance ExactSum MoneyDecimal where + data Accum MoneyDecimal + = DecimalFailure !ExactSumError + | DecimalAccum !(Decimal.DecimalRaw Integer) + emptyAccum = DecimalAccum 0 + addAccum _ failure@(DecimalFailure _) = failure + addAccum (MoneyDecimal value) (DecimalAccum total) + | value < 0 = DecimalFailure NegativeInput + | otherwise = DecimalAccum (total + value) + mergeAccum failure@(DecimalFailure _) _ = failure + mergeAccum _ failure@(DecimalFailure _) = failure + mergeAccum (DecimalAccum left) (DecimalAccum right) = DecimalAccum (left + right) + netAccumState (DecimalFailure failure) _ = Left failure + netAccumState _ (DecimalFailure failure) = Left failure + netAccumState (DecimalAccum left) (DecimalAccum right) = + Right (compare left right, DecimalAccum (abs (left - right))) + roundAccum (DecimalFailure failure) = Left failure + roundAccum (DecimalAccum value) = Right (MoneyDecimal value) + +-- | Largest finite binary64 value, expressed without an overflowing intermediate. +maximumFinite :: Double +maximumFinite = encodeFloat (2 ^ (53 :: Int) - 1) (1024 - 53) + +-- | Error-free two-sum with the greater-magnitude operand first. +twoSum :: Double -> Double -> (Double, Double) +twoSum left right + | abs left < abs right = twoSum right left + | otherwise = let !high = left + right + !low = right - (high - left) + in (high, low) + +-- | Insert a signed component into an expansion without range checking. +-- An infinite high component records arithmetic overflow for the caller. +insertPartial :: Double -> Partials -> Partials +insertPartial value NoPartials + | value == 0 = NoPartials + | otherwise = Partial value NoPartials +insertPartial value (Partial next rest) + | isInfinite high = Partial high NoPartials + | low == 0 = insertPartial high rest + | otherwise = Partial low (insertPartial high rest) + where + (!high, !low) = twoSum value next + +-- | Reverse an expansion for comparisons, subtraction, and final rounding. +reversePartials :: Partials -> Partials +reversePartials = go NoPartials + where + go !result NoPartials = result + go !result (Partial value rest) = go (Partial value result) rest + +-- | Compare an expansion with zero using its largest nonzero component. +signPartials :: Partials -> Ordering +signPartials NoPartials = EQ +signPartials (Partial value NoPartials) = compare value 0 +signPartials (Partial _ rest) = signPartials rest + +-- | Keep zero and one-component states in a strict scalar payload, without a spine. +compactPartials :: Partials -> FloatingState +compactPartials NoPartials = FloatingSingle 0 +compactPartials (Partial value NoPartials) = FloatingSingle value +compactPartials partials = FloatingSum partials + +-- | Check the exact expansion against M. If the largest component is M, +-- the sign of the remaining expansion distinguishes M from M + one subnormal. +checkPartials :: Partials -> FloatingState +checkPartials partials = check 0 partials + where + check _ NoPartials = compactPartials partials + check previous (Partial largest NoPartials) + | isInfinite largest = FloatingFailure SumOutOfRange + | largest > maximumFinite = FloatingFailure SumOutOfRange + | largest == maximumFinite && previous > 0 = FloatingFailure SumOutOfRange + | otherwise = compactPartials partials + check _ (Partial value rest) = check value rest + +-- | Add two checked non-negative scalars with one TwoSum. Allocate partials only +-- for a nonzero residual; a positive low term above M still fails before rounding. +addSingles :: Double -> Double -> FloatingState +addSingles 0 right = FloatingSingle right +addSingles left 0 = FloatingSingle left +addSingles left right + | isInfinite high = FloatingFailure SumOutOfRange + | high == maximumFinite && low > 0 = FloatingFailure SumOutOfRange + | low == 0 = FloatingSingle high + | otherwise = FloatingSum (Partial low (Partial high NoPartials)) + where + (!high, !low) = twoSum left right + +-- | Validate an input before inserting it into a valid floating state. +addFloating :: Double -> FloatingState -> FloatingState +addFloating _ failure@(FloatingFailure _) = failure +addFloating value (FloatingSingle total) + | isNaN value || isInfinite value = FloatingFailure NonFiniteInput + | value < 0 = FloatingFailure NegativeInput + | otherwise = addSingles total value +addFloating value (FloatingSum partials) + | isNaN value || isInfinite value = FloatingFailure NonFiniteInput + | value < 0 = FloatingFailure NegativeInput + | otherwise = checkPartials (insertPartial value partials) + +-- | Merge ascending partials, then check the whole exact aggregation unit. +mergeFloating :: FloatingState -> FloatingState -> FloatingState +mergeFloating failure@(FloatingFailure _) _ = failure +mergeFloating _ failure@(FloatingFailure _) = failure +mergeFloating (FloatingSingle left) (FloatingSingle right) = addSingles left right +mergeFloating (FloatingSingle left) right = + mergeFloating (FloatingSum (insertPartial left NoPartials)) right +mergeFloating left (FloatingSingle right) = + mergeFloating left (FloatingSum (insertPartial right NoPartials)) +mergeFloating (FloatingSum left) (FloatingSum right) = checkPartials (go left right) + where + go !total NoPartials = total + go !total (Partial value rest) = go (insertPartial value total) rest + +-- | Merge both expansions in descending magnitude, negating only the second +-- state's components. Cancel the large opposing components before inserting +-- either state's small signed tails. Inserting -M into an existing expansion +-- with a negative low component could otherwise overflow before cancellation. +netFloating :: FloatingState -> FloatingState + -> Either ExactSumError (Ordering, FloatingState) +netFloating (FloatingFailure failure) _ = Left failure +netFloating _ (FloatingFailure failure) = Left failure +netFloating (FloatingSingle 0) (FloatingSingle 0) = Right (EQ, FloatingSingle 0) +netFloating (FloatingSingle 0) right = Right (LT, right) +netFloating left (FloatingSingle 0) = Right (GT, left) +netFloating (FloatingSingle left) (FloatingSingle right) = + Right (compare left right, difference) + where + (!high, !low) = twoSum (max left right) (negate (min left right)) + difference + | low == 0 = FloatingSingle high + | otherwise = FloatingSum (Partial low (Partial high NoPartials)) +netFloating (FloatingSingle left) right = + netFloating (FloatingSum (insertPartial left NoPartials)) right +netFloating left (FloatingSingle right) = + netFloating left (FloatingSum (insertPartial right NoPartials)) +netFloating (FloatingSum NoPartials) (FloatingSum NoPartials) = + Right (EQ, FloatingSingle 0) +netFloating (FloatingSum NoPartials) right = Right (LT, right) +netFloating left (FloatingSum NoPartials) = Right (GT, left) +netFloating (FloatingSum left) (FloatingSum right) = + Right (direction, compactPartials magnitude) + where + difference = subtractPartials NoPartials (reversePartials left) (reversePartials right) + direction = signPartials difference + magnitude + | direction == LT = negatePartials difference + | otherwise = difference + subtractPartials !total NoPartials NoPartials = total + subtractPartials !total (Partial value rest) NoPartials = + subtractPartials (insertPartial value total) rest NoPartials + subtractPartials !total NoPartials (Partial value rest) = + subtractPartials (insertPartial (negate value) total) NoPartials rest + subtractPartials !total first@(Partial firstValue firstRest) + second@(Partial secondValue secondRest) + | abs firstValue >= abs secondValue = + subtractPartials (insertPartial firstValue total) firstRest second + | otherwise = + subtractPartials (insertPartial (negate secondValue) total) first secondRest + negatePartials NoPartials = NoPartials + negatePartials (Partial value rest) = Partial (negate value) (negatePartials rest) + +-- | Collapse from the largest component, correcting ties with the next residual. +-- This is the nearest-even finalization used with Shewchuk expansions. +roundPartials :: Partials -> Double +roundPartials NoPartials = 0 +roundPartials (Partial value NoPartials) = value +roundPartials partials = case reversePartials partials of + NoPartials -> 0 + Partial value rest -> collapse value rest + where + collapse !high NoPartials = high + collapse !high (Partial value rest) + | low == 0 = collapse rounded rest + | otherwise = correct rounded low rest + where + (!rounded, !low) = twoSum high value + correct high low (Partial next _) + | (low < 0 && next < 0) || (low > 0 && next > 0) + , let doubled = low * 2 + , let adjusted = high + doubled + , adjusted - high == doubled = adjusted + correct high _ _ = high + +-- | Extract one checked scalar; zero has its canonical positive sign. +roundFloating :: FloatingState -> Either ExactSumError Double +roundFloating (FloatingFailure failure) = Left failure +roundFloating (FloatingSingle value) + | value == 0 = Right 0 + | otherwise = Right value +roundFloating (FloatingSum partials) + | rounded == 0 = Right 0 + | otherwise = Right rounded + where + rounded = roundPartials partials + +-- | Validate two exact states and round their absolute difference once. +-- The direction compares the first state with the second without tolerance. +netAccum :: ExactSum n => Accum n -> Accum n -> Either ExactSumError (Ordering, n) +netAccum left right = do + (direction, difference) <- netAccumState left right + magnitude <- roundAccum difference + pure (direction, magnitude) + +-- | Sum finite non-negative inputs exactly and round once. The exact total +-- must fit the value type; unlike a sequential floating sum, order has no effect. +sumExact :: (ExactSum n, Foldable f) => f n -> Either ExactSumError n +sumExact = roundAccum . Foldable.foldl' (flip addAccum) emptyAccum + +-- * Algebra readouts + +-- | Two non-negative states, ordered as Not then Hat, or debit then credit. +data Sides n = Sides !(Accum n) !(Accum n) + +-- | Two empty side totals. +emptySides :: ExactSum n => Sides n +emptySides = Sides emptyAccum emptyAccum + +-- | Add to the first side when the predicate holds, otherwise the second. +addSide :: ExactSum n => Bool -> n -> Sides n -> Sides n +addSide True value (Sides first second) = Sides (addAccum value first) second +addSide False value (Sides first second) = Sides first (addAccum value second) + +-- | Add the entries observed by foldEntries, preserving its exact-zero filter. +addPosting :: ExactSum n => Accum n -> n -> Accum n +{-# INLINE addPosting #-} +addPosting total value + | isZeroValue value = total + | otherwise = addAccum value total + +-- | Visit the stored complete-base pairs without reconstructing posting bases. +foldPairs :: (HatVal n, HatBaseClass b) + => (a -> BasePart b -> Internal.Pair n -> a) -> a -> Alg n b -> a +{-# INLINE foldPairs #-} +foldPairs _ initial Internal.Zero = initial +foldPairs collect initial (value Internal.:@ postingBase) + | isZeroValue value = initial + | otherwise = collect initial (base postingBase) pair + where + pair + | isHat postingBase = Internal.Pair (Seq.singleton value) Seq.empty + | otherwise = Internal.Pair Seq.empty (Seq.singleton value) +foldPairs collect initial (Internal.Liner pairs _ _ _ _ _) = + HashMap.foldlWithKey' collect initial pairs + +-- | Accumulate each stored side before exact cancellation, without regrouping. +netPairState :: ExactSum n => Internal.Pair n -> Either ExactSumError (Ordering, Accum n) +{-# INLINE netPairState #-} +netPairState (Internal.Pair hats nots) = netAccumState + (Foldable.foldl' addPosting emptyAccum nots) + (Foldable.foldl' addPosting emptyAccum hats) + +-- | Exact absolute residual states, retaining the winning complete base. +baseResiduals :: (ExactSum n, HatBaseClass b) + => Alg n b -> Either ExactSumError [(b, Accum n)] +{-# INLINE baseResiduals #-} +baseResiduals = foldPairs collect (Right []) + where + collect result basePart pair = do + residuals <- result + (direction, magnitude) <- netPairState pair + case direction of + EQ -> pure residuals + GT -> pure ((merge Not basePart, magnitude) : residuals) + LT -> pure ((merge Hat basePart, magnitude) : residuals) + +-- | Read the gross norm of all finite non-negative postings with one rounding. +-- Hat and Not both contribute; their combined exact total must fit the type. +-- This avoids the order-dependent floating addition used by the existing norm. +normExact :: (ExactSum n, HatBaseClass b) => Alg n b -> Either ExactSumError n +{-# INLINABLE normExact #-} +normExact Internal.Zero = roundAccum emptyAccum +normExact (value Internal.:@ _) = roundAccum (addPosting emptyAccum value) +normExact (Internal.Liner pairs _ _ _ _ _) = + roundAccum (HashMap.foldl' collect emptyAccum pairs) + where + collect total (Internal.Pair hats nots) = + Foldable.foldl' addPosting (Foldable.foldl' addPosting total hats) nots + +-- | Cancel only exactly equal complete bases, returning non-negative postings. +-- Each finite non-negative side total must fit the type. Each surviving base +-- difference is rounded once, with no cancellation tolerance as in the old bar. +-- Scalar bits follow the module's multiset guarantee; posting order does not. +barExact :: (ExactSum n, HatBaseClass b) + => Alg n b -> Either ExactSumError (Alg n b) +{-# INLINABLE barExact #-} +barExact Internal.Zero = Right Internal.Zero +barExact (value Internal.:@ _) | isZeroValue value = Right Internal.Zero +barExact (value Internal.:@ postingBase) = + (.@ merge side (base postingBase)) <$> roundAccum (addPosting emptyAccum value) + where + side + | isHat postingBase = Hat + | otherwise = Not +barExact (Internal.Liner pairs _ _ _ _ _) = do + rounded <- traverse roundPair pairs + let remaining = HashMap.mapMaybe id rounded + pure $ case HashMap.null remaining of + True -> Internal.Zero + False -> Internal.linerFromMap remaining + where + roundPair pair = do + (direction, state) <- netPairState pair + case direction of + EQ -> pure Nothing + GT -> do + value <- roundAccum state + pure (makePair Not value) + LT -> do + value <- roundAccum state + pure (makePair Hat value) + makePair _ value | isZeroValue value = Nothing + makePair Hat value = Just (Internal.Pair (Seq.singleton value) Seq.empty) + makePair _ value = Just (Internal.Pair Seq.empty (Seq.singleton value)) + +-- | Project with set semantics, cancel per complete base, then round the sum +-- of residual states once. Selected inputs must be finite and non-negative; +-- each side total and the residual total must fit the type. +-- +-- Unlike the existing projection readout, no sequential rounding or tolerance +-- is used. It equals @normExact =<< barExact (Algebra.proj bases algebra)@ only +-- as a mathematical operation interpreting every operation at infinite precision. +-- With T = 2^53, residuals T+1 and 1 give T+2 here but T after rounding each base +-- first. Duplicate queries never duplicate postings. +projNetNormExact :: (ExactSum n, HatBaseClass b) + => [b] -> Alg n b -> Either ExactSumError n +projNetNormExact bases algebra = do + residuals <- baseResiduals (Algebra.proj bases algebra) + roundAccum (Foldable.foldl' (\total (_, state) -> mergeAccum total state) + emptyAccum residuals) + +-- | Sum selected finite non-negative postings by key and net each key once. +-- Each key's side totals must fit the type. GT means Not is larger, LT means +-- Hat is larger, and EQ retains a zero key. Unlike the signed, sequential old +-- readout, the magnitude is non-negative and no tolerance is applied. +-- Postings whose key is Nothing are not validated or aggregated. +balanceMapByExact :: (ExactSum n, HatBaseClass b, Ord k) + => (BasePart b -> Maybe k) -> Alg n b + -> Either ExactSumError (Map.Map k (Ordering, n)) +{-# INLINABLE balanceMapByExact #-} +balanceMapByExact keyOf algebra = traverse finish grouped + where + grouped = case algebra of + singleton@(_ Internal.:@ _) -> foldEntries collectPosting Map.empty singleton + _ -> foldPairs collect Map.empty algebra + collectPosting previous value postingBase = case keyOf (base postingBase) of + Nothing -> previous + Just key -> Map.alter (Just . addSide (not (isHat postingBase)) value + . maybe emptySides id) key previous + collect totals basePart (Internal.Pair hats nots) + | Foldable.all isZeroValue hats && Foldable.all isZeroValue nots = totals + | otherwise = case keyOf basePart of + Nothing -> totals + Just key -> Map.alter (Just . addPair . maybe emptySides id) key totals + where + addPair (Sides first second) = Sides + (Foldable.foldl' addPosting first nots) + (Foldable.foldl' addPosting second hats) + finish (Sides first second) = netAccum first second + +-- | Cancel per complete base before merging residual states by key and side. +-- All inputs must be finite and non-negative; base-side and key-side totals +-- must fit the type. Each output side is rounded once. There is no tolerance. +-- Distinct bases with Not 10 and Hat 7 give (10,7), as in the existing readout; +-- the pair is ordered Not then Hat and does not net across bases. +netPairMapByExact :: (ExactSum n, HatBaseClass b, Ord k) + => (BasePart b -> Maybe k) -> Alg n b + -> Either ExactSumError (Map.Map k (n, n)) +{-# INLINABLE netPairMapByExact #-} +netPairMapByExact keyOf algebra = do + residuals <- baseResiduals algebra + traverse finish (Foldable.foldl' collect Map.empty residuals) + where + collect totals (postingBase, state) = case keyOf (base postingBase) of + Nothing -> totals + Just key -> Map.alter (Just . combine . maybe emptySides id) key totals + where + combine (Sides first second) + | isHat postingBase = Sides first (mergeAccum second state) + | otherwise = Sides (mergeAccum first state) second + finish (Sides first second) = (,) <$> roundAccum first <*> roundAccum second + +-- | Net each complete base, restore its winning side, select its key, merge +-- residual states by key, round once, then call the posting function. +-- All input base-side and selected key totals must fit the type; inputs must be +-- finite and non-negative. Unlike the old function, no tolerance or rounded +-- intermediate algebra is used. Validation and the one-rounding guarantee end +-- at the amount passed to the callback; values made by the callback are not covered. +postFromNetByExact :: (ExactSum n, HatBaseClass b, Ord k) + => (b -> Maybe k) -> (k -> n -> Alg n b) -> Alg n b + -> Either ExactSumError (Alg n b) +postFromNetByExact keyOf post algebra = do + residuals <- baseResiduals algebra + amounts <- traverse roundAccum (Foldable.foldl' collect Map.empty residuals) + pure (Map.foldlWithKey' (\result key value -> result .+ post key value) mempty amounts) + where + collect totals (postingBase, state) = case keyOf postingBase of + Nothing -> totals + Just key -> Map.insertWith mergeAccum key state totals + +-- * Accounting readouts + +-- | Collect accounting sides; a structural Side contributes to neither total. +accountSide :: ExactSum n => Side -> n -> Sides n -> Sides n +accountSide Debit = addSide True +accountSide Credit = addSide False +accountSide Side = const id + +-- | Recover a debit or credit direction from an exact comparison. +accountDirection :: Ordering -> Side +accountDirection GT = Debit +accountDirection LT = Credit +accountDirection EQ = Side + +-- | Compare debit and credit exact totals, rounding only their absolute difference. +-- Finite non-negative inputs and both side totals must fit the type. Only exact +-- equality returns (Side,0); the existing tolerance-based diffRL is lossy. +-- Structural Side postings contribute no value and are not validated. +diffRLExact :: (ExactSum n, ExBaseClass b) + => Alg n b -> Either ExactSumError (Side, n) +diffRLExact algebra = do + let Sides debit credit = foldEntries collect emptySides algebra + (direction, amount) <- netAccum debit credit + pure (accountDirection direction, amount) + where + collect totals value postingBase = accountSide (whichSide postingBase) value totals + +-- | Test exact debit-credit equality without the old balance tolerance. +-- The finite non-negative input and side-total range checks of 'diffRLExact' +-- apply. Its amount is rounded once, while this predicate observes exact direction. +balanceExact :: (ExactSum n, ExBaseClass b) => Alg n b -> Either ExactSumError Bool +balanceExact = fmap ((== Side) . fst) . diffRLExact + +-- | Aggregate by account title and net debit against credit without tolerance. +-- Finite non-negative inputs and each account's side totals must fit the type. +-- Each account magnitude is rounded once, instead of sequentially summing as +-- in the old accountBalances. Balanced accounts remain present as NoBalance. +-- Structural Side postings contribute no value and are not validated. +accountBalancesExact :: (ExactSum n, ExBaseClass b) + => Alg n b -> Either ExactSumError (Map.Map AccountTitles (AccountBalance n)) +accountBalancesExact = traverse finish . foldEntries collect Map.empty + where + collect totals value postingBase = + Map.alter (Just . accountSide (whichSide postingBase) value + . maybe emptySides id) (getAccountTitle postingBase) totals + finish (Sides debit credit) = do + (direction, amount) <- netAccum debit credit + pure $ case direction of + EQ -> NoBalance + GT -> DebitBalance amount + LT -> CreditBalance amount diff --git a/src/ExchangeAlgebra/Algebra/Internal.hs b/src/ExchangeAlgebra/Algebra/Internal.hs --- a/src/ExchangeAlgebra/Algebra/Internal.hs +++ b/src/ExchangeAlgebra/Algebra/Internal.hs @@ -52,6 +52,7 @@ , HatVal(..) , Pair(..) , Alg(..) + , linerFromMap , isZero , (.@) , (<@) @@ -243,12 +244,19 @@ (.^) :: a n b -> a n b -- | Bar operation. Cancels Hat/Not on the same base and retains only the difference. + -- Floating-point side totals use sequential addition and depend on posting order; + -- near-equal sides cancel under 'nearlyEqScaled'. For exact totals, see + -- "ExchangeAlgebra.Algebra.Exact" or "ExchangeAlgebra.Journal.Exact". -- Complexity: O(n) (n is the number of base keys) (.-) :: a n b -> a n b -- | Alias for bar operation. Identical to @(.-)@. -- On an axis-preserving ledger, @norm . bar@ cancels only within each full -- base. Use 'balanceMapBy' or 'netPairMapBy' for net amounts by group. + -- Floating-point side totals depend on posting order, and near-equal sides + -- cancel under 'nearlyEqScaled'. See "ExchangeAlgebra.Algebra.Exact" for + -- exact netting of the original postings, or "ExchangeAlgebra.Journal.Exact" + -- for journal readouts. bar :: a n b -> a n b bar = (.-) @@ -315,9 +323,19 @@ -- | Extracts only the Not-side elements (the M-projection of the -- decomposition; @isHat@ does not hold). Complexity: O(s) decM :: a n b -> a n b - -- | Checks whether the norms of debit and credit sides are equal. Complexity: O(s) + -- | Checks whether the norms of debit and credit sides are equal. The norms + -- sum floating-point postings sequentially, so their totals depend on order; + -- 'nearlyEqScaled' treats near-equal totals as balanced. For an exact check + -- over the original postings, see "ExchangeAlgebra.Algebra.Exact" or + -- "ExchangeAlgebra.Journal.Exact". + -- Complexity: O(s) balance :: a n b -> Bool - -- | Returns the debit-credit difference as a (Side, difference) pair. Complexity: O(s) + -- | Returns the debit-credit difference as a (Side, difference) pair. The + -- side norms sum floating-point postings sequentially and depend on order; + -- 'nearlyEqScaled' reports a zero difference for near-equal totals. For + -- exact netting of the original postings, see "ExchangeAlgebra.Algebra.Exact" + -- or "ExchangeAlgebra.Journal.Exact". + -- Complexity: O(s) diffRL :: a n b -> (Side, n) @@ -1696,6 +1714,9 @@ -- On an axis-preserving ledger, this nets only within each projected full -- base; it does not cancel across axis values. Use 'balanceMapBy' or -- 'netPairMapBy' for net amounts by group. +-- Floating-point side and projected totals use sequential addition and depend +-- on posting order. 'nearlyEqScaled' cancels near-equal sides. See +-- "ExchangeAlgebra.Algebra.Exact" for exact sums over the original postings. -- -- Complexity: O(cost(proj) + cost(bar) + cost(norm)). projNetNorm :: (HatVal n, HatBaseClass b) => [b] -> Alg n b -> n @@ -1751,6 +1772,9 @@ -- | Compute the net balance as the difference of two projections. -- @balanceBy plusBases minusBases alg@ computes -- @projNetNorm plusBases alg - projNetNorm minusBases alg@. +-- Floating-point totals inherit the posting-order dependence and near-equal +-- cancellation of 'projNetNorm'. See "ExchangeAlgebra.Algebra.Exact" for exact +-- sums over the original postings. -- -- Useful for calculating stock quantities, profits, etc. -- @@ -1783,6 +1807,9 @@ -- type (e.g. 'Double', @MoneyDouble@, @MoneyDecimal@); a non-negative-only type -- such as @Number.NonNegative.Double@ is unsuitable here. Keys whose net is zero -- are kept (like 'foldEntriesToMap'); filter afterwards if undesired. +-- Floating-point bucket sums use sequential addition and depend on posting +-- order. See "ExchangeAlgebra.Algebra.Exact" for exact sums over the original +-- postings. -- -- Complexity: O(total number of entries) — a single fold, no per-key projection. -- @@ -1828,6 +1855,9 @@ -- @n - h@ identity with 'balanceMapBy' only holds on a /signed/ value type -- (e.g. 'Double', @MoneyDouble@, @MoneyDecimal@) where the difference can be -- negative. +-- Floating-point per-base and per-key sums use sequential addition and depend +-- on posting order. 'nearlyEqScaled' drops near-equal per-base sides. See +-- "ExchangeAlgebra.Algebra.Exact" for exact sums over the original postings. -- -- Complexity: O(total number of entries) — a single fold over the entries, -- followed by one collapse over the distinct bases. @@ -1972,6 +2002,9 @@ -- Thus it factors through the quotient induced by 'bar': it is not the free -- extension that acts independently on entries in the redundant layer (that -- one is 'extendBy'). +-- Floating-point per-base and class totals use sequential addition and depend +-- on posting order; 'bar' cancels near-equal sides under 'nearlyEqScaled'. See +-- "ExchangeAlgebra.Algebra.Exact" for exact sums over the original postings. -- -- Complexity: O(m + Σ cost(post)). -- diff --git a/src/ExchangeAlgebra/Journal.hs b/src/ExchangeAlgebra/Journal.hs --- a/src/ExchangeAlgebra/Journal.hs +++ b/src/ExchangeAlgebra/Journal.hs @@ -826,6 +826,10 @@ -- (e.g. a @HatNot@ wildcard, or a list selecting both sides of one base) -- selects both the hat and the not side of a base: the un-netted norm sums -- both sides, the netted one cancels them. See 'EA.projNetNorm'. +-- Floating-point sums within each note and across notes use sequential addition +-- and depend on posting and note order. Near-equal sides cancel under +-- 'EA.nearlyEqScaled'. See "ExchangeAlgebra.Journal.Exact" for exact sums over +-- the original postings. -- -- Complexity: O(j * proj cost) where j is the number of Notes projWithBaseNetNorm :: (HatVal v, HatBaseClass b, Note n) @@ -878,6 +882,10 @@ -- -- which is __not__ the same as @norm (projWithNoteBase ns bs js)@ when a query -- selects both sides of one base (see 'projWithBaseNetNorm'). +-- Floating-point sums within each note and across selected notes use sequential +-- addition and depend on posting and note order. Near-equal sides cancel under +-- 'EA.nearlyEqScaled'. See "ExchangeAlgebra.Journal.Exact" for exact sums over +-- the original postings. -- -- Complexity: O(|ns| * proj cost) projWithNoteBaseNetNorm :: (HatVal v, HatBaseClass b, Note n) diff --git a/src/ExchangeAlgebra/Journal/Exact.hs b/src/ExchangeAlgebra/Journal/Exact.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Journal/Exact.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Checked journal readouts preserve exact residuals across note boundaries. +-- This journal layer uses "ExchangeAlgebra.Algebra.Exact" and the existing +-- journal projections. Start with the algebra accumulator contract, then read +-- the projection section for cancellation within each note. Other readouts +-- aggregate notes, as the existing journal bar does. +-- +-- Inputs must be finite and non-negative; all intermediate aggregation units +-- and final outputs must fit the value type. Each scalar is rounded once, +-- without cancellation tolerance, and negative zero becomes positive zero. +-- For Double, MoneyDouble, and NN.Double, scalar bits depend only on the multiset +-- of (note, complete base, side, value), including under accumulator merging. +-- Reassigning notes, compressing, substituting rounded partial sums, enumeration, +-- Show, and Binary are outside that guarantee. +module ExchangeAlgebra.Journal.Exact ( + -- * Accumulators + ExactSum(..) + , ExactSumError(..) + , netAccum + , sumExact + -- * Journal readouts + , normExact + , barExact + , balanceMapByExact + , netPairMapByExact + , postFromNetByExact + -- * Projections + , projNetNormExact + , projWithBaseNetNormExact + , projWithNoteBaseNetNormExact + -- * Accounting readouts + , diffRLExact + , balanceExact + , accountBalancesExact + ) where + +import qualified Data.Foldable as Foldable +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map.Strict as Map + +import ExchangeAlgebra.Algebra (Alg, HatVal(..)) +import qualified ExchangeAlgebra.Algebra.Internal as Internal +import ExchangeAlgebra.Algebra.Base ( + AccountTitles + , ExBaseClass + , Hat(..) + , HatBaseClass(..) + , Side + ) +import ExchangeAlgebra.Algebra.Exact ( + ExactSum(..) + , ExactSumError(..) + , netAccum + , sumExact + ) +import qualified ExchangeAlgebra.Algebra.Exact as Exact +import ExchangeAlgebra.Journal (Journal, Note(..), (.|)) +import qualified ExchangeAlgebra.Journal as Journal +import ExchangeAlgebra.TrialBalance.Balance (AccountBalance) + +-- * Accumulators + +-- The scalar accumulator operations are re-exported from the algebra layer. + +-- * Journal readouts + +-- | Scan stored complete-base pairs, retaining Not and Hat states independently. +-- No note boundary is crossed until the caller explicitly combines its input. +residuals :: (ExactSum n, HatBaseClass b) + => Alg n b -> Either ExactSumError [(b, Accum n)] +residuals Internal.Zero = Right [] +residuals (value Internal.:@ postingBase) + | isZeroValue value = Right [] + | otherwise = do + (direction, state) <- netAccumState (addAccum value emptyAccum) emptyAccum + pure $ case direction of + EQ -> [] + _ -> [(merge side (base postingBase), state)] + where + side + | isHat postingBase = Hat + | otherwise = Not +residuals (Internal.Liner pairs _ _ _ _ _) = HashMap.foldlWithKey' finish (Right []) pairs + where + add total value + | isZeroValue value = total + | otherwise = addAccum value total + finish result basePart (Internal.Pair hats nots) = do + previous <- result + (direction, difference) <- netAccumState + (Foldable.foldl' add emptyAccum nots) (Foldable.foldl' add emptyAccum hats) + pure $ case direction of + EQ -> previous + GT -> (merge Not basePart, difference) : previous + LT -> (merge Hat basePart, difference) : previous + +-- | Sum every posting across notes and round the gross norm once. +-- Finite non-negative inputs and their combined Hat-plus-Not total must fit the +-- type. Unlike the existing norm, floating summation order does not affect bits. +normExact :: (ExactSum n, HatBaseClass b, Note t) + => Journal t n b -> Either ExactSumError n +normExact = Exact.normExact . Journal.toAlg + +-- | Gather notes into plank, then cancel complete bases exactly. +-- Each finite non-negative base-side total must fit the type. Each residual is +-- rounded once, with no tolerance. Notes are aggregated as in the existing bar; +-- use the projection readouts for cancellation confined to each note. +barExact :: (ExactSum n, HatBaseClass b, Note t) + => Journal t n b -> Either ExactSumError (Journal t n b) +barExact journal = (.| plank) <$> Exact.barExact (Journal.toAlg journal) + +-- | Aggregate selected postings across notes by key and net each key once. +-- Inputs must be finite and non-negative and each key-side total must fit the +-- type. GT means Not wins, LT means Hat wins, and zero keys remain (EQ,0). +-- The magnitude is non-negative, without the old signed sequential summation. +-- Postings whose key is Nothing are not validated or aggregated. +balanceMapByExact :: (ExactSum n, HatBaseClass b, Note t, Ord k) + => (BasePart b -> Maybe k) -> Journal t n b + -> Either ExactSumError (Map.Map k (Ordering, n)) +balanceMapByExact keyOf = Exact.balanceMapByExact keyOf . Journal.toAlg + +-- | Gather notes, cancel per complete base, and merge by key and winning side. +-- Finite non-negative inputs, base-side totals, and key-side residual totals +-- must fit the type. Each (Not,Hat) output component is rounded once, without +-- tolerance. Distinct bases with Not 10 and Hat 7 retain (10,7). +netPairMapByExact :: (ExactSum n, HatBaseClass b, Note t, Ord k) + => (BasePart b -> Maybe k) -> Journal t n b + -> Either ExactSumError (Map.Map k (n, n)) +netPairMapByExact keyOf = Exact.netPairMapByExact keyOf . Journal.toAlg + +-- | Gather notes, net each base, restore its winning side, select the key, +-- merge residual states, round once per key, then invoke the journal callback. +-- Finite non-negative inputs and all base-side and selected key totals must +-- fit the type. No tolerance or rounded intermediate bar is used. The checks +-- and rounding guarantee end at the callback's argument, not its output. +postFromNetByExact :: (ExactSum n, HatBaseClass b, Note t, Ord k) + => (b -> Maybe k) -> (k -> n -> Journal t n b) -> Journal t n b + -> Either ExactSumError (Journal t n b) +postFromNetByExact keyOf post journal = do + remaining <- residuals (Journal.toAlg journal) + amounts <- traverse roundAccum (Foldable.foldl' collect Map.empty remaining) + pure (Map.foldlWithKey' (\result key value -> result <> post key value) mempty amounts) + where + collect totals (postingBase, state) = case keyOf postingBase of + Nothing -> totals + Just key -> Map.insertWith mergeAccum key state totals + +-- * Projections + +-- | Merge every note's exact base residuals before the only scalar rounding. +-- The caller has already selected notes and bases with the existing projections. +projectedNorm :: (ExactSum n, HatBaseClass b, Note t) + => Journal t n b -> Either ExactSumError n +projectedNorm journal = do + total <- HashMap.foldl' collect (Right emptyAccum) (Journal.toMap journal) + roundAccum total + where + collect result algebra = do + previous <- result + remaining <- residuals algebra + pure (Foldable.foldl' (\total (_, state) -> mergeAccum total state) previous remaining) + +-- | Project bases with set semantics and cancel within each note. +-- This is 'projWithBaseNetNormExact': finite non-negative selected inputs, +-- base-side totals, and the combined residual total must fit the type. There +-- is one final rounding and no tolerance; repeated queries do not repeat values. +projNetNormExact :: (ExactSum n, HatBaseClass b, Note t) + => [b] -> Journal t n b -> Either ExactSumError n +projNetNormExact = projWithBaseNetNormExact + +-- | Project bases, net each complete base within each note, merge residual +-- states across notes, and round once. Finite non-negative selected inputs, +-- each base-side total, and the final residual sum must fit the type. +-- Different notes containing Not 10 and Hat 10 yield 20, not zero. +-- +-- Unlike the old readout, no note-local scalar is rounded before summation. +-- Equality with a norm of per-note bars holds only as a mathematical operation +-- interpreting every operation at infinite precision. With T = 2^53, residuals +-- T+1 and 1 yield T+2 here, but T if each base is rounded first. Duplicate base +-- queries have set semantics and do not change output bits. +projWithBaseNetNormExact :: (ExactSum n, HatBaseClass b, Note t) + => [b] -> Journal t n b -> Either ExactSumError n +projWithBaseNetNormExact bases = projectedNorm . Journal.projWithBase bases + +-- | Select notes and bases with the existing wildcard and set semantics, then +-- cancel within each note and round the merged residual states once. +-- Empty notes or plank select all notes; duplicate queries do not duplicate +-- postings. Finite non-negative selected inputs, base-side totals, and the +-- final residual sum must fit the type. No tolerance or intermediate rounding +-- is used, with the same mathematical equality qualification as +-- 'projWithBaseNetNormExact'. +projWithNoteBaseNetNormExact :: (ExactSum n, HatBaseClass b, Note t) + => [t] -> [b] -> Journal t n b -> Either ExactSumError n +projWithNoteBaseNetNormExact notes bases = + projectedNorm . Journal.projWithNoteBase notes bases + +-- * Accounting readouts + +-- | Net debit and credit across notes and round the absolute difference once. +-- Finite non-negative inputs and both side totals must fit the type. Only +-- exact equality yields Side, without the tolerance of the old diffRL. +-- Structural Side postings contribute no value and are not validated. +diffRLExact :: (ExactSum n, ExBaseClass b, Note t) + => Journal t n b -> Either ExactSumError (Side, n) +diffRLExact = Exact.diffRLExact . Journal.toAlg + +-- | Test exact debit-credit equality across notes with the checks of 'diffRLExact'. +-- This observes exact direction, with no tolerance; its scalar is rounded once. +balanceExact :: (ExactSum n, ExBaseClass b, Note t) + => Journal t n b -> Either ExactSumError Bool +balanceExact = Exact.balanceExact . Journal.toAlg + +-- | Aggregate by account title across notes and net each account exactly. +-- Finite non-negative inputs and account-side totals must fit the type. Each +-- magnitude is rounded once, replacing sequential sums without a tolerance. +-- Exact zero accounts remain NoBalance, as in the algebra account readout. +-- Structural Side postings contribute no value and are not validated. +accountBalancesExact :: (ExactSum n, ExBaseClass b, Note t) + => Journal t n b + -> Either ExactSumError (Map.Map AccountTitles (AccountBalance n)) +accountBalancesExact = Exact.accountBalancesExact . Journal.toAlg diff --git a/src/ExchangeAlgebra/Reporting/Group.hs b/src/ExchangeAlgebra/Reporting/Group.hs --- a/src/ExchangeAlgebra/Reporting/Group.hs +++ b/src/ExchangeAlgebra/Reporting/Group.hs @@ -231,6 +231,10 @@ -- scale-aware near-equality as @ExchangeAlgebra.Write.netGross@\/@diffRL@, so -- a balance that nets to zero within tolerance reports a zero magnitude -- rather than floating-point dust. +-- This function compares two supplied totals; it does not sum postings. If +-- floating-point addition has already rounded those totals, use +-- @ExchangeAlgebra.Journal.Exact.accountBalancesExact@ or +-- @ExchangeAlgebra.Algebra.Exact.diffRLExact@ upstream on the original postings. relativeTo :: HatVal v => Side -> (v, v) -> RelativeAmount v relativeTo side (debit, credit) | nearlyEqScaled debit credit = RelativeAmount False zeroValue diff --git a/src/ExchangeAlgebra/Write.hs b/src/ExchangeAlgebra/Write.hs --- a/src/ExchangeAlgebra/Write.hs +++ b/src/ExchangeAlgebra/Write.hs @@ -632,6 +632,10 @@ -- against @l = 'norm' . 'decL'@ (debit) with the scale-aware tolerance, so the -- same comparison is applied here: near-equal sides report v'Side' with zero -- magnitude, otherwise the larger side wins with the non-negative difference. +-- This function compares two supplied totals; it does not sum postings. If +-- floating-point addition has already rounded those totals, use +-- @ExchangeAlgebra.Journal.Exact.accountBalancesExact@ or +-- @ExchangeAlgebra.Algebra.Exact.diffRLExact@ upstream on the original postings. -- -- Complexity: O(1). netGross :: (HatVal n) => (n, n) -> (Side, n) diff --git a/test/Algebra/ExactSumSpec.hs b/test/Algebra/ExactSumSpec.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/ExactSumSpec.hs @@ -0,0 +1,419 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Rational-oracle and bit-level acceptance tests for checked exact readouts. +module Algebra.ExactSumSpec (runTests) where + +import Control.Monad (unless) +import qualified Data.Decimal as Decimal +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import Data.Word (Word64) +import GHC.Float (castDoubleToWord64) +import qualified Number.NonNegative as NN +import System.Exit (exitFailure) +import Test.QuickCheck hiding (collect) + +import ExchangeAlgebra.Algebra.Base hiding (equal) +import ExchangeAlgebra.Algebra (Alg, (.@)) +import qualified ExchangeAlgebra.Algebra as Algebra +import ExchangeAlgebra.Algebra.Exact +import qualified ExchangeAlgebra.Journal as Journal +import qualified ExchangeAlgebra.Journal.Exact as JournalExact +import ExchangeAlgebra.TrialBalance.Balance (AccountBalance(..)) +import ExchangeAlgebra.Value (MoneyDecimal(..), MoneyDouble(..)) + +-- | Concrete complete bases with no wildcard ordering in the oracle. +type TestBase = HatBase AccountTitles + +-- | Double posting ledger used by the readout acceptance cases. +type TestAlg = Alg Double TestBase + +-- | Notes are strings, including the existing empty-string plank wildcard. +type TestJournal = Journal.Journal String Double TestBase + +-- | Largest finite binary64 input. +maximumFinite :: Double +maximumFinite = encodeFloat (2 ^ (53 :: Int) - 1) 971 + +-- | Smallest positive binary64 subnormal input. +subnormal :: Double +subnormal = encodeFloat 1 (-1074) + +-- | First integer whose successor cannot be represented in binary64. +threshold :: Double +threshold = 2 ^ (53 :: Int) + +-- | Compare successful outputs by all 64 bits, including the sign of zero. +bits :: Either ExactSumError Double -> Either ExactSumError Word64 +bits = fmap castDoubleToWord64 + +-- | Exact reference with a range check before nearest-even conversion. +oracle :: Rational -> Either ExactSumError Double +oracle value + | value > toRational maximumFinite = Left SumOutOfRange + | otherwise = Right (fromRational value) + +-- | Build an accumulator without rounding its intermediate states. +accumulate :: ExactSum n => [n] -> Accum n +accumulate = List.foldl' (flip addAccum) emptyAccum + +-- | Generate finite non-negative inputs across all binary64 exponent ranges. +genValue :: Gen Double +genValue = frequency + [ (3, elements [0, subnormal, maximumFinite, threshold, 1, 1e308]) + , (7, do + mantissa <- chooseInteger (1, 2 ^ (53 :: Int) - 1) + power <- chooseInt (-1074, 971) + pure (encodeFloat mantissa power)) + ] + +-- | Moderate-sized lists include both valid and overflowing exact totals. +genValues :: Gen [Double] +genValues = chooseInt (0, 25) >>= flip vectorOf genValue + +-- | Permutations, construction by split, and merge association share one oracle. +propSum :: Property +propSum = forAll genValues $ \values -> forAll (shuffle values) $ \permuted -> + forAll (chooseInt (0, length values)) $ \cut -> + let (left, right) = splitAt cut values + expected = bits (oracle (sum (fmap toRational values))) + first = accumulate left + second = accumulate right + (middle, lastPart) = splitAt (length right `div` 2) right + middleState = accumulate middle + lastState = accumulate lastPart + in conjoin + [ bits (sumExact values) === expected + , bits (sumExact permuted) === expected + , bits (roundAccum (mergeAccum first second)) === expected + , bits (roundAccum (mergeAccum second first)) === expected + , bits (roundAccum (mergeAccum emptyAccum (mergeAccum first second))) === expected + , bits (roundAccum (mergeAccum (mergeAccum first emptyAccum) second)) === expected + , bits (roundAccum (mergeAccum first (mergeAccum middleState lastState))) === expected + , bits (roundAccum (mergeAccum (mergeAccum first middleState) lastState)) === expected + ] + +-- | Netting checks both exact side ranges before subtracting, without tolerance. +propNet :: Property +propNet = forAll genValues $ \left -> forAll genValues $ \right -> + let first = sum (fmap toRational left) + second = sum (fmap toRational right) + expected + | max first second > toRational maximumFinite = Left SumOutOfRange + | otherwise = (,) (compare first second) <$> oracle (abs (first - second)) + observe = fmap (\(direction, value) -> (direction, castDoubleToWord64 value)) + in observe (netAccum (accumulate left) (accumulate right)) === observe expected + +-- | Merging signed residual expansions preserves their exact non-negative values. +propResidualMerge :: Property +propResidualMerge = forAll genValue $ \a -> forAll genValue $ \b -> + forAll genValue $ \c -> forAll genValue $ \d -> + let result = do + (_, first) <- netAccumState (accumulate [a]) (accumulate [b]) + (_, second) <- netAccumState (accumulate [c]) (accumulate [d]) + let left = mergeAccum first second + right = mergeAccum second first + pure (bits (roundAccum left), bits (roundAccum right)) + expected = bits (oracle (abs (toRational a - toRational b) + + abs (toRational c - toRational d))) + in result === Right (expected, expected) + +-- | Bias toward high-exponent ties that create a negative low partial. +genBoundarySide :: Gen [Double] +genBoundarySide = frequency + [ (1, pure [maximumFinite]) + , (3, do + high <- chooseInteger (2 ^ (53 :: Int) - 16, 2 ^ (53 :: Int) + 16) + low <- chooseInteger (1, 31) + pure [encodeFloat high 970, encodeFloat low 970]) + ] + +-- | Both subtraction directions must stay finite for valid near-boundary states. +propBoundaryNet :: Property +propBoundaryNet = forAll genBoundarySide $ \left -> forAll genBoundarySide $ \right -> + let first = sum (fmap toRational left) + second = sum (fmap toRational right) + observe = fmap (\(direction, value) -> (direction, castDoubleToWord64 value)) + expected = (,) (compare first second) <$> oracle (abs (first - second)) + in observe (netAccum (accumulate left) (accumulate right)) === observe expected + +-- | Subtraction also accepts previously netted states with signed low components. +propNestedNet :: Property +propNestedNet = forAll genValue $ \a -> forAll genValue $ \b -> + forAll genValue $ \c -> forAll genValue $ \d -> + let first = abs (toRational a - toRational b) + second = abs (toRational c - toRational d) + result = do + (_, left) <- netAccumState (accumulate [a]) (accumulate [b]) + (_, right) <- netAccumState (accumulate [c]) (accumulate [d]) + netAccum left right + expected = (,) (compare first second) <$> oracle (abs (first - second)) + observe = fmap (\(direction, value) -> (direction, castDoubleToWord64 value)) + in observe result === observe expected + +-- | Generate small ledgers with exact, independently calculable group residuals. +genEntries :: Gen [(Double, TestBase)] +genEntries = do + count <- chooseInt (0, 20) + vectorOf count $ do + value <- elements [subnormal, 1, 2, 3, threshold, threshold + 2] + postingBase <- (:<) <$> elements [Not, Hat] <*> elements [Cash, Deposits, Sales] + pure (value, postingBase) + +-- | Construct only through the public checked posting constructor. +build :: [(Double, TestBase)] -> TestAlg +build = Algebra.fromList . fmap (uncurry (.@)) + +-- | Observe scalar bits without relying on HashMap traversal or Alg equality. +observeAlg :: TestAlg -> [(String, Word64)] +observeAlg = List.sort . Algebra.foldEntries + (\entries value postingBase -> (show postingBase, castDoubleToWord64 value) : entries) [] + +-- | Independently sum signed Rational values per concrete account title. +exactGroups :: [(Double, TestBase)] -> Map.Map AccountTitles Rational +exactGroups = List.foldl' collect Map.empty + where + collect totals (value, postingBase) = Map.insertWith (+) (base postingBase) + (signed postingBase (toRational value)) totals + signed postingBase value + | isHat postingBase = negate value + | otherwise = value + +-- | Regrouping a multiset preserves bar bits; residual merging rounds only once. +propReadouts :: Property +propReadouts = forAll genEntries $ \entries -> forAll (shuffle entries) $ \permuted -> + let groups = exactGroups entries + original = build entries + reordered = mconcat (fmap (uncurry (.@)) permuted) + gross = sum (fmap (toRational . fst) entries) + residual = sum (fmap abs (Map.elems groups)) + expectedBalances = traverse (\value -> + (,) (compare value 0) <$> oracle (abs value)) groups + expectedPair = (,) + <$> oracle (sum [value | value <- Map.elems groups, value > 0]) + <*> oracle (sum [abs value | value <- Map.elems groups, value < 0]) + pairs = netPairMapByExact (const (Just ())) original + actualPair = fmap (Map.findWithDefault (0, 0) ()) pairs + queries = [HatNot :< wildcard] + in conjoin + [ fmap observeAlg (barExact original) === fmap observeAlg (barExact reordered) + , bits (normExact original) === bits (oracle gross) + , bits (projNetNormExact queries original) === bits (oracle residual) + , balanceMapByExact Just original === expectedBalances + , actualPair === expectedPair + ] + +-- | Journal permutation and assembly preserve per-note projection residuals. +propJournal :: Property +propJournal = forAll genEntries $ \entries -> + let annotated = zip (cycle ["a", "b", "c"]) entries + make (note, (value, postingBase)) = value .@ postingBase Journal..| note + original = mconcat (fmap make annotated) :: TestJournal + query = [HatNot :< wildcard] + noteGroups = List.foldl' collect Map.empty annotated + collect totals (note, (value, postingBase)) = + Map.insertWith (+) (note, base postingBase) (signed postingBase value) totals + signed postingBase value + | isHat postingBase = negate (toRational value) + | otherwise = toRational value + expected = bits (oracle (sum (fmap abs (Map.elems noteGroups)))) + in forAll (shuffle annotated) $ \permuted -> + let reordered = Journal.fromList (fmap make permuted) + in conjoin + [ bits (JournalExact.projNetNormExact query original) === expected + , bits (JournalExact.projNetNormExact query reordered) === expected + , JournalExact.balanceMapByExact Just reordered + === JournalExact.balanceMapByExact Just original + , JournalExact.accountBalancesExact reordered + === JournalExact.accountBalancesExact original + ] + +-- | Handwritten wrappers preserve the Double oracle; Decimal merge is exact. +propInstances :: Property +propInstances = forAll genValues $ \values -> forAll (shuffle values) $ \permuted -> + let expected = bits (sumExact values) + money = fmap MoneyDouble values + nonNegative = fmap NN.fromNumber permuted :: [NN.Double] + unwrapMoney (MoneyDouble value) = value + decimalValues = fmap (MoneyDecimal . Decimal.Decimal 2 . toInteger) [1 .. length values] + decimalState = accumulate decimalValues + in conjoin + [ bits (fmap unwrapMoney (sumExact money)) === expected + , bits (fmap NN.toNumber (sumExact nonNegative)) === expected + , roundAccum (mergeAccum decimalState emptyAccum) === Right (sum decimalValues) + , sumExact (reverse decimalValues) === Right (sum decimalValues) + ] + +-- | Run a deterministic check and stop the suite on failure. +check :: (Eq a, Show a) => String -> a -> a -> IO () +check name expected actual = unless (expected == actual) $ do + putStrLn ("[FAIL] exact " ++ name ++ ": expected " ++ show expected ++ ", got " ++ show actual) + exitFailure + +-- | Run a reproducible-size property batch with failure details on demand. +propertyCheck :: String -> Property -> IO () +propertyCheck name proposition = do + result <- quickCheckWithResult stdArgs { maxSuccess = 1000, chatty = False } proposition + unless (isSuccess result) $ do + putStrLn ("[FAIL] exact " ++ name ++ ": " ++ output result) + exitFailure + putStrLn ("[PASS] exact " ++ name ++ " (1000 cases)") + +-- | Floating boundaries and sticky validation errors, independent of algebra construction. +testAccumulator :: IO () +testAccumulator = do + check "2^53,1,1" (Right (threshold + 2)) (sumExact [threshold, 1, 1]) + check "subnormals" (Right (3 * subnormal)) (sumExact [subnormal, subnormal, subnormal]) + check "tie even down" (Right threshold) (sumExact [threshold, 1]) + check "tie even up" (Right (threshold + 4)) (sumExact [threshold + 2, 1]) + check "beyond tie" (Right (threshold + 2)) (sumExact [threshold, 1, subnormal]) + check "net below tie" (Right (GT, threshold)) + (netAccum (accumulate [threshold + 2]) (accumulate [1, subnormal])) + check "zero sign" (Right 0) (bits (sumExact [-0, 0 :: Double])) + check "net zero sign" (Right (EQ, 0)) + (fmap (\(direction, value) -> (direction, castDoubleToWord64 value)) + (netAccum (accumulate [-0 :: Double]) (accumulate [0]))) + check "M" (Right maximumFinite) (sumExact [maximumFinite]) + check "M boundary inside" (Right maximumFinite) + (sumExact [encodeFloat (2 ^ (53 :: Int) - 2) 971, encodeFloat 1 971]) + check "M plus smallest" (Left SumOutOfRange) (sumExact [maximumFinite, subnormal]) + check "both sides overflow" (Left SumOutOfRange) + (netAccum (accumulate [1e308, 1e308 :: Double]) (accumulate [1e308, 1e308])) + let boundaryValues = [encodeFloat 1 1023, 3 * encodeFloat 1 970] + boundaryState = accumulate boundaryValues + expectedDifference = fromRational + (toRational maximumFinite - sum (fmap toRational boundaryValues)) + boundaryLedger = build + [(value, Not :< Cash) | value <- boundaryValues] + <> build [(maximumFinite, Hat :< Cash)] + check "negative low versus M" (Right (LT, expectedDifference)) + (netAccum boundaryState (accumulate [maximumFinite])) + check "M versus negative low" (Right (GT, expectedDifference)) + (netAccum (accumulate [maximumFinite]) boundaryState) + check "boundary projection finite" (Right expectedDifference) + (projNetNormExact [HatNot :< Cash] boundaryLedger) + check "boundary bar does not throw" (Right expectedDifference) + (barExact boundaryLedger >>= normExact) + check "negative" (Left NegativeInput) (sumExact [-1 :: Double]) + check "NaN" (Left NonFiniteInput) (sumExact [0 / 0 :: Double]) + check "positive infinity" (Left NonFiniteInput) (sumExact [1 / 0 :: Double]) + check "negative infinity" (Left NonFiniteInput) (sumExact [-1 / 0 :: Double]) + let failed = accumulate [-1 :: Double] + check "sticky add" (Left NegativeInput) (roundAccum (addAccum 1 failed)) + check "sticky merge left" (Left NegativeInput) (roundAccum (mergeAccum failed emptyAccum)) + check "sticky merge right" (Left NegativeInput) (roundAccum (mergeAccum emptyAccum failed)) + check "sticky net" (Left NegativeInput) (netAccum failed failed) + let nearMaximum = accumulate [maximumFinite] + tiny = accumulate [subnormal] + case netAccumState nearMaximum tiny of + Left failure -> check "M-small state" (Right ()) (Left failure) + Right (_, below) -> do + check "M-small rounds M" (Right maximumFinite) (roundAccum below) + check "M-small plus small" (Right maximumFinite) (roundAccum (mergeAccum below tiny)) + check "small plus M-small" (Right maximumFinite) (roundAccum (mergeAccum tiny below)) + check "nested residual" (Right (GT, subnormal)) (netAccum nearMaximum below) + check "MoneyDouble" (Right (MoneyDouble (threshold + 2))) + (sumExact [MoneyDouble threshold, 1, 1]) + check "MoneyDouble nonfinite" (Left NonFiniteInput) (sumExact [MoneyDouble (1 / 0)]) + check "MoneyDouble negative" (Left NegativeInput) (sumExact [MoneyDouble (-1)]) + check "NN.Double" (Right (NN.fromNumber (threshold + 2))) + (sumExact [NN.fromNumber threshold, 1, 1] :: Either ExactSumError NN.Double) + check "NN magnitude only" (Right (LT, 7 :: NN.Double)) + (netAccum (accumulate [3]) (accumulate [10])) + check "MoneyDecimal negative" (Left NegativeInput) (sumExact [-1 :: MoneyDecimal]) + let decimal = MoneyDecimal (Decimal.Decimal 2 1) + check "MoneyDecimal scale" (Right (MoneyDecimal (Decimal.Decimal 2 101))) + (sumExact [1, decimal]) + check "MoneyDecimal unlimited" (Right (2 * 10 ^ (400 :: Int) :: MoneyDecimal)) + (sumExact [10 ^ (400 :: Int), 10 ^ (400 :: Int)]) + check "MoneyDecimal net" (Right (LT, decimal)) + (netAccum (accumulate [1]) (accumulate [1, decimal])) + +-- | Fixed grouping, projection, and accounting cases from the accepted contract. +testReadouts :: IO () +testReadouts = do + let pairExample = build [(10, Not :< Cash), (7, Hat :< Deposits)] + sameBase = build [(10, Not :< Cash), (7, Hat :< Cash)] + selectHat postingBase + | isHat postingBase = Just () + | otherwise = Nothing + post _ value = value .@ (Not :< Sales) + query = [HatNot :< wildcard] + large = build [(1e308, Not :< Cash), (1e308, Not :< Deposits)] + roundExample = build [(threshold, Not :< Cash), (1, Not :< Cash), (1, Not :< Deposits)] + equal = build [(10, Not :< Cash), (10, Hat :< Cash)] + check "pair retains base distinction" (Right (Map.singleton () (10, 7))) + (netPairMapByExact (const (Just ())) pairExample) + check "post selects after netting" (Right []) + (fmap observeAlg (postFromNetByExact selectHat post sameBase)) + check "balance direction" (Right (Map.fromList [(Cash, (GT, 10)), (Deposits, (LT, 7))])) + (balanceMapByExact Just pairExample) + check "zero key retained" (Right (Map.singleton Cash (EQ, 0))) + (balanceMapByExact Just equal) + check "bar zero removed" (Right []) (fmap observeAlg (barExact equal)) + check "gross overflow" (Left SumOutOfRange) (normExact large) + check "residual overflow" (Left SumOutOfRange) (projNetNormExact query large) + check "pair overflow" (Left SumOutOfRange) (netPairMapByExact (const (Just ())) large) + check "post overflow" (Left SumOutOfRange) + (fmap observeAlg (postFromNetByExact (const (Just ())) post large)) + check "projection rounds once" (Right (threshold + 2)) (projNetNormExact query roundExample) + check "pair rounds once per key side" (Right (Map.singleton () (threshold + 2, 0))) + (netPairMapByExact (const (Just ())) roundExample) + check "post rounds once per key" (Right (threshold + 2)) + (postFromNetByExact (const (Just ())) post roundExample >>= normExact) + check "two rounds differ" (Right threshold) (barExact roundExample >>= normExact) + check "duplicate base query" (projNetNormExact query roundExample) + (projNetNormExact (query ++ query) roundExample) + check "debit difference" (Right (Debit, 3)) (diffRLExact sameBase) + check "exact balance" (Right True) (balanceExact equal) + check "account balances" (Right (Map.singleton Cash (DebitBalance 3))) + (accountBalancesExact sameBase) + let journal = (10 .@ (Not :< Cash) Journal..| "a") + <> (10 .@ (Hat :< Cash) Journal..| "b") :: TestJournal + roundedJournal = (build [(threshold, Not :< Cash), (1, Not :< Cash)] Journal..| "a") + <> (build [(1, Not :< Cash)] Journal..| "b") + check "journal separate notes" (Right 20) (JournalExact.projWithBaseNetNormExact query journal) + check "journal duplicate base queries" (Right 20) + (JournalExact.projWithBaseNetNormExact (query ++ query) journal) + check "journal note selection" (Right 10) + (JournalExact.projWithNoteBaseNetNormExact ["a", "a"] query journal) + check "journal empty notes" (Right 20) + (JournalExact.projWithNoteBaseNetNormExact [] query journal) + check "journal plank notes" (Right 20) + (JournalExact.projWithNoteBaseNetNormExact ["a", ""] query journal) + check "journal once across notes" (Right (threshold + 2)) + (JournalExact.projWithBaseNetNormExact query roundedJournal) + check "journal bar gathers" (Right 0) (JournalExact.barExact journal >>= JournalExact.normExact) + check "journal balance" (Right True) (JournalExact.balanceExact journal) + check "journal diff" (Right (Side, 0)) (JournalExact.diffRLExact journal) + check "journal account" (Right (Map.singleton Cash NoBalance)) + (JournalExact.accountBalancesExact journal) + check "journal pair gathers" (Right Map.empty) + (JournalExact.netPairMapByExact Just journal) + check "journal signed gathers" (Right (Map.singleton Cash (EQ, 0))) + (JournalExact.balanceMapByExact Just journal) + check "journal post gathers" (Right 0) + (JournalExact.postFromNetByExact selectHat + (\key value -> post key value Journal..| "new") journal >>= JournalExact.normExact) + check "journal post rounds once" (Right (threshold + 2)) + (JournalExact.postFromNetByExact (const (Just ())) + (\key value -> post key value Journal..| "new") roundedJournal + >>= JournalExact.normExact) + check "journal alias" (Right 20) (JournalExact.projNetNormExact query journal) + check "journal residual overflow" (Left SumOutOfRange) + (JournalExact.projWithBaseNetNormExact query (large Journal..| "a")) + +-- | Execute all exact-readout acceptance checks in the main test suite. +runTests :: IO () +runTests = do + testAccumulator + testReadouts + propertyCheck "sum, permutation, merge, and Rational oracle" propSum + propertyCheck "net and Rational oracle" propNet + propertyCheck "residual merge and Rational oracle" propResidualMerge + propertyCheck "high-exponent tie netting" propBoundaryNet + propertyCheck "nested netting and Rational oracle" propNestedNet + propertyCheck "readouts, construction order, and Rational oracle" propReadouts + propertyCheck "journal multiset and note-local Rational oracle" propJournal + propertyCheck "handwritten instances" propInstances + putStrLn "[PASS] exact boundary, grouping, journal, and instance acceptance cases" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -75,6 +75,7 @@ import Golden.WriteRows import qualified Transfer.RuleSpec as TransferRuleSpec import qualified Algebra.ProjWildcardSpec as ProjWildcardSpec +import qualified Algebra.ExactSumSpec as ExactSumSpec import Numeric (showHex) import Control.Monad (forM_) import Control.Monad.ST @@ -6965,6 +6966,7 @@ main :: IO () main = do + ExactSumSpec.runTests TransferRuleSpec.runTests ProjWildcardSpec.runTests testAccountTitlesBinary diff --git a/test/Surface/Algebra/Exact.hs b/test/Surface/Algebra/Exact.hs new file mode 100644 --- /dev/null +++ b/test/Surface/Algebra/Exact.hs @@ -0,0 +1,36 @@ +-- | Compile-time lock for the public names exported by +-- "ExchangeAlgebra.Algebra.Exact". +module Surface.Algebra.Exact ( + -- * Accumulators + ExactSum(..) + , ExactSumError(..) + , netAccum + , sumExact + -- * Algebra readouts + , normExact + , barExact + , projNetNormExact + , balanceMapByExact + , netPairMapByExact + , postFromNetByExact + -- * Accounting readouts + , diffRLExact + , balanceExact + , accountBalancesExact + ) where + +import ExchangeAlgebra.Algebra.Exact ( + ExactSum(..) + , ExactSumError(..) + , netAccum + , sumExact + , normExact + , barExact + , projNetNormExact + , balanceMapByExact + , netPairMapByExact + , postFromNetByExact + , diffRLExact + , balanceExact + , accountBalancesExact + ) diff --git a/test/Surface/Journal/Exact.hs b/test/Surface/Journal/Exact.hs new file mode 100644 --- /dev/null +++ b/test/Surface/Journal/Exact.hs @@ -0,0 +1,41 @@ +-- | Compile-time lock for the public names exported by +-- "ExchangeAlgebra.Journal.Exact". +module Surface.Journal.Exact ( + -- * Accumulators + ExactSum(..) + , ExactSumError(..) + , netAccum + , sumExact + -- * Journal readouts + , normExact + , barExact + , balanceMapByExact + , netPairMapByExact + , postFromNetByExact + -- * Projections + , projNetNormExact + , projWithBaseNetNormExact + , projWithNoteBaseNetNormExact + -- * Accounting readouts + , diffRLExact + , balanceExact + , accountBalancesExact + ) where + +import ExchangeAlgebra.Journal.Exact ( + ExactSum(..) + , ExactSumError(..) + , netAccum + , sumExact + , normExact + , barExact + , balanceMapByExact + , netPairMapByExact + , postFromNetByExact + , projNetNormExact + , projWithBaseNetNormExact + , projWithNoteBaseNetNormExact + , diffRLExact + , balanceExact + , accountBalancesExact + ) diff --git a/test/SurfaceMain.hs b/test/SurfaceMain.hs --- a/test/SurfaceMain.hs +++ b/test/SurfaceMain.hs @@ -1,8 +1,10 @@ module Main (main) where import Surface.Accounting () +import Surface.Algebra.Exact () import Surface.Algebra.Readout.Net () import Surface.Foundation () +import Surface.Journal.Exact () import Surface.Render.Bookkeeping () import Surface.Render.Csv () import Surface.Render.Simulation () @@ -13,4 +15,3 @@ -- | Report successful compilation of every surface lock module. main :: IO () main = putStrLn "surface ok" -