diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,37 +1,1105 @@ # Changelog for ExchangeAlgebra -## 0.4.1.2 - 2026-06-11 - -### Fixed -- `incomeSummaryAccount` (both `ExchangeAlgebra.Algebra.Transfer` and - `ExchangeAlgebra.Journal.Transfer`) crashed with `Non-exhaustive patterns in - case` on a **balanced ledger** (credit == debit, i.e. zero net income). In that - case `diffRL` reports the wildcard `Side` constructor, which the - `case dc of { Credit -> …; Debit -> … }` did not handle. The fix adds a `Side` - branch that returns the input ledger unchanged (no `NetIncome` / `NetLoss` - posting is appended when net income is zero). Note that appending a `Zero` - posting is **not** a correct alternative for the Journal version, since it is - not an identity there. Covered by the new `testIncomeSummaryBalancedAlg` and - `testIncomeSummaryBalancedJournal` regression tests. - -## 0.4.1.1 - 2026-06-07 - -### Fixed -- `union` (and therefore `(.+)` / `mappend` / `fromList`) misassociated a value - with the wrong base when one operand was a **zero-valued singleton**. For - `(v1:@b1) .+ (v2:@b2)` with `isZeroValue v1`, the result was `v2:@b1` — the - surviving nonzero value relabeled onto the *zero posting's* base (symmetrically - `v1:@b2` when `v2` was zero). A zero contributes nothing, so the result must be - `v2:@b2` / `v1:@b1` (the nonzero value on its **own** base). - The bug preserved `norm` (the total was unchanged) but corrupted **per-base - projection** (`proj` / `projWithBase` / `balanceBy` / stock & profit queries): - a value silently moved to a neighboring base. It was construction-order - sensitive — ledgers that build explicit `0:@base` singletons via the raw `(:@)` - constructor (e.g. sparsified input coefficients in agent-based simulations) - would, depending on accumulation order, invent a phantom posting on an adjacent - base. In the bundled simulation example this shifted a company's reported stock - by up to ~30% over 100 terms. One-line fix in `Algebra.hs union`, covered by the - new `testUnionZeroSingletonBase` unit test. (Independently confirmed root cause.) +## 0.5.0.0 - 2026-09-04 + +The 0.5 line was first prepared on 2026-06-07 around a selectable value type, with recovery tag `recovery/0.5.0.0-dev-2026-06-08`. Before publication, it absorbed the account registry and semantics, the Definition 7 contra amendment with netting presentation, the JCCI/EDINET vocabulary, checked-conversion posting capability, categorical phase-1 laws, the CL-SBM industrial network generator, and the audit-eval tooling. + +Selectable value type: `Double` (default, fast) / `MoneyDouble` (typed fast FP) +vs an exact non-negative `Decimal` (`MoneyDecimal`) for determinism/auditability. +**Breaking** (PVP major): +`HatVal` lost its `RealFloat` superclass and gained `showValue`. See the README +"Choosing a value type" and "Migrating to 0.5.0.0" sections. + +### Highlights +- Add selectable value types with `MoneyDecimal` and `MoneyDouble`, while removing the `RealFloat` superclass from `HatVal`. +- Add an exhaustive account registry and `AccountSemantics` covering roles, posting capability, and JCCI/EDINET presentation names. +- Amend Definition 7 with `isContra`, contra-aware projections, and netting presentation in `bsRows` / `plRows`. +- Make closing entries cover every Cost and Revenue account. +- Enforce posting capability by processing context in checked conversion. +- Encode `AccountTitles` Binary tags as big-endian `Word16`. +- Document the categorical phase-1 laws for `mapBasePart`, `foldEntries`, and `postFromNetBy`, pinned by property tests. +- Add trial-balance validation, consolidation-worksheet validation, JGAAP reporting transformation, and derived period-result metrics. +- Add the ordered CL-SBM `industrialNetwork` / `industrialFlows` generator and `industrialEx1`. +- Add audit-eval compatibility, scoring, checkpoint, Track S checked-loader, and generated-suite tooling in the examples. +- Improve performance with strict `Journal.fromList`, an exact-projection fast path, faster journal append, and projection-sharing trial-balance rows. +- Tighten module boundaries: `Alg`, `Journal` and `TransTable` are abstract (`Algebra.Internal` holds the representation); posting authority lives in `Accounting.PostingPolicy`, account balances in `TrialBalance.Balance`, spill codec and restore in `Simulate.Spill`; `Write` no longer depends on `Simulate`; Chart plotting sits behind the `visualize` flag; typed `mapPosting`, `replaceNotes` and `mkJournal` replace implicit contracts. + +### Breaking +- **BREAKING: `Alg`, `Journal` and `TransTable` are abstract.** `Alg` exports + only `Zero`, `(:@)`, `_val` and `_hatBase`; the multi-posting `Liner` + representation, `Pair` and the cache fields live in the new + `ExchangeAlgebra.Algebra.Internal` (outside the PVP contract). `Journal` is + built with `mkJournal`, `(.|)` or `fromList`; `TransTable` with `table`, + `(.->)` or `(|%)`. Hand-built values could desynchronise the cached axis + indices and make wildcard projections answer wrongly without an error. +- **BREAKING: binary spill files are validated on read.** `readBinarySpillFile` + now raises an error at the first undecodable chunk instead of silently + truncating the remainder, and `restoreJournalFromBinarySpill` rejects + out-of-order, overlapping, gapped, or empty chunk ranges (previously a + partially readable or stale file was merged as if complete, dropping every + term up to the last readable chunk). Its constraints gain `Enum t` and + `Show t`, both already implied by `StateTime`. `Simulate.Lite` now truncates + the spill file when a run opens it (`WriteMode` instead of `AppendMode`), so + re-running with the same path no longer accumulates stale chunks. + +- **BREAKING: checked conversion now enforces posting capability by processing + context.** `checkedEntryIn`, `checkedEntryTextIn`, `checkedJournalIn`, and + `certifyJournalTextIn` admit ordinary postings plus exactly the capability + owned by `ClosingProcess`, `ConsolidationWorksheet`, or + `EngineComputation`. The existing context-free functions now delegate to + `OrdinaryJournal`, so they reject closing-only, consolidation-only, + engine-generated, and non-postable coordinates with `PostingNotAllowed`. + Unknown account text remains a vocabulary failure, while a resolved but + context-disallowed title is a structural rejection. Algebra construction, + balance rules, and unchecked conversion (including `Convert.Csv`) are + unchanged. + +- **BREAKING: LLM-facing account metadata now separates bookkeeping and + reporting semantics.** `AccountSemantics` records account roles, posting + capability, the meaning of the legacy five-way division, home-side + semantics, and reporting eligibility for all 235 concrete titles; + `AccountTitle` remains explicitly outside the domain. `AccountInfo` exposes + these fields instead of the ambiguous `aiDivision` / `aiHomeSide` pair, so + direction encodings such as `IncomeSummary = Assets` and + `NetIncome = Cost` are no longer presented as statement classifications. + The exchange-algebra basis, legacy division/side/PIMO behaviour, Binary + encoding, closing, projections, and financial-statement rows are unchanged. + +- **BREAKING: closing entries now cover every Cost and Revenue account.** + `finalStockTransfer` derives its policy from the exhaustive account registry; + previously it closed only 17 SNA-era accounts. `NetIncome` and `NetLoss` + are permanent explicit `NoClose` overrides: their division encodes the + P/L presentation side, so the division-derived rule would invert their + transfer sign; the dedicated net-income transfer owns their closing. + +- **BREAKING: `AccountTitles` binary tags now use Word16 big-endian encoding** + instead of Word8. This removes the 256-constructor ceiling and rejects + out-of-range tags through the `Get` failure channel. Journals and other + values persisted with the old format cannot be read by 0.5.0.0. + +- **BREAKING: account division semantics for contra accounts** (Definition 7 + amendment, Land 2). `AllowanceForDoubtfulAccounts` and + `AccumulatedDepreciation` are now classified `Assets` with the new + `ExBaseClass` method `isContra = True` (previously `Liability`). Home side + and PIMO are both derived from `(whatDiv, isContra)`: home side = + `defaultSide` of the division, reversed for contra; PIMO = + `pimoFromDivision`, flipped by `pimoFlip` (PS↔MS, IN↔OUT) for contra. + Observable invariants: `whichSide`, `whatPIMO` and `fixedCurrent` are + unchanged for every account (the two contra accounts keep the Credit home + side and MS); only `whatDiv` — and, in the pre-Land1 assistance API, + `aiDivision` and descriptions — changed, for exactly these two accounts. + +- **BREAKING: `(<=>)` on `AccountDivision` is now derived via + `pimoFromDivision`**, matching Proposition 5.3.8 (Deguchi 2004; PS⇔IN, + PS⇔MS, OUT⇔IN, OUT⇔MS). Migration table (ordered cases; every other pair + is unchanged): `(Assets, Revenue)` False→True, `(Revenue, Assets)` + False→True, `(Cost, Revenue)` False→True, `(Revenue, Cost)` False→True. + Exchange checks on bases should use `whatPIMO` (contra-aware), not bare + divisions. + +- **BREAKING: real contra deduction/netting presentation (Definition 7, + Land 3).** `bsRows` and `plRows` now render active presentation groups as + gross rows, deduction rows, and a net row instead of placing contra assets + in the Liability column or dropping P/L contra accounts. The shared + `ExchangeAlgebra.Reporting.Group` module defines the five registry-backed + groups and keeps stored and rendered magnitudes non-negative; a leading + minus sign is introduced only when rows are rendered. Statements without a + contra posting keep their ordinary rows, while formerly hidden abnormal + balances are no longer included in column totals. Contra amounts exceeding their gross + parent, multiple contra rows, absent parents, and nested groups have explicit + test coverage. Column totals are calculated from displayed net amounts. + The six division projections now exclude contra accounts entirely; + select them with `projContraAssets` (Assets division) or the generic + `projContra` (attribute-based: keeps both Hat and Not postings). + +- **BREAKING: Add shared JCCI B-column names.** The 6 labels accepted by + `parseAccountTitle` (`未払金`, `借入金`, `仮払金`, `仮受金`, `有価証券`, + `投資有価証券`) now produce `AmbiguousAccount` with a list of candidates + instead of resolving uniquely. Use canonical constructor names or explicitly + select a candidate based on context. + +- `whichSide` now rejects a `HatNot` (wildcard) base with an error instead of + silently treating it as `Hat` (design-review C5): stored postings are always + `Hat`/`Not` (same policy as `isHat`), so a wildcard reaching `whichSide` + means a query-side value leaked into a posting-side computation. __Breaking__ + only for code that relied on the silent-`Hat` behaviour. + +- The universal `instance (HatVal n) => Show (n -> n)` + (`ExchangeAlgebra.Algebra.Transfer`) was removed (design-review C5): + __breaking__ for code that `show`ed raw rule-list tuples. `TransTable`'s own + `Show` still prints `` without it; one doctest was adjusted. + +- `ExchangeAlgebra.Simulate.Lite` export hygiene (design-review C5): + __breaking__. `Stage` is now exported name-only (build with + `stageFor`/`stage`/`stageOf`, read the name via `stageName`); the `GLite*` + Generic-plumbing classes are exported name-only (their primed methods are + internal Rep wiring — user code only names the classes in constraints). + +- The `ExchangeAlgebra` umbrella no longer re-exports `ExchangeAlgebra.Simulate`: + __breaking__ (design-review C1). The simulation engine exports very generic + names (`copy`, `modify`, `update`, `initialize`, `normal`, `initAll`, …) that + polluted the recommended bookkeeping entry point. Migration: add + `import ExchangeAlgebra.Simulate` where those names are used — the module now + follows the same "import directly" policy as `Bookkeeping`/`Simulate.Lite`/ + `Simulate.Network`/`Simulate.Policy` (documented in the umbrella Haddock). + The bundled examples were migrated mechanically (import line only). + +- `ExchangeAlgebra.Algebra.Base.Element` no longer re-exports the whole + `Data.Hashable` and `GHC.Generics` modules: __breaking__ (design-review C1). + Only the two names needed to define an `Element` instance remain re-exported + (`Hashable(..)` and `Generic`); the previous module-level re-exports leaked + their entire namespaces through `Base` → `Algebra` → the umbrella. Migration: + import `Data.Hashable`/`GHC.Generics` directly for any other names. + +- `Element` class wildcard methods (`ExchangeAlgebra.Algebra.Base.Element`): + __breaking__. The misspelt `wiledcard` method family is renamed to the correct + spelling, with no compatibility aliases (audit R2). Migration (旧名 → 新名): + `wiledcard` → `wildcard`, `haveWiledcard` → `haveWildcard`, + `isWiledcard` → `isWildcard`, `ignoreWiledcard` → `ignoreWildcard`. Any + `instance Element` defining `wiledcard` (and overriding `haveWiledcard` / + `isWiledcard` / `ignoreWiledcard`) must rename those method definitions; all + call sites use the new names. The `(.#)` wildcard shorthand is unchanged. + The bundled SICE-frozen examples were updated by mechanical identifier rename + only (the rename is compile-following and preserves their semantics/values). + +- `(.*)` (scalar product) now **rejects a negative / non-finite scalar** with an + `error`, instead of silently producing out-of-domain (negative) postings (the + algebra is over non-negative values; audit divergence C). The check is on the + scalar only — `0 .* x = Zero` and non-negative scalars are unchanged, and the + fast internal value map is preserved. Covered by `testScalarRejectsNegative`; + the bundled `ripple`/`CGE` Double examples are unaffected (their production + amounts stay non-negative). + +- `HatVal` no longer has `RealFloat` as a superclass; it gains a `showValue :: + n -> String` method. This lets non-floating-point value types (e.g. an exact + `Decimal`) become `HatVal` instances. The `Double` / `NN.Double` instances render + byte-for-byte identically to before (the old internal `showV` was inlined into + each instance's `showValue`). `Fractional` is kept, so numeric literals still + work for value types. Downstream code that relied on `HatVal n => RealFloat n`, + or defined its own `HatVal` instance, must adapt (add `showValue`). + +- `Journal.fromList` is now a strict left fold (`L.foldl' (.+) mempty`) instead of + the lazy right fold (`foldr (.+) mempty`). It is `O(N)` and ~15× faster at + N=10000 / ~40× at N=20000 in the core benchmark (the lazy right fold built a deep + thunk that was expensive to force). The posting **multiset is preserved**; the + only change is the accumulation order of same-note/same-base postings within one + `Alg` sequence. That `Seq` order is observable through `Eq` / `Show` / `toAlg` / + `Binary`, and for `Double` through the last-ULP of `norm` / `bar`. For the exact + `MoneyDecimal` value type the order never affects `norm` / `bar` / balance. (The + interim `fromListFast`, added during staging, was folded back into `fromList`.) + +- Removed: `Journal` `_jVersion` field (`ExchangeAlgebra.Journal`): __breaking__. This + write-only counter was never observed by any read path (audit R3/F2). The + `Journal(..)` constructor now has one fewer field and the `_jVersion` record + accessor is gone; the internal `mkJournal` no longer takes a version argument. + The `Binary` instance is unaffected (it serialises via `toMap`/`fromMap` and + never touched `_jVersion`), so the on-disk/spill format is unchanged. + +- Removed: `forceBalance` (`ExchangeAlgebra.Algebra`): removed unused, unexported, + untyped `undefined` placeholder (audit R3). + +### Added +- Add `ExchangeAlgebra.TrialBalance.Balance`: one `AccountBalance` type + (`NoBalance` / `DebitBalance` / `CreditBalance`) and one set of netting + primitives (`balancePair` in debit-then-credit order, `netPair`, + `combineBalances`, `balanceFor`, `balanceSide`, `balanceAmount`, + `accountBalances`) shared by trial-balance validation, JGAAP presentation + and the consolidation worksheet. The worksheet's separate `BalancePosition` + type, whose pair order was credit-then-debit, is gone; its constructors are + the shared ones re-exported, so `CW.CreditBalance` keeps working. +- Add `ExchangeAlgebra.Simulate.Spill`: spill options, chunk writers, the + checked readers and journal restoration now live in one module that depends + only on `Algebra` and `Journal`. `Simulate` and `Write` re-export the + historical names unchanged; `Write` no longer imports `Simulate` and + `Simulate.Policy` no longer imports `Write`. `Write.writeTermIO` drops its + unused `StateTime` constraint (`Ix t` suffices). +- Add `ExchangeAlgebra.Accounting.PostingPolicy`: `ProcessingContext`, + `postingAllowedIn` and `postingCapabilityFor` now live in the accounting + layer; `Convert.Checked` re-exports them and `Consolidation.Worksheet` no + longer depends on the input adapter. `Convert.Csv.splitTrim` is exported and + shared with the `Simulate.Network` CSV readers, and + `Convert.concreteAccountTitles` is the registry's definition re-exported. +- Add typed `mapPosting` / `mapMaybePosting` (one posting to exactly one, or + to zero or one, with the same zero normalisation as `(.@)`), the explicit + `Journal.replaceNotes` (left-biased whole-note replacement), and + `Journal.Transfer.finalStockTransferAggregated`, the name that makes visible + that the Journal-level closing folds the note axis onto the plank via `(.-)`. + `Journal.mkJournal` is now exported as the safe constructor. +- Add `SpillReadError` / `SpillRangeIssue`, `readBinarySpillFileChecked`, + `restoreJournalFromBinarySpillChecked` and `renderSpillReadError`, the + `Either`-returning forms of the spill readers. + +- `examples/audit-eval` second-experiment harness (audit-harness T3 / T5): the + generator now covers five task categories (`closing`, `statements` and + `consolidation` join the existing kinds in `gen/kinds.py`) with dual pandas / + EA oracles, parameter-only closing adjustments (both oracles compute the + amounts independently), voucher-id contracts in `given.transactions`, and a + per-cell manifest with a task-bundle digest (`gen/make_manifest.py`, + `TASK-FORMAT.md`). The runner adds a no-code-execution arm C with tool-event + counting, `--chart-of-accounts`, `--skill v3`, a full V gate (voucher + reconciliation plus a canonicalisation dictionary), manifest-hash checks on + fresh runs and byte-pinned frozen v1 prompts; the scorer reports + `posting_complete` and a three-valued outcome with explicit infra-missing + handling. Examples-only; no library code touched. +- `examples/audit-eval/harness` documentation (audit-harness T4c): a transfer + catalog (`CATALOG.md`, 19 of 27 library operations adopted plus two loader + recipes), `SKILL-ea-v3.md`, the A′ named-call contract (`APRIME-CALLS.md` + with `aprime-calls.schema.json`) and the `LoadChecked` bypass-guard design + note. Examples-only; no library code touched. +- Add `industrialNetwork` / `industrialFlows` for deterministic ordered CL-SBM + trade networks and exact demand-driven flows, plus the `industrialEx1` + accounting example. + +- Add a read-only `audit-eval` compatibility replay tool that pins frozen + confirmatory inputs and compares historical and current checked-loader + verdicts without regenerating model outputs. + +- Add an opt-in `side` scoring contract to `audit-eval`. Ledger and + trial-balance balances are compared as an actual debit/credit/zero side plus + a non-negative amount, while the frozen signed-value `v1` contract remains + the default for confirmatory-result reproducibility. + +- Add dedicated `ConsumptionTaxRefundReceivable`, `PropertyTaxPayable`, and + `DepositsReceivedFromOfficers` constructors for the corresponding JCCI + level-2 A-column names. Add `AccountSpec.asLabelJa` for all 235 concrete + titles and a complete JCCI level-2 A-column presentation-label sweep. + +- Add typed, read-only reporting metrics. `PeriodResultMetric` represents one + identity whose value is structurally `PeriodProfit`, `PeriodLoss`, or + `PeriodBreakEven`; `GrossProfitMetric`, `OrdinaryProfitMetric`, and custom + metric IDs are likewise separate from account-basis coordinates. Reporting + subtotal definitions now carry this identity, profile-resolved labels, an + explicit absent-title policy, and duplicate-identity validation. + +- Add `periodResultOfAlg` / `periodResultOf`, which derive period profit or loss + from genuine statement-classified revenue and cost coordinates without + inserting a balancing account. After-closing trial-balance validation now + reports residual period-result or reporting-subtotal coordinates explicitly. + +- Add a JGAAP reporting transformation from validated trial balances with + standalone/combined scope, reciprocal elimination, maturity allocation, + materiality and contra policy, profile labels, auditable subtotals, and final + debit-credit reconciliation. + +- Add a trial-balance validation boundary with explicit reciprocal, temporary, + closing-residual, abnormal-side, reclassification, and maturity-evidence + findings, plus an opaque policy-controlled boundary for downstream reporting. + +- Add a consolidation-worksheet validation boundary that preserves source and + adjustment provenance, rejects imbalanced adjustments individually before + aggregation, and checks net-income attribution, retained-earnings, and + non-controlling-interest linkage across P/L, S/S, and B/S columns. + +- Add pre-change goldens and a regeneration tool ahead of the 0.5.0.0 + separation of account-title semantics from the presentation layer. They + freeze Binary bytes, registry/closing/side/PIMO, Assist metadata, projection + membership, and legacy BS/P&L output for 232 concrete titles. Also add closed + inventory checks for classification-related consumers to detect unintended + differences and omitted consumers in subsequent lands. + +- Add a checkpoint mechanism that splits and resumes long-running confirmatory + runs of `audit-eval` at cell boundaries. It rejects drift in the + task/model/backend/git surface/hash, corrupted or duplicate JSONL, and resume + forks before execution, and supports lineage audits with independent + verification and merge CLIs. + +- Add the JCCI 2022 bookkeeping level 2 / level 3 A-column / B-column lists as + frozen fixtures, with a coverage gate for 316 distinct normalized queries. + 295 queries resolve uniquely, while 21 queries for permitted shared names or + generic profit-and-loss names are rejected as `AmbiguousAccount` with frozen + candidate sets. Also add post-vocabulary ordinal, semantics, account-info, + and suggestion fixtures and a regeneration tool, plus synchronization tests + for 232 titles / 5 contra accounts in the Python account mirror. + +- Add 116 account titles from JCCI bookkeeping level 2 commercial bookkeeping, + with English display names conforming to the EDINET 2026 'general commercial + and industrial' taxonomy, to `AccountTitles` and the exhaustive account + registry. Limit the EDINET English labels to external display names while + preserving the compatibility and uniqueness of internal constructor IDs and + Japanese aliases. Also explicitly mark 3 contra accounts and 3 accounts + excluded from closing transfers as registry attributes. + +- Definition 7 amendment support: `ExBaseClass.isContra` (registry-delegated + default), `defaultSide`, `pimoFromDivision`, `pimoFlip`, + `projContraAssets`, and `projContra`. + +- `JournalCert` and `certifyJournalText` in + `ExchangeAlgebra.Convert.Checked` add staged certification for text-originated + journal batches. Duplicate txids and structural errors are rejected first, + then debit/credit balance is checked from sides and amounts independently of + account-title resolution. Balanced batches with vocabulary-only failures are + returned as `BalancedUnresolved`, including resolved postings, unresolved + account text/errors with 0-origin indices, and exact debit/credit totals; + fully resolved batches produce the same `Journal` as `checkedJournal`. + +- `ExchangeAlgebra.Optimize` (new subsystem): a pluggable optimization + solver interface — the `Solver` class fixes + `optimize :: Monad m => strategy -> Config strategy -> (Candidate strategy + -> m Double) -> Candidate strategy -> m (Candidate strategy, Double)`, so + objectives can run stateful simulations (`ST s`) while each solver threads + its own seeded pure RNG (reproducible runs, no random-monad constraint on + the objective). Ships two strategies: `ExchangeAlgebra.Optimize.Annealing` + (simulated annealing over an arbitrary candidate type; configurable cooling + schedule / neighbor move / acceptance rule, with `geometricCooling` and + `metropolis` provided) and `ExchangeAlgebra.Optimize.GA` (real-coded genetic + algorithm over `Vector Double` chromosomes; tournament selection, uniform + crossover, per-gene Gaussian mutation, elitism, optional per-gene bounds, + `defaultGAConfig`). Further strategies (DE/PSO/CMA-ES) are added by giving + a new strategy type a `Solver` instance — no interface change. Objective + values must be finite (fail-fast on NaN/Infinity) and configurations are + validated up front; solvers never re-evaluate an already-scored candidate. + This subsystem is a generic numeric layer independent of the + redundant-algebra core. + +- `circulant` (`ExchangeAlgebra.Simulate.Network`): a deterministic circulant + (ring-lattice) generator where each buyer draws its `min k (N-1)` suppliers + from the `k` nodes that follow it cyclically. Needs no `StdGen` and is built + in `O(kN)` (never scans the `O(N²)` ordered pairs), so it stays usable at the + `N` a market-scale run needs — unlike `kRegular` / `erdosRenyi`, whose + generation cost is `O(kN²)` / `O(N²)`. `|E| = min k (N-1) · N` exactly, with + no duplicate or self edges. Doctested. + +- `ExchangeAlgebra.Assist` (new module): deterministic assistance layer for + LLM-facing workflows. `describeAccount` / `allAccountInfos` expose per-account + metadata (division and home side derived from `classifyAccountDivision` / + `whichSide`; English/Japanese names and description machine-generated from + the `AccountTitles` Haddock in `Element.hs` via + `tools/gen-assist-descriptions.py`, checked in as + `ExchangeAlgebra.Assist.Descriptions` and guarded by a drift test); + `suggestAccounts` gives deterministic keyword lookup (no LLM); and + `explainEntryError` / `explainJournalErrors` / `explainSourceErrors` render + `Convert.Checked` rejections as structured one-line feedback for retry loops. + +- `ExchangeAlgebra.Convert.Checked` (new module): checked construction for + externally generated (LLM/runner) journal entries. `checkedEntry` / + `checkedEntryText` reject empty entries, wildcard `Side`/`AccountTitle`, + non-positive amounts and debit/credit imbalance at construction time + (errors accumulate as `NonEmpty EntryError` with 0-origin posting indices); + `checkedJournal` additionally pre-scans txid duplicates (`DuplicateTxId`) + before notes are merged into the `Journal`; `reconcileSources` performs + source-coverage reconciliation (missing / unknown txid / amount mismatch) + between input transactions and the note-indexed journal. Balance uses the + new `exactBalanced` (strict `==` over `norm . decL` / `norm . decR` — the + exact-equality predicate is closed under `(.+)`, unlike the tolerance-based + `balance`). Accepted values are built with `journalFromSides`, so the + unchecked path's semantics are unchanged. Property tests (accept-iff, + equivalence, submonoid closure, duplicate rejection, reconciliation) and + doctests included. + +- `stepBackWith` / `spillDeleteDecision` (`ExchangeAlgebra.Simulate`): the + eviction-window arithmetic and the per-chunk delete decision are now pure, + exported, unit-tested functions — the __single source__ of "which term range + is evicted" (design-review C4). Previously the same logic lived inline in + three places: the classic `runSimulationWithSpill` loop (`backBy` + + `deleteRangeForChunk`), `Simulate.Lite`'s retention loop (`backByTerms`), + and implicitly behind the `policySpillOptions` bridge. Both engines now call + the shared functions (classic passes `prevTerm`, Lite passes `pred` — each + engine keeps its own notion of "previous term"); behaviour is unchanged and + the decision table is pinned by tests. + +- Pure row builders for the legacy CSV writers (design-review C7): `bsRows`, + `plRows`, `journalRows`, `accountLedgerRowsJournal` and + `compoundTrialBalanceRows` are the pure counterparts of `writeBS` / + `writePL` / `writeJournal` / `writeAccountOfJournal` / + `writeCompoundTrialBalance`, which are now thin `writeCSV` wrappers around + them — same "pure `*Rows` + IO wrapper" shape as `worksheetRows` / + `postClosingTrialBalanceRows` / `accountLedgerRows`. Output is bit-for-bit + unchanged (pinned regression tests were added before the refactor and pass + unmodified after it); each new builder carries Haddock + doctests. + +- `BaseClass` instance for 7-tuples (design-review C5): `Element` and + `AxisDecompose` already had 7-tuple instances, so every Element tuple arity + is now also usable as a base. + +- `examples/audit-eval`: full 23-task pilot suite (representative tasks #4–#23 + converted to `tasks/*.json` with per-task `ea_account_map`) and a v2 task/output + contract (`TASK-FORMAT.md`) extending the runner beyond journal-posting arrays: + `derived` (statement figures), `findings` (audit defect detection with a fixed + type taxonomy), `decision` (classification calls) and judgment escape-hatch + scoring. Scoring is collision-aware (many-to-one `ea_account_map` entries are + matched via candidate sets disambiguated by amount) and the finding-type + vocabulary is normalized — both fixes remove name-translation measurement bias + from arm comparisons (same rationale as the P1 account-map fix). Runner gains + multi-seed runs (`--seed 0-4`) and an append-mode `metrics/summary.csv`. + Follow-up (seed-0 forensics): the exact `derived` key vocabulary is now + injected into every arm's output contract (keys are the output schema, not + the answer — third P1-family fairness fix) and the codex timeout is raised + to 360s (largest task returned empty at 240s). + Contract v2.1: canonical printing is now harness-owned — + `harness/EmitCanonical.hs` projects the postings JSON from the EA algebra + value itself (same `whichSide` convention as the oracle, roundtrip-closed) + and the arm-A/D minimal instruction forbids hand-assembled JSON. This pins + the printing seam observed in pilot seed 0 (a correctly-built journal + misprinted by model-written string code) to the measurement layer; the + versioned SKILL treatment artifact is untouched. + Examples-only change; no library code touched. + +- `examples/audit-eval` Track S Land 3: arm Aprime now uses the + `LoadChecked.hs` checked-loader gate with raw/rich retry feedback, arm A can + select `SKILL-ea-v2`, and runner metadata records effective model / CLI + versions automatically. Examples-only change; no library code touched. + +- `examples/audit-eval` Track S Land 4: `gen/` now has a deterministic generator + fairness pass, independent pandas/EA double-oracle adoption via + `DeriveEA.hs`, explicit defect injection checks, and `make_suite.py` for + generated suites. Examples-only change; no library code touched. + +- `ExchangeAlgebra.Simulate`: the `StateSpace` methods `initT` / `lastT` are now + exported. Their Haddock has always described them as customizable (they let an + instance override the simulation start/end term, and `runSimulationWithSpill` + consults them), but the export list only exposed + `StateSpace(event, randomSeeds)`, so external instances could not actually + override — or even name — them. Purely additive. + +- `CumulativeTranslationAdjustment` `AccountTitles` constructor (為替換算調整勘定, + classified as `Equity`) — the equity/OCI account that absorbs the foreign-currency + translation adjustment. This is the only library primitive that foreign-currency + translation requires: the translation itself (relabel a `CountUnit` currency axis + and rescale the value at the exchange rate) is expressed with the existing + `ExchangeAlgebra.Algebra.Transfer` machinery (`createTransfer`/`.->`/`|%`), and the + CTA residual is posted from the caller, so no new translation operator is added to + the library. Classification and exhaustiveness tests updated. + +- `ExchangeAlgebra.Bookkeeping.priorPeriodErrorCorrection` — prior-period error + correction builder (前期修正/誤謬訂正): the current-period portion is charged to + an expense account while the prior-period portion is routed, by construction, to + `RetainedEarnings` (IAS 8 / ASC 250-10 retrospective restatement), so the caller + cannot misbook the prior-period amount to the income statement. Adds the + `AmortizationExpense` `AccountTitles` constructor (無形固定資産償却費, Cost; + distinct from tangible-asset `Depreciation`); classification and exhaustiveness + tests updated. Balanced by construction (`norm (decL x) == norm (decR x)`). + +- `ExchangeAlgebra.Bookkeeping` — equity-method closing builders + (`equityMethodEarningsEntry`, `equityMethodDividendEntry`, `equityMethodEntries`) + plus `equityMethodBalance`, the engine-recomputed carrying amount + (`norm . bar . projByAccountTitle InvestmentInAssociate`), so the + `cost + Σ(share of NI) − Σ(dividends)` roll-forward of an equity-method + investment is correct-by-construction rather than hand-written. Adds two + `AccountTitles`: `InvestmentInAssociate` (関係会社株式, Asset/Fixed) and + `EquityInEarningsOfInvestee` (持分法による投資利益, Revenue). All builders are + debit-credit balanced (`norm (decL x) == norm (decR x)`); the exhaustiveness + and classification unit tests cover the two new titles. + +- `ExchangeAlgebra.Algebra.netPairMapBy` — the pair read-out of the paper's + class-net operator ν_κ (`def:class-net`, notes Def 2.7). For each bucket key it + returns a non-negative `(notTotal, hatTotal)` pair, built by netting each base's + two sides (bar-like cancellation) and summing the residual on the winning side + — `(Σ_{n>h}(n−h), Σ_{h>n}(h−n))`. `balanceMapBy` is its signed-difference + version: `balanceMapBy kf == fmap (\(n,h) -> n − h) . netPairMapBy kf`. Both + components are non-negative, so `netPairMapBy` is well-behaved on non-negative + value types (the `n − h` identity with `balanceMapBy` only holds on a signed + type such as `Double`/`MoneyDecimal`). Single pass; redundancy is intentionally + reduced (named, not an implicit `bar`). + +- `ExchangeAlgebra.Simulate.Lite` — `stageOf` / `StageTagged`: a note-tagged BSP + stage whose note type is fixed to `(tag, t)` by construction. Each agent emits + a bare `Alg v b`; the runner attaches the single note `(stTag, t)` in exactly + one place (`runStage`), eliminating the write-site `alg .| (Tag, t)` + duplication. Because the tag and any downstream `projWithNote [(tag, t)]` are + now checked against the same constructor, a stringly-typed note mismatch is a + compile error rather than a silently empty projection. `stageFor` / `stage` / + the existing `StageFor` constructor are unchanged (purely additive: `Stage` is + now a GADT with both constructors). Multi-note stages (e.g. a closing stage + posting both `(Closing, t)` and `(Carryover, t+1)`) keep using `stageFor`, + which still returns a fully general `Journal`. Also adds `stageName` + (`stName` for `StageFor`, `show stTag` for `StageTagged`) for stages that may + be either constructor. Determinism is unaffected — the per-agent `StdGen` is + still derived from `(specSeed, termIx, stageIx, agentIx)` only, and the note + attachment is a pure post-transform. + +- `ExchangeAlgebra.Write` — three closing-document CSV writers (and their pure + row-builders, for testing/composition). `writeWorksheet` / `worksheetRows` + render an 8-column worksheet (8 桁精算表): per account title, the + trial-balance, adjustment, profit-&-loss and balance-sheet debit/credit column + pairs. The trial-balance and adjustment columns come from the pre-adjustment + ledger and the adjustment entries respectively; the final balance of + `pre .+ adj` is routed by `whatDiv` (Cost/Revenue → P/L, Assets/Liability/ + Equity → B/S). The closing row is the profit/loss balancing figure + (当期純利益/純損失) placed so each statement's debit/credit pair balances; since + `norm` is a homomorphism the P/L and B/S imbalances coincide — that equality is + the worksheet's own self-check (it is *not* enforced: an inconsistent input + still emits both figures so the discrepancy stays visible). + `writePostClosingTrialBalance` / `postClosingTrialBalanceRows` produce a + post-closing trial balance (繰越試算表) listing only the real + (Assets/Liability/Equity) accounts — nominal Cost/Revenue accounts are excluded + by construction. `writeAccountOf` (previously an unimplemented stub) and the new + `writeAccountOfJournal` / `accountLedgerRows` render the general ledger + (総勘定元帳 / T-account): every posting on a title is listed individually in + date order with **no aggregation**, so the redundant sequence is preserved as + the audit trail (`writeAccountOfJournal` additionally carries each posting's + note/摘要). The trial-balance and post-closing balances use an explicit + `diffRL` netting (the same aggregation as `writeCompoundTrialBalance`); no + implicit `bar`. All three have Haddock doctests on their pure row-builders and + unit tests (worksheet self-check P/L diff == B/S diff == net income; post-closing + TB excludes Cost/Revenue; ledger preserves posting count). + +- `ExchangeAlgebra.Bookkeeping` — a new module of *closing-adjustment entry + builders* (決算整理仕訳) at the 日商簿記 3 級 level. Unlike + `ExchangeAlgebra.Algebra.Transfer` (which relabels existing ledger balances), + these record fresh postings whose amounts come from outside the ledger + (period-end inventory, estimated allowance, depreciation, tax). The base + polymorphism is absorbed by a caller-supplied injection `type MkBase b = Hat -> + AccountTitles -> b`. Builders: `cogsAdjustmentEntries` (cost of goods sold under + the periodic/3-account method, 売上原価算定), `depreciationIndirectEntry` / + `depreciationDirectEntry` (減価償却, 間接法/直接法), `allowanceReplenishmentEntry` + (差額補充法) / `allowanceResetEntries` (洗替法) for the allowance for doubtful + accounts, the four deferral/accrual entries (経過勘定) `prepaidExpenseEntry` / + `unearnedRevenueEntry` / `accruedRevenueEntry` / `accruedExpenseEntry`, + `consumptionTaxSettlementEntry` (消費税確定; a tax refund `received < paid` is + rejected as out of 3-級 scope), and `corporateTaxInterimEntry` / + `corporateTaxSettlementEntries` (法人税等の中間納付・確定). `reversingEntry` is a + vocabulary alias for the Hat operation `(.^)`: it expresses the opening + reversing entry (再振替仕訳) and the correction entry + (訂正仕訳 = `reversingEntry wrong .+ correct`), whose redundant sequence is + retained as an audit trail of the correction. Every builder is constructed only + with the smart constructor `(.@)` (zero amounts normalise to `Zero`, + negative/non-finite amounts are rejected) and is debit-credit balanced + (`norm (decL x) == norm (decR x)`), verified as a QuickCheck property for all + builders plus unit tests on representative lecture figures. + +- `AccountTitles` — added `ReversalOfAllowanceForDoubtfulAccounts` (貸倒引当金戻入, + `Revenue`), the credit counterpart released by the allowance builders when the + estimate is below the current balance. Appended before the `AccountTitle` + wildcard (existing ordinals preserved) and added to the classification + exhaustiveness table. + +- `AccountTitles` — added ~49 account titles at the 日商簿記 3 級 (elementary + Japanese bookkeeping) level, each with an English/Japanese bilingual Haddock + gloss: assets (e.g. `PettyCash`, `NotesReceivable`, `MerchandiseInventory`, + `Land`, `Fixtures`, `Patent`, `CashOverShort`), liabilities (e.g. + `AccountsPayable`, `NotesPayable`, `BankOverdraft`, `AllowanceForDoubtfulAccounts`, + `AccumulatedDepreciation`), equity (`LegalRetainedEarnings`), costs (e.g. + `ProvisionForDoubtfulAccounts`, `BadDebtLoss`, `PaymentFees`, `MiscellaneousLoss`, + `CorporateIncomeTaxes`, `CommunicationExpenses`) and revenues (e.g. + `GainOnSalesOfFixedAssets`, `RecoveryOfBadDebts`, `MiscellaneousIncome`). + Valuation accounts (`AllowanceForDoubtfulAccounts`, `AccumulatedDepreciation`) + are classified under `Liability` (B/S contra-asset presentation deferred to the + Write side), keeping values non-negative and the Hat/Not structure intact. New + constructors are appended before the `AccountTitle` wildcard so existing + `Enum`/`Binary` ordinals are preserved. `AccountTitles` now also derives + `Bounded`. A new exhaustiveness table test pins `(whatDiv, whichSide, + fixedCurrent)` for every constructor and fails if a new title is left + unclassified, guarding against `classifyAccountDivision`'s wildcard silently + treating a title as `Assets`. This also completed the `fixedCurrent` cases for + the pre-existing `AccountsReceivable` (now `Current`) and `Sales` (now `Other`), + which previously had no case and would `error` on a non-exhaustive pattern. + +- `ExchangeAlgebra.Simulate.Policy` — a declarative vocabulary for managing the + size of a long simulation's audit trail, decided once when the ledger is + built. A `LedgerPolicy` bundles three orthogonal choices: **retention** + (`Retention` = `RetainAll` | `RetainRecent Int`, the resident-history window), + **spill** (`spillTo :: Maybe FilePath`, an optional binary backup of evicted + terms), and **compaction** (`Compaction` = `FullAudit` | `CompressClosedTerms`). + `CompressClosedTerms` applies `compress` only to *closed* terms — it is + norm- and balance-preserving (only the within-term posting sequence is + collapsed) and the in-progress term always keeps its full audit trail; per the + prohibition on implicit `bar`/`compress` it is reachable only through this + named policy. The term a `Note` belongs to is fixed by the `HasTermAxis` class + (type family `TermOf n`, method `termOf`): **the term is the last component of + the Note**, with shipped `(e, t)` and `(e1, e2, t)` instances and a one-line + instance for bespoke Notes. Two bridges connect the policy to the existing + spill engine: `policySpillOptions` builds a binary `SpillOptions` for the + classic `runSimulationWithSpill`, deriving the per-chunk extraction and the + eviction range from `termOf` (replacing the ~20 lines of hand-written + `filterWithNote` plumbing), and `restoreLedger` rebuilds the full ledger from a + spill file plus the in-memory remainder (lossless with an exact value type). + `defaultLedgerPolicy` (`RetainAll` / `Nothing` / `FullAudit`) is exactly the + classic full-audit behaviour. **Data-loss note:** `spillTo = Nothing` together + with `RetainRecent w` *discards* evicted terms with no backup — documented + prominently. `Simulate.Lite` gains `runLiteWithPolicy`, an `IO` runner whose + BSP loop is identical to `runLite` but which, at each term boundary, compresses + closed terms (under `CompressClosedTerms`) and evicts/spills out-of-window + terms (under `RetainRecent`); under `defaultLedgerPolicy` it is observationally + equal to `runLite`. The existing `SpillOptions`, `runSimulationWithSpill` and + `runLite` are unchanged. + +- `ExchangeAlgebra.Simulate.Network` — separates a market's *trade relation* + from its *technology*. `TradeNetwork k` is a sparse directed "who may supply + whom" graph (edge `(i, j)` = supplier `i` of buyer `j`); `InputCoefficients + k v` is the matching sparse, buyer-major coefficient table, with the invariant + `supp(A) ⊆ edges(G)` enforced by the smart constructors. All three types are + abstract (no exported constructors) and every read-out (`nodes`, `edges`, + `suppliersOf`, `buyersOf`, `inputsOf`, `coefficient`, `edgeCount`) is returned + in ascending order, so results never depend on hash-table iteration. The key + operation `sigmaEdges g f` runs the familiar Σ notation over a network's + *edges* (cost `O(E)`) instead of over all ordered pairs (`O(N²)`); with + `completeNetwork` the two coincide exactly + (`sigmaEdges (completeNetwork ks) f == sigma2When ks ks (/=) f`), so an + all-pairs model can adopt a sparse market structure without changing its Σ. + Includes deterministic network generators driven by an explicit `StdGen` + (`completeNetwork`, `kRegular`, `erdosRenyi`, `scaleFree` Barabási–Albert, + `sectorBlock` stochastic-block), random coefficient generation with an + optional Hawkins–Simon (productivity) column-sum rescale (`randomCoefficients` + / `CoefOptions` / `defaultCoefOptions`), long-form table and dense-matrix + ingestion (`networkFromTable`, `coefficientsFromTable`, `fromCoefficientMatrix`), + and a tiny dependency-free CSV reader for the fixed `from,to[,coef]` schemas + (`parseEdgeCsv`, `parseCoefCsv`, `readEdgeCsv`, `readCoefCsv`). Smart + constructors reject self-loops, duplicate edges, out-of-network coefficients, + negative coefficients, and duplicate coefficients with a `NetworkError` + (nothing is silently merged or dropped). The network types carry `Show` / `Eq` + / `NFData`. No `Updatable` instance is provided (the `Updatable` functional + dependency makes one impossible for the library to supply); the Haddock shows + a three-line `UpdatableSTRef` wrapper for the classic `Simulate` engine, and + in `Simulate.Lite` a network is simply a `carry` field. + +- `ExchangeAlgebra.Simulate.Lite` — a small, additive front-end for agent-based + bookkeeping simulations with bulk-synchronous-parallel (BSP) semantics. It + sits beside the classic `ExchangeAlgebra.Simulate` (unchanged) and removes + most of its boilerplate: the world is a product-only higher-kinded record + (`HK` role tags `InitT` / `RefT s` / `SnapT`; only `deriving Generic` + needed — no per-field `Updatable` instances, no newtype wrappers), term + boundaries are declared per field (`carry` / `resetEach` / `updateEach`), + the term range and seed are runtime values (`SimSpec` via `mkSimSpec`), and + stages are pure functions from a read-only world snapshot to a `Journal` + "message" (`stage` / `stageFor`). `runLite` drives the BSP loop: per stage + it freezes the world once, runs every agent against that same snapshot + (sequentially or with fixed-chunk parallelism, `Par`), merges the messages + in one pass (via `sigma`) and commits them to the ledger; per-field rules + fire once per term (regression-tested with a multi-stage model). + Determinism: per-agent generators derive purely from + (seed, term, stage, agent); with the exact `MoneyDecimal` value type the + parallel and sequential runs agree exactly (tested), and with `MoneyDouble` + a fixed schedule is run-to-run reproducible (tested). Note the BSP semantic + difference from the classic engine: within a stage, agents cannot observe + each other's same-stage postings (covered by a sentinel test). A minimal + model is ~20 lines versus ~90 with the classic instances. + +- `instance NFData (Journal n v b)` (shallow-structural, mirroring the `Alg` + instance): forces the base/delta map spines and each contained `Alg`, + leaving the lazily built axis indices untouched. Used by `Simulate.Lite`'s + parallel stage evaluation; generally useful for `parMap rdeepseq` over + journals. + +- `ExchangeAlgebra.Algebra.decBy :: Ord k => (b -> Maybe k) -> Alg v b -> + Map k (Alg v b)` — quotient decomposition (dec_κ): one-pass partition of an + algebra along the classes induced by a classifier on the full `HatBase`. + Each class is the redundancy-preserving restriction of the input (no `bar`, + no aggregation); the pieces reconstruct the input and `norm` is additive over + classes. Generalizes the Deguchi-Nakano (1986) decomposition operators + (`decR`/`decL`/`decP`/`decM` are two-class special cases). Replaces per-class + projection loops (`O(classes * query)`) with a single `O(entries)` fold. + `bar` commutes with `decBy` componentwise iff the classifier does not + distinguish Hat/Not (side-sensitive classifiers encode a semantic choice; + covered by sentinel tests). + +- `ExchangeAlgebra.Algebra.postFromNetBy :: Ord k => (b -> Maybe k) -> + (k -> v -> Alg v b) -> Alg v b -> Alg v b` — fused classify→net→post: + `bar` (explicit in the name), classify the netted entries, sum per class, and + bulk-merge the generated postings. The "shortage detection → purchase + postings" pattern becomes one call running in a single pass (the naive + all-pairs formulation costs `O(N^2)` per-pair queries). + +- `ExchangeAlgebra.Journal.decTo :: Note n' => (b -> Maybe n') -> Alg v b -> + Journal n' v b` — quotient decomposition landing on the `Journal` (the + library's native keyed family of algebras, paper Definition 12), keeping the + per-key result inside the algebra vocabulary (no external `Map` in the + result). Same redundancy/norm guarantees as `decBy`; `plank` cannot carry a + class (such entries join the residual). + +- Quotient-decomposition axiom property tests (reconstruction, norm additivity + over classes, componentwise `bar` commutation for base-part classifiers) plus + fixed sentinels for the side-sensitive non-commutation cases (`isHat`, + `whichSide`) and for `mapBasePart`'s coarsen-vs-net order sensitivity. + +- `bench-core` gains a `dec/*` group: per-key reporting A/B between the naive + per-key wildcard `balanceBy` loop, `balanceMapBy`, `decBy`+`norm`, and + `postFromNetBy` at K=200/1000 keys. + +- `projCapitalStock` (`ExchangeAlgebra.Algebra`): now implemented (previously an + `undefined` placeholder that crashed when called, audit R3). It projects the + credit-side entries classified under the `Equity` division — the equity + counterpart of `projCurrentLiability` / `projFixedLiability`. Includes a Haddock + doctest. + +- `ExchangeAlgebra.Convert` — a new dependency-free (Text only) input-conversion + core that turns external `(side, account-name, amount)` postings into exchange + algebra `Alg` terms. `parseAccountTitle` matches a name (case-, whitespace- and + symbol-insensitively via `norm`) against the canonical English constructor names + plus a Japanese-label / abbreviation alias table built from the + `ExchangeAlgebra.Algebra.Base.Element` bilingual Haddock; unknown names and the + wildcard `AccountTitle` are rejected (`UnknownAccount`), and a label shared by + several accounts (e.g. `準備預金` for both the asset and liability side of reserve + deposits, or `通信費` for `CommunicationExpenses`/legacy `Commutation`) is + rejected as `AmbiguousAccount` with the candidates listed — a correct-by- + construction guard against hallucinated or under-specified accounts. `parseSide` + parses debit/credit; `markerForSide` derives the `Hat`/`Not` marker from the + library's own `whichSide` (so the debit/credit rule is never duplicated); + `postingFromSide` / `journalFromSides` build the algebra terms through the + non-negative smart constructor `.@`. Serialization glue (JSON/XML) deliberately + stays out of the core. Haddock doctests assert the Debit/Credit ↔ Hat/Not + mapping explicitly. + +- `ExchangeAlgebra.Convert.Csv` — a fixed-schema, dependency-light + (Text + scientific) reader for general journal CSV: a header + `side,account,amount` with an optional trailing `note` column, one posting per + row. `parseJournalCsv` folds the rows into a single `Alg` term; + `parseJournalCsvWith` takes a caller-supplied amount parser (keeping the value + type open); `parseNotedJournalCsv` returns `(side, account, value, note)` rows + so a caller can key a `Journal` by the note. `scientificAmount` parses a + non-negative decimal via `Data.Scientific` exactly through `toRational` (so + exact-decimal value types keep precision). Blank lines and `#` comment lines + are skipped and fields are trimmed; unknown/ambiguous accounts, bad sides, + malformed headers/rows and negative or non-numeric amounts are rejected through + the `ConvError` channel (now extended with `MalformedCsv` and `BadAmount`). + This is the read counterpart of the `ExchangeAlgebra.Write` ledger/report CSV + writers (writing is not handled here). The minimal CSV splitter intentionally + mirrors the one in `ExchangeAlgebra.Simulate.Network` (`parseEdgeCsv` etc.); a + future refactor could share it, but the two stay independent for now to avoid a + cross-module dependency. A QuickCheck round-trip property (render → parse is + exact for `MoneyDecimal`) and structural-rejection unit tests are included. + +- `ExchangeAlgebra.Value` with `MoneyDecimal`, an exact non-negative decimal value type + (wraps `Data.Decimal.Decimal`) usable as the `v` in `Alg v b` / `Journal n v b`. + Numeric literals work directly (derived `Num`/`Fractional`). Because decimal addition + is exact and associative, `norm` / `bar` results are independent of construction order + (unlike `Double`). Ships `bankersRound` (round-half-to-even, the unbiased financial + default) and `ceilingRound`. New dependency: `Decimal`. + +- `ExchangeAlgebra.Value.MoneyDouble`, a zero-cost `newtype` over `Double` for a fast + IEEE-754 value type that is *typed* as money (distinct from bare `Double` + coefficients / random draws) yet has identical speed and precision. All its + instances (`HatVal`/`Nearly`/`Binary`/`Hashable`/`NFData`, plus the numeric + classes) are derived from the bare-`Double` instances via `deriving newtype`, so — + like `MoneyDecimal` — there are no orphan instances. Its subtraction is signed, so + the negative intermediates that arise inside `bar`/`(.-)` are fine (unlike + `Number.NonNegative.Double`, whose `(-)` errors on a negative result, making it + unusable as a value type). Measured: `MoneyDouble` matches `MoneyDecimal` exactly + where a result is exactly representable but diverges in the last ULP at scale, and + runs ~5–7× faster with ~15% less memory than `MoneyDecimal` in `sim2`. + +- `ExchangeAlgebra.Algebra.mapBasePart :: (BasePart b -> BasePart b') -> Alg v b -> + Alg v b'` — relabel the base part of every element while preserving the Hat/Not + structure and the redundancy (ordered sequences); colliding targets are + concatenated, so `norm` is preserved. (Hat is left untouched; the type expresses + the Hat/Not-preserving intent, per the redundant-algebra design.) + +- `ExchangeAlgebra.Algebra.balanceMapBy :: (BasePart b -> Maybe k) -> Alg v b -> + Map k v` — the bucketed form of `balanceBy`: nets each entry by a key projected + from its `BasePart` (Not adds, Hat subtracts) in a single fold, replacing one + wildcard projection per key. For per-key reporting (e.g. per-company stock / + profit) this turns `O(keys * entries)` into `O(entries)`; the result equals the + per-key `balanceBy` up to floating-point reassociation. Returns *signed* net + balances, so use a signed value type (`Double` / `MoneyDouble` / `MoneyDecimal`). + +- README gains a "Choosing a value type" section (Double vs MoneyDecimal comparison + table, the simulation boundary pattern, the large-scale precision×memory + trade-off, and the `fromList` ordering contract). + +### Changed +- Cabal flag `visualize` (manual, default on) now guards + `ExchangeAlgebra.Simulate.Visualize` and the `Chart` / `Chart-cairo` + dependencies. `stack build --flag exchangealgebra:-visualize` builds the + accounting algebra without a cairo toolchain; the default build and the + bundled examples are unchanged. +- Resolve Japanese presentation and LLM-facing names through the cleaned + `asLabelJa` registry field, with the JCCI `AdvancesReceived` override kept as + `契約負債`. Mark `EquityInEarningsOfInvestee` and + `CumulativeTranslationAdjustment` as consolidation-only and contextual. + Replace catch-all branches in all five account-semantics classifiers with + exhaustive constructor cases. + +- Clarify that the retained `GrossProfit` and `OrdinaryProfit` constructors and + transfer functions are historical SNA/simulation coordinates, not complete + JGAAP subtotal definitions. Their ordinals and Binary tags remain unchanged; + see `docs/migration-0.5-derived-metrics.md`. + +- Correct `NonControllingInterests` metadata to `ConsolidationOnly`, + `ContextualPresentation`, and `AttributionAccount`, preventing the + consolidated balance-sheet coordinate from being posted to an individual + entity's ordinary journal. + +- Correct `HeadOfficeCurrentAccount` (`本店`) from `Assets` to `Liability` to + match its credit balance in branch books. + +- The bar-netted projection read-outs are renamed so the netting is visible in + the name (design-review C2): `projNorm` → `projNetNorm` + (`ExchangeAlgebra.Algebra`), `projWithBaseNorm` → `projWithBaseNetNorm` and + `projWithNoteNorm` → `projWithNoteBaseNetNorm` (`ExchangeAlgebra.Journal` — + the last also gains the missing `Base` in its name: it takes note AND base + queries). The old names remain as __deprecated aliases__ (removal planned + for 0.6), so this is warning-only, not immediately breaking. + +- `ExchangeAlgebra.Convert`: the account-name normaliser is renamed + `norm` → `normalizeTitle` (the module has never been released, so no + migration burden). The old name collided with the core value-domain + homomorphism `ExchangeAlgebra.Algebra.norm` — a fundamental, entirely + unrelated operation — and would have made `norm` ambiguous in any module + importing both unqualified. + +- `Liner` (`ExchangeAlgebra.Algebra`) and `Journal` (`ExchangeAlgebra.Journal`): + added Haddock documenting the constructor invariants (the internal axis/index + cache fields must stay consistent with `_realg` / `_jBase`/`_jDelta`, or the + wildcard projection / `filterByAxis` paths return wrong answers silently). Build + values via the smart constructors (`fromList`/`fromMap`/`(.@)`/`(.|)`), not by + applying the data constructors directly (audit R11, doc only). + +- `Updatable.copy` / `Updatable.modify` default methods + (`ExchangeAlgebra.Simulate`): the unoverridden default now raises a diagnostic + `error "Updatable.copy: default method not overridden"` (resp. `modify`) instead + of bare `undefined` (audit R4). Behaviour-equivalent for any instance that + overrides them. + +- `Liner` `_bpToId` / `_nextBpId` fields (`ExchangeAlgebra.Algebra`): no longer + built by `linerFromMap` (they were never read; reserved for a dormant + incremental-id scheme). They are now lazy `error` poison — forcing either throws + with an explanatory message — guarded by a regression test (audit R3/F6). + Normal projection (concrete and wildcard) never forces them. + +- Examples: `marketEx1`\/`marketEx1d` (`examples/market/MarketModel.hs`): the model note + is now an ADT `MTag` (`PlankTag | Trade | Production | Report | Closing | + Carryover`) instead of a `String` tag, so `MNote = (MTag, Int)`. The event tag + is written (`.| (Trade, t)`) and read (`projWithNote [(Trade, t)]`) by the same + constructor, so a typo is now a compile error rather than a projection that + silently matches nothing. Behaviour and all numeric results are unchanged (the + default N=20 run still reports `norm = 8587.1027`, shortage `200.0000`). The + test suite's Market mirror gains the same-shape `MktTag`. The `Note` class + Haddock now documents the "prefer an ADT note over `String`" guidance with the + `MTag` sketch. No library API change. + +- Performance: `Journal` append (`.+` / `addJournal`): two redundancies removed on the hot + commit path (audit R5 = ROAD_MAP P1b). `toMap` no longer copies when either + the base or the delta layer is empty, and appending to an *existing* note key + no longer re-inserts the (unchanged) note-axis index entry. Values, sequence + order (audit trail) and the public API are unchanged; the whole test suite + passes unmodified. Measured: append micro-benches alloc -29%/-36% + (base-only / same-note), end-to-end simulation alloc -4.5% with a small + wall-clock improvement. + +- Performance: `Write` trial-balance documents (`writeCompoundTrialBalance`, + `worksheetRows` / `writeWorksheet`, `postClosingTrialBalanceRows` / + `writePostClosingTrialBalance`): aggregation changed from O(a·s) (a full + `projByAccountTitle` scan per distinct account title) to a single + `foldEntries` pass O(s) (audit R6). Per-title gross debit/credit totals are + accumulated **non-negatively** (preserving the value-domain invariant) and + netted with the same `diffRL`/tolerance rule, so the CSV output is + byte-identical (verified by the existing doctests/unit self-checks and an + ebex6/7/9 byte-diff). Measured: trial-balance row build a=50/s=10⁴ wall + 13.4 ms → 1.3 ms (~90% reduction, ~10× speedup). + +- Performance: Concrete (non-wildcard) `proj` / `projNorm` no longer force/build the lazy axis + index. The module is compiled `Strict`, so passing the index to the shared + projection helper previously forced its full construction even for an exact + single-base lookup that only needs a `Map.lookup`. The helper is now split into + `projExactMap` (index-free) and `projWildMap` (uses the index), and callers + dispatch on `haveWildcard` with the index fields bound lazily — so an exact + projection is a plain `Map.lookup` and a wildcard projection still uses the + index. Measured ~4× faster for repeated concrete projections over a large + ledger (more for workloads that rebuild the projected algebra per query, e.g. + per-company stock reporting). Results are unchanged; guarded by a poison-index + regression test. + +- Examples: The bundled bookkeeping and simulation examples (`elementaryBookkeepingEx1–5`, + `simulateEx1`, `simulateEx2`) and the test suite's simulation now use the exact + `MoneyDecimal` ledger value type, following the boundary pattern (ABM + parameters/coefficients/random draws stay `Double` and convert at the ledger + boundary; reported stocks/profits convert back). The numeric-method examples + (`ripple/*`, `CGE`) intentionally stay `Double`, demonstrating the Double side of + the selectable value type. + +### Deprecated +- `Journal.insert`: deprecated alias of `replaceNotes`. The name suggested a + redundant addition, but it replaces whole notes (left-biased) and is not + `(.+)`. +- `projNorm` / `projWithBaseNorm` / `projWithNoteNorm`: deprecated aliases of + `projNetNorm` / `projWithBaseNetNorm` / `projWithNoteBaseNetNorm` (see + Changed — the old names concealed the bar-netting). Removal planned for 0.6. + +- The `HatVal NN.Double` instance (`Number.NonNegative.Double`): deprecated + since 0.5.0.0, removal planned for 0.6 (design-review C3). Its `(-)` errors + on the negative intermediates that the algebra's netting produces, and + `MoneyDouble` covers the same use case safely. GHC cannot attach `DEPRECATED` + to an instance, so the notice lives in the Haddock (class + instance), the + README value-type section, and here. All library doctests were migrated from + `NN.Double` to `Double`; the value-type guidance is unified across the + umbrella Haddock, the `HatVal` class doc and the README (`Double` / + `MoneyDouble` = fast, `MoneyDecimal` = exact\/audited). + +- `rounding` (`ExchangeAlgebra.Algebra`): the `NN.Double`-only whole-unit + ceiling helper is deprecated in favour of the explicit, value-type-appropriate + `ExchangeAlgebra.Value.ceilingRound` / `bankersRound` (which take a + decimal-places argument and work on `MoneyDecimal`). No internal callers; the + function itself is unchanged. + +### Fixed +- `ExchangeAlgebra.Bookkeeping.corporateTaxSettlementEntries` now rejects + `interim > total` (a corporate-tax refund position, out of 日商簿記 3 級 + scope) with a clear error, mirroring the guard style of its sibling + `consumptionTaxSettlementEntry`; previously the negative `unpaid` leg hit + the generic `(.@)` error (design-review C5). + +- `classifyAccountDivision` (`ExchangeAlgebra.Algebra.Base`) is now total by + explicit enumeration: the trailing catch-all `_ = Assets` was replaced with + explicit `Assets` cases for the 19 legacy SNA/macro asset titles (`Cash`, + `Deposits`, …, `GovernmentService`). Previously any __future__ + `AccountTitles` constructor added without a classification would have been + silently classified as `Assets`; now a missing case fails loudly (pattern- + match error, caught by the Bounded/Enum exhaustiveness test). No behaviour + change for existing titles. + +- `ExchangeAlgebra.Journal`: removed two GHC `RULES` that rewrote + `norm (projWithBase bs js)` to `projWithBaseNorm bs js` (and the + note-base analogue). The equation is __false__ whenever a query selects both + sides of one base (e.g. a `HatNot` wildcard, or a list containing both + `Hat:>` + (intermittent, scheduling-dependent — the thunk graph is acyclic and + sequential runs are unaffected). Results are unchanged (pure values; + determinism tests assert exact equality). The library and example executables + are also compiled with `-feager-blackholing`, as recommended by GHC for + programs using sparks. + +### Documentation +- Document the precise validity layers of the category-theory phase 1 laws for + `mapBasePart`, `foldEntries`, and `postFromNetBy`, and pin them with QuickCheck + properties plus raw-order and `bar` non-commutation counterexamples. This is + documentation/test coverage only; library behaviour and exports are unchanged. + +- `plank` in the note-query lists of `projWithNote` / + `projWithNoteBase` / `projWithNoteBaseNetNorm` is now documented as a + note-wildcard (the projection widens to all notes) — previously an + undocumented behaviour (design-review C5). The underscore-prefixed + `UpdatableSTRef` methods are documented as instance wiring, not user API. + +- Same-base sequence order documented as __construction-path dependent__: the + pairwise-union path (`fromList`/`mconcat`) and the bulk-merge path + (`sigma`/`unionsMerge`) arrange the same multiset of postings in different + orders (verified: `[3,1,2]` vs `[3,2,1]` for three same-base postings), which + `Eq`/`Binary` observe and `Double` observes through the last ULP of + `norm`/`bar`. The `Redundant` class, `sigma` and `unionsMerge` Haddocks now + warn against comparing algebras built by different routes with `==` (compare + after `compress`/`bar`, or use `MoneyDecimal`), and a characterization test + pins the current orders so any change to either path is deliberate. Path + unification is deferred to the 0.5.0.0 cleanup plan. + +- `projCredit` / `projDebit` Haddock: documented that for `Alg` they coincide + with the `Exchange` methods `decR` / `decL` respectively, and removed the + stale guidance "use this instead of decL/decR when the base contains non-Enum + elements" (it referred to long-removed `Enum`-based class defaults — and even + named the wrong counterpart). The dead commented-out `credit`/`debit` class + members in `ExBaseClass` were removed. + +- `Exchange` class Haddock corrected: the class-level docs of `decR`/`decL` were + __inverted__ relative to both the implementation and the Deguchi & Nakano + (1986, Definition 2.16) convention. `decR` extracts the __credit__ side + (R = Right = Credit, 貸方) and `decL` the __debit__ side (L = Left = Debit, + 借方) — the instance code was always correct; only the class Haddock (and thus + the rendered Hackage docs) said the opposite. The `decP`/`decM` glosses were + also reworded neutrally as the Hat-side/Not-side projections. Likewise the + `HatBaseClass` Haddock no longer equates Hat/Not with credit/debit: the side + of a posting is determined by the account division together with the Hat/Not + label (`whichSide`). + +- Module-reachability policy made explicit (audit R10): `ExchangeAlgebra.Bookkeeping`, + `ExchangeAlgebra.Simulate.Lite`, `ExchangeAlgebra.Simulate.Network` and + `ExchangeAlgebra.Simulate.Policy` are __designed to be imported directly__ and + are intentionally not re-exported from the `ExchangeAlgebra` umbrella (re-export + would collide names with the Algebra layer or with each other). This is now + stated in the umbrella module's Haddock and in the README's import-patterns + section. + +- `Simulate.Lite.specLedger` Haddock now warns that the committed-ledger role is + a model declaration conferred by the selector alone, not inferred from the + product type: with more than one `Journal` field a wrong selector type-checks + and fails silently (commits, eviction and the final projection all hit the + wrong ledger). Recommends exactly one `Journal` field per world. + +- README module overview now lists all 31 modules in seven layers and states + that `Simulate.Lite` is the canonical simulation front-end while `Simulate`'s + `Updatable` front-end is kept frozen for published examples; the + `Simulate.Lite` module header no longer claims spill policies are out of + scope. + +### Internal +- Drop `mtl` from the library dependencies (no module in `src/` imports it); + the test suite keeps it as a test-only dependency. +- `-Wall` warning cleanup (audit R9): removed unused imports\/bindings, silenced + unused-match and name-shadowing warnings (mechanical, behaviour-preserving), and + documented the remaining audited non-exhaustive patterns in place (168 → 27 + `-Wall` warnings; residual are doctest-only imports and out-of-scope categories + such as orphans\/x-partial\/type-defaults). No public API change beyond exporting + the previously-unused `balanceOf` (`ExchangeAlgebra.Write`) and `createTransfer` + (`ExchangeAlgebra.Journal.Transfer`). + +- Added a QuickCheck property suite (test dep `QuickCheck`) encoding the Definition 6 + redundant-algebra axioms (Hat involution, scalar on element, scalar distribution, + norm additivity, norm homogeneity) and derived lemmas (bar idempotent, zero + identity, associativity), plus two regression generalizations: `union` preserves + the per-base net even for zero-valued singletons (the 0.4.1.1 bug class), and + `MoneyDecimal` `fromList` per-base nets are construction-order independent. + Journal-level properties: `norm` additivity, Hat preserves the note set, and + per-(note,base) net is construction-order independent. + +- Documented the Definition 6 axioms on the `Redundant` class and `norm` (Haddock + only), cross-referencing the property suite. + +- Benchmark/CI scaffolding: `simulateEx2` agent count and horizon are now + env-configurable (`EA_LASTC`, `EA_LASTTERM`; defaults 200 / 100) for end-to-end + scale benchmarking; added a GitHub Actions CI workflow (build + test + doctest, + bench build-only). + +## 0.4.1.2 - 2026-06-11 + +### Fixed +- `incomeSummaryAccount` (both `ExchangeAlgebra.Algebra.Transfer` and + `ExchangeAlgebra.Journal.Transfer`) crashed with `Non-exhaustive patterns in + case` on a **balanced ledger** (credit == debit, i.e. zero net income). In that + case `diffRL` reports the wildcard `Side` constructor, which the + `case dc of { Credit -> …; Debit -> … }` did not handle. The fix adds a `Side` + branch that returns the input ledger unchanged (no `NetIncome` / `NetLoss` + posting is appended when net income is zero). Note that appending a `Zero` + posting is **not** a correct alternative for the Journal version, since it is + not an identity there. Covered by the new `testIncomeSummaryBalancedAlg` and + `testIncomeSummaryBalancedJournal` regression tests. + +## 0.4.1.1 - 2026-06-07 + +### Fixed +- `union` (and therefore `(.+)` / `mappend` / `fromList`) misassociated a value + with the wrong base when one operand was a **zero-valued singleton**. For + `(v1:@b1) .+ (v2:@b2)` with `isZeroValue v1`, the result was `v2:@b1` — the + surviving nonzero value relabeled onto the *zero posting's* base (symmetrically + `v1:@b2`). A zero contributes nothing, so the result must be `v2:@b2` / `v1:@b1` + (the nonzero value on its **own** base). The bug preserved `norm` (the total was + unchanged) but corrupted **per-base projection** (`proj` / `projWithBase` / + `balanceBy` / stock & profit queries): a value silently moved to a neighboring + base. It was construction-order sensitive — ledgers that build explicit + `0:@base` singletons via the raw `(:@)` constructor (e.g. sparsified input + coefficients in agent-based simulations) would, depending on accumulation order, + invent a phantom posting on an adjacent base. In the bundled simulation example + this shifted a company's reported stock by up to ~30% over 100 terms. One-line + fix in `Algebra.hs union`, covered by the new `testUnionZeroSingletonBase` test. ## 0.4.1.0 - 2026-06-06 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.4.0.0 + - exchangealgebra-0.4.1.2 ``` ```yaml @@ -43,7 +43,11 @@ - GHC 9.10 (tested with Stackage `lts-24.4`) - Cabal 3.0 or later - `Chart` / `Chart-cairo` transitively require the Cairo / Pango / Freetype system libraries - (on macOS: `brew install cairo pango`) + (on macOS: `brew install cairo pango`). If you cannot or do not want to + install them, build without the plotting module: `stack build --flag + exchangealgebra:-visualize` (Cabal flag `visualize`, default on). This drops + `ExchangeAlgebra.Simulate.Visualize` and the Chart dependencies; the bundled + `ripple*`, `sim*` and `cge` examples import that module and need the default ## How to consume this package @@ -89,45 +93,186 @@ ## Module Overview -The public modules are organised into two parallel layers. +The 35 public modules are organised into seven layers. -### Foundation layer (Algebra) +### Umbrella -|Module|Role| -|---|---| -|`ExchangeAlgebra.Algebra`|Core algebra: the `Alg` type, `HatVal` / `BaseClass`, addition `.+` / hat `.^` / bar `.-` / projection `proj`| -|`ExchangeAlgebra.Algebra.Base`|Basis classes (`BaseClass`, `HatBaseClass`, `ExBaseClass`) and basis display helpers| -|`ExchangeAlgebra.Algebra.Base.Element`|The `Element` type class (wildcard-aware basis components)| -|`ExchangeAlgebra.Algebra.Transfer`|Transfer rewriting (`TransTable`, `(.->)`, `transfer`, `finalStockTransfer`)| +The recommended entry point collects the common single-period bookkeeping API. -### Journal layer — metadata-aware basis algebra +- `ExchangeAlgebra` — re-exports `Algebra`, `Algebra.Transfer`, `Value`, and `Write`. -|Module|Role| -|---|---| -|`ExchangeAlgebra.Journal`|`Journal n v b` (journal entries carrying a `Note`), `sigmaOn`, `filterByAxis`, `projWithNote`, …| -|`ExchangeAlgebra.Journal.Transfer`|Transfer API specialised for `Journal` (thin wrappers over `Algebra.Transfer`)| +### Account vocabulary -### Simulation / IO layer +These modules define basis elements and the canonical account metadata vocabulary. -|Module|Role| -|---|---| -|`ExchangeAlgebra.Simulate`|`StateSpace`, `Updatable`, `runSimulation`, spill-to-disk, ripple-effect utilities (`rippleEffect`, `leontiefInverse`)| -|`ExchangeAlgebra.Simulate.Visualize`|Chart/Cairo based PNG rendering (see the caveats below)| -|`ExchangeAlgebra.Write`|CSV output (`writeBS`, `writePL`, `writeIOMatrix`, `writeCSV`) and binary-spill restore helpers| +- `ExchangeAlgebra.Algebra.Base.Element` — defines wildcard-aware basis components and the built-in account-title vocabulary. +- `ExchangeAlgebra.Algebra.Base.Account.Types` — defines account metadata types shared by the basis and registry. +- `ExchangeAlgebra.Algebra.Base.Account.JcciAliases` — supplies the generated JCCI 2022 account-name alias overlay. +- `ExchangeAlgebra.Algebra.Base.Account.Registry` — is the exhaustive source of canonical account classification, semantics, and descriptions. +- `ExchangeAlgebra.Algebra.Base` — defines basis classes, Hat/Not bases, account divisions, and basis display helpers. -### Umbrella entry modules +### Core algebra -|Module|Content| -|---|---| -|`ExchangeAlgebra` (top level)|Umbrella for the Algebra layer: re-exports `Algebra`, `Algebra.Transfer`, `Write`, and `Simulate`| -|`ExchangeAlgebra.Journal`|Umbrella for the Journal layer. Re-exports `Algebra.Base`, so user-defined `Element` instances are available through this import as well| +These modules implement exchange-algebra values, transformations, and selectable numeric representations. +- `ExchangeAlgebra.Algebra` — defines `Alg`, exchange-algebra operations, projections, and aggregation. +- `ExchangeAlgebra.Algebra.Internal` — the representation behind `Alg` (all constructors, cache fields, rebuild helpers); outside the PVP contract. +- `ExchangeAlgebra.Algebra.Transfer` — rewrites existing algebra balances through transfer tables and closing transfers. +- `ExchangeAlgebra.Value` — provides fast typed and exact non-negative value types for `Alg` and `Journal`. + +### Journal and simulation + +These modules attach notes to postings and run classic, Lite, network, policy-driven, and visual simulation workflows. + +- `ExchangeAlgebra.Journal` — defines metadata-bearing `Journal` values, indexed projections, and journal aggregation. +- `ExchangeAlgebra.Journal.Transfer` — specialises the algebra transfer API to `Journal`. +- `ExchangeAlgebra.Simulate` — provides the state-space engine, classic front-end, spill support, ripple utilities, and scenario execution. +- `ExchangeAlgebra.Simulate.Spill` — provides spill chunk writers, checked readers, and ledger restoration shared by simulation and reporting layers. +- `ExchangeAlgebra.Simulate.Policy` — declares retention, spill, and compaction policy for long simulations. +- `ExchangeAlgebra.Simulate.Lite` — provides the product-HKD, BSP front-end with declarative field rules and stages. +- `ExchangeAlgebra.Simulate.Network` — separates sparse trade-network topology from input coefficients and industrial flows. +- `ExchangeAlgebra.Simulate.Visualize` — renders simulation grids and time series with Chart/Cairo. + +### Which simulation API to use + +`ExchangeAlgebra.Simulate.Lite` is the canonical front-end for new simulations: a `Generic`-derived world record, term-boundary field rules, stages, and `runLite` / `runLiteWithPolicy`. `ExchangeAlgebra.Simulate` is the engine underneath it (`StateTime`, spill and restore, `runSimulation`) and also exposes the older `Updatable` / `UpdatePattern` front-end used by the `simulateEx*`, `ripple*` and `cge` examples. That older front-end is kept for reproducibility of published results and receives no new features; write new models against Lite. + +### Bookkeeping and reporting + +These modules build adjustments, validate reporting boundaries, and produce statements and output. + +- `ExchangeAlgebra.Bookkeeping` — builds period-end adjustment postings from explicit external amounts. +- `ExchangeAlgebra.Write` — formats bookkeeping reports and journals as CSV and restores binary spill files. +- `ExchangeAlgebra.Reporting.Group` — defines presentation groups and contra-account netting policy. +- `ExchangeAlgebra.TrialBalance.Balance` — the shared `AccountBalance` type and debit-then-credit netting primitives. +- `ExchangeAlgebra.TrialBalance.Validation` — reports trial-balance findings and gates reporting with explicit policies. +- `ExchangeAlgebra.Reporting.Metric` — derives typed, read-only metrics without inserting posting coordinates. +- `ExchangeAlgebra.Reporting.Presentation` — transforms validated trial balances into auditable JGAAP presentation. +- `ExchangeAlgebra.Consolidation.Worksheet` — validates consolidation adjustments and preserves worksheet provenance. + +### Conversion and assistance + +These modules convert external postings safely and expose deterministic account-selection guidance. + +- `ExchangeAlgebra.Convert` — converts pure side, account-name, and amount data to and from algebra terms. +- `ExchangeAlgebra.Convert.Csv` — reads a fixed journal CSV schema into normalized external postings. +- `ExchangeAlgebra.Accounting.PostingPolicy` — which coordinates may be posted in which processing context (`ProcessingContext`, `postingAllowedIn`). +- `ExchangeAlgebra.Convert.Checked` — validates externally generated entries before constructing journal values. +- `ExchangeAlgebra.Assist` — provides LLM-facing account metadata, suggestions, and validation explanations. +- `ExchangeAlgebra.Assist.Descriptions` — preserves the compatibility projection of canonical account descriptions. + +### Optimisation + +These modules define a common solver interface and two concrete stochastic strategies. + +- `ExchangeAlgebra.Optimize` — defines the strategy-agnostic, monadic `Solver` interface. +- `ExchangeAlgebra.Optimize.Annealing` — implements simulated annealing over arbitrary candidate types. +- `ExchangeAlgebra.Optimize.GA` — implements a real-coded genetic algorithm over numeric vectors. + +Dependencies point downwards in this list; spill writing, checked reading and ledger restoration live in `Simulate.Spill`, which `Simulate`, `Write` and `Simulate.Policy` all import (the historical `Write` → `Simulate` and `Policy` → `Write` edges are gone). + Importing both `ExchangeAlgebra` and `ExchangeAlgebra.Journal` unqualified causes name collisions on `sigma`, `fromList`, `map`, `filter`, and friends. See the recommended import patterns below. +## Choosing a value type + +The value parameter `v` in `Alg v b` / `Journal n v b` is selectable. Pick per +workload. The bare `Double` is the default; `ExchangeAlgebra.Value` adds two +`newtype` money types — `MoneyDouble` (fast, FP) and `MoneyDecimal` (exact). + +| | `Double` (default) | `MoneyDouble` (`…Value`) | `MoneyDecimal` (`…Value`) | +|---|---|---|---| +| Representation | IEEE-754 binary float | `newtype` over `Double` (identical bits) | exact non-negative base-10 decimal (wraps `Data.Decimal`) | +| Distinct money type | ✗ — a bare numeric type | ✓ — can't be silently mixed with coefficients / draws | ✓ | +| Decimal prices / ratios | approximate | approximate | **exact** | +| Tax / proration (`*`, `/`) | rounding noise | rounding noise | exact intermediates; round explicitly with `bankersRound` / `ceilingRound` | +| Construction-order independence | ✗ — addition is non-associative, so the order same-base postings are summed shifts the last-ULP of `norm` / `bar` | ✗ — identical to `Double` | ✓ — addition is exact & associative, so `norm` / `bar` / balance are identical regardless of build order | +| Determinism / auditability | not bit-reproducible across reorderings | not bit-reproducible | bit-reproducible | +| Memory per value | ~16 B | ~16 B (zero-cost wrapper) | ~40 B + indirection (~2.5×) | +| Speed | fastest | fastest (= `Double`) | slower (boxed `Integer` mantissa arithmetic) | +| Typical use | numeric methods (Leontief inverse, optimization), quick ABM | ABM where you want a *typed* money value distinct from raw `Double` | audited ledgers, bookkeeping, anywhere a total must be reproducible | + +```haskell +import ExchangeAlgebra.Value (MoneyDecimal) -- or MoneyDouble +type Ledger = Journal Term MoneyDecimal (HatBase AccountTitles) +entry = 10.5 :@ Hat: String`. If you defined your own `HatVal` instance, add + a `showValue` (how the value prints inside `Alg`'s `Show`). If you relied on + `HatVal n => RealFloat n` in a signature, add the `RealFloat` constraint + explicitly. The built-in `Double` / `NN.Double` instances are unchanged. +- **`fromList` accumulation order**: now a strict left fold. The multiset is + preserved, but if you compared `Show` / `Eq` / serialized output of a + `fromList`-built journal byte-for-byte, the same-(note,base) sequence order may + differ. Switch such ledgers to `MoneyDecimal` for order-independent results, or + compare via `norm` / `bar` / `balanceBy` rather than raw structure. +- **Abstract `Alg` / `Journal` / `TransTable`**: pattern-match `Alg` on `Zero` + and `(:@)` only and build values with `(.@)`, `(.+)`, `fromList`, `mkJournal`, + `(.|)` and `table`. Code that constructed `Liner`, `Journal` or `TransTable` + directly must import `ExchangeAlgebra.Algebra.Internal` (not covered by PVP). +- **Spill files are validated**: `readBinarySpillFile` and + `restoreJournalFromBinarySpill` now raise on a truncated, stale or gapped + file instead of merging a partial ledger; use the `...Checked` variants for an + `Either`. `Simulate.Lite` truncates its spill file when a run opens it. + +(`0.5.0.0` also includes the `union` zero-base correctness fix first shipped in +`0.4.1.1`; see the changelog.) + ## Recommended import patterns +`Alg`, `Journal` and `TransTable` are abstract in 0.5.0.0: construct them with +`(.@)`, `(.+)`, `fromList`, `mkJournal`, `(.|)` and `table`, and match `Alg` on +`Zero` / `(:@)` only. The multi-posting representation and its cache fields live +in `ExchangeAlgebra.Algebra.Internal`, which is outside the PVP contract. + ### Simple single-period bookkeeping ```haskell @@ -154,8 +299,25 @@ type or `EA.proj`, for example). **Using Journal as the unqualified umbrella and pulling the Algebra layer in as `EA` qualified is the idiomatic style for this library.** +### Modules to import directly (not re-exported by the umbrellas) + +`ExchangeAlgebra.Bookkeeping`, `ExchangeAlgebra.Simulate.Lite`, +`ExchangeAlgebra.Simulate.Network`, and `ExchangeAlgebra.Simulate.Policy` are **by design +imported directly** rather than re-exported from the `ExchangeAlgebra` umbrella. They +introduce names that would otherwise collide with the Algebra layer (or with one another), +so the package keeps them off the umbrella and expects an explicit (usually qualified) +import: + +```haskell +import ExchangeAlgebra +import qualified ExchangeAlgebra.Bookkeeping as BK +import qualified ExchangeAlgebra.Simulate.Lite as Lite +``` + ## Large-scale simulations (constant memory) +For new Lite simulations, set `spillTo` in a `LedgerPolicy` and run with `runLiteWithPolicy`. + `runSimulation` keeps the entire world state in memory for the whole run, so peak memory grows with the number of terms. For long horizons or large agent populations, use the **spill-to-disk** variants instead — they periodically write ledger chunks to disk and evict @@ -181,6 +343,16 @@ `DeleteSpilledChunk` evicts each chunk right after it is written, `NoDelete` keeps everything. - Restore spilled data with `ES.readBinarySpillFile` (binary format) or the `restoreJournalFromBinarySpill` helper. + +For policy-driven long runs, `ExchangeAlgebra.Simulate.Policy` keeps `FullAudit` as the +default to preserve the full audit trail, but a declared `LedgerPolicy` can opt into +`CompressClosedTerms` so only closed terms are compressed; `norm` / balance stay unchanged, +the in-progress term keeps its full history, and because the choice is explicit it is not +the forbidden implicit `bar` / `compress` shortcut. Pair it with `RetainRecent 2` and +`spillTo = Just ...` to keep recent terms resident while older terms are restorable from +disk; local measurements of that pattern reduced residency by about 15x. See the +`Tuning long simulations` Haddock section in `ExchangeAlgebra.Simulate.Policy` for the +`LedgerPolicy` record-syntax example. A runnable end-to-end example (multi-scenario run with binary spill, `KeepRecentTerms`, and restore) is `examples/basic/simulateEx2.hs` (the `sim2` executable). diff --git a/docs/migration-0.5-derived-metrics.md b/docs/migration-0.5-derived-metrics.md new file mode 100644 --- /dev/null +++ b/docs/migration-0.5-derived-metrics.md @@ -0,0 +1,72 @@ +# Derived metrics in 0.5.0.0 + +## Summary + +`NetIncome`, `NetLoss`, `GrossProfit`, and `OrdinaryProfit` remain +`AccountTitles` constructors in 0.5.0.0. Existing public transfer functions and +simulations actively use them as engine-generated intermediate coordinates, +and their `Enum` ordinals are part of the Word16 `Binary` encoding. Removing or +renaming them would both break source code and shift the tags of later account +titles. + +They are not canonical financial-statement lines. New reporting code should +use `ExchangeAlgebra.Reporting.Metric` and +`ExchangeAlgebra.Reporting.Presentation`: + +- `PeriodResultMetric` is one identity. Profit, loss, and break-even are value + directions (`PeriodProfit`, `PeriodLoss`, and `PeriodBreakEven`), not three + account classifications. +- `GrossProfitMetric` and `OrdinaryProfitMetric` identify presentation + subtotals without adding an `AccountTitles` coordinate. +- `CustomMetric MetricId` separates a stable identity from profile-specific + display labels. + +`IncomeSummary` is different. It remains a `ClosingOnly` bookkeeping device +that may appear in closing entries and is never a statement line. + +## Legacy transfer boundary + +The following functions remain for compatibility: + +- `incomeSummaryAccount` and `netIncomeTransfer`. +- `grossProfitTransfer`, `ordinaryProfitTransfer`, and + `retainedEarningTransfer`. +- Their `ExchangeAlgebra.Journal.Transfer` counterparts. + +The names predate the JCCI vocabulary. In particular, +`grossProfitTransfer` uses a fixed SNA/simulation list and does not include +`SalesCost` or `MerchandiseInventory`. `ordinaryProfitTransfer` likewise does +not cover the full JCCI chart. They must not be used as JGAAP gross-profit or +ordinary-profit definitions. + +The output of `incomeSummaryAccount` contains a `NetIncome` or `NetLoss` +balancing coordinate. It is an intermediate closing state and cannot be sent +directly to financial-statement presentation. Finish the legacy closing +pipeline, or derive the result from the before-closing trial balance with +`periodResultOf`. + +## Checked and unchecked input + +`EngineGeneratedOnly` is enforced by `ExchangeAlgebra.Convert.Checked`. +Use its `OrdinaryJournal` context for external or LLM-originated postings. + +The legacy unchecked paths, including `ExchangeAlgebra.Convert.Csv`, +`journalFromSides`, and direct algebra construction, intentionally remain +unchecked in 0.5.0.0. They can still construct the four legacy coordinates. +This is compatibility behavior, not authorization for ordinary posting. + +## Serialization + +The retained ordinals and Word16 big-endian encodings are: + +| Constructor | Ordinal | Bytes | +|---|---:|---:| +| `NetIncome` | 49 | `0031` | +| `GrossProfit` | 54 | `0036` | +| `OrdinaryProfit` | 55 | `0037` | +| `NetLoss` | 64 | `0040` | +| `IncomeSummary` | 216 | `00d8` | + +The test suite pins these values directly. Physical removal of the four legacy +derived coordinates is deferred to a separately planned major-version +migration, no earlier than 0.6.0.0. diff --git a/exchangealgebra.cabal b/exchangealgebra.cabal --- a/exchangealgebra.cabal +++ b/exchangealgebra.cabal @@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.39.1. +-- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack --- --- hash: d3a05562cbe70211374afd6c39a40fd7f8ff7e7b23b90f74716875f339171ea4 name: exchangealgebra -version: 0.4.1.2 +version: 0.5.0.0 synopsis: Exchange Algebra for bookkeeping and economic simulation description: Please see the README on GitHub at category: Accounting, Finance, Math @@ -22,30 +20,60 @@ extra-source-files: README.md ChangeLog.md + docs/migration-0.5-derived-metrics.md source-repository head type: git location: https://github.com/yakagika/ExchangeAlgebra +flag visualize + description: Build ExchangeAlgebra.Simulate.Visualize, which needs Chart, Chart-cairo and a cairo / pango toolchain. Disable with --flag exchangealgebra:-visualize to use the accounting algebra without plotting. + manual: True + default: True + library exposed-modules: ExchangeAlgebra + ExchangeAlgebra.Accounting.PostingPolicy ExchangeAlgebra.Algebra ExchangeAlgebra.Algebra.Base + ExchangeAlgebra.Algebra.Base.Account.JcciAliases + ExchangeAlgebra.Algebra.Base.Account.Registry + ExchangeAlgebra.Algebra.Base.Account.Types ExchangeAlgebra.Algebra.Base.Element + ExchangeAlgebra.Algebra.Internal ExchangeAlgebra.Algebra.Transfer + ExchangeAlgebra.Assist + ExchangeAlgebra.Assist.Descriptions + ExchangeAlgebra.Bookkeeping + ExchangeAlgebra.Consolidation.Worksheet + ExchangeAlgebra.Convert + ExchangeAlgebra.Convert.Checked + ExchangeAlgebra.Convert.Csv ExchangeAlgebra.Journal ExchangeAlgebra.Journal.Transfer + ExchangeAlgebra.Optimize + ExchangeAlgebra.Optimize.Annealing + ExchangeAlgebra.Optimize.GA + ExchangeAlgebra.Reporting.Group + ExchangeAlgebra.Reporting.Metric + ExchangeAlgebra.Reporting.Presentation ExchangeAlgebra.Simulate - ExchangeAlgebra.Simulate.Visualize + ExchangeAlgebra.Simulate.Lite + ExchangeAlgebra.Simulate.Network + ExchangeAlgebra.Simulate.Policy + ExchangeAlgebra.Simulate.Spill + ExchangeAlgebra.TrialBalance.Balance + ExchangeAlgebra.TrialBalance.Validation + ExchangeAlgebra.Value ExchangeAlgebra.Write other-modules: Paths_exchangealgebra hs-source-dirs: src + ghc-options: -feager-blackholing build-depends: - Chart ==1.9.* - , Chart-cairo ==1.9.* + Decimal ==0.5.* , array >=0.5.5 && <0.6 , async ==2.2.* , base >=4.17 && <5 @@ -54,7 +82,6 @@ , containers >=0.6 && <0.8 , deepseq >=1.4 && <1.6 , hashable >=1.4 && <1.6 - , mtl ==2.3.* , non-negative >=0.1.2 && <0.2 , numeric-prelude >=0.4.4 && <0.5 , parallel ==3.2.* @@ -66,16 +93,22 @@ , unordered-containers >=0.2.19 && <0.3 , vector ==0.13.* default-language: Haskell2010 + if flag(visualize) + exposed-modules: + ExchangeAlgebra.Simulate.Visualize + build-depends: + Chart ==1.9.* + , Chart-cairo ==1.9.* + else test-suite ExchangeAlgebra-doctest type: exitcode-stdio-1.0 main-is: test/doctests.hs other-modules: Paths_exchangealgebra - ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-Wl,-no_warn_duplicate_libraries + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - Chart ==1.9.* - , Chart-cairo ==1.9.* + Decimal ==0.5.* , array >=0.5.5 && <0.6 , async ==2.2.* , base >=4.17 && <5 @@ -86,7 +119,6 @@ , doctest , exchangealgebra , hashable >=1.4 && <1.6 - , mtl ==2.3.* , non-negative >=0.1.2 && <0.2 , numeric-prelude >=0.4.4 && <0.5 , parallel ==3.2.* @@ -98,6 +130,8 @@ , unordered-containers >=0.2.19 && <0.3 , vector ==0.13.* default-language: Haskell2010 + if os(darwin) + ghc-options: -optl-Wl,-no_warn_duplicate_libraries test-suite ExchangeAlgebra-test type: exitcode-stdio-1.0 @@ -106,10 +140,10 @@ Paths_exchangealgebra hs-source-dirs: test - ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-Wl,-no_warn_duplicate_libraries + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - Chart ==1.9.* - , Chart-cairo ==1.9.* + Decimal ==0.5.* + , QuickCheck >=2.14 && <3 , array >=0.5.5 && <0.6 , async ==2.2.* , base >=4.17 && <5 @@ -132,3 +166,5 @@ , unordered-containers >=0.2.19 && <0.3 , vector ==0.13.* default-language: Haskell2010 + if os(darwin) + ghc-options: -optl-Wl,-no_warn_duplicate_libraries diff --git a/src/ExchangeAlgebra.hs b/src/ExchangeAlgebra.hs --- a/src/ExchangeAlgebra.hs +++ b/src/ExchangeAlgebra.hs @@ -20,7 +20,7 @@ This top-level module is the Algebra-layer umbrella: it re-exports "ExchangeAlgebra.Algebra", "ExchangeAlgebra.Algebra.Transfer", - "ExchangeAlgebra.Write", and "ExchangeAlgebra.Simulate". It is the + "ExchangeAlgebra.Write", and "ExchangeAlgebra.Value". It is the recommended entry point for simple single-period bookkeeping: > import ExchangeAlgebra @@ -29,6 +29,18 @@ > entry :: Alg Double (HatBase AccountTitles) > entry = 100 :@ Hat :< Cash .+ 100 :@ Not :< Sales + == Choosing the value type (@v@ in @Alg v b@) + + * 'Prelude.Double' — fast IEEE-754; fine for simulations and quick work. + * 'ExchangeAlgebra.Value.MoneyDouble' — same speed, but a dedicated money + newtype so a ledger value cannot be confused with a raw coefficient. + * t'ExchangeAlgebra.Value.MoneyDecimal' — exact decimal; construction-order + independent totals. Use for audited\/deterministic ledgers. + * @Number.NonNegative.Double@ (@NN.Double@) — __deprecated__ since + 0.5.0.0: its @(-)@ errors on negative intermediates and the instance + will be removed in 0.6. Migrate to 'ExchangeAlgebra.Value.MoneyDouble' + (or bare 'Prelude.Double'). + For multi-period simulation or metadata-aware journals (notes, axes), switch to the Journal layer. The two umbrellas export overlapping names (@sigma@, @fromList@, @map@, @filter@, …), so Journal-centric @@ -39,6 +51,43 @@ > import qualified ExchangeAlgebra.Journal as EJ > import qualified ExchangeAlgebra.Journal.Transfer as EJT + == Modules to import directly (not re-exported here) + + This umbrella intentionally re-exports only the Algebra-layer modules + listed above. The following modules are __designed to be imported + directly__ and are deliberately /not/ re-exported from @ExchangeAlgebra@, + because they introduce names that would collide with the Algebra layer + (or with each other) and are better used under a qualified import: + + * "ExchangeAlgebra.Bookkeeping" — double-entry adjusting\/closing entries. + * "ExchangeAlgebra.Consolidation.Worksheet" — atomic consolidation + adjustments, source provenance, and cross-statement linkage validation. + * "ExchangeAlgebra.TrialBalance.Validation" — trial-balance findings, + reclassification instructions, and the policy-controlled reporting gate. + * "ExchangeAlgebra.Reporting.Metric" — typed, read-only derived metrics + that do not add account-basis coordinates. + * "ExchangeAlgebra.Reporting.Group" — reusable gross, deduction, and net + presentation groups for contra accounts. + * "ExchangeAlgebra.Reporting.Presentation" — context-sensitive JGAAP + transformation from validated trial balances to financial statements. + * "ExchangeAlgebra.Simulate" — the classic simulation engine. /(Removed + from this umbrella in 0.5.0.0: it exports very generic names — + @copy@, @modify@, @update@, @initialize@, @normal@, … — that polluted + the bookkeeping namespace.)/ + * "ExchangeAlgebra.Simulate.Lite" — the lightweight simulation front-end. + * "ExchangeAlgebra.Simulate.Network" — trade-network generators. + * "ExchangeAlgebra.Simulate.Policy" — ledger\/spill policy configuration. + * "ExchangeAlgebra.Optimize" — pluggable optimization solvers + ("ExchangeAlgebra.Optimize.Annealing" \/ "ExchangeAlgebra.Optimize.GA"); + generic names (@optimize@, @Config@, ...) best used qualified. + + Import them explicitly when you need them, e.g.: + + > import ExchangeAlgebra + > import qualified ExchangeAlgebra.Bookkeeping as BK + > import ExchangeAlgebra.Simulate -- simulation engine + > import qualified ExchangeAlgebra.Simulate.Lite as Lite + == Full examples Runnable examples (elementary bookkeeping, ripple-effect simulations, @@ -56,9 +105,9 @@ ( module ExchangeAlgebra.Algebra , module ExchangeAlgebra.Algebra.Transfer , module ExchangeAlgebra.Write - , module ExchangeAlgebra.Simulate ) where + , module ExchangeAlgebra.Value ) where import ExchangeAlgebra.Algebra import ExchangeAlgebra.Algebra.Transfer import ExchangeAlgebra.Write -import ExchangeAlgebra.Simulate +import ExchangeAlgebra.Value -- MoneyDouble / MoneyDecimal value types diff --git a/src/ExchangeAlgebra/Accounting/PostingPolicy.hs b/src/ExchangeAlgebra/Accounting/PostingPolicy.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Accounting/PostingPolicy.hs @@ -0,0 +1,77 @@ +{-# OPTIONS_GHC -Wincomplete-patterns -Werror=incomplete-patterns #-} + +{- | +Module : ExchangeAlgebra.Accounting.PostingPolicy +Description : Accounting-domain posting authority for processing contexts. + +Accounting-domain posting authority: which coordinates may be posted in which +processing context. Input adapters ("ExchangeAlgebra.Convert.Checked") and the +consolidation worksheet ("ExchangeAlgebra.Consolidation.Worksheet") consume +this; it does not depend on either. + +The policy has two inputs. The 'PostingCapability' of an account title is +canonical registry metadata ('accountSemantics'); the 'ProcessingContext' names +the boundary at which a posting is admitted. 'postingAllowedIn' is the closed +gate that relates the two, and 'postingCapabilityFor' is the total lookup that +maps the wildcard 'AccountTitle' (outside the metadata domain) to 'NotPostable'. +-} +module ExchangeAlgebra.Accounting.PostingPolicy + ( ProcessingContext(..) + , postingAllowedIn + , postingCapabilityFor + ) where + +import ExchangeAlgebra.Algebra.Base (AccountTitles(..)) +import ExchangeAlgebra.Algebra.Base.Account.Registry + ( AccountSemantics(asemPostingCapability) + , accountSemantics + ) +import ExchangeAlgebra.Algebra.Base.Account.Types (PostingCapability(..)) + +-- | Processing boundary at which generated postings are admitted. +-- +-- Each non-ordinary context adds exactly one capability to +-- 'OrdinaryPosting'. This keeps closing, consolidation, and engine authority +-- separate instead of introducing one privileged "internal" bypass. +data ProcessingContext + = OrdinaryJournal + | ClosingProcess + | ConsolidationWorksheet + | EngineComputation + deriving (Show, Eq) + +-- | Whether a capability is admitted at a processing boundary. +postingAllowedIn :: ProcessingContext -> PostingCapability -> Bool +postingAllowedIn OrdinaryJournal capability = case capability of + OrdinaryPosting -> True + ClosingOnly -> False + ConsolidationOnly -> False + EngineGeneratedOnly -> False + NotPostable -> False +postingAllowedIn ClosingProcess capability = case capability of + OrdinaryPosting -> True + ClosingOnly -> True + ConsolidationOnly -> False + EngineGeneratedOnly -> False + NotPostable -> False +postingAllowedIn ConsolidationWorksheet capability = case capability of + OrdinaryPosting -> True + ClosingOnly -> False + ConsolidationOnly -> True + EngineGeneratedOnly -> False + NotPostable -> False +postingAllowedIn EngineComputation capability = case capability of + OrdinaryPosting -> True + ClosingOnly -> False + ConsolidationOnly -> False + EngineGeneratedOnly -> True + NotPostable -> False + +-- | Posting capability of an account title, total over 'AccountTitles'. +-- +-- Concrete titles report their registry capability +-- ('asemPostingCapability'); the wildcard 'AccountTitle' has no registry +-- semantics and is therefore 'NotPostable'. +postingCapabilityFor :: AccountTitles -> PostingCapability +postingCapabilityFor title = + maybe NotPostable asemPostingCapability (accountSemantics title) diff --git a/src/ExchangeAlgebra/Algebra.hs b/src/ExchangeAlgebra/Algebra.hs --- a/src/ExchangeAlgebra/Algebra.hs +++ b/src/ExchangeAlgebra/Algebra.hs @@ -1,1431 +1,78 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - -{- | - Module : ExchangeAlgebra.Algebra - Copyright : (c) Kaya Akagi. 2018-2026 - Maintainer : yakagika@icloud.com - - Released under the OWL license - - Package for Exchange Algebra defined by Hiroshi Deguchi. - - Exchange Algebra is an algebraic description of bookkeeping system. - Details are below. - - - - - --} - - -module ExchangeAlgebra.Algebra - ( module ExchangeAlgebra.Algebra.Base - , Nearly(..) - , isNearlyNum - , nearlyEqScaled - , Redundant(..) - , Exchange(..) - , HatVal(..) - , Pair(..) - , Alg(..) - , isZero - , (.@) - , (<@) - , vals - , bases - , fromList - , toList - , foldEntries - , sigma - , sigma2When - , sigmaFromMap - , toASCList - , map - , filter - , proj - , projCredit - , projDebit - , projByAccountTitle - , projNorm - , balanceBy - , foldEntriesToMap - , projCurrentAssets - , projFixedAssets - , projDeferredAssets - , projCurrentLiability - , projFixedLiability - , projCapitalStock - , rounding - , unionsMerge)where - -import ExchangeAlgebra.Algebra.Base - -import Debug.Trace -import qualified Data.Text as T -import Data.Text (Text) -import qualified Data.List as L (foldl', map, length, elem,sort,sortOn,filter, or, and,any, sum, concat) -import Prelude hiding (map, head, filter,tail, traverse, mapM) -import qualified Data.Time as Time -import Data.Time -import qualified Data.HashMap.Strict as Map -import qualified Data.IntMap.Strict as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.Map.Strict as M -import qualified Data.Foldable as Foldable (foldMap,foldl',foldr,toList) -import qualified Data.Sequence as Seq -import Data.Sequence (Seq) -import qualified Data.Maybe as Maybe -import qualified Number.NonNegative as NN -- Non-negative real numbers -import Numeric.NonNegative.Class (C) -import Algebra.Additive (C) -import qualified Data.Scientific as D (Scientific, fromFloatDigits, formatScientific, FPFormat(..)) -import Control.DeepSeq -import GHC.Stack (HasCallStack, callStack, prettyCallStack) -import Data.Hashable -import qualified Data.Binary as Binary - ------------------------------------------------------------------- --- * Approximate equality ------------------------------------------------------------------- - --- | Type class providing approximate equality for numeric values. --- Performs equality comparison with tolerance for floating-point rounding errors. -class (Eq a, Ord a) => Nearly a where - -- | @isNearly x y t@ : Returns True if the difference between x and y is within the tolerance t. - -- Complexity: O(1) - isNearly :: a -> a -> a -> Bool - -instance Nearly Int where - {-# INLINE isNearly #-} - isNearly = isNearlyNum - -instance Nearly Integer where - {-# INLINE isNearly #-} - isNearly = isNearlyNum - -instance Nearly Float where - {-# INLINE isNearly #-} - isNearly = isNearlyNum - -instance Nearly Double where - {-# INLINE isNearly #-} - isNearly = isNearlyNum - -instance Nearly NN.Double where - {-# INLINE isNearly #-} - isNearly = isNearlyNum - -{-# INLINE isNearlyNum #-} --- | Complexity: O(1) --- Assumes primitive numeric operations and comparisons are constant time. --- --- NOTE: this is an /absolute/-tolerance test (@|x - y| <= |t|@); it does not --- scale with magnitude. For large values, rounding error easily exceeds a small --- fixed @t@, while for small values it can swallow a real residual. Internal --- accounting reconciliation uses 'nearlyEqScaled' instead. The final guard --- returns 'False' (was: 'error') when a NaN makes every ordered comparison fail, --- so a non-finite input can no longer crash the check. -isNearlyNum :: (Show a, Num a, Ord a) => a -> a -> a -> Bool -isNearlyNum x y t - | x == y = True - | x > y = abs (x - y) <= abs t - | x < y = abs (y - x) <= abs t - | otherwise = False -- NaN: not nearly-equal to anything - -{-# INLINE nearlyEqScaled #-} --- | Scale-aware approximate equality for accounting reconciliation: --- --- @|x - y| <= atol + rtol * max |x| |y|@, with @atol = 1e-13@, @rtol = 1e-12@. --- --- The absolute floor @atol@ handles values near zero; the relative term @rtol@ --- lets the threshold track magnitude, so the test stays meaningful for large --- balances (where a fixed @1e-13@ was far too strict and retained pure rounding --- noise as a spurious residual). Returns 'False' if either argument is a --- non-finite error value (NaN/Inf), so error values never read as nearly equal. --- --- Complexity: O(1) -nearlyEqScaled :: (HatVal n) => n -> n -> Bool -nearlyEqScaled x y - | isErrorValue x || isErrorValue y = False - | otherwise = abs (x - y) <= atol + rtol * max (abs x) (abs y) - where - atol = 1e-13 - rtol = 1e-12 - ------------------------------------------------------------- --- * Algebra ------------------------------------------------------------- ------------------------------------------------------------------- --- ** Definition of Redundancy (subclassing this makes a redundant algebra) ------------------------------------------------------------------- - --- | Type class for Redundant Algebra. --- Provides fundamental exchange algebra operations: hat, bar, norm, scalar product, and compress. --- --- Redundant ⊃ Exchange --- --- hat calculation --- >>> (.^) (10:@Not:>> x = 10:@Not:>> y = 5:@Hat:>> (.-) $ x .+ y --- 5.00:@Not:>> norm $ 10:@Not:>> (.*) 5 $ 10:@Not:>> compress $ 10:@Not: Redundant a n b where - -- | Hat operation. Flips Hat/Not on all elements. - -- Complexity: O(1) for singleton, O(n) for Liner (n is the number of base keys) - (.^) :: a n b -> a n b - - -- | Bar operation. Cancels Hat/Not on the same base and retains only the difference. - -- Complexity: O(n) (n is the number of base keys) - (.-) :: a n b -> a n b - - -- | Alias for bar operation. Identical to @(.-)@. - bar :: a n b -> a n b - bar = (.-) - - -- | Aggregates values on the same base. Sums while preserving the Hat/Not distinction. - -- Complexity: O(n) (n is the number of base keys) - compress :: a n b -> a n b - - -- | Addition of algebra elements. Alias for the Monoid @<>@ operation. - -- Complexity: O(union cost) - (.+) :: a n b -> a n b -> a n b - - -- | Scalar product. Multiplies all element values by a scalar. - -- Complexity: O(1) for singleton, O(n) for Liner - (.*) :: n -> a n b -> a n b - - -- | Norm. Returns the sum of all element values. - -- Complexity: O(n) (n is the number of base keys) - norm :: a n b -> n - - -- | Addition in an Applicative context. - -- Complexity: O(union cost) - {-# INLINE (<+) #-} - (<+) :: (Applicative f) => f (a n b) -> f (a n b) -> f (a n b) - (<+) x y = (.+) <$> x <*> y - - -infixr 7 .^ -infixr 2 .- -infixr 3 .+ -infixr 3 <+ - ------------------------------------------------------------- --- ** Definition of Exchange Algebra ------------------------------------------------------------- - --- | Type class for Exchange Algebra. In addition to Redundant Algebra, provides --- debit(R)/credit(L) decomposition, stock increase(P)/decrease(M) decomposition, and balance checking. -class (Redundant a n b ) => Exchange a n b where - -- | Extracts only the debit side elements. Complexity: O(s) - decR :: a n b -> a n b - -- | Extracts only the credit side elements. Complexity: O(s) - decL :: a n b -> a n b - -- | Extracts only the Hat (stock increase) side elements. Complexity: O(s) - decP :: a n b -> a n b - -- | Extracts only the Not (stock decrease) side elements. Complexity: O(s) - decM :: a n b -> a n b - -- | Checks whether the norms of debit and credit sides are equal. Complexity: O(s) - balance :: a n b -> Bool - -- | Returns the debit-credit difference as a (Side, difference) pair. Complexity: O(s) - diffRL :: a n b -> (Side, n) - - ------------------------------------------------------------------- --- * Algebra ------------------------------------------------------------------- - --- | Type class for algebra element values. --- Provides zero-value and error-value predicates. --- Instances are defined for @Double@ and @NN.Double@ (non-negative reals). -class ( Show n - , Ord n - , Eq n - , Nearly n - , Fractional n - , RealFloat n - , Num n) => HatVal n where - - -- | Zero value. Complexity: O(1) - zeroValue :: n - - -- | Tests whether the value is zero. Complexity: O(1) - isZeroValue :: n -> Bool - isZeroValue x - | zeroValue == x = True - | otherwise = False - - -- | Tests whether the value is an error value (NaN, Infinity, etc.). Complexity: O(1) - isErrorValue :: n -> Bool - - -instance RealFloat NN.Double where - floatRadix = floatRadix . NN.toNumber - floatDigits = floatDigits . NN.toNumber - floatRange = floatRange . NN.toNumber - decodeFloat = decodeFloat . NN.toNumber - encodeFloat m e = NN.fromNumber (encodeFloat m e) - exponent = exponent . NN.toNumber - significand = NN.fromNumber . significand . NN.toNumber - scaleFloat n = NN.fromNumber . scaleFloat n . NN.toNumber - isNaN = isNaN . NN.toNumber - isInfinite = isInfinite . NN.toNumber - isDenormalized = isDenormalized . NN.toNumber - isNegativeZero = isNegativeZero . NN.toNumber - isIEEE = isIEEE . NN.toNumber - -instance HatVal NN.Double where - {-# INLINE zeroValue #-} - zeroValue = 0 - {-# INLINE isErrorValue #-} - isErrorValue x = isNaN (NN.toNumber x) - || isInfinite (NN.toNumber x) - -instance HatVal Prelude.Double where - {-# INLINE zeroValue #-} - zeroValue = 0 - - {-# INLINE isErrorValue #-} - isErrorValue x = isNaN x - || isInfinite x - || x < 0 - -data Pair v where - Pair :: {_hatSide :: !(Seq v) - ,_notSide :: !(Seq v)} -> Pair v - deriving (Eq) - -instance (Binary.Binary v) => Binary.Binary (Pair v) where - {-# INLINABLE put #-} - {-# INLINABLE get #-} - put (Pair hs ns) = do - Binary.put (Seq.length hs :: Int) - Foldable.foldr (\x k -> Binary.put x >> k) (pure ()) hs - Binary.put (Seq.length ns :: Int) - Foldable.foldr (\x k -> Binary.put x >> k) (pure ()) ns - get = do - hsLen <- Binary.get :: Binary.Get Int - hs <- go hsLen Seq.empty - nsLen <- Binary.get :: Binary.Get Int - ns <- go nsLen Seq.empty - pure (Pair hs ns) - where - go :: Binary.Binary a => Int -> Seq a -> Binary.Get (Seq a) - go n !acc - | n <= 0 = pure acc - | otherwise = do - x <- Binary.get - go (n - 1) (acc Seq.|> x) - - -instance (HatVal v) => Ord (Pair v) where - {-# INLINE compare #-} - compare (Pair hs1 ns1) (Pair hs2 ns2) = compare ((sum hs1) - (sum ns1)) ((sum hs2) - (sum ns2)) - - (<) x y | compare x y == LT = True - | otherwise = False - - (>) x y | compare x y == GT = True - | otherwise = False - - (<=) x y | compare x y == LT = True - | compare x y == EQ = True - | otherwise = False - - (>=) x y | compare x y == GT = True - | compare x y == EQ = True - | otherwise = False - - max x y | x >= y = x - | otherwise = y - - min x y | x <= y = x - | otherwise = y - -{-# INLINE nullPair #-} --- | Complexity: O(1) -nullPair :: Pair v -nullPair = Pair Seq.empty Seq.empty - -{-# INLINE isNullPair #-} --- | Complexity: O(1) -isNullPair :: Pair v -> Bool -isNullPair (Pair hs ns) = Seq.null hs && Seq.null ns - -{-# INLINE pairAppend #-} --- | Complexity: O(log(min(h1,h2)) + log(min(n1,n2))) --- where h1/h2 and n1/n2 are the lengths of the appended 'Seq's on each side. -pairAppend :: Pair v -> Pair v -> Pair v -pairAppend (Pair x1 y1) (Pair x2 y2) = - let !hs = x1 Seq.>< x2 - !ns = y1 Seq.>< y2 - in Pair hs ns - --- | Algebra element. An element of exchange algebra consisting of a value-base pair. --- Zero is the zero element, @(:@)@ is a singleton, and Liner is a HashMap-based multi-element representation. -data Alg v b where - Zero :: Alg v b - (:@) :: {_val :: !v, _hatBase :: !b} -> Alg v b - Liner :: { _realg :: !(Map.HashMap (BasePart b) (Pair v)) - , _axisPosting :: ~(IntMap.IntMap (Map.HashMap AxisKey IntSet.IntSet)) - , _bpToId :: ~(Map.HashMap (BasePart b) Int) - , _idToBp :: ~(IntMap.IntMap (BasePart b)) - , _nextBpId :: ~Int - , _allBpIds :: ~IntSet.IntSet - } -> Alg v b - -instance ( HatBaseClass b - , Binary.Binary v - , Binary.Binary b - , Binary.Binary (BasePart b) - ) => Binary.Binary (Alg v b) where - {-# INLINABLE put #-} - {-# INLINABLE get #-} - put Zero = Binary.put (0 :: Int) - put (v :@ b) = do - Binary.put (1 :: Int) - Binary.put v - Binary.put b - put (Liner m _ _ _ _ _) = do - Binary.put (2 :: Int) - Binary.put (Map.size m :: Int) - Map.foldrWithKey - (\bp p k -> Binary.put bp >> Binary.put p >> k) - (pure ()) - m - - get = do - tag <- Binary.get - case (tag :: Int) of - 0 -> pure Zero - 1 -> (:@) <$> Binary.get <*> Binary.get - 2 -> do - n <- Binary.get :: Binary.Get Int - linerFromMap <$> go n Map.empty - _ -> fail ("Binary decode failure for Alg: unknown tag " ++ show tag) - where - go n !acc - | n <= 0 = pure acc - | otherwise = do - bp <- Binary.get - p <- Binary.get - go (n - 1) (Map.insert bp p acc) - -type AxisPosting = IntMap.IntMap (Map.HashMap AxisKey IntSet.IntSet) - -{-# INLINE emptyAxisPosting #-} --- | Complexity: O(1) -emptyAxisPosting :: AxisPosting -emptyAxisPosting = IntMap.empty - -{-# INLINE insertAxisPosting #-} --- | Complexity: O(d * (hash-insert + intset-insert)) --- In practice this is near O(d), where d is the number of axes in the base part. -insertAxisPosting :: [AxisKey] -> Int -> AxisPosting -> AxisPosting -insertAxisPosting !keys !bpId !idx = - snd $ L.foldl' step (0 :: Int, idx) keys - where - step (!axis, !acc) !k = - let !axisMap = IntMap.findWithDefault Map.empty axis acc - !ids0 = Map.lookupDefault IntSet.empty k axisMap - !ids1 = IntSet.insert bpId ids0 - !axisMap' = Map.insert k ids1 axisMap - !acc' = IntMap.insert axis axisMap' acc - in (axis + 1, acc') - -{-# INLINE queryAxisPosting #-} --- | Complexity: O(d + intersection cost) --- d is the number of axes; intersections are performed in ascending set-size order. -queryAxisPosting :: [AxisKey] -> AxisPosting -> IntSet.IntSet -> IntSet.IntSet -queryAxisPosting !keys !idx !allIds = - case matchedSets of - Left () -> IntSet.empty - Right [] -> allIds - Right xs -> - let !(x:rest) = L.sortOn IntSet.size xs - in L.foldl' IntSet.intersection x rest - where - matchedSets = - L.foldl' collect (Right []) (zip [0 :: Int ..] keys) - - collect (Left ()) _ = Left () - collect (Right acc) (!axis, !k) - | axisIsWildcard k = Right acc - | otherwise = - case IntMap.lookup axis idx of - Nothing -> Left () - Just axisMap -> case Map.lookup k axisMap of - Nothing -> Left () - Just ids -> Right (ids : acc) - -{-# INLINE linerFromMap #-} --- | Complexity: O(n * d * (hash-insert + intset-insert)) --- n is the number of distinct base keys in the map. -linerFromMap :: (HatBaseClass b) - => Map.HashMap (BasePart b) (Pair v) - -> Alg v b -linerFromMap m = Liner m idx bpToId idToBp nextBpId allIds - where - ~(idx, bpToId, idToBp, nextBpId, allIds) = - Map.foldlWithKey' - (\(!idxAcc, !bpToIdAcc, !idToBpAcc, !nextId, !allIdsAcc) bp _ -> - let !bpId = nextId - !idx' = insertAxisPosting (toAxisKeys bp) bpId idxAcc - !bpToId' = Map.insert bp bpId bpToIdAcc - !idToBp' = IntMap.insert bpId bp idToBpAcc - !allIds' = IntSet.insert bpId allIdsAcc - in (idx', bpToId', idToBp', bpId + 1, allIds')) - (emptyAxisPosting, Map.empty, IntMap.empty, 0, IntSet.empty) - m - --- | Tests whether the algebra element is zero (empty). --- --- Complexity: O(1) -isZero :: Alg v b -> Bool -isZero Zero = True -isZero _ = False - -{-# INLINE singleton #-} --- | Complexity: O(1) -singleton :: (HatVal v, HatBaseClass b) => v -> b -> Alg v b -singleton v b | isZeroValue v = Zero - | isErrorValue v = error $ "errorValue at (.@) val: " - ++ show v - ++ show ":@" - ++ show b - | otherwise = v :@ b - -{-# INLINE (.@) #-} --- | Smart constructor that builds an algebra element from a value and a base. --- Returns Zero for zero values, and throws an exception for error values. --- --- Complexity: O(1) -(.@) :: (HatVal n, HatBaseClass b) => n -> b -> Alg n b -(.@) v b = singleton v b - --- | Constructs an algebra element in an Applicative context. Lifted version of @(.@)@. --- --- Complexity: O(1) + Applicative effects -(<@) :: (HatVal n, Applicative f, HatBaseClass b) - => f n -> b -> f (Alg n b) -(<@) v b = (.@) <$> v <*> (pure b) - - -infixr 6 :@ -infixr 6 .@ -infixr 6 <@ - --- | Complexity: O(digits(v)) --- Formatting cost is proportional to the textual precision of the number. -showV :: (HatVal v) => v -> String -showV v = D.formatScientific D.Generic (Just 2) (D.fromFloatDigits v) - -instance (HatVal v, HatBaseClass b) => Eq (Alg v b) where - (==) Zero Zero = True - (==) Zero _ = False - (==) _ Zero = False - (==) (v1:@b1) (v2:@b2) = (v1 == v2) && (b1 == b2) - (==) (Liner m1 _ _ _ _ _) (Liner m2 _ _ _ _ _) = m1 == m2 - (==) _ _ = False - (/=) x y = not (x == y) - -instance (HatVal v, HatBaseClass b) => Ord (Alg v b) where - {-# INLINE compare #-} - compare Zero Zero = EQ - compare Zero _ = LT - compare _ Zero = GT - - compare (v:@b) (Liner _ _ _ _ _ _) = LT - compare (Liner _ _ _ _ _ _) (v:@b) = GT - compare (v1:@b1) (v2:@b2) - | b1 == b2 = compare v1 v2 - | b1 > b2 = GT - | b1 < b2 = LT - - compare (Liner m1 _ _ _ _ _) (Liner m2 _ _ _ _ _) = compare m1 m2 - - (<) x y | compare x y == LT = True - | otherwise = False - - (>) x y | compare x y == GT = True - | otherwise = False - - (<=) x y | compare x y == LT = True - | compare x y == EQ = True - | otherwise = False - - (>=) x y | compare x y == GT = True - | compare x y == EQ = True - | otherwise = False - - max x y | x >= y = x - | otherwise = y - - min x y | x <= y = x - | otherwise = y - -instance (HatVal v, HatBaseClass b) => Show (Alg v b) where - show Zero = "0" - show (v:@b) = (showV v) ++ ":@" ++ show b - show xs = let ls = toASCList xs - in go ls - where - go [] = "0" - go [y] = show y - go (y:ys) = show y ++ " .+ " ++ go ys - - -instance NFData (Alg v b) where - rnf Zero = Zero `seq` () - rnf (v:@b) = v `seq` b `seq` () - rnf (Liner m _ _ _ _ _) = Map.foldrWithKey (\k v acc -> k `seq` v `seq` acc) () m ------------------------------------------------------------------- --- Semigroup ------------------------------------------------------------------- - -instance (HatVal n, HatBaseClass b) => Semigroup (Alg n b) where - {-# INLINE (<>) #-} - -- | Associative law ;convert to right join - (<>) = union - - - --- | union two trees --- --- >>> type Test = Alg NN.Double (HatBase CountUnit) --- >>> x = 1:@Hat:>> y = 2:@Hat:>> union x y --- 1.00:@Hat: Alg n b -> Alg n b -> Alg n b -union Zero x = x -union x Zero = x --- singletons --- NOTE: a zero-valued singleton contributes nothing, so the result must keep the --- /nonzero/ value on its OWN base. Earlier code returned @v2:@b1@ / @v1:@b2@, --- relabeling the surviving value onto the zero posting's base — this preserved --- 'norm' but silently moved the value to the wrong base, corrupting per-base --- projection and making construction order observable (raw @(:@)@ on a sparsified --- zero coefficient builds an explicit @0:@base@ singleton). Keep @v2:@b2@ / @v1:@b1@. -union (v1:@b1) (v2:@b2) - | isZeroValue v1 = case isZeroValue v2 of - True -> Zero - False -> v2:@b2 - | isZeroValue v2 = v1:@b1 - | otherwise = insert b2 v2 (v1:@b1) --- If one side is a singleton -union x (v:@b) = insert b v x -union (v:@b) x = insert b v x - --- In the case of multiple elements -union (Liner m1 _ _ _ _ _) (Liner m2 _ _ _ _ _) = linerFromMap (Map.unionWith pairAppend m1 m2) - - -{-# INLINE insert #-} --- | Complexity: --- - into Zero or singleton: O(1) to O(d * index-build) --- - into Liner: O(n * d * index-build) due to rebuilding 'linerFromMap' --- where n is the number of distinct base keys after insertion. -insert :: (HatVal v,HatBaseClass b) => b -> v -> Alg v b -> Alg v b -insert _ v x | isZeroValue v = x -insert !b !v Zero = v .@ b -insert !b1 !v1 (v2:@b2) = case isHat b1 of - True -> insert b2 v2 - $ linerFromMap - $ Map.singleton (base b1) - $ nullPair {_hatSide = Seq.singleton v1} - False -> insert b2 v2 - $ linerFromMap - $ Map.singleton (base b1) - $ nullPair {_notSide = Seq.singleton v1} -insert !b !v (Liner m _ _ _ _ _) = case isHat b of - True -> insertLiner (nullPair {_hatSide = Seq.singleton v}) - False -> insertLiner (nullPair {_notSide = Seq.singleton v}) - where - !bp = base b - insertLiner !pairToInsert = - let !m' = Map.insertWith pairAppend bp pairToInsert m - in linerFromMap m' - ------------------------------------------------------------------- --- Monoid ------------------------------------------------------------------- - -instance (HatVal n, HatBaseClass b) => Monoid (Alg n b) where - -- Identity element - mempty = Zero - mappend = (<>) - mconcat = unions - -{-# INLINE unions #-} --- | Complexity: O(sum of HashMap union costs over the fold) --- For a long list this is typically the dominant construction cost. -unions :: (HatVal n, Foldable f, HatBaseClass b) => f (Alg n b) -> Alg n b -unions ts = Foldable.foldl' union Zero ts - -{-# INLINE mergeAlgMap #-} -mergeAlgMap :: (HatVal n, HatBaseClass b) - => Map.HashMap (BasePart b) (Pair n) - -> Alg n b - -> Map.HashMap (BasePart b) (Pair n) -mergeAlgMap !acc Zero = acc -mergeAlgMap !acc (v :@ b) - | isZeroValue v = acc - | otherwise = - let !p = if isHat b - then nullPair {_hatSide = Seq.singleton v} - else nullPair {_notSide = Seq.singleton v} - in Map.insertWith pairAppend (base b) p acc -mergeAlgMap !acc (Liner m _ _ _ _ _) - | Map.null m = acc - | otherwise = Map.unionWith pairAppend acc m - -{-# INLINE mergeAlgMapIfNonZero #-} -mergeAlgMapIfNonZero :: (HatVal n, HatBaseClass b) - => Map.HashMap (BasePart b) (Pair n) - -> Alg n b - -> Map.HashMap (BasePart b) (Pair n) -mergeAlgMapIfNonZero !acc Zero = acc -mergeAlgMapIfNonZero !acc alg@(v :@ _) - | isZeroValue v = acc - | otherwise = mergeAlgMap acc alg -mergeAlgMapIfNonZero !acc alg = mergeAlgMap acc alg - -{-# INLINE unionsMerge #-} --- | Merge multiple Algs by directly combining their internal HashMaps, --- building the AxisPosting index only once at the end. -unionsMerge :: (HatVal n, Foldable f, HatBaseClass b) => f (Alg n b) -> Alg n b -unionsMerge ts = - let !m = Foldable.foldl' mergeAlgMap Map.empty ts - in mkAlgFromMap m - ------------------------------------------------------------------- --- Redundant ------------------------------------------------------------------- - -instance (HatVal n, HatBaseClass b) => Redundant Alg n b where - (.^) Zero = Zero - (.^) (n:@ b) = n :@ (revHat b) - (.^) (Liner ms idx bpToId idToBp nextBpId allIds) = Liner - (Map.map (\ (Pair hs ns) -> Pair ns hs) ms) - idx - bpToId - idToBp - nextBpId - allIds - - (.+) = mappend - - x .* Zero = Zero - 0 .* x = Zero - x .* (v:@b) = (x * v) :@ b - x .* (Liner ms idx bpToId idToBp nextBpId allIds) = Liner - (Map.map (\ (Pair hs ns) -> Pair (fmap (x *) hs) (fmap (x *) ns)) ms) - idx - bpToId - idToBp - nextBpId - allIds - - norm Zero = 0 - norm (v:@b) = v - norm (Liner ms _ _ _ _ _) = Map.foldl' (\ !x (Pair hs ns) -> x + Foldable.foldl' (+) 0 hs + Foldable.foldl' (+) 0 ns) 0 ms - - {-# INLINE (.-) #-} - (.-) Zero = Zero - (.-) (v:@b) = v:@b - (.-) (Liner m _ _ _ _ _) = let !res = Map.mapMaybe f m - in case null res of - True -> Zero - False -> linerFromMap res - where - {-# INLINE f #-} - f p@(Pair hs ns) = - let !h = Foldable.foldl' (+) 0 hs - !n = Foldable.foldl' (+) 0 ns - in case nearlyEqScaled h n of -- scale-aware tolerance (WI-11) - True -> Nothing - False -> case (Seq.length hs, Seq.length ns) of - -- Already in canonical form: singleton on winning side, empty on other - (1, 0) | h > n -> Just p - (0, 1) | n > h -> Just p - _ -> case compare h n of - GT -> Just (Pair (Seq.singleton (h - n)) Seq.empty) - LT -> Just (Pair Seq.empty (Seq.singleton (n - h))) - - {-# INLINE compress #-} - compress Zero = Zero - compress (v:@b) = v:@b - compress (Liner m idx bpToId idToBp nextBpId allIds) = Liner - (Map.map compressPair m) - idx - bpToId - idToBp - nextBpId - allIds - where - {-# INLINE compressPair #-} - compressPair p@(Pair hs ns) = case (Seq.length hs, Seq.length ns) of - (1, 1) -> p -- already singleton on both sides, reuse - (1, 0) -> p -- already singleton + empty, reuse - (0, 1) -> p -- already empty + singleton, reuse - _ -> Pair (Seq.singleton (Foldable.foldl' (+) 0 hs)) - (Seq.singleton (Foldable.foldl' (+) 0 ns)) - - -instance (HatVal n, ExBaseClass b) => Exchange Alg n b where - -- | filter Credit side - decR xs = filter (\x -> x /= Zero && (whichSide . _hatBase) x == Credit) xs - - -- | filter Debit side - decL xs = filter (\x -> x /= Zero && (whichSide . _hatBase) x == Debit) xs - - -- | filter Plus Stock - decP xs = filter (\x -> x /= Zero && (isHat . _hatBase ) x) xs - - -- | filter Minus Stock - decM xs = filter (\x -> x /= Zero && (not. isHat. _hatBase) x) xs - - -- | check Credit Debit balance (scale-aware tolerance, WI-12) - balance xs = nearlyEqScaled ((norm . decR) xs) ((norm . decL) xs) - - -- | (scale-aware tolerance, WI-12); near-equal sides report (Side, 0) - diffRL xs | nearlyEqScaled r l = (Side, 0) - | r > l = (Credit, r - l) - | otherwise = (Debit, l - r) - where - r = (norm . decR) xs - l = (norm . decL) xs - ------------------------------------------------------------------- --- * Basic functions ------------------------------------------------------------------- - --- | Returns all values contained in the algebra element as a list. --- --- Complexity: O(s) (s is the total number of scalar entries) -vals :: (HatVal v, HatBaseClass b) => Alg v b -> [v] -vals Zero = [] -vals (v:@b) = [v] -vals (Liner m _ _ _ _ _) = - reverse $ - Map.foldl' - (\acc (Pair hs ns) -> - Foldable.foldl' (flip (:)) - (Foldable.foldl' (flip (:)) acc hs) - ns - ) - [] - m - - --- | Returns all bases contained in the algebra element as a list. --- --- Complexity: O(s) (s is the total number of scalar entries) -bases :: (HatVal v, HatBaseClass b) => Alg v b -> [b] -bases Zero = [] -bases (v:@b) = [b] -bases (Liner m _ _ _ _ _) = Map.foldlWithKey' f [] m - where - f :: (HatVal v, HatBaseClass b) => [b] -> BasePart b -> Pair v -> [b] - f xs b (Pair {_hatSide = hs, _notSide = ns}) - = Foldable.foldl' (g Not b) (Foldable.foldl' (g Hat b) xs hs) ns - - g :: (HatVal v, HatBaseClass b) => Hat -> BasePart b -> [b] -> v -> [b] - g h b ys v = (merge h b):ys - -{-# INLINE fromList #-} --- | convert List to Alg n b --- Complexity: O(sum of HashMap union costs), because this is implemented via 'mconcat'. --- --- >>> type Test = Alg NN.Double (HatBase AccountTitles) --- >>> xs = [1:@Hat:>> fromList xs --- 1.00:@Hat:>> type Test = Alg NN.Double (HatBase CountUnit) --- >>> x = 1:@Hat:>> y = 2:@Hat:>> fromList [x,y] --- 1.00:@Hat: [Alg v b] -> Alg v b -fromList = mconcat - - - --- | Summation function that applies a function to each element of a list and sums the results. --- Complexity: O(sum of HashMap union costs over produced elements). --- --- >>> type Test = Alg NN.Double (HatBase CountUnit) --- >>> sigma [1,2] (\x -> x:@Hat: [a] -> (a -> Alg v b) -> Alg v b -sigma xs f = mkAlgFromMap $ L.foldl' step Map.empty xs - where - step !acc !x = mergeAlgMapIfNonZero acc (f x) - --- | Conditional summation over a double loop. For all combinations of two lists, --- applies the function only to pairs that satisfy the condition and sums the results. --- --- Complexity: O(|xs| * |ys| * union cost) -{-# INLINE sigma2When #-} -sigma2When :: (HatVal v, HatBaseClass b) - => [a] - -> [c] - -> (a -> c -> Bool) - -> (a -> c -> Alg v b) - -> Alg v b -sigma2When xs ys cond f = - mkAlgFromMap $ L.foldl' outer Map.empty xs - where - outer !acc !x = L.foldl' (inner x) acc ys - inner !x !acc !y - | cond x y = mergeAlgMapIfNonZero acc (f x y) - | otherwise = acc - --- | Summation using keys and values from a Map. Skips entries with zero values. --- --- Complexity: O(|map| * union cost) -{-# INLINE sigmaFromMap #-} -sigmaFromMap :: (HatVal v, HatBaseClass b, Ord k) - => M.Map k v - -> (k -> v -> Alg v b) - -> Alg v b -sigmaFromMap kvs f = - mkAlgFromMap $ M.foldlWithKey' step Map.empty kvs - where - step !acc !k !v - | isZeroValue v = acc - | otherwise = mergeAlgMapIfNonZero acc (f k v) - --- | Converts an algebra element to a list. --- Complexity: O(s) (s is the total number of scalar entries) --- --- >>> toList (10:@Hat:<(Cash) .+ 10:@Hat:<(Deposits) .+ Zero :: Alg NN.Double (HatBase AccountTitles)) --- [10.00:@Hat:>> toList Zero :: [Alg NN.Double (HatBase AccountTitles)] --- [] -toList :: (HatVal v, HatBaseClass b) => Alg v b -> [Alg v b] -toList Zero = [] -toList (v:@b) = [v:@b] -toList (Liner m _ _ _ _ _) = Map.foldlWithKey' f [] m - where - f :: (HatVal v, HatBaseClass b) => [Alg v b] -> BasePart b -> Pair v -> [Alg v b] - f xs b Pair {_hatSide = hs, _notSide = ns} - = Foldable.foldl' (g Hat b) (Foldable.foldl' (g Not b) xs ns) hs - - g :: (HatVal v, HatBaseClass b) => Hat -> BasePart b -> [Alg v b] -> v -> [Alg v b] - g h b ys v - | isZeroValue v = ys - | otherwise = (v :@ (merge h b)):ys - -{-# INLINE foldEntries #-} --- | Strict left fold over scalar entries without building an intermediate list. -foldEntries :: (HatVal v, HatBaseClass b) - => (acc -> v -> b -> acc) - -> acc - -> Alg v b - -> acc -foldEntries _ !acc Zero = acc -foldEntries f !acc (v :@ b) - | isZeroValue v = acc - | otherwise = f acc v b -foldEntries f !acc (Liner m _ _ _ _ _) = - Map.foldlWithKey' step acc m - where - step !acc0 !bp (Pair hs ns) = - let !hatBase = merge Hat bp - !notBase = merge Not bp - !acc1 = Foldable.foldl' (\a v -> if isZeroValue v then a else f a v hatBase) acc0 hs - in Foldable.foldl' (\a v -> if isZeroValue v then a else f a v notBase) acc1 ns - -{-# INLINE toASCList #-} --- | Complexity: O(s log s), dominated by sorting the list representation. -toASCList :: (HatVal v, HatBaseClass b) => Alg v b -> [Alg v b] -toASCList = L.sort . toList - - --- | map --- Complexity: O(s + c), where s is traversed scalar entries and c is transformed output size. --- --- >>> type Test = Alg Double (HatBase CountUnit) --- >>> x = 1:@Hat:>> y = 2:@Not:>> map (\ (x:@hb) -> x:@(toHat hb)) $ x .+ y --- 1.00:@Hat:>> type Test = Alg Double Hat --- >>> x = 1:@Hat .+ 1:@Not :: Test --- >>> y = 2:@Not .+ 2:@Hat :: Test --- >>> map (\ (x:@hb) -> (2 * x):@hb) $ x .+ y --- 2.00:@Hat .+ 4.00:@Hat .+ 2.00:@Not .+ 4.00:@Not - -map :: (HasCallStack,HatVal v, HatBaseClass b) - => (Alg v b -> Alg v b) -> Alg v b -> Alg v b -map f Zero = Zero -map f (v:@b) = let v2:@b2 = f (v:@b) - in case isZeroValue v2 of - True -> Zero - False -> (v2 :@ b2) -map f (Liner m _ _ _ _ _) = mkAlgFromMap $ (Map.foldrWithKey (p f) dnilMap m) Map.empty - where - {-# INLINE dnilMap #-} - dnilMap = id - {-# INLINE dappendMap #-} - dappendMap = (.) - {-# INLINE dsingleMap #-} - dsingleMap (bp, p') = Map.insertWith pairAppend bp p' - - {-# INLINE p #-} - p :: (HatVal v, HatBaseClass b) - => (Alg v b -> Alg v b) - -> BasePart b - -> Pair v - -> DMap (BasePart b) (Pair v) - -> DMap (BasePart b) (Pair v) - p f b Pair {_hatSide=hs, _notSide=ns} accDList = - let (dl1, hs2) = q f Hat b hs - (dl2, ns2) = q f Not b ns - prefix = dappendMap dl1 dl2 - in case (Seq.null hs2, Seq.null ns2) of - (True,True) -> dappendMap prefix accDList - (True,False) -> dappendMap prefix - . dappendMap (dsingleMap (b, nullPair{_notSide = ns2})) - $ accDList - (False,True) -> dappendMap prefix - . dappendMap (dsingleMap (b, nullPair{_hatSide = hs2})) - $ accDList - (False,False) -> dappendMap prefix - . dappendMap (dsingleMap (b, Pair hs2 ns2)) - $ accDList - {-# INLINE q #-} - q :: (HatVal v, HatBaseClass b) - => (Alg v b -> Alg v b) - -> Hat - -> BasePart b - -> Seq v - -> (DMap (BasePart b) (Pair v), Seq v) - q f h b vs = Foldable.foldl' (r f h b) (dnilMap, Seq.empty) vs - - {-# INLINE r #-} - r :: (HatVal v, HatBaseClass b) - => (Alg v b -> Alg v b) - -> Hat - -> BasePart b - -> (DMap (BasePart b) (Pair v), Seq v) - -> v - -> (DMap (BasePart b) (Pair v), Seq v) - r f h b (dlAcc,vsAcc) v = case f (v:@(merge h b)) of - Zero -> (dlAcc, vsAcc) - ------------------------------------------------------------------ - v2:@b2 - | isZeroValue v2 -> (dlAcc, vsAcc) - | b2 .== (merge h b) -> (dlAcc, v2 Seq.<| vsAcc) - | isHat (hat b2) -> (dappendMap dlAcc (dsingleMap ( base b2 - ,nullPair{_hatSide = Seq.singleton v2})) - ,vsAcc ) - | otherwise -> (dappendMap dlAcc (dsingleMap ( base b2 - ,nullPair{_notSide = Seq.singleton v2} )) - ,vsAcc ) - --- Difference list definition -type DList a = [a] -> [a] -type DMap k v = Map.HashMap k v -> Map.HashMap k v - -{-# INLINE dnil #-} --- | Complexity: O(1) -dnil :: DList a -dnil = id - -{-# INLINE dappend #-} --- | Complexity: O(1) -dappend :: DList a -> DList a -> DList a -dappend = (.) -- Function composition - -{-# INLINE dsingle #-} --- | Complexity: O(1) -dsingle :: a -> DList a -dsingle x = \rest -> x : rest - -{-# INLINE dToList #-} --- | Complexity: O(k), where k is the resulting list length. -dToList :: DList a -> [a] -dToList dl = dl [] - -{-# INLINE dFromList #-} --- | Complexity: O(k) to capture the prefix list xs. -dFromList :: [a] -> DList a -dFromList xs = (xs ++) - - -{-# INLINE filter #-} --- | filter --- Complexity: O(s), where s is total number of scalar entries. --- --- >>> type Test = Alg Double (HatBase CountUnit) --- >>> x = 1:@Hat:>> y = 2:@Not:>> filter (isHat . _hatBase) $ x .+ y --- 1.00:@Hat:>> type Test = Alg Double (HatBase CountUnit) --- >>> x = 1:@Hat:>> y = 2:@Not:>> filter ((1 <). _val) $ x .+ y --- 2.00:@Not: (Alg v b -> Bool) -> Alg v b -> Alg v b -filter f Zero = Zero -filter f (v:@b) | f (v:@b) = v:@b - | otherwise = Zero - -filter f (Liner m _ _ _ _ _) = - -- Build a new Map using mapMaybeWithKey - let m' = Map.mapMaybeWithKey - (\basePart (Pair hs ns) -> - -- Filter each of hs and ns - let hs' = filterSide basePart Hat hs - ns' = filterSide basePart Not ns - in - -- Remove the entry (Nothing) if both become empty - if Seq.null hs' && Seq.null ns' - then Nothing - else Just (Pair hs' ns')) - m - in - -- If the resulting Map is empty, return Zero; otherwise Liner m' - if Map.null m' then Zero else linerFromMap m' - where - ---------------------------------------------------------------- - -- Filter function that constructs "v:@(merge h basePart)" from - -- basePart and Hat/Not, and tests whether it satisfies predicate f - ---------------------------------------------------------------- - -- filterSide :: BasePart b -> Hat -> Seq v -> Seq v - {-# INLINE filterSide #-} - filterSide bp h = Seq.filter (\val -> f (val :@ merge h bp)) - ------------------------------------------------------------- --- | proj --- Complexity: --- exact single-key path: expected O(1) --- wildcard single-key path: O(queryAxisPosting + c * verify) --- multi-pattern path: O(sum pattern costs + union costs) --- --- where c is candidate count returned by the posting index. --- >>> type Test = Alg NN.Double (HatBase CountUnit) --- >>> x = 1:@Hat:>> y = 2:@Not:>> proj [Hat:>> type Test = Alg NN.Double (HatBase CountUnit) --- >>> x = 1:@Hat:>> y = 2:@Not:>> proj [HatNot:>> type Test = Alg NN.Double (HatBase (AccountTitles, CountUnit)) --- >>> x = 1:@Hat:<(Cash,Yen) .+ 1:@Not:<(Products,Amount) :: Test --- >>> y = 2:@Not:<(Cash,Yen) .+ 2:@Hat:<(Deposits,Yen) :: Test --- >>> proj [Hat:<((.#),Yen)] $ x .+ y --- 1.00:@Hat:<(Cash,Yen) .+ 2.00:@Hat:<(Deposits,Yen) --- --- >>> type Test = HatBase CountUnit --- >>> compareHatBase (Not:<(.#) :: Test) (Not:>> type Test = Alg NN.Double (HatBase CountUnit) --- >>> x = 1:@Hat:>> y = 2:@Not:>> proj [Not:<(.#)] $ x .+ y --- 2.00:@Not: [b] -> Alg v b -> Alg v b -proj [] _ = Zero -proj _ Zero = Zero -proj [b] (v:@b2) - | b .== b2 = v:@b2 - | otherwise = Zero -proj [b] (Liner m idx _ idToBp _ allIds) = - mkAlgFromMap $ projSingleMap b m idx idToBp allIds -proj (b:bs) (v:@b2) - | b .== b2 = v:@b2 - | otherwise = proj bs (v:@b2) -proj (b:bs) (Liner m idx _ idToBp _ allIds) = - mkAlgFromMap $ - L.foldl' - (\acc q -> Map.unionWith pairAppend acc (projSingleMap q m idx idToBp allIds)) - Map.empty - (b:bs) - -{-# INLINE choosePairByHat #-} --- | Complexity: O(1) -choosePairByHat :: Hat -> Pair v -> Pair v -choosePairByHat h Pair {_hatSide = hs, _notSide = ns} = - case h of - Hat -> nullPair {_hatSide = hs} - Not -> nullPair {_notSide = ns} - HatNot -> Pair {_hatSide = hs, _notSide = ns} - -{-# INLINE projSingleMap #-} --- | Complexity: --- - wildcard path: O(queryAxisPosting + c * verify) --- - exact path: expected O(1) -projSingleMap - :: (HatBaseClass b) - => b - -> Map.HashMap (BasePart b) (Pair v) - -> AxisPosting - -> IntMap.IntMap (BasePart b) - -> IntSet.IntSet - -> Map.HashMap (BasePart b) (Pair v) -projSingleMap b m idx idToBp allIds - | haveWiledcard bp = - let !ids = queryAxisPosting (toAxisKeys bp) idx allIds - in IntSet.foldl' - (\acc bpId -> case IntMap.lookup bpId idToBp of - Nothing -> acc - Just bp0 -> case Map.lookup bp0 m of - Nothing -> acc - Just p -> if bp .== bp0 - then Map.insert bp0 (choosePairByHat h p) acc - else acc) - Map.empty - ids - | otherwise = case Map.lookup bp m of - Nothing -> Map.empty - Just p -> Map.singleton bp (choosePairByHat h p) - where - !bp = base b - !h = hat b - -{-# INLINE mkAlgFromMap #-} --- | Complexity: O(n) to inspect shape and possibly rebuild index. -mkAlgFromMap :: (HatVal v, HatBaseClass b) => Map.HashMap (BasePart b) (Pair v) -> Alg v b -mkAlgFromMap m - | Map.null m = Zero - | otherwise = case Map.toList m of - [(b, p)] -> Maybe.fromMaybe (linerFromMap $ Map.singleton b p) (singlePairToAlg b p) - _ -> linerFromMap m - -{-# INLINE singlePairToAlg #-} --- | Complexity: O(1) -singlePairToAlg :: (HatVal v, HatBaseClass b) => BasePart b -> Pair v -> Maybe (Alg v b) -singlePairToAlg b (Pair hs ns) = case (Seq.viewl hs, Seq.viewl ns) of - (Seq.EmptyL, n Seq.:< nsRest) | Seq.null nsRest -> Just (n :@ merge Not b) - (h Seq.:< hsRest, Seq.EmptyL) | Seq.null hsRest -> Just (h :@ merge Hat b) - _ -> Nothing - ------------------------------------------------------------------- - --- | Projects only the credit side elements. --- Use this instead of decL when the base contains non-Enum elements such as Text or Int. --- --- Complexity: O(s) (s is the total number of scalar entries) -projCredit :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b -projCredit = filter (\x -> (whichSide . _hatBase) x == Credit) - --- | Projects only the debit side elements. --- Use this instead of decR when the base contains non-Enum elements such as Text or Int. --- --- Complexity: O(s) (s is the total number of scalar entries) -projDebit :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b -projDebit = filter (\x -> (whichSide . _hatBase) x == Debit) - --- | Projects only the elements matching the specified account title. --- --- Complexity: O(s) (s is the total number of scalar entries) -projByAccountTitle :: (HatVal n, ExBaseClass b) => AccountTitles -> Alg n b -> Alg n b -projByAccountTitle at alg = filter (f at) alg - where - f :: (HatVal n,ExBaseClass b) => AccountTitles -> Alg n b -> Bool - f at Zero = False - f at x = ((getAccountTitle ._hatBase) x) .== at - --- | Complexity: O(cost(proj) + cost(bar) + cost(norm)). -projNorm :: (HatVal n, HatBaseClass b) => [b] -> Alg n b -> n -projNorm [] _ = 0 -projNorm _ Zero = 0 -projNorm bs (v :@ b) - | L.any (.== b) bs = v - | otherwise = 0 -projNorm [b] (Liner m idx _ idToBp _ allIds) = - foldProjectedNorm (projSingleMap b m idx idToBp allIds) -projNorm bs (Liner m idx _ idToBp _ allIds) = - foldProjectedNorm $ - L.foldl' - (\acc q -> Map.unionWith pairAppend acc (projSingleMap q m idx idToBp allIds)) - Map.empty - bs - -{-# INLINE foldProjectedNorm #-} --- | Complexity: O(k), where k is the number of projected base keys. -foldProjectedNorm :: (HatVal n) => Map.HashMap k (Pair n) -> n -foldProjectedNorm = Map.foldl' (\acc p -> acc + barNormPair p) 0 - -{-# INLINE barNormPair #-} --- | Complexity: O(h + n), where h/n are side lengths within the pair. -barNormPair :: (HatVal n) => Pair n -> n -barNormPair (Pair hs ns) = - let !h = Foldable.foldl' (+) 0 hs - !n = Foldable.foldl' (+) 0 ns - in if nearlyEqScaled h n - then 0 - else if h > n then h - n else n - h - - --- | Compute the net balance as the difference of two projections. --- @balanceBy plusBases minusBases alg@ computes --- @projNorm plusBases alg - projNorm minusBases alg@. --- --- Useful for calculating stock quantities, profits, etc. --- --- >>> type T = Alg Double (HatBase AccountTitles) --- >>> let alg = 100 :@ Not:>> balanceBy [Not:>> balanceBy [Hat: [b] -> [b] -> Alg n b -> n -balanceBy plusBases minusBases alg = - projNorm plusBases alg - projNorm minusBases alg - --- | Fold algebra entries into a @Map@, combining values with @(+)@. --- --- The selector function examines each entry @(v, b)@ and optionally returns --- a @(key, value)@ pair. Values for duplicate keys are summed. --- --- >>> type T = Alg Double (HatBase AccountTitles) --- >>> let alg = 10 :@ Hat:>> let f v (Hat :< a) = Just (a, v); f _ _ = Nothing --- >>> foldEntriesToMap f alg --- fromList [(Cash,15.0),(Deposits,20.0)] -foldEntriesToMap :: (HatVal v, HatBaseClass b, Ord k) - => (v -> b -> Maybe (k, v)) - -> Alg v b - -> M.Map k v -foldEntriesToMap f = foldEntries step M.empty - where - step acc v b = case f v b of - Just (k, v') -> M.insertWith (+) k v' acc - Nothing -> acc - --- | Projects only current assets. --- Extracts asset items classified as current from the debit side. --- --- Complexity: O(s) (s is the total number of scalar entries) -projCurrentAssets :: ( HatVal n, ExBaseClass b) => Alg n b -> Alg n b -projCurrentAssets = (filter (\x -> (fixedCurrent . _hatBase) x == Current)) - . (filter (\x -> (whatDiv . _hatBase) x == Assets)) - . projDebit - --- | Projects only fixed assets. --- Extracts asset items classified as fixed from the debit side. --- --- Complexity: O(s) (s is the total number of scalar entries) -projFixedAssets :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b -projFixedAssets = (filter (\x -> (fixedCurrent . _hatBase) x == Fixed)) - . (filter (\x -> (whatDiv . _hatBase) x == Assets)) - . projDebit - --- | Projects only deferred assets. --- Tax-specific deferred assets are presented under "investments and other assets" with appropriate items such as long-term prepaid expenses. --- --- Complexity: O(s) (s is the total number of scalar entries) -projDeferredAssets :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b -projDeferredAssets = (filter (\x -> (fixedCurrent . _hatBase) x == Other)) - . (filter (\x -> (whatDiv . _hatBase) x == Assets)) - . projDebit - --- | Projects only current liabilities. --- Extracts liability items classified as current from the credit side. --- --- Complexity: O(s) (s is the total number of scalar entries) -projCurrentLiability :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b -projCurrentLiability = (filter (\x -> (fixedCurrent . _hatBase) x == Current)) - . (filter (\x -> (whatDiv . _hatBase) x == Liability)) - . projCredit - --- | Projects only fixed liabilities. --- Extracts liability items classified as fixed from the credit side. --- --- Complexity: O(s) (s is the total number of scalar entries) -projFixedLiability :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b -projFixedLiability = (filter (\x -> (fixedCurrent . _hatBase) x == Fixed)) - . (filter (\x -> (whatDiv . _hatBase) x == Liability)) - . projCredit - --- | Projects only capital stock. --- --- __Note__: Not yet implemented. Calling this will throw an exception. -projCapitalStock :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b -projCapitalStock = undefined - - --- * Balance - -{- | Handling when the balance does not hold -} --- Complexity: O(1) currently (undefined placeholder). -forceBalance = undefined - - --- * Rounding - --- | Rounding (ceiling). --- Applied to the results of division and multiplication; uses ceiling rounding by default. --- This should be applied to all multiplication and division of account titles. --- --- Complexity: O(1) -rounding :: NN.Double -> NN.Double -rounding = fromIntegral . ceiling +{-# LANGUAGE TypeOperators #-} + +{- | + Module : ExchangeAlgebra.Algebra + Copyright : (c) Kaya Akagi. 2018-2026 + Maintainer : yakagika@icloud.com + + Released under the OWL license + + Package for Exchange Algebra defined by Hiroshi Deguchi. + + Exchange Algebra is an algebraic description of bookkeeping system. + Details are below. + + + + + + 'Alg' is abstract here: 'Zero' and '(:@)' can be constructed and matched, + the multi-posting 'ExchangeAlgebra.Algebra.Internal.Liner' representation + and its cache fields are reachable + only through "ExchangeAlgebra.Algebra.Internal". + +-} + +module ExchangeAlgebra.Algebra + ( module ExchangeAlgebra.Algebra.Base + , Nearly(..) + , isNearlyNum + , nearlyEqScaled + , Redundant(..) + , Exchange(..) + , HatVal(..) + , Alg(Zero, (:@), _val, _hatBase) + , isZero + , (.@) + , (<@) + , vals + , bases + , fromList + , toList + , foldEntries + , sigma + , sigma2When + , sigmaFromMap + , toASCList + , map + , mapPosting + , mapMaybePosting + , mapBasePart + , filter + , proj + , projCredit + , projDebit + , projByAccountTitle + , projNetNorm + , projNorm + , balanceBy + , balanceMapBy + , netPairMapBy + , foldEntriesToMap + , decBy + , postFromNetBy + , projCurrentAssets + , projFixedAssets + , projDeferredAssets + , projCurrentLiability + , projFixedLiability + , projCapitalStock + , projContraAssets + , projContra + , rounding + , unionsMerge + ) where + +import Prelude hiding (map, filter) +import ExchangeAlgebra.Algebra.Internal +import ExchangeAlgebra.Algebra.Base diff --git a/src/ExchangeAlgebra/Algebra/Base.hs b/src/ExchangeAlgebra/Algebra/Base.hs --- a/src/ExchangeAlgebra/Algebra/Base.hs +++ b/src/ExchangeAlgebra/Algebra/Base.hs @@ -26,17 +26,18 @@ {-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE DeriveGeneric #-} - module ExchangeAlgebra.Algebra.Base ( module ExchangeAlgebra.Algebra.Base + , module ExchangeAlgebra.Algebra.Base.Account.Registry + , module ExchangeAlgebra.Algebra.Base.Account.Types , module ExchangeAlgebra.Algebra.Base.Element) where import ExchangeAlgebra.Algebra.Base.Element +import ExchangeAlgebra.Algebra.Base.Account.Registry +import ExchangeAlgebra.Algebra.Base.Account.Types import Data.Time (Day, TimeOfDay) import GHC.Stack (HasCallStack, callStack, prettyCallStack) -import GHC.Generics (Generic) -import Data.Hashable import qualified Data.Binary as Binary customError :: HasCallStack => String -> a @@ -71,14 +72,22 @@ instance (Element e1, Element e2, Element e3, Element e4, Element e5, Element e6) => BaseClass (e1, e2, e3, e4, e5, e6) where +-- 7-tuple: 'Element'/'AxisDecompose' already provide 7-tuple instances; this +-- closes the gap so every Element tuple arity is also usable as a base. +instance (Element e1, Element e2, Element e3, Element e4, Element e5, Element e6, Element e7) + => BaseClass (e1, e2, e3, e4, e5, e6, e7) where + ------------------------------------------------------------------ -- ** HatBase ------------------------------------------------------------------ -- | Type class for bases with a Hat component. Provides functionality to decompose and --- compose a base into its Hat part and BasePart. Manages the credit (Hat) / debit (Not) --- distinction at the base level in exchange algebra. +-- compose a base into its Hat part and BasePart. Manages the Hat (decrease) \/ +-- Not (increase) label at the base level in exchange algebra. Note that Hat\/Not +-- is __not__ the debit\/credit distinction: the side of a posting is determined +-- by the account division /together with/ this label (see 'whichSide' — an +-- account sits on its home side when 'Not' and on the opposite side when v'Hat'). class (BaseClass a, BaseClass (BasePart a), AxisDecompose (BasePart a)) => HatBaseClass a where -- | The type of the base part excluding the Hat. type BasePart a @@ -116,7 +125,7 @@ instance Binary.Binary Hat instance Element Hat where - wiledcard = HatNot + wildcard = HatNot {-# INLINE equal #-} equal Hat Hat = True @@ -137,7 +146,7 @@ instance Binary.Binary BaseForSingleHat instance Element BaseForSingleHat where - wiledcard = BaseForSingleHat + wildcard = BaseForSingleHat equal _ _ = True instance BaseClass BaseForSingleHat where @@ -145,8 +154,15 @@ instance HatBaseClass Hat where type BasePart Hat = BaseForSingleHat hat = id - base x = BaseForSingleHat + base _ = BaseForSingleHat + -- NB. 'merge'\/'revHat'\/'isHat' below match only @Hat@ and @Not@. The third + -- v'Hat' constructor @HatNot@ is the formalization-only wildcard state (the + -- paper convention is the 2-state Hat\/Not; see CLAUDE.md "HatNot wildcard"). + -- These methods are never invoked on a @HatNot@ label by library code, so the + -- non-exhaustive @-Wincomplete-patterns@ here is by design (audited). Adding a + -- @HatNot@ case would change behaviour (turn the pattern-match failure into a + -- different error), so it is intentionally left as-is rather than masked. merge Hat _ = Hat merge Not _ = Not @@ -198,8 +214,8 @@ `hashWithSalt` b -- | Element (HatBase a) --- haveWiledcard --- >>> haveWiledcard (HatNot:>> haveWildcard (HatNot:>> compareHatBase (Not:>> ignoreWiledcard (Not:<(Products,Yen)) (Hat:<(Products,Amount)) +-- ignoreWildcard +-- >>> ignoreWildcard (Not:<(Products,Yen)) (Hat:<(Products,Amount)) -- Hat:<(Products,Amount) -- --- >>> ignoreWiledcard (Not:<(Products,Yen)) (Hat:<(Products,(.#))) +-- >>> ignoreWildcard (Not:<(Products,Yen)) (Hat:<(Products,(.#))) -- Hat:<(Products,Yen) -- --- >>> ignoreWiledcard (Not:<(Cash,(.#))) (HatNot:<((.#),Amount)) +-- >>> ignoreWildcard (Not:<(Cash,(.#))) (HatNot:<((.#),Amount)) -- Not:<(Cash,Amount) instance (BaseClass a) => Element (HatBase a) where - wiledcard = HatNot : Side +defaultSide Assets = Debit +defaultSide Cost = Debit +defaultSide Liability = Credit +defaultSide Equity = Credit +defaultSide Revenue = Credit -- | Classify an account title into an account division (Assets/Equity/Liability/Cost/Revenue). -- -- Complexity: O(1) {-# INLINE classifyAccountDivision #-} classifyAccountDivision :: HasCallStack => AccountTitles -> AccountDivision -classifyAccountDivision AccountTitle = customError "this is wiledcard AccountTitle" -classifyAccountDivision CapitalStock = Equity -classifyAccountDivision RetainedEarnings = Equity -classifyAccountDivision LongTermLoansPayable = Liability -classifyAccountDivision ShortTermLoansPayable = Liability -classifyAccountDivision LoansPayable = Liability -classifyAccountDivision ReserveForDepreciation = Liability -classifyAccountDivision DepositPayable = Liability -classifyAccountDivision LongTermNationalBondsPayable = Liability -classifyAccountDivision ShortTermNationalBondsPayable = Liability -classifyAccountDivision ReserveDepositPayable = Liability -classifyAccountDivision CentralBankNotePayable = Liability -classifyAccountDivision Depreciation = Cost -classifyAccountDivision SalesCost = Cost -classifyAccountDivision BusinessTrip = Cost -classifyAccountDivision Commutation = Cost -classifyAccountDivision UtilitiesExpense = Cost -classifyAccountDivision RentExpense = Cost -classifyAccountDivision AdvertisingExpense = Cost -classifyAccountDivision DeliveryExpenses = Cost -classifyAccountDivision SuppliesExpenses = Cost -classifyAccountDivision MiscellaneousExpenses = Cost -classifyAccountDivision WageExpenditure = Cost -classifyAccountDivision InterestExpense = Cost -classifyAccountDivision TaxesExpense = Cost -classifyAccountDivision ConsumptionExpenditure = Cost -classifyAccountDivision SubsidyExpense = Cost -classifyAccountDivision CentralBankPaymentExpense = Cost -classifyAccountDivision Purchases = Cost -classifyAccountDivision NetIncome = Cost -classifyAccountDivision ValueAdded = Revenue -classifyAccountDivision SubsidyIncome = Revenue -classifyAccountDivision NationalBondInterestEarned = Revenue -classifyAccountDivision DepositInterestEarned = Revenue -classifyAccountDivision GrossProfit = Revenue -classifyAccountDivision OrdinaryProfit = Revenue -classifyAccountDivision InterestEarned = Revenue -classifyAccountDivision ReceiptFee = Revenue -classifyAccountDivision RentalIncome = Revenue -classifyAccountDivision WageEarned = Revenue -classifyAccountDivision TaxesRevenue = Revenue -classifyAccountDivision CentralBankPaymentIncome = Revenue -classifyAccountDivision Sales = Revenue -classifyAccountDivision NetLoss = Revenue -classifyAccountDivision _ = Assets +classifyAccountDivision AccountTitle = customError "this is wildcard AccountTitle" +classifyAccountDivision title = + case accountSpec title of + Just spec -> asDivision spec + Nothing -> customError "this is wildcard AccountTitle" -- | BaseClass ⊃ HatBaseClass ⊃ ExBaseClass -- @@ -373,37 +350,46 @@ whatDiv :: a -> AccountDivision whatDiv = classifyAccountDivision . getAccountTitle - -- | Retrieve the PIMO classification (PS/IN/MS/OUT). Complexity: O(1) + -- | Whether the account is a contra account (評価勘定等): its home side + -- and PIMO direction are the reverse of its division's defaults. + -- Delegates to the registry ('classifyAccountContra') exactly like + -- 'whatDiv' delegates to 'classifyAccountDivision' — a constant default + -- would disconnect the registry flag from every built-in instance. + -- Contract: @isContra b == (homeSide of b \/= defaultSide (whatDiv b))@. + -- Complexity: O(1) + {-# INLINE isContra #-} + isContra :: a -> Bool + isContra = classifyAccountContra . getAccountTitle + + -- | Retrieve the PIMO direction (PS/IN/MS/OUT; see 'PIMO' for the + -- original semantics). Derived from the division via 'pimoFromDivision', + -- flipped by 'pimoFlip' for contra accounts — e.g. a contra asset is MS + -- (minus stock), which is what makes the standard allowance entry + -- OUT ⇔ MS legal under Proposition 5.3.8. Complexity: O(1) {-# INLINE whatPIMO #-} whatPIMO :: a -> PIMO - whatPIMO x = - case whatDiv x of - Assets -> PS - Equity -> MS - Liability -> MS - Cost -> OUT - Revenue -> IN + whatPIMO x + | isContra x = pimoFlip (pimoFromDivision (whatDiv x)) + | otherwise = pimoFromDivision (whatDiv x) -- | Determine whether a base belongs to the Credit or Debit side. - -- Takes the Hat/Not reversal into account. Complexity: O(1) + -- The home side is 'defaultSide' of the division, reversed for contra + -- accounts ('isContra'). Takes the Hat/Not reversal into account: an + -- account sits on its home side under 'Not' and on the opposite side + -- under v'Hat'. A 'HatNot' (wildcard) label is rejected with an error — + -- same policy as 'isHat': stored postings are always Hat\/Not, so a + -- wildcard here means a query-side value leaked into a posting-side + -- computation (this function previously treated 'HatNot' silently as + -- v'Hat'). Complexity: O(1) {-# INLINE whichSide #-} whichSide :: a -> Side whichSide x = - let side = f (whatDiv x) - in if hat x == Not then side else switchSide side - where - {-# INLINE f #-} - f Assets = Debit - f Cost = Debit - f Liability = Credit - f Equity = Credit - f Revenue = Credit - - -- credit :: [a] -- ^ Use projCredit when Elem contains Text, Int, etc. - -- credit = L.filter (\x -> whichSide x == Credit) [toEnum 0 ..] - - -- debit :: [a] -- ^ Use projDebit when Elem contains Text, Int, etc. - -- debit = L.filter (\x -> whichSide x == Debit) [toEnum 0 ..] + let side0 = defaultSide (whatDiv x) + side = if isContra x then switchSide side0 else side0 + in case hat x of + Not -> side + Hat -> switchSide side + HatNot -> customError "whichSide: called on a HatNot (wildcard) base" -- | Retrieve the fixed/current classification. -- Returns Current, Fixed, or Other based on the account title. @@ -411,70 +397,7 @@ -- Complexity: O(1) {-# INLINE fixedCurrent #-} fixedCurrent :: a -> FixedCurrent - fixedCurrent b = f (getAccountTitle b) - where - {-# INLINE f #-} - f Cash = Current - f Deposits = Current - f CurrentDeposits = Current - f Securities = Current - f InvestmentSecurities = Fixed - f LongTermNationalBonds = Fixed - f ShortTermNationalBonds = Current - f Products = Current - f Machinery = Fixed - f Building = Fixed - f Vehicle = Fixed - f StockInvestment = Other -- Note - f EquipmentInvestment = Fixed - f LongTermLoansReceivable = Fixed - f ShortTermLoansReceivable = Current - f ReserveDepositReceivable = Current - f Gold = Fixed - f GovernmentService = Current - f CapitalStock = Other - f RetainedEarnings = Other - f ShortTermLoansPayable = Current - f LoansPayable = Current - f LongTermLoansPayable = Fixed - f ReserveForDepreciation = Current - f DepositPayable = Current - f LongTermNationalBondsPayable = Fixed - f ShortTermNationalBondsPayable = Current - f ReserveDepositPayable = Current - f CentralBankNotePayable = Current - f Depreciation = Other - f SalesCost = Other - f BusinessTrip = Other - f Commutation = Other - f UtilitiesExpense = Other - f RentExpense = Other - f AdvertisingExpense = Other - f DeliveryExpenses = Other - f SuppliesExpenses = Other - f MiscellaneousExpenses = Other - f WageExpenditure = Other - f InterestExpense = Other - f TaxesExpense = Other - f ConsumptionExpenditure = Other - f SubsidyExpense = Other - f CentralBankPaymentExpense = Other - f Purchases = Other - f NetIncome = Other - f ValueAdded = Other - f SubsidyIncome = Other - f NationalBondInterestEarned = Other - f DepositInterestEarned = Other - f GrossProfit = Other - f OrdinaryProfit = Other - f InterestEarned = Other - f ReceiptFee = Other - f RentalIncome = Other - f WageEarned = Other - f TaxesRevenue = Other - f CentralBankPaymentIncome = Other - f NetLoss = Other - f AccountTitle = Other + fixedCurrent b = maybe Other asFixedCurrent (accountSpec (getAccountTitle b)) -- | Type class for determining correspondences between account divisions. @@ -486,32 +409,54 @@ -- | Test whether two account divisions are in a corresponding relationship. (<=>) :: a -> a -> Bool -data AccountDivision = Assets -- ^ Assets - | Equity -- ^ Equity - | Liability -- ^ Liability - | Cost -- ^ Cost - | Revenue -- ^ Revenue - deriving (Ord, Show, Eq) - +-- | Derived from the PIMO relation via 'pimoFromDivision', matching +-- Proposition 5.3.8 (Deguchi 2004). BREAKING (0.5.0.0): the previous +-- hand-enumerated instance omitted the pairs required by PS ⇔ IN and +-- OUT ⇔ IN — @Assets \<=\> Revenue@ (e.g. a cash sale) and +-- @Cost \<=\> Revenue@ are now 'True'. This division-level relation cannot +-- see contra reversal; exchange checks on bases must go through 'whatPIMO'. instance AccountBase AccountDivision where - Assets <=> Liability = True - Liability <=> Assets = True - Assets <=> Equity = True - Equity <=> Assets = True - Cost <=> Liability = True - Liability <=> Cost = True - Cost <=> Equity = True - Equity <=> Cost = True - _ <=> _ = False + a <=> b = pimoFromDivision a <=> pimoFromDivision b --- | PIMO classification. Categories in exchange algebra: Product Stock (PS), Income (IN), --- Money Stock (MS), and Outflow (OUT). -data PIMO = PS -- ^ Product Stock (Assets: production stock) - | IN -- ^ Income (Revenue: income flow) - | MS -- ^ Money Stock (Liability/Equity: monetary stock) - | OUT -- ^ Outflow (Cost: expenditure flow) +-- | PIMO direction. In Proposition 5.3.8 (Deguchi 2004, pp.89-91) PS, IN, +-- MS and OUT mean __plus stock, input, minus stock and output__ — +-- directions of exchange, not statement labels. The allowed exchange pairs +-- are exactly PS ⇔ IN, PS ⇔ MS, OUT ⇔ IN, OUT ⇔ MS (the 'AccountBase' +-- instance below). The earlier Haddock glossed these as "Product Stock \/ +-- Income \/ Money Stock \/ Outflow"; that was naming drift from the +-- original and is kept only as a mnemonic. +data PIMO = PS -- ^ plus stock (stock increase; non-contra Assets) + | IN -- ^ input (flow in; Revenue) + | MS -- ^ minus stock (stock decrease; Liability\/Equity and contra assets) + | OUT -- ^ output (flow out; Cost) deriving (Ord, Show, Eq) +-- | The division-to-PIMO map of the standard interpretation (the @g@ of +-- Proposition 5.3.8 restricted to non-contra accounts): Assets are plus +-- stock, Liability\/Equity are minus stock, Cost is output, Revenue is +-- input. Contra accounts flip this via 'pimoFlip' (see 'whatPIMO'). +-- +-- Complexity: O(1) +{-# INLINE pimoFromDivision #-} +pimoFromDivision :: AccountDivision -> PIMO +pimoFromDivision Assets = PS +pimoFromDivision Equity = MS +pimoFromDivision Liability = MS +pimoFromDivision Cost = OUT +pimoFromDivision Revenue = IN + +-- | Direction flip used for contra accounts: PS ↔ MS, IN ↔ OUT. +-- Self-inverse, and it preserves the exchange relation: +-- @x \<=\> y@ implies @pimoFlip x \<=\> pimoFlip y@. +-- +-- Complexity: O(1) +{-# INLINE pimoFlip #-} +pimoFlip :: PIMO -> PIMO +pimoFlip PS = MS +pimoFlip MS = PS +pimoFlip IN = OUT +pimoFlip OUT = IN + instance AccountBase PIMO where PS <=> IN = True IN <=> PS = True @@ -536,8 +481,8 @@ instance BaseClass AccountTitles where instance ExBaseClass (HatBase AccountTitles) where - getAccountTitle (h :< a) = a - setAccountTitle (h :< a) b = h :< b + getAccountTitle (_ :< a) = a + setAccountTitle (h :< _) b = h :< b -- *** Name only (redundant algebra base) instance BaseClass Name where @@ -559,38 +504,38 @@ -- | Basic BaseClass with 2 elements instance ExBaseClass (HatBase (AccountTitles, Day)) where - getAccountTitle (h:< (a, d)) = a - setAccountTitle (h:< (a, d)) b = h:< (b, d) + getAccountTitle (_:< (a, _)) = a + setAccountTitle (h:< (_, d)) b = h:< (b, d) instance ExBaseClass (HatBase (AccountTitles, Name)) where - getAccountTitle (h:< (a, n)) = a - setAccountTitle (h:< (a, n)) b = h:< (b, n) + getAccountTitle (_:< (a, _)) = a + setAccountTitle (h:< (_, n)) b = h:< (b, n) instance ExBaseClass (HatBase (CountUnit, AccountTitles)) where - getAccountTitle (h:< (u, a)) = a - setAccountTitle (h:< (u, a)) b = h:< (u, b) + getAccountTitle (_:< (_, a)) = a + setAccountTitle (h:< (u, _)) b = h:< (u, b) -- ** 3-element bases -- | Basic BaseClass with 3 elements instance ExBaseClass (HatBase (AccountTitles, Name, CountUnit)) where - getAccountTitle (h:< (a, n, c)) = a - setAccountTitle (h:< (a, n, c)) b = h:< (b, n, c) + getAccountTitle (_:< (a, _, _)) = a + setAccountTitle (h:< (_, n, c)) b = h:< (b, n, c) -- ** 4-element bases -- | Basic BaseClass with 4 elements instance ExBaseClass (HatBase (AccountTitles, Name, CountUnit, Subject)) where - getAccountTitle (h:< (a, n, c, s)) = a - setAccountTitle (h:< (a, n, c, s)) b = h:< (b, n, c, s) + getAccountTitle (_:< (a, _, _, _)) = a + setAccountTitle (h:< (_, n, c, s)) b = h:< (b, n, c, s) -- ** 5-element bases -- | Basic BaseClass with 5 elements instance ExBaseClass (HatBase (AccountTitles, Name, CountUnit, Subject, Day)) where - getAccountTitle (h:< (a, n, c, s, d)) = a - setAccountTitle (h:< (a, n, c, s, d)) b = h:< (b, n, c, s, d) + getAccountTitle (_:< (a, _, _, _, _)) = a + setAccountTitle (h:< (_, n, c, s, d)) b = h:< (b, n, c, s, d) -- ** 6-element bases -- | Basic BaseClass with 6 elements instance ExBaseClass (HatBase (AccountTitles, Name, CountUnit, Subject, Day, TimeOfDay)) where - getAccountTitle (h:< (a, n, c, s, d, t)) = a - setAccountTitle (h:< (a, n, c, s, d, t)) b = h:< (b, n, c, s, d, t) + getAccountTitle (_:< (a, _, _, _, _, _)) = a + setAccountTitle (h:< (_, n, c, s, d, t)) b = h:< (b, n, c, s, d, t) diff --git a/src/ExchangeAlgebra/Algebra/Base/Account/JcciAliases.hs b/src/ExchangeAlgebra/Algebra/Base/Account/JcciAliases.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Algebra/Base/Account/JcciAliases.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +-- Generated by tools/gen-jcci-aliases.py. Do not edit by hand. +module ExchangeAlgebra.Algebra.Base.Account.JcciAliases + ( jcciAliases ) where + +import Data.Text (Text) +import ExchangeAlgebra.Algebra.Base.Element (AccountTitles(..)) + +jcciAliases :: AccountTitles -> [Text] +jcciAliases AccountsPayable = ["〇〇商店", "買掛金"] +jcciAliases AccountsReceivable = ["売掛金", "〇〇商店"] +jcciAliases AccruedConsumptionTax = ["未払金", "未払消費税"] +jcciAliases AccruedCorporateIncomeTaxes = ["未払法人税等"] +jcciAliases AccruedExpenses = ["未払費用", "未払利息"] +jcciAliases AccruedRevenue = ["未収収益", "未収家賃"] +jcciAliases AccumulatedDepreciation = ["建物減価償却累計額", "減価償却累計額", "備品減価償却累計額", "車両運搬具減価償却累計額", "車両減価償却累計額"] +jcciAliases AdditionalIncomeTaxesForPriorPeriods = ["追徴法人税等"] +jcciAliases AdvancesPaid = ["前払金", "前渡金"] +jcciAliases AdvancesReceived = ["前受金", "契約負債"] +jcciAliases AdvertisingExpense = ["広告宣伝費", "広告費", "広告料", "宣伝費"] +jcciAliases AffiliateStocks = ["関係会社株式", "関連会社株式"] +jcciAliases AllowanceForBonuses = ["賞与引当金", "役員賞与引当金"] +jcciAliases AllowanceForDoubtfulAccounts = ["貸倒引当金"] +jcciAliases AllowanceForProductWarranties = ["商品保証引当金", "製品保証引当金"] +jcciAliases AllowanceForRepairs = ["修繕引当金", "特別修繕引当金"] +jcciAliases AllowanceForRetirementBenefits = ["退職給付引当金"] +jcciAliases AmortizationOfGoodwill = ["のれん償却"] +jcciAliases AmortizationOfPatents = ["特許権償却"] +jcciAliases AmortizationOfSoftware = ["ソフトウェア償却"] +jcciAliases AvailableForSaleSecurities = ["投資有価証券", "その他有価証券"] +jcciAliases BadDebtLoss = ["貸倒損失"] +jcciAliases BankOverdraft = ["借入金", "当座借越"] +jcciAliases Bonuses = ["賞与", "役員賞与"] +jcciAliases BonusesPayable = ["未払賞与", "未払役員賞与", "未払賞与金"] +jcciAliases BranchCurrentAccount = ["支店"] +jcciAliases Building = ["建物"] +jcciAliases BusinessCommencementExpenses = ["開業費"] +jcciAliases BusinessTrip = ["旅費交通費", "旅費", "交通費"] +jcciAliases CapitalStock = ["資本金"] +jcciAliases CapitalSurplus = ["資本剰余金"] +jcciAliases Cash = ["現金"] +jcciAliases CashOverShort = ["現金過不足"] +jcciAliases CommunicationExpenses = ["通信費"] +jcciAliases Commutation = ["通信費"] +jcciAliases ConstructionFundReserve = ["新築積立金"] +jcciAliases ConstructionInProgress = ["建設仮勘定", "建設仮", "建設前渡金", "建設仮払金"] +jcciAliases ConsumptionTaxPaid = ["仮払金", "仮払消費税"] +jcciAliases ConsumptionTaxReceived = ["仮受金", "仮受消費税"] +jcciAliases ConsumptionTaxRefundReceivable = ["未収還付消費税", "未収消費税"] +jcciAliases ContraAccountForGuaranteeObligations = ["保証債務見返"] +jcciAliases ContractAssets = ["契約資産"] +jcciAliases CorporateIncomeTaxes = ["法人税、住民税及び事業税", "法人税等"] +jcciAliases CostOfServices = ["役務原価", "営業費用"] +jcciAliases CreditCardReceivable = ["クレジット売掛金"] +jcciAliases CurrentDeposits = ["当座預金", "当座預金○○銀行"] +jcciAliases DeferredTaxAssets = ["繰延税金資産"] +jcciAliases DeferredTaxLiabilities = ["繰延税金負債"] +jcciAliases DeliveryExpenses = ["発送費", "支払運賃", "発送運賃"] +jcciAliases Deposits = ["普通預金", "銀行預金", "普通預金○○銀行"] +jcciAliases DepositsInSpecialAccounts = ["銀行預金", "別段預金"] +jcciAliases DepositsReceived = ["預り金", "従業員預り金", "所得税預り金", "住民税預り金", "社会保険料預り金"] +jcciAliases DepositsReceivedFromOfficers = ["役員預り金"] +jcciAliases Depreciation = ["減価償却費", "建物減価償却費", "備品減価償却費"] +jcciAliases DevelopmentExpenses = ["開発費"] +jcciAliases DishonoredNotesReceivable = ["不渡手形"] +jcciAliases DividendEqualizationReserve = ["配当平均積立金"] +jcciAliases DividendsReceived = ["受取配当金"] +jcciAliases EarnedSurplus = ["利益剰余金"] +jcciAliases ElectronicallyRecordedObligations = ["電子記録債務"] +jcciAliases ElectronicallyRecordedReceivable = ["電子記録債権"] +jcciAliases Fixtures = ["備品"] +jcciAliases ForeignExchangeGains = ["為替差損益", "為替差益"] +jcciAliases ForeignExchangeLosses = ["為替差損益", "為替差損"] +jcciAliases GainOnBargainPurchase = ["負ののれん発生益"] +jcciAliases GainOnConstructionGrants = ["工事負担金受贈益"] +jcciAliases GainOnDonationOfFixedAssets = ["固定資産受贈益"] +jcciAliases GainOnNationalSubsidies = ["国庫補助金受贈益"] +jcciAliases GainOnSalesOfFixedAssets = ["固定資産売却益", "備品売却益", "土地売却益", "建物売却益"] +jcciAliases GainOnSalesOfInvestmentSecurities = ["投資有価証券売却益", "その他有価証券売却益"] +jcciAliases GainOnSalesOfSecurities = ["有価証券売却益", "有価証券売買益", "有価証券運用益"] +jcciAliases GainOnValuationOfSecurities = ["有価証券運用益", "有価証券評価益", "有価証券評価損益", "有価証券運用損益"] +jcciAliases GeneralReserve = ["別途積立金"] +jcciAliases GiftCertificatesReceived = ["受取商品券"] +jcciAliases Goodwill = ["のれん"] +jcciAliases GuaranteeDepositsReceived = ["預り保証金", "受入保証金"] +jcciAliases GuaranteeObligations = ["保証債務"] +jcciAliases HeadOfficeCurrentAccount = ["本店"] +jcciAliases HeldToMaturityBonds = ["満期保有目的債券", "投資有価証券"] +jcciAliases IncomeSummary = ["損益"] +jcciAliases IncomeTaxesAdjustment = ["法人税等調整額"] +jcciAliases IncomeTaxesRefundReceivable = ["未収還付法人税等"] +jcciAliases IncorporationExpenses = ["創立費"] +jcciAliases InsuranceExpense = ["保険料", "支払保険料", "火災保険料"] +jcciAliases InsuranceGain = ["保険差益"] +jcciAliases InterestEarned = ["受取利息"] +jcciAliases InterestExpense = ["支払利息"] +jcciAliases InterestOnSecurities = ["有価証券利息", "受取社債利息"] +jcciAliases InventoryShrinkageLoss = ["棚卸減耗損", "棚卸減耗費"] +jcciAliases InvestmentSecurities = ["投資有価証券"] +jcciAliases Land = ["土地"] +jcciAliases LandRentPaid = ["地代家賃", "支払賃借料", "支払不動産賃借料", "支払地代"] +jcciAliases LandRentReceived = ["受取地代"] +jcciAliases LeaseExpenses = ["支払リース料"] +jcciAliases LeaseObligations = ["リース債務"] +jcciAliases LeasedAssets = ["リース資産"] +jcciAliases LeaseholdRights = ["借地権"] +jcciAliases LegalCapitalSurplus = ["資本準備金", "株式払込剰余金"] +jcciAliases LegalRetainedEarnings = ["利益準備金"] +jcciAliases LoansPayable = ["借入金", "銀行借入金", "役員借入金"] +jcciAliases LoansReceivable = ["貸付金", "従業員貸付金", "役員貸付金"] +jcciAliases LongTermLoansPayable = ["長期借入金"] +jcciAliases LongTermLoansReceivable = ["長期貸付金"] +jcciAliases LongTermOtherPayables = ["長期未払金"] +jcciAliases LongTermPrepaidExpenses = ["長期前払費用"] +jcciAliases LossOnFire = ["火災損失", "災害損失"] +jcciAliases LossOnReductionOfFixedAssets = ["固定資産圧縮損", "備品圧縮損", "建物圧縮損", "機械装置圧縮損"] +jcciAliases LossOnRetirementOfFixedAssets = ["固定資産除却損", "固定資産廃棄損", "備品除却損", "建物除却損", "除却損"] +jcciAliases LossOnSalesOfElectronicallyRecordedReceivables = ["電子記録債権売却損"] +jcciAliases LossOnSalesOfFixedAssets = ["固定資産売却損", "備品売却損", "建物売却損", "土地売却損"] +jcciAliases LossOnSalesOfInvestmentSecurities = ["投資有価証券売却損", "その他有価証券売却損"] +jcciAliases LossOnSalesOfNotesReceivable = ["手形売却損"] +jcciAliases LossOnSalesOfReceivables = ["債権売却損"] +jcciAliases LossOnSalesOfSecurities = ["有価証券売却損", "有価証券売買損", "有価証券運用損"] +jcciAliases LossOnValuationOfMerchandise = ["商品評価損", "棚卸評価損"] +jcciAliases LossOnValuationOfSecurities = ["有価証券運用損", "有価証券評価損", "有価証券評価損益", "有価証券運用損益"] +jcciAliases Machinery = ["機械装置", "機械"] +jcciAliases MaintenanceExpenses = ["保守費", "維持費", "支払メンテナンス料"] +jcciAliases MembershipFees = ["諸会費"] +jcciAliases MerchandiseInventory = ["繰越商品"] +jcciAliases MiscellaneousExpenses = ["雑費"] +jcciAliases MiscellaneousIncome = ["雑益", "雑収入", "雑収益"] +jcciAliases MiscellaneousLoss = ["雑損", "雑損失"] +jcciAliases NetDefinedBenefitAsset = ["退職給付に係る資産"] +jcciAliases NetDefinedBenefitLiability = ["退職給付に係る負債"] +jcciAliases NetIncomeAttributableToNCI = ["非支配株主に帰属する当期純利益"] +jcciAliases NetLossAttributableToNCI = ["非支配株主に帰属する当期純損失"] +jcciAliases NonControllingInterests = ["非支配株主持分"] +jcciAliases NonOperatingElectronicallyRecordedObligations = ["営業外電子記録債務"] +jcciAliases NonOperatingElectronicallyRecordedReceivable = ["営業外電子記録債権"] +jcciAliases NonOperatingNotesPayable = ["営業外支払手形"] +jcciAliases NonOperatingNotesReceivable = ["営業外受取手形"] +jcciAliases NotesLoansPayable = ["借入金", "手形借入金"] +jcciAliases NotesLoansReceivable = ["貸付金", "手形貸付金"] +jcciAliases NotesPayable = ["支払手形"] +jcciAliases NotesReceivable = ["受取手形"] +jcciAliases OperatingExpenses = ["営業費用"] +jcciAliases OperatingRevenue = ["営業収益"] +jcciAliases OtherCapitalSurplus = ["その他資本剰余金"] +jcciAliases OtherPayables = ["未払金"] +jcciAliases OtherReceivables = ["未収入金", "未収金"] +jcciAliases Patent = ["特許権"] +jcciAliases PaymentFees = ["支払手数料", "販売手数料"] +jcciAliases PaymentsOnBehalf = ["立替金", "従業員立替金"] +jcciAliases PettyCash = ["小口現金"] +jcciAliases PrepaidCorporateIncomeTaxes = ["仮払金", "仮払法人税等"] +jcciAliases PrepaidExpenses = ["前払費用", "前払保険料"] +jcciAliases PrepaidPensionCost = ["前払年金費用"] +jcciAliases Products = ["商品"] +jcciAliases PropertyTaxPayable = ["未払固定資産税"] +jcciAliases ProvisionForBonuses = ["賞与引当金繰入", "役員賞与引当金繰入"] +jcciAliases ProvisionForDoubtfulAccounts = ["貸倒引当金繰入", "貸倒引当金繰入額"] +jcciAliases ProvisionForProductWarranties = ["商品保証引当金繰入", "製品保証引当金繰入"] +jcciAliases ProvisionForRepairs = ["修繕引当金繰入", "特別修繕引当金繰入"] +jcciAliases PurchaseRebates = ["仕入割戻"] +jcciAliases Purchases = ["仕入"] +jcciAliases ReceiptFee = ["受取手数料"] +jcciAliases RecoveryOfBadDebts = ["償却債権取立益"] +jcciAliases RefundLiabilities = ["返金負債"] +jcciAliases RefundOfIncomeTaxes = ["還付法人税等"] +jcciAliases RentExpense = ["支払家賃", "地代家賃", "支払賃借料", "支払不動産賃借料"] +jcciAliases RentalIncome = ["受取家賃"] +jcciAliases RepairFundReserve = ["修繕積立金"] +jcciAliases RepairsExpense = ["修繕費", "支払修繕料", "修理費"] +jcciAliases ResearchAndDevelopmentExpenses = ["研究開発費"] +jcciAliases RetainedEarnings = ["繰越利益剰余金"] +jcciAliases RetirementBenefitExpenses = ["退職給付費用", "退職給付引当金繰入", "退職給付引当損"] +jcciAliases ReversalOfAllowanceForDoubtfulAccounts = ["貸倒引当金戻入", "貸倒引当金戻入益"] +jcciAliases ReversalOfAllowanceForProductWarranties = ["商品保証引当金戻入", "製品保証引当金戻入"] +jcciAliases ReversalOfAllowanceForRepairs = ["修繕引当金戻入"] +jcciAliases Sales = ["売上"] +jcciAliases SalesCost = ["売上原価"] +jcciAliases SalesRebates = ["売上割戻"] +jcciAliases Securities = ["有価証券"] +jcciAliases SecurityDepositsPaid = ["差入保証金"] +jcciAliases ServiceRevenue = ["役務収益", "営業収益"] +jcciAliases ShortTermLoansPayable = ["短期借入金"] +jcciAliases ShortTermLoansReceivable = ["短期貸付金"] +jcciAliases Software = ["ソフトウェア"] +jcciAliases SoftwareInProgress = ["ソフトウェア仮勘定"] +jcciAliases StatutoryWelfareExpenses = ["法定福利費", "社会保険料"] +jcciAliases StockIssuanceCosts = ["株式交付費"] +jcciAliases StockSubscriptionDeposits = ["株式申込証拠金", "申込証拠金", "新株式申込証拠金"] +jcciAliases StorageExpenses = ["保管費", "保管料", "倉庫料"] +jcciAliases Structures = ["構築物"] +jcciAliases SubsidiaryStocks = ["子会社株式", "関係会社株式"] +jcciAliases SuppliesExpenses = ["消耗品費", "事務用消耗品費"] +jcciAliases SuppliesOnHand = ["貯蔵品"] +jcciAliases SuspenseAccount = ["未決算", "火災未決算", "保険未決算"] +jcciAliases SuspensePayments = ["仮払金"] +jcciAliases SuspenseReceipts = ["仮受金"] +jcciAliases TaxesExpense = ["租税公課", "公租公課", "固定資産税", "印紙税"] +jcciAliases TimeDeposits = ["銀行預金", "定期預金", "定期預金○○銀行"] +jcciAliases ToolsAndInstruments = ["工具器具"] +jcciAliases Trademark = ["商標権"] +jcciAliases TradingSecurities = ["売買目的有価証券", "有価証券"] +jcciAliases UnearnedRevenue = ["前受収益", "前受地代"] +jcciAliases UnpaidDividends = ["未払配当金", "未払株主配当金"] +jcciAliases UtilitiesExpense = ["水道光熱費", "光熱水費"] +jcciAliases ValuationDifferenceOnOtherSecurities = ["その他有価証券評価差額金"] +jcciAliases Vehicle = ["車両運搬具", "車両", "運搬具"] +jcciAliases WageExpenditure = ["給料", "給料手当", "賃金給料"] +jcciAliases WelfareExpenses = ["福利厚生費"] +jcciAliases WorkInProcess = ["仕掛品"] +jcciAliases _ = [] diff --git a/src/ExchangeAlgebra/Algebra/Base/Account/Registry.hs b/src/ExchangeAlgebra/Algebra/Base/Account/Registry.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Algebra/Base/Account/Registry.hs @@ -0,0 +1,3940 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wincomplete-patterns -Werror=incomplete-patterns #-} +-- The exhaustive registry intentionally retains the deprecated Commutation +-- constructor so that legacy behaviour remains byte-for-byte stable. +{-# OPTIONS_GHC -Wno-deprecations #-} + +{- | +Module : ExchangeAlgebra.Algebra.Base.Account.Registry +Description : Canonical metadata registry for concrete account titles. + +The exhaustive 'accountSpec' case is the single source of truth for account +classification, fixed/current status, and bilingual descriptions. 'accountAliases' +combines its base aliases with the frozen JCCI 2022 standard/permitted-name overlay. +-} +module ExchangeAlgebra.Algebra.Base.Account.Registry + ( AccountSpec(..) + , AccountSemantics(..) + , accountAliases + , accountSpec + , accountSemantics + , accountSpecMap + , concreteAccountTitles + , classifyAccountContra + , accountDescriptions + ) where + +import qualified Data.List as L +import qualified Data.Map.Strict as M +import Data.Map.Strict (Map) +import Data.Maybe (mapMaybe) +import Data.Text (Text) + +import ExchangeAlgebra.Algebra.Base.Account.Types + ( AccountDivision(..), AccountRole(..), ClosingRule(..) + , DivisionSemantics(..), FixedCurrent(..), HomeSideSemantics(..) + , PostingCapability(..), ReportingEligibility(..), Side(..) ) +import ExchangeAlgebra.Algebra.Base.Account.JcciAliases (jcciAliases) +import ExchangeAlgebra.Algebra.Base.Element (AccountTitles(..)) + +-- | All metadata attached to one concrete account title. +data AccountSpec = AccountSpec + { asDivision :: AccountDivision + , asClosing :: ClosingRule + -- ^ Automatic final-stock closing policy. 'NetIncome' and 'NetLoss' are + -- __permanent__ explicit 'NoClose' overrides (adjudicated 2026-08-11): + -- their division encodes the P\/L /presentation side/ (profit sits on + -- the debit side to balance the statement), so the division-derived + -- rule would invert the transfer sign. Their closing is owned by the + -- dedicated net-income transfer pipeline in + -- "ExchangeAlgebra.Algebra.Transfer" (correct signs, engine-inserted + -- balancing postings). GrossProfit and OrdinaryProfit retain + -- CloseByDivision for the historical SNA/simulation transfer pipeline. + -- That asymmetry is compatibility behaviour, not a reporting rule; + -- statement metrics live in "ExchangeAlgebra.Reporting.Metric". + , asIsContra :: Bool + , asFixedCurrent :: FixedCurrent + , asNameEn :: Text + , asNameJa :: Text + -- | Annotation-free Japanese display label (清書和文表示名) used for + -- financial-statement lines + -- ('ExchangeAlgebra.Reporting.Presentation.presentationLabel') and LLM-facing + -- names ('ExchangeAlgebra.Assist.safeNameJa'). Unlike 'asNameJa' it never + -- carries notes, legacy-name + -- remarks, or constructor identifiers; the JCCI level-2 A-column sweep in + -- the test suite pins it against the official standard names. + , asLabelJa :: Text + , asDescription :: Text + -- | Registry-local aliases only. Use 'accountAliases' when constructing a + -- parser or UI: that function also includes the frozen JCCI overlay. + , asAliases :: [Text] + } deriving (Show, Eq) + +-- | Processing and reporting semantics attached to a concrete account title. +-- +-- This record deliberately does not replace 'AccountSpec.asDivision'. The +-- legacy division remains the exchange-algebra direction input, while this +-- layer states whether that value is a financial-statement classification, +-- a bookkeeping control class, or only an internal direction encoding. +data AccountSemantics = AccountSemantics + { asemRoles :: [AccountRole] + , asemPostingCapability :: PostingCapability + , asemDivisionSemantics :: DivisionSemantics + , asemHomeSideSemantics :: HomeSideSemantics + , asemReportingEligibility :: ReportingEligibility + } deriving (Show, Eq) + +-- | All concrete account titles in their stable Enum order. +concreteAccountTitles :: [AccountTitles] +concreteAccountTitles = filter (/= AccountTitle) [minBound .. maxBound] + +-- | Look up processing and reporting semantics for a concrete account title. +-- The wildcard 'AccountTitle' is outside the metadata domain and returns +-- 'Nothing' explicitly. +accountSemantics :: AccountTitles -> Maybe AccountSemantics +accountSemantics title = do + spec <- accountSpec title + pure AccountSemantics + { asemRoles = rolesFor title spec + , asemPostingCapability = postingFor title + , asemDivisionSemantics = divisionFor title spec + , asemHomeSideSemantics = homeSideFor title spec + , asemReportingEligibility = reportingFor title + } + +rolesFor :: AccountTitles -> AccountSpec -> [AccountRole] +rolesFor title _ = case title of + Cash -> [OrdinaryAccount] + Deposits -> [OrdinaryAccount] + CurrentDeposits -> [OrdinaryAccount] + Securities -> [OrdinaryAccount] + InvestmentSecurities -> [OrdinaryAccount] + InvestmentInAssociate -> [OrdinaryAccount] + LongTermNationalBonds -> [OrdinaryAccount] + ShortTermNationalBonds -> [OrdinaryAccount] + Products -> [OrdinaryAccount] + Machinery -> [OrdinaryAccount] + Building -> [OrdinaryAccount] + Vehicle -> [OrdinaryAccount] + StockInvestment -> [OrdinaryAccount] + EquipmentInvestment -> [OrdinaryAccount] + LongTermLoansReceivable -> [OrdinaryAccount] + AccountsReceivable -> [OrdinaryAccount] + ShortTermLoansReceivable -> [OrdinaryAccount] + ReserveDepositReceivable -> [OrdinaryAccount] + Gold -> [OrdinaryAccount] + GovernmentService -> [OrdinaryAccount] + CapitalStock -> [OrdinaryAccount] + RetainedEarnings -> [OrdinaryAccount] + LongTermLoansPayable -> [OrdinaryAccount] + ShortTermLoansPayable -> [OrdinaryAccount] + LoansPayable -> [OrdinaryAccount] + ReserveForDepreciation -> [OrdinaryAccount] + DepositPayable -> [OrdinaryAccount] + LongTermNationalBondsPayable -> [OrdinaryAccount] + ShortTermNationalBondsPayable -> [OrdinaryAccount] + ReserveDepositPayable -> [OrdinaryAccount] + CentralBankNotePayable -> [OrdinaryAccount] + Depreciation -> [OrdinaryAccount] + AmortizationExpense -> [OrdinaryAccount] + SalesCost -> [OrdinaryAccount] + BusinessTrip -> [OrdinaryAccount] + Commutation -> [OrdinaryAccount] + UtilitiesExpense -> [OrdinaryAccount] + RentExpense -> [OrdinaryAccount] + AdvertisingExpense -> [OrdinaryAccount] + DeliveryExpenses -> [OrdinaryAccount] + SuppliesExpenses -> [OrdinaryAccount] + MiscellaneousExpenses -> [OrdinaryAccount] + WageExpenditure -> [OrdinaryAccount] + InterestExpense -> [OrdinaryAccount] + TaxesExpense -> [OrdinaryAccount] + ConsumptionExpenditure -> [OrdinaryAccount] + SubsidyExpense -> [OrdinaryAccount] + CentralBankPaymentExpense -> [OrdinaryAccount] + Purchases -> [OrdinaryAccount] + NetIncome -> [PeriodResult] + ValueAdded -> [OrdinaryAccount] + SubsidyIncome -> [OrdinaryAccount] + NationalBondInterestEarned -> [OrdinaryAccount] + DepositInterestEarned -> [OrdinaryAccount] + GrossProfit -> [ReportingSubtotal] + OrdinaryProfit -> [ReportingSubtotal] + InterestEarned -> [OrdinaryAccount] + ReceiptFee -> [OrdinaryAccount] + RentalIncome -> [OrdinaryAccount] + WageEarned -> [OrdinaryAccount] + TaxesRevenue -> [OrdinaryAccount] + CentralBankPaymentIncome -> [OrdinaryAccount] + Sales -> [OrdinaryAccount] + EquityInEarningsOfInvestee -> [OrdinaryAccount] + NetLoss -> [PeriodResult] + PettyCash -> [OrdinaryAccount] + NotesReceivable -> [OrdinaryAccount] + ElectronicallyRecordedReceivable -> [OrdinaryAccount] + CreditCardReceivable -> [OrdinaryAccount] + NotesLoansReceivable -> [OrdinaryAccount] + MerchandiseInventory -> [OrdinaryAccount] + AdvancesPaid -> [OrdinaryAccount] + PrepaidExpenses -> [OrdinaryAccount] + AccruedRevenue -> [OrdinaryAccount] + OtherReceivables -> [OrdinaryAccount] + PaymentsOnBehalf -> [OrdinaryAccount] + SuspensePayments -> [SuspenseOrClearingAccount] + ConsumptionTaxPaid -> [OrdinaryAccount] + PrepaidCorporateIncomeTaxes -> [OrdinaryAccount] + Land -> [OrdinaryAccount] + Fixtures -> [OrdinaryAccount] + Patent -> [OrdinaryAccount] + Trademark -> [OrdinaryAccount] + Software -> [OrdinaryAccount] + CashOverShort -> [SuspenseOrClearingAccount] + AccountsPayable -> [OrdinaryAccount] + NotesPayable -> [OrdinaryAccount] + ElectronicallyRecordedObligations -> [OrdinaryAccount] + NotesLoansPayable -> [OrdinaryAccount] + BankOverdraft -> [OrdinaryAccount] + AdvancesReceived -> [OrdinaryAccount] + UnearnedRevenue -> [OrdinaryAccount] + AccruedExpenses -> [OrdinaryAccount] + OtherPayables -> [OrdinaryAccount] + DepositsReceived -> [OrdinaryAccount] + SuspenseReceipts -> [SuspenseOrClearingAccount] + ConsumptionTaxReceived -> [OrdinaryAccount] + AccruedConsumptionTax -> [OrdinaryAccount] + AccruedCorporateIncomeTaxes -> [OrdinaryAccount] + UnpaidDividends -> [OrdinaryAccount] + AllowanceForDoubtfulAccounts -> [OrdinaryAccount, ContraAccount] + AccumulatedDepreciation -> [OrdinaryAccount, ContraAccount] + LegalRetainedEarnings -> [OrdinaryAccount] + CumulativeTranslationAdjustment -> [OrdinaryAccount] + ProvisionForDoubtfulAccounts -> [OrdinaryAccount] + BadDebtLoss -> [OrdinaryAccount] + LossOnSalesOfFixedAssets -> [OrdinaryAccount] + LossOnSalesOfNotesReceivable -> [OrdinaryAccount] + PaymentFees -> [OrdinaryAccount] + MiscellaneousLoss -> [OrdinaryAccount] + CorporateIncomeTaxes -> [OrdinaryAccount] + CommunicationExpenses -> [OrdinaryAccount] + GainOnSalesOfFixedAssets -> [OrdinaryAccount] + RecoveryOfBadDebts -> [OrdinaryAccount] + MiscellaneousIncome -> [OrdinaryAccount] + ReversalOfAllowanceForDoubtfulAccounts -> [OrdinaryAccount] + TimeDeposits -> [OrdinaryAccount] + LoansReceivable -> [OrdinaryAccount] + GiftCertificatesReceived -> [OrdinaryAccount] + SecurityDepositsPaid -> [OrdinaryAccount] + SuppliesOnHand -> [OrdinaryAccount] + ContractAssets -> [OrdinaryAccount] + IncomeTaxesRefundReceivable -> [OrdinaryAccount] + WorkInProcess -> [OrdinaryAccount] + DeferredTaxAssets -> [OrdinaryAccount] + LeasedAssets -> [OrdinaryAccount] + ToolsAndInstruments -> [OrdinaryAccount] + ConstructionInProgress -> [OrdinaryAccount] + Goodwill -> [OrdinaryAccount] + SoftwareInProgress -> [OrdinaryAccount] + LongTermPrepaidExpenses -> [OrdinaryAccount] + DishonoredNotesReceivable -> [OrdinaryAccount] + PrepaidPensionCost -> [OrdinaryAccount] + NetDefinedBenefitAsset -> [OrdinaryAccount] + DepositsInSpecialAccounts -> [OrdinaryAccount] + Structures -> [OrdinaryAccount] + LeaseholdRights -> [OrdinaryAccount] + NonOperatingNotesReceivable -> [OrdinaryAccount] + NonOperatingElectronicallyRecordedReceivable -> [OrdinaryAccount] + RefundLiabilities -> [OrdinaryAccount] + NonOperatingNotesPayable -> [OrdinaryAccount] + NonOperatingElectronicallyRecordedObligations -> [OrdinaryAccount] + BonusesPayable -> [OrdinaryAccount] + AllowanceForRepairs -> [OrdinaryAccount] + AllowanceForProductWarranties -> [OrdinaryAccount] + AllowanceForBonuses -> [OrdinaryAccount] + DeferredTaxLiabilities -> [OrdinaryAccount] + LeaseObligations -> [OrdinaryAccount] + GuaranteeDepositsReceived -> [OrdinaryAccount] + AllowanceForRetirementBenefits -> [OrdinaryAccount] + LongTermOtherPayables -> [OrdinaryAccount] + NetDefinedBenefitLiability -> [OrdinaryAccount] + StockSubscriptionDeposits -> [OrdinaryAccount] + LegalCapitalSurplus -> [OrdinaryAccount] + OtherCapitalSurplus -> [OrdinaryAccount] + DividendEqualizationReserve -> [OrdinaryAccount] + RepairFundReserve -> [OrdinaryAccount] + ConstructionFundReserve -> [OrdinaryAccount] + GeneralReserve -> [OrdinaryAccount] + ValuationDifferenceOnOtherSecurities -> [OrdinaryAccount] + NonControllingInterests -> [AttributionAccount] + CapitalSurplus -> [OrdinaryAccount] + EarnedSurplus -> [OrdinaryAccount] + ServiceRevenue -> [OrdinaryAccount] + OperatingRevenue -> [OrdinaryAccount] + GainOnSalesOfSecurities -> [OrdinaryAccount] + GainOnValuationOfSecurities -> [OrdinaryAccount] + DividendsReceived -> [OrdinaryAccount] + InterestOnSecurities -> [OrdinaryAccount] + GainOnSalesOfInvestmentSecurities -> [OrdinaryAccount] + InsuranceGain -> [OrdinaryAccount] + GainOnBargainPurchase -> [OrdinaryAccount] + ReversalOfAllowanceForRepairs -> [OrdinaryAccount] + ReversalOfAllowanceForProductWarranties -> [OrdinaryAccount] + GainOnDonationOfFixedAssets -> [OrdinaryAccount] + GainOnNationalSubsidies -> [OrdinaryAccount] + GainOnConstructionGrants -> [OrdinaryAccount] + LandRentReceived -> [OrdinaryAccount] + SalesRebates -> [OrdinaryAccount, ContraAccount] + CostOfServices -> [OrdinaryAccount] + OperatingExpenses -> [OrdinaryAccount] + InventoryShrinkageLoss -> [OrdinaryAccount] + LossOnValuationOfMerchandise -> [OrdinaryAccount] + Bonuses -> [OrdinaryAccount] + RetirementBenefitExpenses -> [OrdinaryAccount] + ProvisionForRepairs -> [OrdinaryAccount] + ProvisionForBonuses -> [OrdinaryAccount] + ProvisionForProductWarranties -> [OrdinaryAccount] + ResearchAndDevelopmentExpenses -> [OrdinaryAccount] + AmortizationOfGoodwill -> [OrdinaryAccount] + AmortizationOfSoftware -> [OrdinaryAccount] + AmortizationOfPatents -> [OrdinaryAccount] + LeaseExpenses -> [OrdinaryAccount] + IncorporationExpenses -> [OrdinaryAccount] + StockIssuanceCosts -> [OrdinaryAccount] + BusinessCommencementExpenses -> [OrdinaryAccount] + DevelopmentExpenses -> [OrdinaryAccount] + LossOnSalesOfElectronicallyRecordedReceivables -> [OrdinaryAccount] + LossOnSalesOfReceivables -> [OrdinaryAccount] + LossOnSalesOfSecurities -> [OrdinaryAccount] + LossOnValuationOfSecurities -> [OrdinaryAccount] + LossOnSalesOfInvestmentSecurities -> [OrdinaryAccount] + LossOnFire -> [OrdinaryAccount] + LossOnRetirementOfFixedAssets -> [OrdinaryAccount] + LossOnReductionOfFixedAssets -> [OrdinaryAccount] + AdditionalIncomeTaxesForPriorPeriods -> [OrdinaryAccount] + RefundOfIncomeTaxes -> [OrdinaryAccount, ContraAccount] + PurchaseRebates -> [OrdinaryAccount, ContraAccount] + WelfareExpenses -> [OrdinaryAccount] + MaintenanceExpenses -> [OrdinaryAccount] + StatutoryWelfareExpenses -> [OrdinaryAccount] + LandRentPaid -> [OrdinaryAccount] + InsuranceExpense -> [OrdinaryAccount] + RepairsExpense -> [OrdinaryAccount] + StorageExpenses -> [OrdinaryAccount] + MembershipFees -> [OrdinaryAccount] + IncomeSummary -> [ClosingDevice] + SuspenseAccount -> [SuspenseOrClearingAccount] + ForeignExchangeGains -> [OrdinaryAccount] + ForeignExchangeLosses -> [OrdinaryAccount] + ContraAccountForGuaranteeObligations -> [OrdinaryAccount] + GuaranteeObligations -> [OrdinaryAccount] + IncomeTaxesAdjustment -> [OrdinaryAccount] + BranchCurrentAccount -> [ReciprocalAccount] + HeadOfficeCurrentAccount -> [ReciprocalAccount] + NetIncomeAttributableToNCI -> [AttributionAccount, PeriodResult] + NetLossAttributableToNCI -> [AttributionAccount, PeriodResult] + TradingSecurities -> [OrdinaryAccount] + HeldToMaturityBonds -> [OrdinaryAccount] + SubsidiaryStocks -> [OrdinaryAccount] + AffiliateStocks -> [OrdinaryAccount] + AvailableForSaleSecurities -> [OrdinaryAccount] + ConsumptionTaxRefundReceivable -> [OrdinaryAccount] + PropertyTaxPayable -> [OrdinaryAccount] + DepositsReceivedFromOfficers -> [OrdinaryAccount] + AccountTitle -> [OrdinaryAccount] + +postingFor :: AccountTitles -> PostingCapability +postingFor title = case title of + Cash -> OrdinaryPosting + Deposits -> OrdinaryPosting + CurrentDeposits -> OrdinaryPosting + Securities -> OrdinaryPosting + InvestmentSecurities -> OrdinaryPosting + InvestmentInAssociate -> OrdinaryPosting + LongTermNationalBonds -> OrdinaryPosting + ShortTermNationalBonds -> OrdinaryPosting + Products -> OrdinaryPosting + Machinery -> OrdinaryPosting + Building -> OrdinaryPosting + Vehicle -> OrdinaryPosting + StockInvestment -> OrdinaryPosting + EquipmentInvestment -> OrdinaryPosting + LongTermLoansReceivable -> OrdinaryPosting + AccountsReceivable -> OrdinaryPosting + ShortTermLoansReceivable -> OrdinaryPosting + ReserveDepositReceivable -> OrdinaryPosting + Gold -> OrdinaryPosting + GovernmentService -> OrdinaryPosting + CapitalStock -> OrdinaryPosting + RetainedEarnings -> OrdinaryPosting + LongTermLoansPayable -> OrdinaryPosting + ShortTermLoansPayable -> OrdinaryPosting + LoansPayable -> OrdinaryPosting + ReserveForDepreciation -> OrdinaryPosting + DepositPayable -> OrdinaryPosting + LongTermNationalBondsPayable -> OrdinaryPosting + ShortTermNationalBondsPayable -> OrdinaryPosting + ReserveDepositPayable -> OrdinaryPosting + CentralBankNotePayable -> OrdinaryPosting + Depreciation -> OrdinaryPosting + AmortizationExpense -> OrdinaryPosting + SalesCost -> OrdinaryPosting + BusinessTrip -> OrdinaryPosting + Commutation -> OrdinaryPosting + UtilitiesExpense -> OrdinaryPosting + RentExpense -> OrdinaryPosting + AdvertisingExpense -> OrdinaryPosting + DeliveryExpenses -> OrdinaryPosting + SuppliesExpenses -> OrdinaryPosting + MiscellaneousExpenses -> OrdinaryPosting + WageExpenditure -> OrdinaryPosting + InterestExpense -> OrdinaryPosting + TaxesExpense -> OrdinaryPosting + ConsumptionExpenditure -> OrdinaryPosting + SubsidyExpense -> OrdinaryPosting + CentralBankPaymentExpense -> OrdinaryPosting + Purchases -> OrdinaryPosting + NetIncome -> EngineGeneratedOnly + ValueAdded -> OrdinaryPosting + SubsidyIncome -> OrdinaryPosting + NationalBondInterestEarned -> OrdinaryPosting + DepositInterestEarned -> OrdinaryPosting + GrossProfit -> EngineGeneratedOnly + OrdinaryProfit -> EngineGeneratedOnly + InterestEarned -> OrdinaryPosting + ReceiptFee -> OrdinaryPosting + RentalIncome -> OrdinaryPosting + WageEarned -> OrdinaryPosting + TaxesRevenue -> OrdinaryPosting + CentralBankPaymentIncome -> OrdinaryPosting + Sales -> OrdinaryPosting + EquityInEarningsOfInvestee -> ConsolidationOnly + NetLoss -> EngineGeneratedOnly + PettyCash -> OrdinaryPosting + NotesReceivable -> OrdinaryPosting + ElectronicallyRecordedReceivable -> OrdinaryPosting + CreditCardReceivable -> OrdinaryPosting + NotesLoansReceivable -> OrdinaryPosting + MerchandiseInventory -> OrdinaryPosting + AdvancesPaid -> OrdinaryPosting + PrepaidExpenses -> OrdinaryPosting + AccruedRevenue -> OrdinaryPosting + OtherReceivables -> OrdinaryPosting + PaymentsOnBehalf -> OrdinaryPosting + SuspensePayments -> OrdinaryPosting + ConsumptionTaxPaid -> OrdinaryPosting + PrepaidCorporateIncomeTaxes -> OrdinaryPosting + Land -> OrdinaryPosting + Fixtures -> OrdinaryPosting + Patent -> OrdinaryPosting + Trademark -> OrdinaryPosting + Software -> OrdinaryPosting + CashOverShort -> OrdinaryPosting + AccountsPayable -> OrdinaryPosting + NotesPayable -> OrdinaryPosting + ElectronicallyRecordedObligations -> OrdinaryPosting + NotesLoansPayable -> OrdinaryPosting + BankOverdraft -> OrdinaryPosting + AdvancesReceived -> OrdinaryPosting + UnearnedRevenue -> OrdinaryPosting + AccruedExpenses -> OrdinaryPosting + OtherPayables -> OrdinaryPosting + DepositsReceived -> OrdinaryPosting + SuspenseReceipts -> OrdinaryPosting + ConsumptionTaxReceived -> OrdinaryPosting + AccruedConsumptionTax -> OrdinaryPosting + AccruedCorporateIncomeTaxes -> OrdinaryPosting + UnpaidDividends -> OrdinaryPosting + AllowanceForDoubtfulAccounts -> OrdinaryPosting + AccumulatedDepreciation -> OrdinaryPosting + LegalRetainedEarnings -> OrdinaryPosting + CumulativeTranslationAdjustment -> ConsolidationOnly + ProvisionForDoubtfulAccounts -> OrdinaryPosting + BadDebtLoss -> OrdinaryPosting + LossOnSalesOfFixedAssets -> OrdinaryPosting + LossOnSalesOfNotesReceivable -> OrdinaryPosting + PaymentFees -> OrdinaryPosting + MiscellaneousLoss -> OrdinaryPosting + CorporateIncomeTaxes -> OrdinaryPosting + CommunicationExpenses -> OrdinaryPosting + GainOnSalesOfFixedAssets -> OrdinaryPosting + RecoveryOfBadDebts -> OrdinaryPosting + MiscellaneousIncome -> OrdinaryPosting + ReversalOfAllowanceForDoubtfulAccounts -> OrdinaryPosting + TimeDeposits -> OrdinaryPosting + LoansReceivable -> OrdinaryPosting + GiftCertificatesReceived -> OrdinaryPosting + SecurityDepositsPaid -> OrdinaryPosting + SuppliesOnHand -> OrdinaryPosting + ContractAssets -> OrdinaryPosting + IncomeTaxesRefundReceivable -> OrdinaryPosting + WorkInProcess -> OrdinaryPosting + DeferredTaxAssets -> OrdinaryPosting + LeasedAssets -> OrdinaryPosting + ToolsAndInstruments -> OrdinaryPosting + ConstructionInProgress -> OrdinaryPosting + Goodwill -> OrdinaryPosting + SoftwareInProgress -> OrdinaryPosting + LongTermPrepaidExpenses -> OrdinaryPosting + DishonoredNotesReceivable -> OrdinaryPosting + PrepaidPensionCost -> OrdinaryPosting + NetDefinedBenefitAsset -> OrdinaryPosting + DepositsInSpecialAccounts -> OrdinaryPosting + Structures -> OrdinaryPosting + LeaseholdRights -> OrdinaryPosting + NonOperatingNotesReceivable -> OrdinaryPosting + NonOperatingElectronicallyRecordedReceivable -> OrdinaryPosting + RefundLiabilities -> OrdinaryPosting + NonOperatingNotesPayable -> OrdinaryPosting + NonOperatingElectronicallyRecordedObligations -> OrdinaryPosting + BonusesPayable -> OrdinaryPosting + AllowanceForRepairs -> OrdinaryPosting + AllowanceForProductWarranties -> OrdinaryPosting + AllowanceForBonuses -> OrdinaryPosting + DeferredTaxLiabilities -> OrdinaryPosting + LeaseObligations -> OrdinaryPosting + GuaranteeDepositsReceived -> OrdinaryPosting + AllowanceForRetirementBenefits -> OrdinaryPosting + LongTermOtherPayables -> OrdinaryPosting + NetDefinedBenefitLiability -> OrdinaryPosting + StockSubscriptionDeposits -> OrdinaryPosting + LegalCapitalSurplus -> OrdinaryPosting + OtherCapitalSurplus -> OrdinaryPosting + DividendEqualizationReserve -> OrdinaryPosting + RepairFundReserve -> OrdinaryPosting + ConstructionFundReserve -> OrdinaryPosting + GeneralReserve -> OrdinaryPosting + ValuationDifferenceOnOtherSecurities -> OrdinaryPosting + NonControllingInterests -> ConsolidationOnly + CapitalSurplus -> OrdinaryPosting + EarnedSurplus -> OrdinaryPosting + ServiceRevenue -> OrdinaryPosting + OperatingRevenue -> OrdinaryPosting + GainOnSalesOfSecurities -> OrdinaryPosting + GainOnValuationOfSecurities -> OrdinaryPosting + DividendsReceived -> OrdinaryPosting + InterestOnSecurities -> OrdinaryPosting + GainOnSalesOfInvestmentSecurities -> OrdinaryPosting + InsuranceGain -> OrdinaryPosting + GainOnBargainPurchase -> OrdinaryPosting + ReversalOfAllowanceForRepairs -> OrdinaryPosting + ReversalOfAllowanceForProductWarranties -> OrdinaryPosting + GainOnDonationOfFixedAssets -> OrdinaryPosting + GainOnNationalSubsidies -> OrdinaryPosting + GainOnConstructionGrants -> OrdinaryPosting + LandRentReceived -> OrdinaryPosting + SalesRebates -> OrdinaryPosting + CostOfServices -> OrdinaryPosting + OperatingExpenses -> OrdinaryPosting + InventoryShrinkageLoss -> OrdinaryPosting + LossOnValuationOfMerchandise -> OrdinaryPosting + Bonuses -> OrdinaryPosting + RetirementBenefitExpenses -> OrdinaryPosting + ProvisionForRepairs -> OrdinaryPosting + ProvisionForBonuses -> OrdinaryPosting + ProvisionForProductWarranties -> OrdinaryPosting + ResearchAndDevelopmentExpenses -> OrdinaryPosting + AmortizationOfGoodwill -> OrdinaryPosting + AmortizationOfSoftware -> OrdinaryPosting + AmortizationOfPatents -> OrdinaryPosting + LeaseExpenses -> OrdinaryPosting + IncorporationExpenses -> OrdinaryPosting + StockIssuanceCosts -> OrdinaryPosting + BusinessCommencementExpenses -> OrdinaryPosting + DevelopmentExpenses -> OrdinaryPosting + LossOnSalesOfElectronicallyRecordedReceivables -> OrdinaryPosting + LossOnSalesOfReceivables -> OrdinaryPosting + LossOnSalesOfSecurities -> OrdinaryPosting + LossOnValuationOfSecurities -> OrdinaryPosting + LossOnSalesOfInvestmentSecurities -> OrdinaryPosting + LossOnFire -> OrdinaryPosting + LossOnRetirementOfFixedAssets -> OrdinaryPosting + LossOnReductionOfFixedAssets -> OrdinaryPosting + AdditionalIncomeTaxesForPriorPeriods -> OrdinaryPosting + RefundOfIncomeTaxes -> OrdinaryPosting + PurchaseRebates -> OrdinaryPosting + WelfareExpenses -> OrdinaryPosting + MaintenanceExpenses -> OrdinaryPosting + StatutoryWelfareExpenses -> OrdinaryPosting + LandRentPaid -> OrdinaryPosting + InsuranceExpense -> OrdinaryPosting + RepairsExpense -> OrdinaryPosting + StorageExpenses -> OrdinaryPosting + MembershipFees -> OrdinaryPosting + IncomeSummary -> ClosingOnly + SuspenseAccount -> OrdinaryPosting + ForeignExchangeGains -> OrdinaryPosting + ForeignExchangeLosses -> OrdinaryPosting + ContraAccountForGuaranteeObligations -> OrdinaryPosting + GuaranteeObligations -> OrdinaryPosting + IncomeTaxesAdjustment -> OrdinaryPosting + BranchCurrentAccount -> OrdinaryPosting + HeadOfficeCurrentAccount -> OrdinaryPosting + NetIncomeAttributableToNCI -> ConsolidationOnly + NetLossAttributableToNCI -> ConsolidationOnly + TradingSecurities -> OrdinaryPosting + HeldToMaturityBonds -> OrdinaryPosting + SubsidiaryStocks -> OrdinaryPosting + AffiliateStocks -> OrdinaryPosting + AvailableForSaleSecurities -> OrdinaryPosting + ConsumptionTaxRefundReceivable -> OrdinaryPosting + PropertyTaxPayable -> OrdinaryPosting + DepositsReceivedFromOfficers -> OrdinaryPosting + AccountTitle -> NotPostable + +divisionFor :: AccountTitles -> AccountSpec -> DivisionSemantics +divisionFor title spec = case title of + Cash -> StatementDivision (asDivision spec) + Deposits -> StatementDivision (asDivision spec) + CurrentDeposits -> StatementDivision (asDivision spec) + Securities -> StatementDivision (asDivision spec) + InvestmentSecurities -> StatementDivision (asDivision spec) + InvestmentInAssociate -> StatementDivision (asDivision spec) + LongTermNationalBonds -> StatementDivision (asDivision spec) + ShortTermNationalBonds -> StatementDivision (asDivision spec) + Products -> StatementDivision (asDivision spec) + Machinery -> StatementDivision (asDivision spec) + Building -> StatementDivision (asDivision spec) + Vehicle -> StatementDivision (asDivision spec) + StockInvestment -> StatementDivision (asDivision spec) + EquipmentInvestment -> StatementDivision (asDivision spec) + LongTermLoansReceivable -> StatementDivision (asDivision spec) + AccountsReceivable -> StatementDivision (asDivision spec) + ShortTermLoansReceivable -> StatementDivision (asDivision spec) + ReserveDepositReceivable -> StatementDivision (asDivision spec) + Gold -> StatementDivision (asDivision spec) + GovernmentService -> StatementDivision (asDivision spec) + CapitalStock -> StatementDivision (asDivision spec) + RetainedEarnings -> StatementDivision (asDivision spec) + LongTermLoansPayable -> StatementDivision (asDivision spec) + ShortTermLoansPayable -> StatementDivision (asDivision spec) + LoansPayable -> StatementDivision (asDivision spec) + ReserveForDepreciation -> StatementDivision (asDivision spec) + DepositPayable -> StatementDivision (asDivision spec) + LongTermNationalBondsPayable -> StatementDivision (asDivision spec) + ShortTermNationalBondsPayable -> StatementDivision (asDivision spec) + ReserveDepositPayable -> StatementDivision (asDivision spec) + CentralBankNotePayable -> StatementDivision (asDivision spec) + Depreciation -> StatementDivision (asDivision spec) + AmortizationExpense -> StatementDivision (asDivision spec) + SalesCost -> StatementDivision (asDivision spec) + BusinessTrip -> StatementDivision (asDivision spec) + Commutation -> StatementDivision (asDivision spec) + UtilitiesExpense -> StatementDivision (asDivision spec) + RentExpense -> StatementDivision (asDivision spec) + AdvertisingExpense -> StatementDivision (asDivision spec) + DeliveryExpenses -> StatementDivision (asDivision spec) + SuppliesExpenses -> StatementDivision (asDivision spec) + MiscellaneousExpenses -> StatementDivision (asDivision spec) + WageExpenditure -> StatementDivision (asDivision spec) + InterestExpense -> StatementDivision (asDivision spec) + TaxesExpense -> StatementDivision (asDivision spec) + ConsumptionExpenditure -> StatementDivision (asDivision spec) + SubsidyExpense -> StatementDivision (asDivision spec) + CentralBankPaymentExpense -> StatementDivision (asDivision spec) + Purchases -> StatementDivision (asDivision spec) + NetIncome -> DirectionEncoding (asDivision spec) + ValueAdded -> StatementDivision (asDivision spec) + SubsidyIncome -> StatementDivision (asDivision spec) + NationalBondInterestEarned -> StatementDivision (asDivision spec) + DepositInterestEarned -> StatementDivision (asDivision spec) + GrossProfit -> DirectionEncoding (asDivision spec) + OrdinaryProfit -> DirectionEncoding (asDivision spec) + InterestEarned -> StatementDivision (asDivision spec) + ReceiptFee -> StatementDivision (asDivision spec) + RentalIncome -> StatementDivision (asDivision spec) + WageEarned -> StatementDivision (asDivision spec) + TaxesRevenue -> StatementDivision (asDivision spec) + CentralBankPaymentIncome -> StatementDivision (asDivision spec) + Sales -> StatementDivision (asDivision spec) + EquityInEarningsOfInvestee -> StatementDivision (asDivision spec) + NetLoss -> DirectionEncoding (asDivision spec) + PettyCash -> StatementDivision (asDivision spec) + NotesReceivable -> StatementDivision (asDivision spec) + ElectronicallyRecordedReceivable -> StatementDivision (asDivision spec) + CreditCardReceivable -> StatementDivision (asDivision spec) + NotesLoansReceivable -> StatementDivision (asDivision spec) + MerchandiseInventory -> StatementDivision (asDivision spec) + AdvancesPaid -> StatementDivision (asDivision spec) + PrepaidExpenses -> StatementDivision (asDivision spec) + AccruedRevenue -> StatementDivision (asDivision spec) + OtherReceivables -> StatementDivision (asDivision spec) + PaymentsOnBehalf -> StatementDivision (asDivision spec) + SuspensePayments -> BookkeepingControlClass (asDivision spec) + ConsumptionTaxPaid -> StatementDivision (asDivision spec) + PrepaidCorporateIncomeTaxes -> StatementDivision (asDivision spec) + Land -> StatementDivision (asDivision spec) + Fixtures -> StatementDivision (asDivision spec) + Patent -> StatementDivision (asDivision spec) + Trademark -> StatementDivision (asDivision spec) + Software -> StatementDivision (asDivision spec) + CashOverShort -> BookkeepingControlClass (asDivision spec) + AccountsPayable -> StatementDivision (asDivision spec) + NotesPayable -> StatementDivision (asDivision spec) + ElectronicallyRecordedObligations -> StatementDivision (asDivision spec) + NotesLoansPayable -> StatementDivision (asDivision spec) + BankOverdraft -> StatementDivision (asDivision spec) + AdvancesReceived -> StatementDivision (asDivision spec) + UnearnedRevenue -> StatementDivision (asDivision spec) + AccruedExpenses -> StatementDivision (asDivision spec) + OtherPayables -> StatementDivision (asDivision spec) + DepositsReceived -> StatementDivision (asDivision spec) + SuspenseReceipts -> BookkeepingControlClass (asDivision spec) + ConsumptionTaxReceived -> StatementDivision (asDivision spec) + AccruedConsumptionTax -> StatementDivision (asDivision spec) + AccruedCorporateIncomeTaxes -> StatementDivision (asDivision spec) + UnpaidDividends -> StatementDivision (asDivision spec) + AllowanceForDoubtfulAccounts -> StatementDivision (asDivision spec) + AccumulatedDepreciation -> StatementDivision (asDivision spec) + LegalRetainedEarnings -> StatementDivision (asDivision spec) + CumulativeTranslationAdjustment -> StatementDivision (asDivision spec) + ProvisionForDoubtfulAccounts -> StatementDivision (asDivision spec) + BadDebtLoss -> StatementDivision (asDivision spec) + LossOnSalesOfFixedAssets -> StatementDivision (asDivision spec) + LossOnSalesOfNotesReceivable -> StatementDivision (asDivision spec) + PaymentFees -> StatementDivision (asDivision spec) + MiscellaneousLoss -> StatementDivision (asDivision spec) + CorporateIncomeTaxes -> StatementDivision (asDivision spec) + CommunicationExpenses -> StatementDivision (asDivision spec) + GainOnSalesOfFixedAssets -> StatementDivision (asDivision spec) + RecoveryOfBadDebts -> StatementDivision (asDivision spec) + MiscellaneousIncome -> StatementDivision (asDivision spec) + ReversalOfAllowanceForDoubtfulAccounts -> StatementDivision (asDivision spec) + TimeDeposits -> StatementDivision (asDivision spec) + LoansReceivable -> StatementDivision (asDivision spec) + GiftCertificatesReceived -> StatementDivision (asDivision spec) + SecurityDepositsPaid -> StatementDivision (asDivision spec) + SuppliesOnHand -> StatementDivision (asDivision spec) + ContractAssets -> StatementDivision (asDivision spec) + IncomeTaxesRefundReceivable -> StatementDivision (asDivision spec) + WorkInProcess -> StatementDivision (asDivision spec) + DeferredTaxAssets -> StatementDivision (asDivision spec) + LeasedAssets -> StatementDivision (asDivision spec) + ToolsAndInstruments -> StatementDivision (asDivision spec) + ConstructionInProgress -> StatementDivision (asDivision spec) + Goodwill -> StatementDivision (asDivision spec) + SoftwareInProgress -> StatementDivision (asDivision spec) + LongTermPrepaidExpenses -> StatementDivision (asDivision spec) + DishonoredNotesReceivable -> StatementDivision (asDivision spec) + PrepaidPensionCost -> StatementDivision (asDivision spec) + NetDefinedBenefitAsset -> StatementDivision (asDivision spec) + DepositsInSpecialAccounts -> StatementDivision (asDivision spec) + Structures -> StatementDivision (asDivision spec) + LeaseholdRights -> StatementDivision (asDivision spec) + NonOperatingNotesReceivable -> StatementDivision (asDivision spec) + NonOperatingElectronicallyRecordedReceivable -> StatementDivision (asDivision spec) + RefundLiabilities -> StatementDivision (asDivision spec) + NonOperatingNotesPayable -> StatementDivision (asDivision spec) + NonOperatingElectronicallyRecordedObligations -> StatementDivision (asDivision spec) + BonusesPayable -> StatementDivision (asDivision spec) + AllowanceForRepairs -> StatementDivision (asDivision spec) + AllowanceForProductWarranties -> StatementDivision (asDivision spec) + AllowanceForBonuses -> StatementDivision (asDivision spec) + DeferredTaxLiabilities -> StatementDivision (asDivision spec) + LeaseObligations -> StatementDivision (asDivision spec) + GuaranteeDepositsReceived -> StatementDivision (asDivision spec) + AllowanceForRetirementBenefits -> StatementDivision (asDivision spec) + LongTermOtherPayables -> StatementDivision (asDivision spec) + NetDefinedBenefitLiability -> StatementDivision (asDivision spec) + StockSubscriptionDeposits -> StatementDivision (asDivision spec) + LegalCapitalSurplus -> StatementDivision (asDivision spec) + OtherCapitalSurplus -> StatementDivision (asDivision spec) + DividendEqualizationReserve -> StatementDivision (asDivision spec) + RepairFundReserve -> StatementDivision (asDivision spec) + ConstructionFundReserve -> StatementDivision (asDivision spec) + GeneralReserve -> StatementDivision (asDivision spec) + ValuationDifferenceOnOtherSecurities -> StatementDivision (asDivision spec) + NonControllingInterests -> StatementDivision (asDivision spec) + CapitalSurplus -> StatementDivision (asDivision spec) + EarnedSurplus -> StatementDivision (asDivision spec) + ServiceRevenue -> StatementDivision (asDivision spec) + OperatingRevenue -> StatementDivision (asDivision spec) + GainOnSalesOfSecurities -> StatementDivision (asDivision spec) + GainOnValuationOfSecurities -> StatementDivision (asDivision spec) + DividendsReceived -> StatementDivision (asDivision spec) + InterestOnSecurities -> StatementDivision (asDivision spec) + GainOnSalesOfInvestmentSecurities -> StatementDivision (asDivision spec) + InsuranceGain -> StatementDivision (asDivision spec) + GainOnBargainPurchase -> StatementDivision (asDivision spec) + ReversalOfAllowanceForRepairs -> StatementDivision (asDivision spec) + ReversalOfAllowanceForProductWarranties -> StatementDivision (asDivision spec) + GainOnDonationOfFixedAssets -> StatementDivision (asDivision spec) + GainOnNationalSubsidies -> StatementDivision (asDivision spec) + GainOnConstructionGrants -> StatementDivision (asDivision spec) + LandRentReceived -> StatementDivision (asDivision spec) + SalesRebates -> StatementDivision (asDivision spec) + CostOfServices -> StatementDivision (asDivision spec) + OperatingExpenses -> StatementDivision (asDivision spec) + InventoryShrinkageLoss -> StatementDivision (asDivision spec) + LossOnValuationOfMerchandise -> StatementDivision (asDivision spec) + Bonuses -> StatementDivision (asDivision spec) + RetirementBenefitExpenses -> StatementDivision (asDivision spec) + ProvisionForRepairs -> StatementDivision (asDivision spec) + ProvisionForBonuses -> StatementDivision (asDivision spec) + ProvisionForProductWarranties -> StatementDivision (asDivision spec) + ResearchAndDevelopmentExpenses -> StatementDivision (asDivision spec) + AmortizationOfGoodwill -> StatementDivision (asDivision spec) + AmortizationOfSoftware -> StatementDivision (asDivision spec) + AmortizationOfPatents -> StatementDivision (asDivision spec) + LeaseExpenses -> StatementDivision (asDivision spec) + IncorporationExpenses -> StatementDivision (asDivision spec) + StockIssuanceCosts -> StatementDivision (asDivision spec) + BusinessCommencementExpenses -> StatementDivision (asDivision spec) + DevelopmentExpenses -> StatementDivision (asDivision spec) + LossOnSalesOfElectronicallyRecordedReceivables -> StatementDivision (asDivision spec) + LossOnSalesOfReceivables -> StatementDivision (asDivision spec) + LossOnSalesOfSecurities -> StatementDivision (asDivision spec) + LossOnValuationOfSecurities -> StatementDivision (asDivision spec) + LossOnSalesOfInvestmentSecurities -> StatementDivision (asDivision spec) + LossOnFire -> StatementDivision (asDivision spec) + LossOnRetirementOfFixedAssets -> StatementDivision (asDivision spec) + LossOnReductionOfFixedAssets -> StatementDivision (asDivision spec) + AdditionalIncomeTaxesForPriorPeriods -> StatementDivision (asDivision spec) + RefundOfIncomeTaxes -> StatementDivision (asDivision spec) + PurchaseRebates -> StatementDivision (asDivision spec) + WelfareExpenses -> StatementDivision (asDivision spec) + MaintenanceExpenses -> StatementDivision (asDivision spec) + StatutoryWelfareExpenses -> StatementDivision (asDivision spec) + LandRentPaid -> StatementDivision (asDivision spec) + InsuranceExpense -> StatementDivision (asDivision spec) + RepairsExpense -> StatementDivision (asDivision spec) + StorageExpenses -> StatementDivision (asDivision spec) + MembershipFees -> StatementDivision (asDivision spec) + IncomeSummary -> DirectionEncoding (asDivision spec) + SuspenseAccount -> BookkeepingControlClass (asDivision spec) + ForeignExchangeGains -> StatementDivision (asDivision spec) + ForeignExchangeLosses -> StatementDivision (asDivision spec) + ContraAccountForGuaranteeObligations -> StatementDivision (asDivision spec) + GuaranteeObligations -> StatementDivision (asDivision spec) + IncomeTaxesAdjustment -> StatementDivision (asDivision spec) + BranchCurrentAccount -> BookkeepingControlClass (asDivision spec) + HeadOfficeCurrentAccount -> BookkeepingControlClass (asDivision spec) + NetIncomeAttributableToNCI -> DirectionEncoding (asDivision spec) + NetLossAttributableToNCI -> DirectionEncoding (asDivision spec) + TradingSecurities -> StatementDivision (asDivision spec) + HeldToMaturityBonds -> StatementDivision (asDivision spec) + SubsidiaryStocks -> StatementDivision (asDivision spec) + AffiliateStocks -> StatementDivision (asDivision spec) + AvailableForSaleSecurities -> StatementDivision (asDivision spec) + ConsumptionTaxRefundReceivable -> StatementDivision (asDivision spec) + PropertyTaxPayable -> StatementDivision (asDivision spec) + DepositsReceivedFromOfficers -> StatementDivision (asDivision spec) + AccountTitle -> NoStatementDivision + +homeSideFor :: AccountTitles -> AccountSpec -> HomeSideSemantics +homeSideFor title spec = case title of + Cash -> FixedHomeSide (legacyHomeSide spec) + Deposits -> FixedHomeSide (legacyHomeSide spec) + CurrentDeposits -> FixedHomeSide (legacyHomeSide spec) + Securities -> FixedHomeSide (legacyHomeSide spec) + InvestmentSecurities -> FixedHomeSide (legacyHomeSide spec) + InvestmentInAssociate -> FixedHomeSide (legacyHomeSide spec) + LongTermNationalBonds -> FixedHomeSide (legacyHomeSide spec) + ShortTermNationalBonds -> FixedHomeSide (legacyHomeSide spec) + Products -> FixedHomeSide (legacyHomeSide spec) + Machinery -> FixedHomeSide (legacyHomeSide spec) + Building -> FixedHomeSide (legacyHomeSide spec) + Vehicle -> FixedHomeSide (legacyHomeSide spec) + StockInvestment -> FixedHomeSide (legacyHomeSide spec) + EquipmentInvestment -> FixedHomeSide (legacyHomeSide spec) + LongTermLoansReceivable -> FixedHomeSide (legacyHomeSide spec) + AccountsReceivable -> FixedHomeSide (legacyHomeSide spec) + ShortTermLoansReceivable -> FixedHomeSide (legacyHomeSide spec) + ReserveDepositReceivable -> FixedHomeSide (legacyHomeSide spec) + Gold -> FixedHomeSide (legacyHomeSide spec) + GovernmentService -> FixedHomeSide (legacyHomeSide spec) + CapitalStock -> FixedHomeSide (legacyHomeSide spec) + RetainedEarnings -> FixedHomeSide (legacyHomeSide spec) + LongTermLoansPayable -> FixedHomeSide (legacyHomeSide spec) + ShortTermLoansPayable -> FixedHomeSide (legacyHomeSide spec) + LoansPayable -> FixedHomeSide (legacyHomeSide spec) + ReserveForDepreciation -> FixedHomeSide (legacyHomeSide spec) + DepositPayable -> FixedHomeSide (legacyHomeSide spec) + LongTermNationalBondsPayable -> FixedHomeSide (legacyHomeSide spec) + ShortTermNationalBondsPayable -> FixedHomeSide (legacyHomeSide spec) + ReserveDepositPayable -> FixedHomeSide (legacyHomeSide spec) + CentralBankNotePayable -> FixedHomeSide (legacyHomeSide spec) + Depreciation -> FixedHomeSide (legacyHomeSide spec) + AmortizationExpense -> FixedHomeSide (legacyHomeSide spec) + SalesCost -> FixedHomeSide (legacyHomeSide spec) + BusinessTrip -> FixedHomeSide (legacyHomeSide spec) + Commutation -> FixedHomeSide (legacyHomeSide spec) + UtilitiesExpense -> FixedHomeSide (legacyHomeSide spec) + RentExpense -> FixedHomeSide (legacyHomeSide spec) + AdvertisingExpense -> FixedHomeSide (legacyHomeSide spec) + DeliveryExpenses -> FixedHomeSide (legacyHomeSide spec) + SuppliesExpenses -> FixedHomeSide (legacyHomeSide spec) + MiscellaneousExpenses -> FixedHomeSide (legacyHomeSide spec) + WageExpenditure -> FixedHomeSide (legacyHomeSide spec) + InterestExpense -> FixedHomeSide (legacyHomeSide spec) + TaxesExpense -> FixedHomeSide (legacyHomeSide spec) + ConsumptionExpenditure -> FixedHomeSide (legacyHomeSide spec) + SubsidyExpense -> FixedHomeSide (legacyHomeSide spec) + CentralBankPaymentExpense -> FixedHomeSide (legacyHomeSide spec) + Purchases -> FixedHomeSide (legacyHomeSide spec) + NetIncome -> FixedHomeSide (legacyHomeSide spec) + ValueAdded -> FixedHomeSide (legacyHomeSide spec) + SubsidyIncome -> FixedHomeSide (legacyHomeSide spec) + NationalBondInterestEarned -> FixedHomeSide (legacyHomeSide spec) + DepositInterestEarned -> FixedHomeSide (legacyHomeSide spec) + GrossProfit -> FixedHomeSide (legacyHomeSide spec) + OrdinaryProfit -> FixedHomeSide (legacyHomeSide spec) + InterestEarned -> FixedHomeSide (legacyHomeSide spec) + ReceiptFee -> FixedHomeSide (legacyHomeSide spec) + RentalIncome -> FixedHomeSide (legacyHomeSide spec) + WageEarned -> FixedHomeSide (legacyHomeSide spec) + TaxesRevenue -> FixedHomeSide (legacyHomeSide spec) + CentralBankPaymentIncome -> FixedHomeSide (legacyHomeSide spec) + Sales -> FixedHomeSide (legacyHomeSide spec) + EquityInEarningsOfInvestee -> FixedHomeSide (legacyHomeSide spec) + NetLoss -> FixedHomeSide (legacyHomeSide spec) + PettyCash -> FixedHomeSide (legacyHomeSide spec) + NotesReceivable -> FixedHomeSide (legacyHomeSide spec) + ElectronicallyRecordedReceivable -> FixedHomeSide (legacyHomeSide spec) + CreditCardReceivable -> FixedHomeSide (legacyHomeSide spec) + NotesLoansReceivable -> FixedHomeSide (legacyHomeSide spec) + MerchandiseInventory -> FixedHomeSide (legacyHomeSide spec) + AdvancesPaid -> FixedHomeSide (legacyHomeSide spec) + PrepaidExpenses -> FixedHomeSide (legacyHomeSide spec) + AccruedRevenue -> FixedHomeSide (legacyHomeSide spec) + OtherReceivables -> FixedHomeSide (legacyHomeSide spec) + PaymentsOnBehalf -> FixedHomeSide (legacyHomeSide spec) + SuspensePayments -> FixedHomeSide (legacyHomeSide spec) + ConsumptionTaxPaid -> FixedHomeSide (legacyHomeSide spec) + PrepaidCorporateIncomeTaxes -> FixedHomeSide (legacyHomeSide spec) + Land -> FixedHomeSide (legacyHomeSide spec) + Fixtures -> FixedHomeSide (legacyHomeSide spec) + Patent -> FixedHomeSide (legacyHomeSide spec) + Trademark -> FixedHomeSide (legacyHomeSide spec) + Software -> FixedHomeSide (legacyHomeSide spec) + CashOverShort -> ContextDependentHomeSide + AccountsPayable -> FixedHomeSide (legacyHomeSide spec) + NotesPayable -> FixedHomeSide (legacyHomeSide spec) + ElectronicallyRecordedObligations -> FixedHomeSide (legacyHomeSide spec) + NotesLoansPayable -> FixedHomeSide (legacyHomeSide spec) + BankOverdraft -> FixedHomeSide (legacyHomeSide spec) + AdvancesReceived -> FixedHomeSide (legacyHomeSide spec) + UnearnedRevenue -> FixedHomeSide (legacyHomeSide spec) + AccruedExpenses -> FixedHomeSide (legacyHomeSide spec) + OtherPayables -> FixedHomeSide (legacyHomeSide spec) + DepositsReceived -> FixedHomeSide (legacyHomeSide spec) + SuspenseReceipts -> FixedHomeSide (legacyHomeSide spec) + ConsumptionTaxReceived -> FixedHomeSide (legacyHomeSide spec) + AccruedConsumptionTax -> FixedHomeSide (legacyHomeSide spec) + AccruedCorporateIncomeTaxes -> FixedHomeSide (legacyHomeSide spec) + UnpaidDividends -> FixedHomeSide (legacyHomeSide spec) + AllowanceForDoubtfulAccounts -> FixedHomeSide (legacyHomeSide spec) + AccumulatedDepreciation -> FixedHomeSide (legacyHomeSide spec) + LegalRetainedEarnings -> FixedHomeSide (legacyHomeSide spec) + CumulativeTranslationAdjustment -> FixedHomeSide (legacyHomeSide spec) + ProvisionForDoubtfulAccounts -> FixedHomeSide (legacyHomeSide spec) + BadDebtLoss -> FixedHomeSide (legacyHomeSide spec) + LossOnSalesOfFixedAssets -> FixedHomeSide (legacyHomeSide spec) + LossOnSalesOfNotesReceivable -> FixedHomeSide (legacyHomeSide spec) + PaymentFees -> FixedHomeSide (legacyHomeSide spec) + MiscellaneousLoss -> FixedHomeSide (legacyHomeSide spec) + CorporateIncomeTaxes -> FixedHomeSide (legacyHomeSide spec) + CommunicationExpenses -> FixedHomeSide (legacyHomeSide spec) + GainOnSalesOfFixedAssets -> FixedHomeSide (legacyHomeSide spec) + RecoveryOfBadDebts -> FixedHomeSide (legacyHomeSide spec) + MiscellaneousIncome -> FixedHomeSide (legacyHomeSide spec) + ReversalOfAllowanceForDoubtfulAccounts -> FixedHomeSide (legacyHomeSide spec) + TimeDeposits -> FixedHomeSide (legacyHomeSide spec) + LoansReceivable -> FixedHomeSide (legacyHomeSide spec) + GiftCertificatesReceived -> FixedHomeSide (legacyHomeSide spec) + SecurityDepositsPaid -> FixedHomeSide (legacyHomeSide spec) + SuppliesOnHand -> FixedHomeSide (legacyHomeSide spec) + ContractAssets -> FixedHomeSide (legacyHomeSide spec) + IncomeTaxesRefundReceivable -> FixedHomeSide (legacyHomeSide spec) + WorkInProcess -> FixedHomeSide (legacyHomeSide spec) + DeferredTaxAssets -> FixedHomeSide (legacyHomeSide spec) + LeasedAssets -> FixedHomeSide (legacyHomeSide spec) + ToolsAndInstruments -> FixedHomeSide (legacyHomeSide spec) + ConstructionInProgress -> FixedHomeSide (legacyHomeSide spec) + Goodwill -> FixedHomeSide (legacyHomeSide spec) + SoftwareInProgress -> FixedHomeSide (legacyHomeSide spec) + LongTermPrepaidExpenses -> FixedHomeSide (legacyHomeSide spec) + DishonoredNotesReceivable -> FixedHomeSide (legacyHomeSide spec) + PrepaidPensionCost -> FixedHomeSide (legacyHomeSide spec) + NetDefinedBenefitAsset -> FixedHomeSide (legacyHomeSide spec) + DepositsInSpecialAccounts -> FixedHomeSide (legacyHomeSide spec) + Structures -> FixedHomeSide (legacyHomeSide spec) + LeaseholdRights -> FixedHomeSide (legacyHomeSide spec) + NonOperatingNotesReceivable -> FixedHomeSide (legacyHomeSide spec) + NonOperatingElectronicallyRecordedReceivable -> FixedHomeSide (legacyHomeSide spec) + RefundLiabilities -> FixedHomeSide (legacyHomeSide spec) + NonOperatingNotesPayable -> FixedHomeSide (legacyHomeSide spec) + NonOperatingElectronicallyRecordedObligations -> FixedHomeSide (legacyHomeSide spec) + BonusesPayable -> FixedHomeSide (legacyHomeSide spec) + AllowanceForRepairs -> FixedHomeSide (legacyHomeSide spec) + AllowanceForProductWarranties -> FixedHomeSide (legacyHomeSide spec) + AllowanceForBonuses -> FixedHomeSide (legacyHomeSide spec) + DeferredTaxLiabilities -> FixedHomeSide (legacyHomeSide spec) + LeaseObligations -> FixedHomeSide (legacyHomeSide spec) + GuaranteeDepositsReceived -> FixedHomeSide (legacyHomeSide spec) + AllowanceForRetirementBenefits -> FixedHomeSide (legacyHomeSide spec) + LongTermOtherPayables -> FixedHomeSide (legacyHomeSide spec) + NetDefinedBenefitLiability -> FixedHomeSide (legacyHomeSide spec) + StockSubscriptionDeposits -> FixedHomeSide (legacyHomeSide spec) + LegalCapitalSurplus -> FixedHomeSide (legacyHomeSide spec) + OtherCapitalSurplus -> FixedHomeSide (legacyHomeSide spec) + DividendEqualizationReserve -> FixedHomeSide (legacyHomeSide spec) + RepairFundReserve -> FixedHomeSide (legacyHomeSide spec) + ConstructionFundReserve -> FixedHomeSide (legacyHomeSide spec) + GeneralReserve -> FixedHomeSide (legacyHomeSide spec) + ValuationDifferenceOnOtherSecurities -> FixedHomeSide (legacyHomeSide spec) + NonControllingInterests -> FixedHomeSide (legacyHomeSide spec) + CapitalSurplus -> FixedHomeSide (legacyHomeSide spec) + EarnedSurplus -> FixedHomeSide (legacyHomeSide spec) + ServiceRevenue -> FixedHomeSide (legacyHomeSide spec) + OperatingRevenue -> FixedHomeSide (legacyHomeSide spec) + GainOnSalesOfSecurities -> FixedHomeSide (legacyHomeSide spec) + GainOnValuationOfSecurities -> FixedHomeSide (legacyHomeSide spec) + DividendsReceived -> FixedHomeSide (legacyHomeSide spec) + InterestOnSecurities -> FixedHomeSide (legacyHomeSide spec) + GainOnSalesOfInvestmentSecurities -> FixedHomeSide (legacyHomeSide spec) + InsuranceGain -> FixedHomeSide (legacyHomeSide spec) + GainOnBargainPurchase -> FixedHomeSide (legacyHomeSide spec) + ReversalOfAllowanceForRepairs -> FixedHomeSide (legacyHomeSide spec) + ReversalOfAllowanceForProductWarranties -> FixedHomeSide (legacyHomeSide spec) + GainOnDonationOfFixedAssets -> FixedHomeSide (legacyHomeSide spec) + GainOnNationalSubsidies -> FixedHomeSide (legacyHomeSide spec) + GainOnConstructionGrants -> FixedHomeSide (legacyHomeSide spec) + LandRentReceived -> FixedHomeSide (legacyHomeSide spec) + SalesRebates -> FixedHomeSide (legacyHomeSide spec) + CostOfServices -> FixedHomeSide (legacyHomeSide spec) + OperatingExpenses -> FixedHomeSide (legacyHomeSide spec) + InventoryShrinkageLoss -> FixedHomeSide (legacyHomeSide spec) + LossOnValuationOfMerchandise -> FixedHomeSide (legacyHomeSide spec) + Bonuses -> FixedHomeSide (legacyHomeSide spec) + RetirementBenefitExpenses -> FixedHomeSide (legacyHomeSide spec) + ProvisionForRepairs -> FixedHomeSide (legacyHomeSide spec) + ProvisionForBonuses -> FixedHomeSide (legacyHomeSide spec) + ProvisionForProductWarranties -> FixedHomeSide (legacyHomeSide spec) + ResearchAndDevelopmentExpenses -> FixedHomeSide (legacyHomeSide spec) + AmortizationOfGoodwill -> FixedHomeSide (legacyHomeSide spec) + AmortizationOfSoftware -> FixedHomeSide (legacyHomeSide spec) + AmortizationOfPatents -> FixedHomeSide (legacyHomeSide spec) + LeaseExpenses -> FixedHomeSide (legacyHomeSide spec) + IncorporationExpenses -> FixedHomeSide (legacyHomeSide spec) + StockIssuanceCosts -> FixedHomeSide (legacyHomeSide spec) + BusinessCommencementExpenses -> FixedHomeSide (legacyHomeSide spec) + DevelopmentExpenses -> FixedHomeSide (legacyHomeSide spec) + LossOnSalesOfElectronicallyRecordedReceivables -> FixedHomeSide (legacyHomeSide spec) + LossOnSalesOfReceivables -> FixedHomeSide (legacyHomeSide spec) + LossOnSalesOfSecurities -> FixedHomeSide (legacyHomeSide spec) + LossOnValuationOfSecurities -> FixedHomeSide (legacyHomeSide spec) + LossOnSalesOfInvestmentSecurities -> FixedHomeSide (legacyHomeSide spec) + LossOnFire -> FixedHomeSide (legacyHomeSide spec) + LossOnRetirementOfFixedAssets -> FixedHomeSide (legacyHomeSide spec) + LossOnReductionOfFixedAssets -> FixedHomeSide (legacyHomeSide spec) + AdditionalIncomeTaxesForPriorPeriods -> FixedHomeSide (legacyHomeSide spec) + RefundOfIncomeTaxes -> FixedHomeSide (legacyHomeSide spec) + PurchaseRebates -> FixedHomeSide (legacyHomeSide spec) + WelfareExpenses -> FixedHomeSide (legacyHomeSide spec) + MaintenanceExpenses -> FixedHomeSide (legacyHomeSide spec) + StatutoryWelfareExpenses -> FixedHomeSide (legacyHomeSide spec) + LandRentPaid -> FixedHomeSide (legacyHomeSide spec) + InsuranceExpense -> FixedHomeSide (legacyHomeSide spec) + RepairsExpense -> FixedHomeSide (legacyHomeSide spec) + StorageExpenses -> FixedHomeSide (legacyHomeSide spec) + MembershipFees -> FixedHomeSide (legacyHomeSide spec) + IncomeSummary -> ContextDependentHomeSide + SuspenseAccount -> ContextDependentHomeSide + ForeignExchangeGains -> FixedHomeSide (legacyHomeSide spec) + ForeignExchangeLosses -> FixedHomeSide (legacyHomeSide spec) + ContraAccountForGuaranteeObligations -> FixedHomeSide (legacyHomeSide spec) + GuaranteeObligations -> FixedHomeSide (legacyHomeSide spec) + IncomeTaxesAdjustment -> FixedHomeSide (legacyHomeSide spec) + BranchCurrentAccount -> FixedHomeSide (legacyHomeSide spec) + HeadOfficeCurrentAccount -> FixedHomeSide (legacyHomeSide spec) + NetIncomeAttributableToNCI -> FixedHomeSide (legacyHomeSide spec) + NetLossAttributableToNCI -> FixedHomeSide (legacyHomeSide spec) + TradingSecurities -> FixedHomeSide (legacyHomeSide spec) + HeldToMaturityBonds -> FixedHomeSide (legacyHomeSide spec) + SubsidiaryStocks -> FixedHomeSide (legacyHomeSide spec) + AffiliateStocks -> FixedHomeSide (legacyHomeSide spec) + AvailableForSaleSecurities -> FixedHomeSide (legacyHomeSide spec) + ConsumptionTaxRefundReceivable -> FixedHomeSide (legacyHomeSide spec) + PropertyTaxPayable -> FixedHomeSide (legacyHomeSide spec) + DepositsReceivedFromOfficers -> FixedHomeSide (legacyHomeSide spec) + AccountTitle -> NoPostingSide + +legacyHomeSide :: AccountSpec -> Side +legacyHomeSide spec + | asIsContra spec = reverseSide (divisionSide (asDivision spec)) + | otherwise = divisionSide (asDivision spec) + +divisionSide :: AccountDivision -> Side +divisionSide Assets = Debit +divisionSide Cost = Debit +divisionSide Equity = Credit +divisionSide Liability = Credit +divisionSide Revenue = Credit + +reverseSide :: Side -> Side +reverseSide Debit = Credit +reverseSide Credit = Debit +reverseSide Side = Side + +reportingFor :: AccountTitles -> ReportingEligibility +reportingFor title = case title of + Cash -> StatementEligible + Deposits -> StatementEligible + CurrentDeposits -> StatementEligible + Securities -> StatementEligible + InvestmentSecurities -> StatementEligible + InvestmentInAssociate -> StatementEligible + LongTermNationalBonds -> StatementEligible + ShortTermNationalBonds -> StatementEligible + Products -> StatementEligible + Machinery -> StatementEligible + Building -> StatementEligible + Vehicle -> StatementEligible + StockInvestment -> StatementEligible + EquipmentInvestment -> StatementEligible + LongTermLoansReceivable -> StatementEligible + AccountsReceivable -> StatementEligible + ShortTermLoansReceivable -> StatementEligible + ReserveDepositReceivable -> StatementEligible + Gold -> StatementEligible + GovernmentService -> StatementEligible + CapitalStock -> StatementEligible + RetainedEarnings -> StatementEligible + LongTermLoansPayable -> StatementEligible + ShortTermLoansPayable -> StatementEligible + LoansPayable -> StatementEligible + ReserveForDepreciation -> StatementEligible + DepositPayable -> StatementEligible + LongTermNationalBondsPayable -> StatementEligible + ShortTermNationalBondsPayable -> StatementEligible + ReserveDepositPayable -> StatementEligible + CentralBankNotePayable -> StatementEligible + Depreciation -> StatementEligible + AmortizationExpense -> StatementEligible + SalesCost -> StatementEligible + BusinessTrip -> StatementEligible + Commutation -> StatementEligible + UtilitiesExpense -> StatementEligible + RentExpense -> StatementEligible + AdvertisingExpense -> StatementEligible + DeliveryExpenses -> StatementEligible + SuppliesExpenses -> StatementEligible + MiscellaneousExpenses -> StatementEligible + WageExpenditure -> StatementEligible + InterestExpense -> StatementEligible + TaxesExpense -> StatementEligible + ConsumptionExpenditure -> StatementEligible + SubsidyExpense -> StatementEligible + CentralBankPaymentExpense -> StatementEligible + Purchases -> StatementEligible + NetIncome -> DerivedPresentation + ValueAdded -> StatementEligible + SubsidyIncome -> StatementEligible + NationalBondInterestEarned -> StatementEligible + DepositInterestEarned -> StatementEligible + GrossProfit -> DerivedPresentation + OrdinaryProfit -> DerivedPresentation + InterestEarned -> StatementEligible + ReceiptFee -> StatementEligible + RentalIncome -> StatementEligible + WageEarned -> StatementEligible + TaxesRevenue -> StatementEligible + CentralBankPaymentIncome -> StatementEligible + Sales -> StatementEligible + EquityInEarningsOfInvestee -> ContextualPresentation + NetLoss -> DerivedPresentation + PettyCash -> StatementEligible + NotesReceivable -> StatementEligible + ElectronicallyRecordedReceivable -> StatementEligible + CreditCardReceivable -> StatementEligible + NotesLoansReceivable -> StatementEligible + MerchandiseInventory -> StatementEligible + AdvancesPaid -> StatementEligible + PrepaidExpenses -> StatementEligible + AccruedRevenue -> StatementEligible + OtherReceivables -> StatementEligible + PaymentsOnBehalf -> StatementEligible + SuspensePayments -> ContextualPresentation + ConsumptionTaxPaid -> StatementEligible + PrepaidCorporateIncomeTaxes -> StatementEligible + Land -> StatementEligible + Fixtures -> StatementEligible + Patent -> StatementEligible + Trademark -> StatementEligible + Software -> StatementEligible + CashOverShort -> NotPresented + AccountsPayable -> StatementEligible + NotesPayable -> StatementEligible + ElectronicallyRecordedObligations -> StatementEligible + NotesLoansPayable -> StatementEligible + BankOverdraft -> StatementEligible + AdvancesReceived -> StatementEligible + UnearnedRevenue -> StatementEligible + AccruedExpenses -> StatementEligible + OtherPayables -> StatementEligible + DepositsReceived -> StatementEligible + SuspenseReceipts -> ContextualPresentation + ConsumptionTaxReceived -> StatementEligible + AccruedConsumptionTax -> StatementEligible + AccruedCorporateIncomeTaxes -> StatementEligible + UnpaidDividends -> StatementEligible + AllowanceForDoubtfulAccounts -> StatementEligible + AccumulatedDepreciation -> StatementEligible + LegalRetainedEarnings -> StatementEligible + CumulativeTranslationAdjustment -> ContextualPresentation + ProvisionForDoubtfulAccounts -> StatementEligible + BadDebtLoss -> StatementEligible + LossOnSalesOfFixedAssets -> StatementEligible + LossOnSalesOfNotesReceivable -> StatementEligible + PaymentFees -> StatementEligible + MiscellaneousLoss -> StatementEligible + CorporateIncomeTaxes -> StatementEligible + CommunicationExpenses -> StatementEligible + GainOnSalesOfFixedAssets -> StatementEligible + RecoveryOfBadDebts -> StatementEligible + MiscellaneousIncome -> StatementEligible + ReversalOfAllowanceForDoubtfulAccounts -> StatementEligible + TimeDeposits -> StatementEligible + LoansReceivable -> StatementEligible + GiftCertificatesReceived -> StatementEligible + SecurityDepositsPaid -> StatementEligible + SuppliesOnHand -> StatementEligible + ContractAssets -> StatementEligible + IncomeTaxesRefundReceivable -> StatementEligible + WorkInProcess -> StatementEligible + DeferredTaxAssets -> StatementEligible + LeasedAssets -> StatementEligible + ToolsAndInstruments -> StatementEligible + ConstructionInProgress -> StatementEligible + Goodwill -> StatementEligible + SoftwareInProgress -> StatementEligible + LongTermPrepaidExpenses -> StatementEligible + DishonoredNotesReceivable -> StatementEligible + PrepaidPensionCost -> StatementEligible + NetDefinedBenefitAsset -> StatementEligible + DepositsInSpecialAccounts -> StatementEligible + Structures -> StatementEligible + LeaseholdRights -> StatementEligible + NonOperatingNotesReceivable -> StatementEligible + NonOperatingElectronicallyRecordedReceivable -> StatementEligible + RefundLiabilities -> StatementEligible + NonOperatingNotesPayable -> StatementEligible + NonOperatingElectronicallyRecordedObligations -> StatementEligible + BonusesPayable -> StatementEligible + AllowanceForRepairs -> StatementEligible + AllowanceForProductWarranties -> StatementEligible + AllowanceForBonuses -> StatementEligible + DeferredTaxLiabilities -> StatementEligible + LeaseObligations -> StatementEligible + GuaranteeDepositsReceived -> StatementEligible + AllowanceForRetirementBenefits -> StatementEligible + LongTermOtherPayables -> StatementEligible + NetDefinedBenefitLiability -> StatementEligible + StockSubscriptionDeposits -> StatementEligible + LegalCapitalSurplus -> StatementEligible + OtherCapitalSurplus -> StatementEligible + DividendEqualizationReserve -> StatementEligible + RepairFundReserve -> StatementEligible + ConstructionFundReserve -> StatementEligible + GeneralReserve -> StatementEligible + ValuationDifferenceOnOtherSecurities -> StatementEligible + NonControllingInterests -> ContextualPresentation + CapitalSurplus -> StatementEligible + EarnedSurplus -> StatementEligible + ServiceRevenue -> StatementEligible + OperatingRevenue -> StatementEligible + GainOnSalesOfSecurities -> StatementEligible + GainOnValuationOfSecurities -> StatementEligible + DividendsReceived -> StatementEligible + InterestOnSecurities -> StatementEligible + GainOnSalesOfInvestmentSecurities -> StatementEligible + InsuranceGain -> StatementEligible + GainOnBargainPurchase -> StatementEligible + ReversalOfAllowanceForRepairs -> StatementEligible + ReversalOfAllowanceForProductWarranties -> StatementEligible + GainOnDonationOfFixedAssets -> StatementEligible + GainOnNationalSubsidies -> StatementEligible + GainOnConstructionGrants -> StatementEligible + LandRentReceived -> StatementEligible + SalesRebates -> StatementEligible + CostOfServices -> StatementEligible + OperatingExpenses -> StatementEligible + InventoryShrinkageLoss -> StatementEligible + LossOnValuationOfMerchandise -> StatementEligible + Bonuses -> StatementEligible + RetirementBenefitExpenses -> StatementEligible + ProvisionForRepairs -> StatementEligible + ProvisionForBonuses -> StatementEligible + ProvisionForProductWarranties -> StatementEligible + ResearchAndDevelopmentExpenses -> StatementEligible + AmortizationOfGoodwill -> StatementEligible + AmortizationOfSoftware -> StatementEligible + AmortizationOfPatents -> StatementEligible + LeaseExpenses -> StatementEligible + IncorporationExpenses -> StatementEligible + StockIssuanceCosts -> StatementEligible + BusinessCommencementExpenses -> StatementEligible + DevelopmentExpenses -> StatementEligible + LossOnSalesOfElectronicallyRecordedReceivables -> StatementEligible + LossOnSalesOfReceivables -> StatementEligible + LossOnSalesOfSecurities -> StatementEligible + LossOnValuationOfSecurities -> StatementEligible + LossOnSalesOfInvestmentSecurities -> StatementEligible + LossOnFire -> StatementEligible + LossOnRetirementOfFixedAssets -> StatementEligible + LossOnReductionOfFixedAssets -> StatementEligible + AdditionalIncomeTaxesForPriorPeriods -> StatementEligible + RefundOfIncomeTaxes -> StatementEligible + PurchaseRebates -> StatementEligible + WelfareExpenses -> StatementEligible + MaintenanceExpenses -> StatementEligible + StatutoryWelfareExpenses -> StatementEligible + LandRentPaid -> StatementEligible + InsuranceExpense -> StatementEligible + RepairsExpense -> StatementEligible + StorageExpenses -> StatementEligible + MembershipFees -> StatementEligible + IncomeSummary -> NotPresented + SuspenseAccount -> ContextualPresentation + ForeignExchangeGains -> StatementEligible + ForeignExchangeLosses -> StatementEligible + ContraAccountForGuaranteeObligations -> StatementEligible + GuaranteeObligations -> StatementEligible + IncomeTaxesAdjustment -> StatementEligible + BranchCurrentAccount -> ContextualPresentation + HeadOfficeCurrentAccount -> ContextualPresentation + NetIncomeAttributableToNCI -> ContextualPresentation + NetLossAttributableToNCI -> ContextualPresentation + TradingSecurities -> StatementEligible + HeldToMaturityBonds -> StatementEligible + SubsidiaryStocks -> StatementEligible + AffiliateStocks -> StatementEligible + AvailableForSaleSecurities -> StatementEligible + ConsumptionTaxRefundReceivable -> StatementEligible + PropertyTaxPayable -> StatementEligible + DepositsReceivedFromOfficers -> StatementEligible + AccountTitle -> NotPresented + +-- | Every accepted non-canonical alias for an account. The JCCI overlay is +-- generated from the frozen 2022 standard/permitted account-name fixture; +-- shared permitted names intentionally remain shared so parsing reports an +-- explicit ambiguity instead of silently choosing one account. +accountAliases :: AccountTitles -> [Text] +accountAliases title = L.nub (baseAliases <> jcciAliases title) + where + baseAliases = maybe [] asAliases (accountSpec title) + +-- | Look up metadata for an account title. The wildcard has no metadata. +-- +-- Complexity: O(1) +{-# INLINE accountSpec #-} +accountSpec :: AccountTitles -> Maybe AccountSpec +accountSpec Cash = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Cash" + , asNameJa = "現金" + , asLabelJa = "現金" + , asDescription = "Asset: Cash (現金)" + , asAliases = ["現金"] + } +accountSpec Deposits = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Savings deposits" + , asNameJa = "普通預金" + , asLabelJa = "普通預金" + , asDescription = "Asset: Savings deposits (普通預金)" + , asAliases = ["普通預金"] + } +accountSpec CurrentDeposits = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Current deposits" + , asNameJa = "当座預金" + , asLabelJa = "当座預金" + , asDescription = "Asset: Current deposits (当座預金)" + , asAliases = ["当座預金"] + } +accountSpec Securities = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Securities" + , asNameJa = "有価証券" + , asLabelJa = "有価証券" + , asDescription = "Asset: Securities (有価証券)" + , asAliases = ["有価証券"] + } +accountSpec InvestmentSecurities = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Investment securities" + , asNameJa = "投資有価証券" + , asLabelJa = "投資有価証券" + , asDescription = "Asset: Investment securities (投資有価証券)" + , asAliases = ["投資有価証券"] + } +accountSpec InvestmentInAssociate = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Investment in associate" + , asNameJa = "関係会社株式" + , asLabelJa = "関係会社株式" + , asDescription = "Asset: Investment in associate (関係会社株式). Carrying amount under the equity method (持分法適用投資勘定)." + , asAliases = [] + } +accountSpec LongTermNationalBonds = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Long-term national bonds" + , asNameJa = "長期国債" + , asLabelJa = "長期国債" + , asDescription = "Asset: Long-term national bonds (長期国債)" + , asAliases = ["長期国債"] + } +accountSpec ShortTermNationalBonds = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Short-term national bonds" + , asNameJa = "短期国債" + , asLabelJa = "短期国債" + , asDescription = "Asset: Short-term national bonds (短期国債)" + , asAliases = ["短期国債"] + } +accountSpec Products = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Products" + , asNameJa = "商品" + , asLabelJa = "商品" + , asDescription = "Asset: Products (商品)。分記法用。3 分法 (仕入\\/売上\\/繰越商品) では 'MerchandiseInventory' を使う" + , asAliases = ["商品"] + } +accountSpec Machinery = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Machinery and equipment" + , asNameJa = "機械装置" + , asLabelJa = "機械装置" + , asDescription = "Asset: Machinery and equipment (機械装置)" + , asAliases = ["機械装置"] + } +accountSpec Building = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Real estate" + , asNameJa = "建物" + , asLabelJa = "建物" + , asDescription = "Asset: Real estate (建物)" + , asAliases = ["建物"] + } +accountSpec Vehicle = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Vehicles" + , asNameJa = "車両運搬具" + , asLabelJa = "車両運搬具" + , asDescription = "Asset: Vehicles (車両運搬具)" + , asAliases = ["車両運搬具"] + } +accountSpec StockInvestment = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Stock investment" + , asNameJa = "株式投資" + , asLabelJa = "株式投資" + , asDescription = "Asset: Stock investment (株式投資)" + , asAliases = ["株式投資"] + } +accountSpec EquipmentInvestment = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Equipment investment" + , asNameJa = "設備投資" + , asLabelJa = "設備投資" + , asDescription = "Asset: Equipment investment (設備投資)" + , asAliases = ["設備投資"] + } +accountSpec LongTermLoansReceivable = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Long-term loans receivable" + , asNameJa = "長期貸付金" + , asLabelJa = "長期貸付金" + , asDescription = "Asset: Long-term loans receivable (長期貸付金)" + , asAliases = ["長期貸付金"] + } +accountSpec AccountsReceivable = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Accounts receivable" + , asNameJa = "売掛金" + , asLabelJa = "売掛金" + , asDescription = "Asset: Accounts receivable (売掛金)" + , asAliases = ["売掛金", "a/r", "accounts receivable"] + } +accountSpec ShortTermLoansReceivable = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Short-term loans receivable" + , asNameJa = "短期貸付金" + , asLabelJa = "短期貸付金" + , asDescription = "Asset: Short-term loans receivable (短期貸付金)" + , asAliases = ["短期貸付金"] + } +accountSpec ReserveDepositReceivable = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Reserve deposits, asset side" + , asNameJa = "準備預金, 資産側 — 市中銀行が中央銀行に置く準備預金。SNA\\/マクロ系" + , asLabelJa = "準備預金" + , asDescription = "Asset: Reserve deposits, asset side (準備預金, 資産側 — 市中銀行が中央銀行に置く準備預金。SNA\\/マクロ系)" + , asAliases = ["準備預金"] + } +accountSpec Gold = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Gold" + , asNameJa = "金" + , asLabelJa = "金" + , asDescription = "Asset: Gold (金)" + , asAliases = ["金"] + } +accountSpec GovernmentService = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Government service" + , asNameJa = "政府サービス。SNA\\/マクロ系" + , asLabelJa = "政府サービス" + , asDescription = "Asset: Government service (政府サービス。SNA\\/マクロ系)" + , asAliases = ["政府サービス"] + } +accountSpec CapitalStock = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Capital stock" + , asNameJa = "資本金" + , asLabelJa = "資本金" + , asDescription = "Equity: Capital stock (資本金)" + , asAliases = ["資本金"] + } +accountSpec RetainedEarnings = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Retained earnings" + , asNameJa = "繰越利益剰余金" + , asLabelJa = "繰越利益剰余金" + , asDescription = "Equity: Retained earnings (繰越利益剰余金)" + , asAliases = ["繰越利益剰余金"] + } +accountSpec LongTermLoansPayable = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Long-term loans payable" + , asNameJa = "長期借入金" + , asLabelJa = "長期借入金" + , asDescription = "Liability: Long-term loans payable (長期借入金)" + , asAliases = ["長期借入金"] + } +accountSpec ShortTermLoansPayable = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Short-term loans payable" + , asNameJa = "短期借入金" + , asLabelJa = "短期借入金" + , asDescription = "Liability: Short-term loans payable (短期借入金)" + , asAliases = ["短期借入金"] + } +accountSpec LoansPayable = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Loans payable" + , asNameJa = "借入金" + , asLabelJa = "借入金" + , asDescription = "Liability: Loans payable (借入金)" + , asAliases = ["借入金"] + } +accountSpec ReserveForDepreciation = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Reserve for depreciation" + , asNameJa = "減価償却引当金 — SNA\\/マクロ系の旧称。簿記の間接法には 'AccumulatedDepreciation' (減価償却累計額" + , asLabelJa = "減価償却引当金" + , asDescription = "Liability: Reserve for depreciation (減価償却引当金 — SNA\\/マクロ系の旧称。簿記の間接法には 'AccumulatedDepreciation' (減価償却累計額) を使う)" + , asAliases = ["減価償却引当金"] + } +accountSpec DepositPayable = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Deposits accepted" + , asNameJa = "受入預金 — 銀行側の負債としての預金。SNA\\/マクロ系。従業員等からの預り金は 'DepositsReceived'" + , asLabelJa = "受入預金" + , asDescription = "Liability: Deposits accepted (受入預金 — 銀行側の負債としての預金。SNA\\/マクロ系。従業員等からの預り金は 'DepositsReceived')" + , asAliases = ["受入預金"] + } +accountSpec LongTermNationalBondsPayable = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Long-term national bonds payable" + , asNameJa = "長期国債, 発行側" + , asLabelJa = "長期国債" + , asDescription = "Liability: Long-term national bonds payable (長期国債, 発行側)" + , asAliases = ["長期国債"] + } +accountSpec ShortTermNationalBondsPayable = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Short-term national bonds payable" + , asNameJa = "短期国債, 発行側" + , asLabelJa = "短期国債" + , asDescription = "Liability: Short-term national bonds payable (短期国債, 発行側)" + , asAliases = ["短期国債"] + } +accountSpec ReserveDepositPayable = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Reserve deposits, liability side" + , asNameJa = "準備預金, 負債側 — 中央銀行が受け入れる準備預金。SNA\\/マクロ系" + , asLabelJa = "準備預金" + , asDescription = "Liability: Reserve deposits, liability side (準備預金, 負債側 — 中央銀行が受け入れる準備預金。SNA\\/マクロ系)。※簿記の買掛金は 'AccountsPayable' を使うこと (旧 examples が本科目を買掛金の代用にしていた経緯あり)" + , asAliases = ["準備預金"] + } +accountSpec CentralBankNotePayable = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Central bank notes" + , asNameJa = "発行銀行券。SNA\\/マクロ系" + , asLabelJa = "発行銀行券" + , asDescription = "Liability: Central bank notes (発行銀行券。SNA\\/マクロ系)" + , asAliases = ["発行銀行券"] + } +accountSpec Depreciation = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Depreciation" + , asNameJa = "減価償却費" + , asLabelJa = "減価償却費" + , asDescription = "Expense: Depreciation (減価償却費)" + , asAliases = ["減価償却費"] + } +accountSpec AmortizationExpense = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Amortization expense for intangibles" + , asNameJa = "無形固定資産償却費 — 特許権・商標権・ソフトウェア等の無形資産の償却費。有形の 'Depreciation' (減価償却費" + , asLabelJa = "無形固定資産償却費" + , asDescription = "Expense: Amortization expense for intangibles (無形固定資産償却費 — 特許権・商標権・ソフトウェア等の無形資産の償却費。有形の 'Depreciation' (減価償却費) と区別される)" + , asAliases = [] + } +accountSpec SalesCost = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Cost of sales" + , asNameJa = "売上原価" + , asLabelJa = "売上原価" + , asDescription = "Expense: Cost of sales (売上原価)" + , asAliases = ["売上原価", "cogs", "cost of sales"] + } +accountSpec BusinessTrip = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Travel and transportation" + , asNameJa = "旅費交通費" + , asLabelJa = "旅費交通費" + , asDescription = "Expense: Travel and transportation (旅費交通費)" + , asAliases = ["旅費交通費"] + } +accountSpec Commutation = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Communication" + , asNameJa = "通信費 — 旧称。新規コードでは 'CommunicationExpenses' を使う" + , asLabelJa = "通信費" + , asDescription = "Expense: Communication (通信費 — 旧称。新規コードでは 'CommunicationExpenses' を使う)" + , asAliases = ["通信費"] + } +accountSpec UtilitiesExpense = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Utilities" + , asNameJa = "水道光熱費" + , asLabelJa = "水道光熱費" + , asDescription = "Expense: Utilities (水道光熱費)" + , asAliases = ["水道光熱費"] + } +accountSpec RentExpense = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Rent" + , asNameJa = "支払家賃" + , asLabelJa = "支払家賃" + , asDescription = "Expense: Rent (支払家賃)" + , asAliases = ["支払家賃"] + } +accountSpec AdvertisingExpense = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Advertising" + , asNameJa = "広告宣伝費" + , asLabelJa = "広告宣伝費" + , asDescription = "Expense: Advertising (広告宣伝費)" + , asAliases = ["広告宣伝費"] + } +accountSpec DeliveryExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Delivery" + , asNameJa = "発送費" + , asLabelJa = "発送費" + , asDescription = "Expense: Delivery (発送費)" + , asAliases = ["発送費"] + } +accountSpec SuppliesExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Supplies" + , asNameJa = "消耗品費" + , asLabelJa = "消耗品費" + , asDescription = "Expense: Supplies (消耗品費)" + , asAliases = ["消耗品費"] + } +accountSpec MiscellaneousExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Miscellaneous" + , asNameJa = "雑費" + , asLabelJa = "雑費" + , asDescription = "Expense: Miscellaneous (雑費)" + , asAliases = ["雑費"] + } +accountSpec WageExpenditure = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Wages" + , asNameJa = "給料" + , asLabelJa = "給料" + , asDescription = "Expense: Wages (給料)" + , asAliases = ["給料"] + } +accountSpec InterestExpense = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Interest expense" + , asNameJa = "支払利息" + , asLabelJa = "支払利息" + , asDescription = "Expense: Interest expense (支払利息)" + , asAliases = ["支払利息"] + } +accountSpec TaxesExpense = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Taxes" + , asNameJa = "租税公課" + , asLabelJa = "租税公課" + , asDescription = "Expense: Taxes (租税公課)" + , asAliases = ["租税公課"] + } +accountSpec ConsumptionExpenditure = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Consumption expenditure" + , asNameJa = "消費支出。SNA\\/マクロ系" + , asLabelJa = "消費支出" + , asDescription = "Expense: Consumption expenditure (消費支出。SNA\\/マクロ系)" + , asAliases = ["消費支出"] + } +accountSpec SubsidyExpense = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Subsidy expenditure" + , asNameJa = "補助金支出。SNA\\/マクロ系" + , asLabelJa = "補助金支出" + , asDescription = "Expense: Subsidy expenditure (補助金支出。SNA\\/マクロ系)" + , asAliases = ["補助金支出"] + } +accountSpec CentralBankPaymentExpense = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Central bank payment to treasury" + , asNameJa = "国庫納付金支出。SNA\\/マクロ系" + , asLabelJa = "国庫納付金支出" + , asDescription = "Expense: Central bank payment to treasury (国庫納付金支出。SNA\\/マクロ系)" + , asAliases = ["国庫納付金支出"] + } +accountSpec Purchases = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Purchases" + , asNameJa = "仕入" + , asLabelJa = "仕入" + , asDescription = "Expense: Purchases (仕入)" + , asAliases = ["仕入"] + } +accountSpec NetIncome = Just AccountSpec + { asDivision = Cost + , asClosing = NoClose + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Net income" + , asNameJa = "当期純利益 — 決算振替用。借方側に立つため Expense 区分" + , asLabelJa = "当期純利益" + , asDescription = "Expense: Net income (当期純利益 — 決算振替用。借方側に立つため Expense 区分)" + , asAliases = ["当期純利益"] + } +accountSpec ValueAdded = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Value added" + , asNameJa = "付加価値。SNA\\/マクロ系" + , asLabelJa = "付加価値" + , asDescription = "Revenue: Value added (付加価値。SNA\\/マクロ系)" + , asAliases = ["付加価値"] + } +accountSpec SubsidyIncome = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Subsidy income" + , asNameJa = "補助金収入。SNA\\/マクロ系" + , asLabelJa = "補助金収入" + , asDescription = "Revenue: Subsidy income (補助金収入。SNA\\/マクロ系)" + , asAliases = ["補助金収入"] + } +accountSpec NationalBondInterestEarned = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "National bond interest earned" + , asNameJa = "国債利息収入" + , asLabelJa = "国債利息収入" + , asDescription = "Revenue: National bond interest earned (国債利息収入)" + , asAliases = ["国債利息収入"] + } +accountSpec DepositInterestEarned = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Deposit interest earned" + , asNameJa = "預金利息収入" + , asLabelJa = "預金利息収入" + , asDescription = "Revenue: Deposit interest earned (預金利息収入)" + , asAliases = ["預金利息収入"] + } +accountSpec GrossProfit = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Gross profit" + , asNameJa = "売上総利益 — 決算振替用" + , asLabelJa = "売上総利益" + , asDescription = "Revenue: Gross profit (売上総利益 — 決算振替用)" + , asAliases = ["売上総利益"] + } +accountSpec OrdinaryProfit = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Ordinary profit" + , asNameJa = "経常利益 — 決算振替用" + , asLabelJa = "経常利益" + , asDescription = "Revenue: Ordinary profit (経常利益 — 決算振替用)" + , asAliases = ["経常利益"] + } +accountSpec InterestEarned = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Interest earned" + , asNameJa = "受取利息" + , asLabelJa = "受取利息" + , asDescription = "Revenue: Interest earned (受取利息)" + , asAliases = ["受取利息"] + } +accountSpec ReceiptFee = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Receipt fee" + , asNameJa = "受取手数料。支払側は 'PaymentFees'" + , asLabelJa = "受取手数料" + , asDescription = "Revenue: Receipt fee (受取手数料。支払側は 'PaymentFees')" + , asAliases = ["受取手数料"] + } +accountSpec RentalIncome = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Rental income" + , asNameJa = "受取家賃" + , asLabelJa = "受取家賃" + , asDescription = "Revenue: Rental income (受取家賃)" + , asAliases = ["受取家賃"] + } +accountSpec WageEarned = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Wage income" + , asNameJa = "賃金収入。SNA\\/マクロ系" + , asLabelJa = "賃金収入" + , asDescription = "Revenue: Wage income (賃金収入。SNA\\/マクロ系)" + , asAliases = ["賃金収入"] + } +accountSpec TaxesRevenue = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Tax revenue" + , asNameJa = "租税収入。SNA\\/マクロ系" + , asLabelJa = "租税収入" + , asDescription = "Revenue: Tax revenue (租税収入。SNA\\/マクロ系)" + , asAliases = ["租税収入"] + } +accountSpec CentralBankPaymentIncome = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Central bank payment to treasury" + , asNameJa = "国庫納付金収入。SNA\\/マクロ系" + , asLabelJa = "国庫納付金収入" + , asDescription = "Revenue: Central bank payment to treasury (国庫納付金収入。SNA\\/マクロ系)" + , asAliases = ["国庫納付金収入"] + } +accountSpec Sales = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Sales" + , asNameJa = "売上" + , asLabelJa = "売上" + , asDescription = "Revenue: Sales (売上)" + , asAliases = ["売上"] + } +accountSpec EquityInEarningsOfInvestee = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Equity in earnings of investee" + , asNameJa = "持分法による投資利益" + , asLabelJa = "持分法による投資利益" + , asDescription = "Revenue: Equity in earnings of investee (持分法による投資利益). Recognised under the equity method." + , asAliases = [] + } +accountSpec NetLoss = Just AccountSpec + { asDivision = Revenue + , asClosing = NoClose + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Net loss" + , asNameJa = "当期純損失 — 決算振替用。貸方側に立つため Revenue 区分" + , asLabelJa = "当期純損失" + , asDescription = "Revenue: Net loss (当期純損失 — 決算振替用。貸方側に立つため Revenue 区分)" + , asAliases = ["当期純損失"] + } +accountSpec PettyCash = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Petty cash" + , asNameJa = "小口現金" + , asLabelJa = "小口現金" + , asDescription = "Asset: Petty cash (小口現金)" + , asAliases = ["小口現金"] + } +accountSpec NotesReceivable = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Notes receivable" + , asNameJa = "受取手形" + , asLabelJa = "受取手形" + , asDescription = "Asset: Notes receivable (受取手形)" + , asAliases = ["受取手形"] + } +accountSpec ElectronicallyRecordedReceivable = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Electronically recorded monetary claims" + , asNameJa = "電子記録債権" + , asLabelJa = "電子記録債権" + , asDescription = "Asset: Electronically recorded monetary claims (電子記録債権)" + , asAliases = ["電子記録債権"] + } +accountSpec CreditCardReceivable = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Credit card receivable" + , asNameJa = "クレジット売掛金" + , asLabelJa = "クレジット売掛金" + , asDescription = "Asset: Credit card receivable (クレジット売掛金)" + , asAliases = ["クレジット売掛金"] + } +accountSpec NotesLoansReceivable = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Loans receivable on notes" + , asNameJa = "手形貸付金" + , asLabelJa = "手形貸付金" + , asDescription = "Asset: Loans receivable on notes (手形貸付金)" + , asAliases = ["手形貸付金"] + } +accountSpec MerchandiseInventory = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Merchandise inventory" + , asNameJa = "繰越商品" + , asLabelJa = "繰越商品" + , asDescription = "Asset: Merchandise inventory (繰越商品). Use under the periodic/3-account method (3 分法: Purchases\\/Sales\\/MerchandiseInventory). For the perpetual\\/specific-identification method (分記法) use 'Products' instead." + , asAliases = ["繰越商品"] + } +accountSpec AdvancesPaid = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Advances paid" + , asNameJa = "前払金" + , asLabelJa = "前払金" + , asDescription = "Asset: Advances paid (前払金)" + , asAliases = ["前払金"] + } +accountSpec PrepaidExpenses = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Prepaid expenses" + , asNameJa = "前払費用" + , asLabelJa = "前払費用" + , asDescription = "Asset: Prepaid expenses (前払費用), deferral accrual account (経過勘定)" + , asAliases = ["前払費用"] + } +accountSpec AccruedRevenue = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Accrued revenue" + , asNameJa = "未収収益" + , asLabelJa = "未収収益" + , asDescription = "Asset: Accrued revenue (未収収益), deferral accrual account (経過勘定)" + , asAliases = ["未収収益"] + } +accountSpec OtherReceivables = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Other receivables" + , asNameJa = "未収入金" + , asLabelJa = "未収入金" + , asDescription = "Asset: Other receivables (未収入金)" + , asAliases = ["未収入金"] + } +accountSpec PaymentsOnBehalf = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Payments made on behalf" + , asNameJa = "立替金" + , asLabelJa = "立替金" + , asDescription = "Asset: Payments made on behalf (立替金)" + , asAliases = ["立替金"] + } +accountSpec SuspensePayments = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Suspense payments" + , asNameJa = "仮払金" + , asLabelJa = "仮払金" + , asDescription = "Asset: Suspense payments (仮払金)" + , asAliases = ["仮払金"] + } +accountSpec ConsumptionTaxPaid = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Consumption tax paid" + , asNameJa = "仮払消費税" + , asLabelJa = "仮払消費税" + , asDescription = "Asset: Consumption tax paid (仮払消費税)" + , asAliases = ["仮払消費税"] + } +accountSpec PrepaidCorporateIncomeTaxes = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Prepaid corporate income taxes" + , asNameJa = "仮払法人税等" + , asLabelJa = "仮払法人税等" + , asDescription = "Asset: Prepaid corporate income taxes (仮払法人税等)" + , asAliases = ["仮払法人税等"] + } +accountSpec Land = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Land" + , asNameJa = "土地" + , asLabelJa = "土地" + , asDescription = "Asset: Land (土地)" + , asAliases = ["土地"] + } +accountSpec Fixtures = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Fixtures and equipment" + , asNameJa = "備品" + , asLabelJa = "備品" + , asDescription = "Asset: Fixtures and equipment (備品)" + , asAliases = ["備品"] + } +accountSpec Patent = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Patent" + , asNameJa = "特許権" + , asLabelJa = "特許権" + , asDescription = "Asset: Patent (特許権)" + , asAliases = ["特許権"] + } +accountSpec Trademark = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Trademark" + , asNameJa = "商標権" + , asLabelJa = "商標権" + , asDescription = "Asset: Trademark (商標権)" + , asAliases = ["商標権"] + } +accountSpec Software = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Software" + , asNameJa = "ソフトウェア" + , asLabelJa = "ソフトウェア" + , asDescription = "Asset: Software (ソフトウェア)" + , asAliases = ["ソフトウェア"] + } +accountSpec CashOverShort = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Cash over and short" + , asNameJa = "現金過不足" + , asLabelJa = "現金過不足" + , asDescription = "Asset: Cash over and short (現金過不足), a temporary/suspense account cleared at closing to MiscellaneousIncome\\/MiscellaneousLoss" + , asAliases = ["現金過不足"] + } +accountSpec AccountsPayable = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Accounts payable" + , asNameJa = "買掛金" + , asLabelJa = "買掛金" + , asDescription = "Liability: Accounts payable (買掛金)" + , asAliases = ["買掛金", "a/p", "accounts payable"] + } +accountSpec NotesPayable = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Notes payable" + , asNameJa = "支払手形" + , asLabelJa = "支払手形" + , asDescription = "Liability: Notes payable (支払手形)" + , asAliases = ["支払手形"] + } +accountSpec ElectronicallyRecordedObligations = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Electronically recorded monetary obligations" + , asNameJa = "電子記録債務" + , asLabelJa = "電子記録債務" + , asDescription = "Liability: Electronically recorded monetary obligations (電子記録債務)" + , asAliases = ["電子記録債務"] + } +accountSpec NotesLoansPayable = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Loans payable on notes" + , asNameJa = "手形借入金" + , asLabelJa = "手形借入金" + , asDescription = "Liability: Loans payable on notes (手形借入金)" + , asAliases = ["手形借入金"] + } +accountSpec BankOverdraft = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Bank overdraft" + , asNameJa = "当座借越" + , asLabelJa = "当座借越" + , asDescription = "Liability: Bank overdraft (当座借越)" + , asAliases = ["当座借越"] + } +accountSpec AdvancesReceived = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Advances received" + , asNameJa = "前受金" + , asLabelJa = "前受金" + , asDescription = "Liability: Advances received (前受金)" + , asAliases = ["前受金"] + } +accountSpec UnearnedRevenue = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Unearned revenue" + , asNameJa = "前受収益" + , asLabelJa = "前受収益" + , asDescription = "Liability: Unearned revenue (前受収益), deferral accrual account (経過勘定)" + , asAliases = ["前受収益"] + } +accountSpec AccruedExpenses = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Accrued expenses" + , asNameJa = "未払費用" + , asLabelJa = "未払費用" + , asDescription = "Liability: Accrued expenses (未払費用), deferral accrual account (経過勘定)" + , asAliases = ["未払費用"] + } +accountSpec OtherPayables = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Other payables" + , asNameJa = "未払金" + , asLabelJa = "未払金" + , asDescription = "Liability: Other payables (未払金)" + , asAliases = ["未払金"] + } +accountSpec DepositsReceived = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Deposits received" + , asNameJa = "預り金" + , asLabelJa = "預り金" + , asDescription = "Liability: Deposits received (預り金)" + , asAliases = ["預り金"] + } +accountSpec SuspenseReceipts = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Suspense receipts" + , asNameJa = "仮受金" + , asLabelJa = "仮受金" + , asDescription = "Liability: Suspense receipts (仮受金)" + , asAliases = ["仮受金"] + } +accountSpec ConsumptionTaxReceived = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Consumption tax received" + , asNameJa = "仮受消費税" + , asLabelJa = "仮受消費税" + , asDescription = "Liability: Consumption tax received (仮受消費税)" + , asAliases = ["仮受消費税"] + } +accountSpec AccruedConsumptionTax = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Accrued (unpaid) consumption tax" + , asNameJa = "未払消費税" + , asLabelJa = "未払消費税" + , asDescription = "Liability: Accrued (unpaid) consumption tax (未払消費税)" + , asAliases = ["未払消費税"] + } +accountSpec AccruedCorporateIncomeTaxes = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Accrued (unpaid) corporate income taxes" + , asNameJa = "未払法人税等" + , asLabelJa = "未払法人税等" + , asDescription = "Liability: Accrued (unpaid) corporate income taxes (未払法人税等)" + , asAliases = ["未払法人税等"] + } +accountSpec UnpaidDividends = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Unpaid dividends" + , asNameJa = "未払配当金" + , asLabelJa = "未払配当金" + , asDescription = "Liability: Unpaid dividends (未払配当金)" + , asAliases = ["未払配当金"] + } +accountSpec AllowanceForDoubtfulAccounts = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = True + , asFixedCurrent = Current + , asNameEn = "Allowance for doubtful accounts" + , asNameJa = "貸倒引当金" + , asLabelJa = "貸倒引当金" + , asDescription = "Asset (contra): Allowance for doubtful accounts (貸倒引当金), a credit-balance valuation account (評価勘定) deducted from receivables. Home side is Credit because it is a contra asset (isContra); values stay non-negative and the Hat\\/Not structure is intact. B\\/S deduction (net) presentation is the Write side's job." + , asAliases = ["貸倒引当金"] + } +accountSpec AccumulatedDepreciation = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = True + , asFixedCurrent = Fixed + , asNameEn = "Accumulated depreciation" + , asNameJa = "減価償却累計額" + , asLabelJa = "減価償却累計額" + , asDescription = "Asset (contra): Accumulated depreciation (減価償却累計額), a credit-balance valuation account (評価勘定) under the indirect method (間接法), deducted from the related depreciable assets. Home side is Credit because it is a contra asset (isContra). This is the canonical bookkeeping account for accumulated depreciation; the existing 'ReserveForDepreciation' is retained as the legacy SNA\\/macro-accounting name." + , asAliases = ["減価償却累計額"] + } +accountSpec LegalRetainedEarnings = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Legal (appropriated) retained earnings reserve" + , asNameJa = "利益準備金" + , asLabelJa = "利益準備金" + , asDescription = "Equity: Legal (appropriated) retained earnings reserve (利益準備金)" + , asAliases = ["利益準備金"] + } +accountSpec CumulativeTranslationAdjustment = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Cumulative translation adjustment" + , asNameJa = "為替換算調整勘定; 在外子会社等の外貨建財務諸表の換算差額を計上する OCI/資本の部の項目" + , asLabelJa = "為替換算調整勘定" + , asDescription = "Equity: Cumulative translation adjustment (為替換算調整勘定; 在外子会社等の外貨建財務諸表の換算差額を計上する OCI/資本の部の項目)" + , asAliases = [] + } +accountSpec ProvisionForDoubtfulAccounts = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Provision for doubtful accounts" + , asNameJa = "貸倒引当金繰入" + , asLabelJa = "貸倒引当金繰入" + , asDescription = "Cost: Provision for doubtful accounts (貸倒引当金繰入)" + , asAliases = ["貸倒引当金繰入"] + } +accountSpec BadDebtLoss = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Bad debt loss" + , asNameJa = "貸倒損失" + , asLabelJa = "貸倒損失" + , asDescription = "Cost: Bad debt loss (貸倒損失)" + , asAliases = ["貸倒損失"] + } +accountSpec LossOnSalesOfFixedAssets = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Loss on sales of fixed assets" + , asNameJa = "固定資産売却損" + , asLabelJa = "固定資産売却損" + , asDescription = "Cost: Loss on sales of fixed assets (固定資産売却損)" + , asAliases = ["固定資産売却損"] + } +accountSpec LossOnSalesOfNotesReceivable = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Loss on sales of notes receivable" + , asNameJa = "手形売却損" + , asLabelJa = "手形売却損" + , asDescription = "Cost: Loss on sales of notes receivable (手形売却損)" + , asAliases = ["手形売却損"] + } +accountSpec PaymentFees = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Payment fees / fees paid" + , asNameJa = "支払手数料" + , asLabelJa = "支払手数料" + , asDescription = "Cost: Payment fees / fees paid (支払手数料), the debit counterpart of 'ReceiptFee'" + , asAliases = ["支払手数料"] + } +accountSpec MiscellaneousLoss = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Miscellaneous loss" + , asNameJa = "雑損" + , asLabelJa = "雑損" + , asDescription = "Cost: Miscellaneous loss (雑損)" + , asAliases = ["雑損"] + } +accountSpec CorporateIncomeTaxes = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Corporate income taxes" + , asNameJa = "法人税等" + , asLabelJa = "法人税等" + , asDescription = "Cost: Corporate income taxes (法人税等)" + , asAliases = ["法人税等"] + } +accountSpec CommunicationExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Communication expenses" + , asNameJa = "通信費" + , asLabelJa = "通信費" + , asDescription = "Cost: Communication expenses (通信費). Explicitly named counterpart of the legacy 'Commutation' (also \"Communication\"); 'Commutation' is retained for backward compatibility." + , asAliases = ["通信費"] + } +accountSpec GainOnSalesOfFixedAssets = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Gain on sales of fixed assets" + , asNameJa = "固定資産売却益" + , asLabelJa = "固定資産売却益" + , asDescription = "Revenue: Gain on sales of fixed assets (固定資産売却益)" + , asAliases = ["固定資産売却益"] + } +accountSpec RecoveryOfBadDebts = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Recovery of bad debts written off" + , asNameJa = "償却債権取立益" + , asLabelJa = "償却債権取立益" + , asDescription = "Revenue: Recovery of bad debts written off (償却債権取立益)" + , asAliases = ["償却債権取立益"] + } +accountSpec MiscellaneousIncome = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Miscellaneous income" + , asNameJa = "雑益" + , asLabelJa = "雑益" + , asDescription = "Revenue: Miscellaneous income (雑益)" + , asAliases = ["雑益"] + } +accountSpec ReversalOfAllowanceForDoubtfulAccounts = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Reversal of allowance for doubtful accounts" + , asNameJa = "貸倒引当金戻入" + , asLabelJa = "貸倒引当金戻入" + , asDescription = "Revenue: Reversal of allowance for doubtful accounts (貸倒引当金戻入). Credit counterpart used by the 差額補充法/洗替法 when the estimated allowance is smaller than the existing balance (the excess of 'AllowanceForDoubtfulAccounts' is released)." + , asAliases = ["貸倒引当金戻入"] + } +accountSpec TimeDeposits = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Time deposits" + , asNameJa = "定期預金" + , asLabelJa = "定期預金" + , asDescription = "Assets: Time deposits (定期預金)" + , asAliases = ["定期預金"] + } +accountSpec LoansReceivable = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Loans receivable" + , asNameJa = "貸付金" + , asLabelJa = "貸付金" + , asDescription = "Assets: Loans receivable (貸付金)" + , asAliases = ["貸付金"] + } +accountSpec GiftCertificatesReceived = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Gift certificates received" + , asNameJa = "受取商品券" + , asLabelJa = "受取商品券" + , asDescription = "Assets: Gift certificates received (受取商品券)" + , asAliases = ["受取商品券"] + } +accountSpec SecurityDepositsPaid = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Guarantee deposits" + , asNameJa = "差入保証金" + , asLabelJa = "差入保証金" + , asDescription = "Assets: Guarantee deposits (差入保証金)" + , asAliases = ["差入保証金"] + } +accountSpec SuppliesOnHand = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Supplies" + , asNameJa = "貯蔵品" + , asLabelJa = "貯蔵品" + , asDescription = "Assets: Supplies (貯蔵品)" + , asAliases = ["貯蔵品"] + } +accountSpec ContractAssets = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Contract assets" + , asNameJa = "契約資産" + , asLabelJa = "契約資産" + , asDescription = "Assets: Contract assets (契約資産)" + , asAliases = ["契約資産"] + } +accountSpec IncomeTaxesRefundReceivable = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Income taxes refund receivable" + , asNameJa = "未収還付法人税等" + , asLabelJa = "未収還付法人税等" + , asDescription = "Assets: Income taxes refund receivable (未収還付法人税等)" + , asAliases = ["未収還付法人税等"] + } +accountSpec WorkInProcess = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Work in process" + , asNameJa = "仕掛品" + , asLabelJa = "仕掛品" + , asDescription = "Assets: Work in process (仕掛品)" + , asAliases = ["仕掛品"] + } +accountSpec DeferredTaxAssets = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Deferred tax assets" + , asNameJa = "繰延税金資産" + , asLabelJa = "繰延税金資産" + , asDescription = "Assets: Deferred tax assets (繰延税金資産)" + , asAliases = ["繰延税金資産"] + } +accountSpec LeasedAssets = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Leased assets" + , asNameJa = "リース資産" + , asLabelJa = "リース資産" + , asDescription = "Assets: Leased assets (リース資産)" + , asAliases = ["リース資産"] + } +accountSpec ToolsAndInstruments = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Tools and instruments" + , asNameJa = "工具器具" + , asLabelJa = "工具器具" + , asDescription = "Assets: Tools and instruments (工具器具)" + , asAliases = ["工具器具"] + } +accountSpec ConstructionInProgress = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Construction in progress" + , asNameJa = "建設仮勘定" + , asLabelJa = "建設仮勘定" + , asDescription = "Assets: Construction in progress (建設仮勘定)" + , asAliases = ["建設仮勘定"] + } +accountSpec Goodwill = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Goodwill" + , asNameJa = "のれん" + , asLabelJa = "のれん" + , asDescription = "Assets: Goodwill (のれん)" + , asAliases = ["のれん"] + } +accountSpec SoftwareInProgress = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Software in progress" + , asNameJa = "ソフトウェア仮勘定" + , asLabelJa = "ソフトウェア仮勘定" + , asDescription = "Assets: Software in progress (ソフトウェア仮勘定)" + , asAliases = ["ソフトウェア仮勘定"] + } +accountSpec LongTermPrepaidExpenses = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Long-term prepaid expenses" + , asNameJa = "長期前払費用" + , asLabelJa = "長期前払費用" + , asDescription = "Assets: Long-term prepaid expenses (長期前払費用)" + , asAliases = ["長期前払費用"] + } +accountSpec DishonoredNotesReceivable = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Dishonored notes receivable" + , asNameJa = "不渡手形" + , asLabelJa = "不渡手形" + , asDescription = "Assets: Dishonored notes receivable (不渡手形)" + , asAliases = ["不渡手形"] + } +accountSpec PrepaidPensionCost = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Prepaid pension costs" + , asNameJa = "前払年金費用" + , asLabelJa = "前払年金費用" + , asDescription = "Assets: Prepaid pension costs (前払年金費用)" + , asAliases = ["前払年金費用"] + } +accountSpec NetDefinedBenefitAsset = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Retirement benefit asset" + , asNameJa = "退職給付に係る資産" + , asLabelJa = "退職給付に係る資産" + , asDescription = "Assets: Retirement benefit asset (退職給付に係る資産)" + , asAliases = ["退職給付に係る資産"] + } +accountSpec DepositsInSpecialAccounts = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Deposits in special accounts" + , asNameJa = "別段預金" + , asLabelJa = "別段預金" + , asDescription = "Assets: Deposits in special accounts (別段預金)" + , asAliases = ["別段預金"] + } +accountSpec Structures = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Structures" + , asNameJa = "構築物" + , asLabelJa = "構築物" + , asDescription = "Assets: Structures (構築物)" + , asAliases = ["構築物"] + } +accountSpec LeaseholdRights = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Leasehold interests in land" + , asNameJa = "借地権" + , asLabelJa = "借地権" + , asDescription = "Assets: Leasehold interests in land (借地権)" + , asAliases = ["借地権"] + } +accountSpec NonOperatingNotesReceivable = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Non-operating notes receivable" + , asNameJa = "営業外受取手形" + , asLabelJa = "営業外受取手形" + , asDescription = "Assets: Non-operating notes receivable (営業外受取手形)" + , asAliases = ["営業外受取手形"] + } +accountSpec NonOperatingElectronicallyRecordedReceivable = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Electronically recorded monetary claims - non-operating" + , asNameJa = "営業外電子記録債権" + , asLabelJa = "営業外電子記録債権" + , asDescription = "Assets: Electronically recorded monetary claims - non-operating (営業外電子記録債権)" + , asAliases = ["営業外電子記録債権"] + } +accountSpec RefundLiabilities = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Refund liabilities" + , asNameJa = "返金負債" + , asLabelJa = "返金負債" + , asDescription = "Liability: Refund liabilities (返金負債)" + , asAliases = ["返金負債"] + } +accountSpec NonOperatingNotesPayable = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Non-operating notes payable" + , asNameJa = "営業外支払手形" + , asLabelJa = "営業外支払手形" + , asDescription = "Liability: Non-operating notes payable (営業外支払手形)" + , asAliases = ["営業外支払手形"] + } +accountSpec NonOperatingElectronicallyRecordedObligations = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Electronically recorded obligations - non-operating" + , asNameJa = "営業外電子記録債務" + , asLabelJa = "営業外電子記録債務" + , asDescription = "Liability: Electronically recorded obligations - non-operating (営業外電子記録債務)" + , asAliases = ["営業外電子記録債務"] + } +accountSpec BonusesPayable = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Accrued bonuses" + , asNameJa = "未払賞与" + , asLabelJa = "未払賞与" + , asDescription = "Liability: Accrued bonuses (未払賞与)" + , asAliases = ["未払賞与"] + } +accountSpec AllowanceForRepairs = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Provision for repairs" + , asNameJa = "修繕引当金" + , asLabelJa = "修繕引当金" + , asDescription = "Liability: Provision for repairs (修繕引当金)" + , asAliases = ["修繕引当金"] + } +accountSpec AllowanceForProductWarranties = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Provision for warranties" + , asNameJa = "商品保証引当金" + , asLabelJa = "商品保証引当金" + , asDescription = "Liability: Provision for warranties (商品保証引当金)" + , asAliases = ["商品保証引当金"] + } +accountSpec AllowanceForBonuses = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Provision for bonuses" + , asNameJa = "賞与引当金" + , asLabelJa = "賞与引当金" + , asDescription = "Liability: Provision for bonuses (賞与引当金)" + , asAliases = ["賞与引当金"] + } +accountSpec DeferredTaxLiabilities = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Deferred tax liabilities" + , asNameJa = "繰延税金負債" + , asLabelJa = "繰延税金負債" + , asDescription = "Liability: Deferred tax liabilities (繰延税金負債)" + , asAliases = ["繰延税金負債"] + } +accountSpec LeaseObligations = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Lease liabilities" + , asNameJa = "リース債務" + , asLabelJa = "リース債務" + , asDescription = "Liability: Lease liabilities (リース債務)" + , asAliases = ["リース債務"] + } +accountSpec GuaranteeDepositsReceived = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Guarantee deposits received" + , asNameJa = "預り保証金" + , asLabelJa = "預り保証金" + , asDescription = "Liability: Guarantee deposits received (預り保証金)" + , asAliases = ["預り保証金"] + } +accountSpec AllowanceForRetirementBenefits = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Provision for retirement benefits" + , asNameJa = "退職給付引当金" + , asLabelJa = "退職給付引当金" + , asDescription = "Liability: Provision for retirement benefits (退職給付引当金)" + , asAliases = ["退職給付引当金"] + } +accountSpec LongTermOtherPayables = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Long-term accounts payable - other" + , asNameJa = "長期未払金" + , asLabelJa = "長期未払金" + , asDescription = "Liability: Long-term accounts payable - other (長期未払金)" + , asAliases = ["長期未払金"] + } +accountSpec NetDefinedBenefitLiability = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Retirement benefit liability" + , asNameJa = "退職給付に係る負債" + , asLabelJa = "退職給付に係る負債" + , asDescription = "Liability: Retirement benefit liability (退職給付に係る負債)" + , asAliases = ["退職給付に係る負債"] + } +accountSpec StockSubscriptionDeposits = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Deposits for subscriptions of shares" + , asNameJa = "株式申込証拠金" + , asLabelJa = "株式申込証拠金" + , asDescription = "Equity: Deposits for subscriptions of shares (株式申込証拠金)" + , asAliases = ["株式申込証拠金"] + } +accountSpec LegalCapitalSurplus = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Legal capital surplus" + , asNameJa = "資本準備金" + , asLabelJa = "資本準備金" + , asDescription = "Equity: Legal capital surplus (資本準備金)" + , asAliases = ["資本準備金"] + } +accountSpec OtherCapitalSurplus = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Other capital surplus" + , asNameJa = "その他資本剰余金" + , asLabelJa = "その他資本剰余金" + , asDescription = "Equity: Other capital surplus (その他資本剰余金)" + , asAliases = ["その他資本剰余金"] + } +accountSpec DividendEqualizationReserve = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Reserve for dividend equalization" + , asNameJa = "配当平均積立金" + , asLabelJa = "配当平均積立金" + , asDescription = "Equity: Reserve for dividend equalization (配当平均積立金)" + , asAliases = ["配当平均積立金"] + } +accountSpec RepairFundReserve = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Reserve for repairs" + , asNameJa = "修繕積立金" + , asLabelJa = "修繕積立金" + , asDescription = "Equity: Reserve for repairs (修繕積立金)" + , asAliases = ["修繕積立金"] + } +accountSpec ConstructionFundReserve = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Reserve for new construction" + , asNameJa = "新築積立金" + , asLabelJa = "新築積立金" + , asDescription = "Equity: Reserve for new construction (新築積立金)" + , asAliases = ["新築積立金"] + } +accountSpec GeneralReserve = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "General reserve" + , asNameJa = "別途積立金" + , asLabelJa = "別途積立金" + , asDescription = "Equity: General reserve (別途積立金)" + , asAliases = ["別途積立金"] + } +accountSpec ValuationDifferenceOnOtherSecurities = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Valuation difference on available-for-sale securities" + , asNameJa = "その他有価証券評価差額金" + , asLabelJa = "その他有価証券評価差額金" + , asDescription = "Equity: Valuation difference on available-for-sale securities (その他有価証券評価差額金)" + , asAliases = ["その他有価証券評価差額金"] + } +accountSpec NonControllingInterests = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Non-controlling interests" + , asNameJa = "非支配株主持分" + , asLabelJa = "非支配株主持分" + , asDescription = "Equity: Non-controlling interests (非支配株主持分)" + , asAliases = ["非支配株主持分"] + } +accountSpec CapitalSurplus = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Capital surplus" + , asNameJa = "資本剰余金" + , asLabelJa = "資本剰余金" + , asDescription = "Equity: Capital surplus (資本剰余金)" + , asAliases = ["資本剰余金"] + } +accountSpec EarnedSurplus = Just AccountSpec + { asDivision = Equity + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Retained earnings" + , asNameJa = "利益剰余金" + , asLabelJa = "利益剰余金" + , asDescription = "Equity: Retained earnings (利益剰余金)" + , asAliases = ["利益剰余金"] + } +accountSpec ServiceRevenue = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Service revenue" + , asNameJa = "役務収益" + , asLabelJa = "役務収益" + , asDescription = "Revenue: Service revenue (役務収益)" + , asAliases = ["役務収益"] + } +accountSpec OperatingRevenue = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Operating revenue" + , asNameJa = "営業収益" + , asLabelJa = "営業収益" + , asDescription = "Revenue: Operating revenue (営業収益)" + , asAliases = ["営業収益"] + } +accountSpec GainOnSalesOfSecurities = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Gain on sale of securities" + , asNameJa = "有価証券売却益" + , asLabelJa = "有価証券売却益" + , asDescription = "Revenue: Gain on sale of securities (有価証券売却益)" + , asAliases = ["有価証券売却益"] + } +accountSpec GainOnValuationOfSecurities = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Gain on valuation of securities" + , asNameJa = "有価証券評価益" + , asLabelJa = "有価証券評価益" + , asDescription = "Revenue: Gain on valuation of securities (有価証券評価益)" + , asAliases = ["有価証券評価益"] + } +accountSpec DividendsReceived = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Dividend income" + , asNameJa = "受取配当金" + , asLabelJa = "受取配当金" + , asDescription = "Revenue: Dividend income (受取配当金)" + , asAliases = ["受取配当金"] + } +accountSpec InterestOnSecurities = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Interest on securities" + , asNameJa = "有価証券利息" + , asLabelJa = "有価証券利息" + , asDescription = "Revenue: Interest on securities (有価証券利息)" + , asAliases = ["有価証券利息"] + } +accountSpec GainOnSalesOfInvestmentSecurities = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Gain on sale of investment securities" + , asNameJa = "投資有価証券売却益" + , asLabelJa = "投資有価証券売却益" + , asDescription = "Revenue: Gain on sale of investment securities (投資有価証券売却益)" + , asAliases = ["投資有価証券売却益"] + } +accountSpec InsuranceGain = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Gain on insurance claims" + , asNameJa = "保険差益" + , asLabelJa = "保険差益" + , asDescription = "Revenue: Gain on insurance claims (保険差益)" + , asAliases = ["保険差益"] + } +accountSpec GainOnBargainPurchase = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Gain on bargain purchase" + , asNameJa = "負ののれん発生益" + , asLabelJa = "負ののれん発生益" + , asDescription = "Revenue: Gain on bargain purchase (負ののれん発生益)" + , asAliases = ["負ののれん発生益"] + } +accountSpec ReversalOfAllowanceForRepairs = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Reversal of provision for repairs" + , asNameJa = "修繕引当金戻入" + , asLabelJa = "修繕引当金戻入" + , asDescription = "Revenue: Reversal of provision for repairs (修繕引当金戻入)" + , asAliases = ["修繕引当金戻入"] + } +accountSpec ReversalOfAllowanceForProductWarranties = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Reversal of provision for warranties" + , asNameJa = "商品保証引当金戻入" + , asLabelJa = "商品保証引当金戻入" + , asDescription = "Revenue: Reversal of provision for warranties (商品保証引当金戻入)" + , asAliases = ["商品保証引当金戻入"] + } +accountSpec GainOnDonationOfFixedAssets = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Gain on receipt of donated non-current assets" + , asNameJa = "固定資産受贈益" + , asLabelJa = "固定資産受贈益" + , asDescription = "Revenue: Gain on receipt of donated non-current assets (固定資産受贈益)" + , asAliases = ["固定資産受贈益"] + } +accountSpec GainOnNationalSubsidies = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Gain on receipt of national subsidies" + , asNameJa = "国庫補助金受贈益" + , asLabelJa = "国庫補助金受贈益" + , asDescription = "Revenue: Gain on receipt of national subsidies (国庫補助金受贈益)" + , asAliases = ["国庫補助金受贈益"] + } +accountSpec GainOnConstructionGrants = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Gain on contribution received for construction" + , asNameJa = "工事負担金受贈益" + , asLabelJa = "工事負担金受贈益" + , asDescription = "Revenue: Gain on contribution received for construction (工事負担金受贈益)" + , asAliases = ["工事負担金受贈益"] + } +accountSpec LandRentReceived = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Rental income from land" + , asNameJa = "受取地代" + , asLabelJa = "受取地代" + , asDescription = "Revenue: Rental income from land (受取地代)" + , asAliases = ["受取地代"] + } +accountSpec SalesRebates = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = True + , asFixedCurrent = Other + , asNameEn = "Sales rebates" + , asNameJa = "売上割戻" + , asLabelJa = "売上割戻" + , asDescription = "Revenue: Sales rebates (売上割戻)" + , asAliases = ["売上割戻"] + } +accountSpec CostOfServices = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Cost of services" + , asNameJa = "役務原価" + , asLabelJa = "役務原価" + , asDescription = "Cost: Cost of services (役務原価)" + , asAliases = ["役務原価"] + } +accountSpec OperatingExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Operating expenses" + , asNameJa = "営業費用" + , asLabelJa = "営業費用" + , asDescription = "Cost: Operating expenses (営業費用)" + , asAliases = ["営業費用"] + } +accountSpec InventoryShrinkageLoss = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Inventory shrinkage loss" + , asNameJa = "棚卸減耗損" + , asLabelJa = "棚卸減耗損" + , asDescription = "Cost: Inventory shrinkage loss (棚卸減耗損)" + , asAliases = ["棚卸減耗損"] + } +accountSpec LossOnValuationOfMerchandise = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Valuation loss on goods" + , asNameJa = "商品評価損" + , asLabelJa = "商品評価損" + , asDescription = "Cost: Valuation loss on goods (商品評価損)" + , asAliases = ["商品評価損"] + } +accountSpec Bonuses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Bonuses" + , asNameJa = "賞与" + , asLabelJa = "賞与" + , asDescription = "Cost: Bonuses (賞与)" + , asAliases = ["賞与"] + } +accountSpec RetirementBenefitExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Retirement benefit expenses" + , asNameJa = "退職給付費用" + , asLabelJa = "退職給付費用" + , asDescription = "Cost: Retirement benefit expenses (退職給付費用)" + , asAliases = ["退職給付費用"] + } +accountSpec ProvisionForRepairs = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Provision for repairs" + , asNameJa = "修繕引当金繰入" + , asLabelJa = "修繕引当金繰入" + , asDescription = "Cost: Provision for repairs (修繕引当金繰入)" + , asAliases = ["修繕引当金繰入"] + } +accountSpec ProvisionForBonuses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Provision for bonuses" + , asNameJa = "賞与引当金繰入" + , asLabelJa = "賞与引当金繰入" + , asDescription = "Cost: Provision for bonuses (賞与引当金繰入)" + , asAliases = ["賞与引当金繰入"] + } +accountSpec ProvisionForProductWarranties = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Provision for warranties" + , asNameJa = "商品保証引当金繰入" + , asLabelJa = "商品保証引当金繰入" + , asDescription = "Cost: Provision for warranties (商品保証引当金繰入)" + , asAliases = ["商品保証引当金繰入"] + } +accountSpec ResearchAndDevelopmentExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Research and development expenses" + , asNameJa = "研究開発費" + , asLabelJa = "研究開発費" + , asDescription = "Cost: Research and development expenses (研究開発費)" + , asAliases = ["研究開発費"] + } +accountSpec AmortizationOfGoodwill = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Amortization of goodwill" + , asNameJa = "のれん償却" + , asLabelJa = "のれん償却" + , asDescription = "Cost: Amortization of goodwill (のれん償却)" + , asAliases = ["のれん償却"] + } +accountSpec AmortizationOfSoftware = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Amortization of software" + , asNameJa = "ソフトウェア償却" + , asLabelJa = "ソフトウェア償却" + , asDescription = "Cost: Amortization of software (ソフトウェア償却)" + , asAliases = ["ソフトウェア償却"] + } +accountSpec AmortizationOfPatents = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Amortization of patent rights" + , asNameJa = "特許権償却" + , asLabelJa = "特許権償却" + , asDescription = "Cost: Amortization of patent rights (特許権償却)" + , asAliases = ["特許権償却"] + } +accountSpec LeaseExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Lease expenses" + , asNameJa = "支払リース料" + , asLabelJa = "支払リース料" + , asDescription = "Cost: Lease expenses (支払リース料)" + , asAliases = ["支払リース料"] + } +accountSpec IncorporationExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Organization expenses" + , asNameJa = "創立費" + , asLabelJa = "創立費" + , asDescription = "Cost: Organization expenses (創立費)" + , asAliases = ["創立費"] + } +accountSpec StockIssuanceCosts = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Share issuance costs" + , asNameJa = "株式交付費" + , asLabelJa = "株式交付費" + , asDescription = "Cost: Share issuance costs (株式交付費)" + , asAliases = ["株式交付費"] + } +accountSpec BusinessCommencementExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Business commencement expenses" + , asNameJa = "開業費" + , asLabelJa = "開業費" + , asDescription = "Cost: Business commencement expenses (開業費)" + , asAliases = ["開業費"] + } +accountSpec DevelopmentExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Development expenses" + , asNameJa = "開発費" + , asLabelJa = "開発費" + , asDescription = "Cost: Development expenses (開発費)" + , asAliases = ["開発費"] + } +accountSpec LossOnSalesOfElectronicallyRecordedReceivables = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Loss on sale of electronically recorded monetary claims" + , asNameJa = "電子記録債権売却損" + , asLabelJa = "電子記録債権売却損" + , asDescription = "Cost: Loss on sale of electronically recorded monetary claims (電子記録債権売却損)" + , asAliases = ["電子記録債権売却損"] + } +accountSpec LossOnSalesOfReceivables = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Loss on sale of receivables" + , asNameJa = "債権売却損" + , asLabelJa = "債権売却損" + , asDescription = "Cost: Loss on sale of receivables (債権売却損)" + , asAliases = ["債権売却損"] + } +accountSpec LossOnSalesOfSecurities = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Loss on sale of securities" + , asNameJa = "有価証券売却損" + , asLabelJa = "有価証券売却損" + , asDescription = "Cost: Loss on sale of securities (有価証券売却損)" + , asAliases = ["有価証券売却損"] + } +accountSpec LossOnValuationOfSecurities = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Loss on valuation of securities" + , asNameJa = "有価証券評価損" + , asLabelJa = "有価証券評価損" + , asDescription = "Cost: Loss on valuation of securities (有価証券評価損)" + , asAliases = ["有価証券評価損"] + } +accountSpec LossOnSalesOfInvestmentSecurities = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Loss on sale of investment securities" + , asNameJa = "投資有価証券売却損" + , asLabelJa = "投資有価証券売却損" + , asDescription = "Cost: Loss on sale of investment securities (投資有価証券売却損)" + , asAliases = ["投資有価証券売却損"] + } +accountSpec LossOnFire = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Loss on fire" + , asNameJa = "火災損失" + , asLabelJa = "火災損失" + , asDescription = "Cost: Loss on fire (火災損失)" + , asAliases = ["火災損失"] + } +accountSpec LossOnRetirementOfFixedAssets = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Loss on retirement of non-current assets" + , asNameJa = "固定資産除却損" + , asLabelJa = "固定資産除却損" + , asDescription = "Cost: Loss on retirement of non-current assets (固定資産除却損)" + , asAliases = ["固定資産除却損"] + } +accountSpec LossOnReductionOfFixedAssets = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Loss on tax purpose reduction entry of non-current assets" + , asNameJa = "固定資産圧縮損" + , asLabelJa = "固定資産圧縮損" + , asDescription = "Cost: Loss on tax purpose reduction entry of non-current assets (固定資産圧縮損)" + , asAliases = ["固定資産圧縮損"] + } +accountSpec AdditionalIncomeTaxesForPriorPeriods = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Additional income taxes for prior periods" + , asNameJa = "追徴法人税等" + , asLabelJa = "追徴法人税等" + , asDescription = "Cost: Additional income taxes for prior periods (追徴法人税等)" + , asAliases = ["追徴法人税等"] + } +accountSpec RefundOfIncomeTaxes = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = True + , asFixedCurrent = Other + , asNameEn = "Refund of income taxes" + , asNameJa = "還付法人税等" + , asLabelJa = "還付法人税等" + , asDescription = "Cost: Refund of income taxes (還付法人税等)" + , asAliases = ["還付法人税等"] + } +accountSpec PurchaseRebates = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = True + , asFixedCurrent = Other + , asNameEn = "Purchase rebates" + , asNameJa = "仕入割戻" + , asLabelJa = "仕入割戻" + , asDescription = "Cost: Purchase rebates (仕入割戻)" + , asAliases = ["仕入割戻"] + } +accountSpec WelfareExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Welfare expenses" + , asNameJa = "福利厚生費" + , asLabelJa = "福利厚生費" + , asDescription = "Cost: Welfare expenses (福利厚生費)" + , asAliases = ["福利厚生費"] + } +accountSpec MaintenanceExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Maintenance expenses" + , asNameJa = "保守費" + , asLabelJa = "保守費" + , asDescription = "Cost: Maintenance expenses (保守費)" + , asAliases = ["保守費"] + } +accountSpec StatutoryWelfareExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Legal welfare expenses" + , asNameJa = "法定福利費" + , asLabelJa = "法定福利費" + , asDescription = "Cost: Legal welfare expenses (法定福利費)" + , asAliases = ["法定福利費"] + } +accountSpec LandRentPaid = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Rent expenses on land" + , asNameJa = "支払地代" + , asLabelJa = "支払地代" + , asDescription = "Cost: Rent expenses on land (支払地代)" + , asAliases = ["支払地代"] + } +accountSpec InsuranceExpense = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Insurance expenses" + , asNameJa = "保険料" + , asLabelJa = "保険料" + , asDescription = "Cost: Insurance expenses (保険料)" + , asAliases = ["保険料"] + } +accountSpec RepairsExpense = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Repair expenses" + , asNameJa = "修繕費" + , asLabelJa = "修繕費" + , asDescription = "Cost: Repair expenses (修繕費)" + , asAliases = ["修繕費"] + } +accountSpec StorageExpenses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Storage costs" + , asNameJa = "保管費" + , asLabelJa = "保管費" + , asDescription = "Cost: Storage costs (保管費)" + , asAliases = ["保管費"] + } +accountSpec MembershipFees = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Membership fees" + , asNameJa = "諸会費" + , asLabelJa = "諸会費" + , asDescription = "Cost: Membership fees (諸会費)" + , asAliases = ["諸会費"] + } +accountSpec IncomeSummary = Just AccountSpec + { asDivision = Assets + , asClosing = NoClose + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Income summary" + , asNameJa = "損益" + , asLabelJa = "損益" + , asDescription = "Bookkeeping device: Income summary (損益). Assets/NoClose is a technical debit-side placeholder; it is not a balance-sheet asset and is not automatically closed." + , asAliases = ["損益"] + } +accountSpec SuspenseAccount = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Suspense account" + , asNameJa = "未決算" + , asLabelJa = "未決算" + , asDescription = "Assets: Suspense account (未決算)" + , asAliases = ["未決算"] + } +accountSpec ForeignExchangeGains = Just AccountSpec + { asDivision = Revenue + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Foreign exchange gains" + , asNameJa = "為替差益" + , asLabelJa = "為替差益" + , asDescription = "Revenue: Foreign exchange gains (為替差益)" + , asAliases = ["為替差益"] + } +accountSpec ForeignExchangeLosses = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Foreign exchange losses" + , asNameJa = "為替差損" + , asLabelJa = "為替差損" + , asDescription = "Cost: Foreign exchange losses (為替差損)" + , asAliases = ["為替差損"] + } +accountSpec ContraAccountForGuaranteeObligations = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Contra account for guarantee obligations" + , asNameJa = "保証債務見返" + , asLabelJa = "保証債務見返" + , asDescription = "Assets: Contra account for guarantee obligations (保証債務見返)" + , asAliases = ["保証債務見返"] + } +accountSpec GuaranteeObligations = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Guarantee obligations" + , asNameJa = "保証債務" + , asLabelJa = "保証債務" + , asDescription = "Liability: Guarantee obligations (保証債務)" + , asAliases = ["保証債務"] + } +accountSpec IncomeTaxesAdjustment = Just AccountSpec + { asDivision = Cost + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Income taxes - deferred" + , asNameJa = "法人税等調整額" + , asLabelJa = "法人税等調整額" + , asDescription = "Cost: Income taxes - deferred (法人税等調整額)" + , asAliases = ["法人税等調整額"] + } +accountSpec BranchCurrentAccount = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Branch current account" + , asNameJa = "支店" + , asLabelJa = "支店" + , asDescription = "Assets: Branch current account (支店)" + , asAliases = ["支店"] + } +accountSpec HeadOfficeCurrentAccount = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Head office current account" + , asNameJa = "本店" + , asLabelJa = "本店" + , asDescription = "Liability: Head office current account (本店), the credit-balance reciprocal account in branch books." + , asAliases = ["本店"] + } +accountSpec NetIncomeAttributableToNCI = Just AccountSpec + { asDivision = Cost + , asClosing = NoClose + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Profit attributable to non-controlling interests" + , asNameJa = "非支配株主に帰属する当期純利益" + , asLabelJa = "非支配株主に帰属する当期純利益" + , asDescription = "Cost: Profit attributable to non-controlling interests (非支配株主に帰属する当期純利益). NoClose: consolidation procedures transfer it separately to non-controlling interests." + , asAliases = ["非支配株主に帰属する当期純利益"] + } +accountSpec NetLossAttributableToNCI = Just AccountSpec + { asDivision = Revenue + , asClosing = NoClose + , asIsContra = False + , asFixedCurrent = Other + , asNameEn = "Loss attributable to non-controlling interests" + , asNameJa = "非支配株主に帰属する当期純損失" + , asLabelJa = "非支配株主に帰属する当期純損失" + , asDescription = "Revenue: Loss attributable to non-controlling interests (非支配株主に帰属する当期純損失). NoClose: consolidation procedures transfer it separately to non-controlling interests." + , asAliases = ["非支配株主に帰属する当期純損失"] + } +accountSpec TradingSecurities = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Trading securities" + , asNameJa = "売買目的有価証券" + , asLabelJa = "売買目的有価証券" + , asDescription = "Assets: Trading securities (売買目的有価証券)" + , asAliases = ["売買目的有価証券"] + } +accountSpec HeldToMaturityBonds = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Held-to-maturity bonds" + , asNameJa = "満期保有目的債券" + , asLabelJa = "満期保有目的債券" + , asDescription = "Assets: Held-to-maturity bonds (満期保有目的債券)" + , asAliases = ["満期保有目的債券"] + } +accountSpec SubsidiaryStocks = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Shares of subsidiaries" + , asNameJa = "子会社株式" + , asLabelJa = "子会社株式" + , asDescription = "Assets: Shares of subsidiaries (子会社株式)" + , asAliases = ["子会社株式"] + } +accountSpec AffiliateStocks = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Shares of associates" + , asNameJa = "関連会社株式" + , asLabelJa = "関連会社株式" + , asDescription = "Assets: Shares of associates (関連会社株式)" + , asAliases = ["関連会社株式"] + } +accountSpec AvailableForSaleSecurities = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Fixed + , asNameEn = "Available-for-sale securities" + , asNameJa = "その他有価証券" + , asLabelJa = "その他有価証券" + , asDescription = "Assets: Available-for-sale securities (その他有価証券)" + , asAliases = ["その他有価証券"] + } +accountSpec ConsumptionTaxRefundReceivable = Just AccountSpec + { asDivision = Assets + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Consumption tax refund receivable" + , asNameJa = "未収還付消費税" + , asLabelJa = "未収還付消費税" + , asDescription = "Asset: Consumption tax refund receivable (未収還付消費税)" + , asAliases = ["未収還付消費税", "未収消費税"] + } +accountSpec PropertyTaxPayable = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Property tax payable" + , asNameJa = "未払固定資産税" + , asLabelJa = "未払固定資産税" + , asDescription = "Liability: Property tax payable (未払固定資産税)" + , asAliases = ["未払固定資産税"] + } +accountSpec DepositsReceivedFromOfficers = Just AccountSpec + { asDivision = Liability + , asClosing = CloseByDivision + , asIsContra = False + , asFixedCurrent = Current + , asNameEn = "Deposits received from officers" + , asNameJa = "役員預り金" + , asLabelJa = "役員預り金" + , asDescription = "Liability: Deposits received from officers (役員預り金)" + , asAliases = ["役員預り金"] + } +accountSpec AccountTitle = Nothing + +-- | Derived strict map view. The exhaustive function above remains canonical. +accountSpecMap :: Map AccountTitles AccountSpec +accountSpecMap = M.fromList + [ (title, spec) + | title <- concreteAccountTitles + , Just spec <- [accountSpec title] + ] + +-- | Whether an account is a contra account. +-- +-- The result is projected from 'AccountSpec.asIsContra'; the wildcard has no +-- specification and therefore returns 'False'. Complexity: O(1) +{-# INLINE classifyAccountContra #-} +classifyAccountContra :: AccountTitles -> Bool +classifyAccountContra title = maybe False asIsContra (accountSpec title) + +-- | Compatibility projection used by the assistance API. +accountDescriptions :: [(AccountTitles, Text, Text, Text)] +accountDescriptions = mapMaybe project concreteAccountTitles + where + project title = do + spec <- accountSpec title + pure (title, asNameEn spec, asNameJa spec, asDescription spec) diff --git a/src/ExchangeAlgebra/Algebra/Base/Account/Types.hs b/src/ExchangeAlgebra/Algebra/Base/Account/Types.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Algebra/Base/Account/Types.hs @@ -0,0 +1,102 @@ +{- | +Module : ExchangeAlgebra.Algebra.Base.Account.Types +Description : Account metadata types shared by Base and the account registry. +-} +module ExchangeAlgebra.Algebra.Base.Account.Types + ( AccountDivision(..) + , Side(..) + , ClosingRule(..) + , FixedCurrent(..) + , AccountRole(..) + , PostingCapability(..) + , DivisionSemantics(..) + , HomeSideSemantics(..) + , ReportingEligibility(..) + ) where + +-- | Account division (financial-statement classification). The +-- 'ExchangeAlgebra.Algebra.Base.AccountBase' +-- correspondence instance lives in "ExchangeAlgebra.Algebra.Base" (the class's +-- home module), so this declaration stays instance-free. +data AccountDivision = Assets -- ^ Assets + | Equity -- ^ Equity + | Liability -- ^ Liability + | Cost -- ^ Cost + | Revenue -- ^ Revenue + deriving (Ord, Show, Eq) + +-- | Credit/debit distinction. v'Side' is the wildcard used by legacy APIs. +data Side = Credit -- ^ Credit side. + | Debit -- ^ Debit side. + | Side -- ^ Wildcard. + deriving (Ord, Show, Eq) + +-- | Registry-level policy for automatic closing entries. +-- +-- 'CloseByDivision' derives the transfer side from 'AccountDivision'. +-- 'NoClose' is an explicit override. Future policies may add explicit +-- keep/flip constructors without returning to an account-title case split. +data ClosingRule = CloseByDivision -- ^ Close Cost/Revenue accounts according to their division. + | NoClose -- ^ Do not generate an automatic closing entry. + deriving (Show, Eq) + +-- | Fixed/Current distinction. Used for classifying account titles as fixed or current. +data FixedCurrent = Fixed -- ^ Fixed + | Current -- ^ Current + | Other -- ^ Other (expenses, revenues, etc.) + deriving (Show, Eq) + +-- | Accounting role of an account-basis coordinate. Roles are not assumed to +-- be mutually exclusive; see +-- 'ExchangeAlgebra.Algebra.Base.Account.Registry.AccountSemantics' in the +-- account registry. +data AccountRole + = OrdinaryAccount + | ContraAccount + | ReciprocalAccount + | SuspenseOrClearingAccount + | ClosingDevice + | AttributionAccount + | PeriodResult + | ReportingSubtotal + deriving (Show, Eq) + +-- | Context in which an account title may be used as a posting coordinate. +-- Enforcement is introduced by the checked-conversion API in a later land; +-- this type is the canonical metadata used by that gate. +data PostingCapability + = OrdinaryPosting + | ClosingOnly + | ConsolidationOnly + | EngineGeneratedOnly + | NotPostable + deriving (Show, Eq) + +-- | Meaning of the legacy five-way 'AccountDivision' value. +-- +-- This separates a genuine statement classification from a bookkeeping +-- control class or an internal direction encoding. The wrapped legacy value +-- remains available for 0.4.x-compatible algebraic behaviour. +data DivisionSemantics + = StatementDivision AccountDivision + | BookkeepingControlClass AccountDivision + | DirectionEncoding AccountDivision + | NoStatementDivision + deriving (Show, Eq) + +-- | Semantic status of an account's normal posting side. +data HomeSideSemantics + = FixedHomeSide Side + | ContextDependentHomeSide + | NoFixedHomeSide + | NoPostingSide + deriving (Show, Eq) + +-- | Coarse reporting eligibility. Actual presentation remains a function of +-- reporting context and policy and is implemented in a later land. +data ReportingEligibility + = StatementEligible + | ContextualPresentation + | DerivedPresentation + | NotPresented + deriving (Show, Eq) diff --git a/src/ExchangeAlgebra/Algebra/Base/Element.hs b/src/ExchangeAlgebra/Algebra/Base/Element.hs --- a/src/ExchangeAlgebra/Algebra/Base/Element.hs +++ b/src/ExchangeAlgebra/Algebra/Base/Element.hs @@ -25,7 +25,7 @@ deriving (Eq, Ord, Show, Generic, Hashable, Typeable) instance Element Company where - wiledcard = CompanyWildcard + wildcard = CompanyWildcard @ == Import guidance @@ -46,10 +46,15 @@ {-# LANGUAGE Strict #-} {-# LANGUAGE DeriveGeneric #-} +-- NB. Only the two names a user needs to define an 'Element' instance are +-- re-exported ('Hashable' for the constraint/instance, 'Generic' for deriving). +-- The former whole-module re-exports of "Data.Hashable" and "GHC.Generics" +-- leaked their entire namespaces (hash, hashUsing, Rep, from/to, …) through +-- Base -> Algebra -> the ExchangeAlgebra umbrella. module ExchangeAlgebra.Algebra.Base.Element ( module ExchangeAlgebra.Algebra.Base.Element - , module Data.Hashable - , module GHC.Generics) where + , Hashable(..) + , Generic) where import qualified Data.Text as T import Data.Text (Text) @@ -59,6 +64,8 @@ import Data.Hashable import Data.Typeable (Typeable, cast, typeOf) import qualified Data.Binary as Binary +import qualified Data.Binary.Get as BinaryGet +import qualified Data.Binary.Put as BinaryPut ------------------------------------------------------------------ -- * Element (components of bases) @@ -74,33 +81,33 @@ -- | The wildcard value. Used for pattern matching in search, transfer transformation, etc. -- -- Complexity: O(1) - wiledcard :: a + wildcard :: a -- | Determines whether the element itself or any of its internal components contains a wildcard. -- For tuple elements, returns True if any component is a wildcard. -- -- Complexity: O(k) (k is the number of tuple components; O(1) for primitive types) - {-# INLINE haveWiledcard #-} - haveWiledcard :: a -> Bool - haveWiledcard = isWiledcard + {-# INLINE haveWildcard #-} + haveWildcard :: a -> Bool + haveWildcard = isWildcard -- | Determines whether the value is exactly the wildcard. -- -- Complexity: O(1) - {-# INLINE isWiledcard #-} - isWiledcard :: a -> Bool - isWiledcard a = a == wiledcard + {-# INLINE isWildcard #-} + isWildcard :: a -> Bool + isWildcard a = a == wildcard -- | Wildcard-ignoring transformation. -- If @after@ is a wildcard, returns @before@. -- Used inside transfer to fill wildcard positions in the target basis with the original values. -- -- Complexity: O(k) (k is the number of tuple components; O(1) for primitive types) - {-# INLINE ignoreWiledcard #-} - ignoreWiledcard :: a -> a -> a - ignoreWiledcard before after + {-# INLINE ignoreWildcard #-} + ignoreWildcard :: a -> a -> a + ignoreWildcard before after | before == after = before - | isWiledcard after = before + | isWildcard after = before | otherwise = after -- | Wildcard-aware equality test. @@ -109,8 +116,8 @@ -- Complexity: O(k) (k is the number of tuple components; O(1) for primitive types) {-# INLINE equal #-} equal :: a -> a -> Bool - equal a b | isWiledcard a = True - | isWiledcard b = True + equal a b | isWildcard a = True + | isWildcard b = True | otherwise = a == b -- | Equality operator that treats wildcards as equal. @@ -119,7 +126,7 @@ -- Complexity: O(k) (k is the number of tuple components; O(1) for primitive types) {-# INLINE (.==) #-} (.==) :: a -> a -> Bool - (.==) a b = a == b || (haveWiledcard a || haveWiledcard b) && equal a b + (.==) a b = a == b || (haveWildcard a || haveWildcard b) && equal a b -- | Inequality operator that treats wildcards as equal. Negation of @(.==)@. -- @@ -192,7 +199,7 @@ {-# INLINE axisIsWildcard #-} axisIsWildcard :: AxisKey -> Bool -axisIsWildcard (AxisKey x) = isWiledcard x +axisIsWildcard (AxisKey x) = isWildcard x -- | A type class for decomposing a basis element into a list of per-axis t'AxisKey's. -- Overlapping instances are defined for tuple types so that each component @@ -206,13 +213,13 @@ {-# INLINE toAxisKeys #-} toAxisKeys a = [AxisKey a] --- | Shorthand notation for the wildcard. An alias for @wiledcard@. +-- | Shorthand notation for the wildcard. An alias for @wildcard@. -- Write @(.#)@ when specifying patterns in projections and transfer transformations. -- -- Complexity: O(1) {-# INLINE (.#) #-} (.#) :: Element a => a -(.#) = wiledcard +(.#) = wildcard infix 4 .== infix 4 ./= @@ -222,84 +229,277 @@ -- ** Account Titles -data AccountTitles = Cash -- ^ Asset: Cash - | Deposits -- ^ Asset: Savings deposits - | CurrentDeposits -- ^ Asset: Current deposits - | Securities -- ^ Asset: Securities - | InvestmentSecurities -- ^ Asset: Investment securities - | LongTermNationalBonds -- ^ Asset: Long-term national bonds - | ShortTermNationalBonds -- ^ Asset: Short-term national bonds - | Products -- ^ Asset: Products - | Machinery -- ^ Asset: Machinery and equipment - | Building -- ^ Asset: Real estate - | Vehicle -- ^ Asset: Vehicles - | StockInvestment -- ^ Asset: Stock investment - | EquipmentInvestment -- ^ Asset: Equipment investment - | LongTermLoansReceivable -- ^ Asset: Loans receivable - | AccountsReceivable -- ^ Asset: Accounts receivable - | ShortTermLoansReceivable -- ^ Asset: Short-term loans receivable - | ReserveDepositReceivable -- ^ Asset: Reserve deposit receivable - | Gold -- ^ Asset: Gold - | GovernmentService -- ^ Asset: Government service expenditure - | CapitalStock -- ^ Equity: Capital stock - | RetainedEarnings -- ^ Equity: Retained earnings - | LongTermLoansPayable -- ^ Liability: Long-term loans payable - | ShortTermLoansPayable -- ^ Liability: Short-term loans payable - | LoansPayable -- ^ Liability: Loans payable - | ReserveForDepreciation -- ^ Liability: Reserve for depreciation - | DepositPayable -- ^ Liability: Deposits received - | LongTermNationalBondsPayable -- ^ Liability: Long-term national bonds payable - | ShortTermNationalBondsPayable -- ^ Liability: Short-term national bonds payable - | ReserveDepositPayable -- ^ Liability: Accounts payable - | CentralBankNotePayable -- ^ Liability: Central bank notes payable - | Depreciation -- ^ Expense: Depreciation - | SalesCost -- ^ Expense: Cost of sales - | BusinessTrip -- ^ Expense: Travel and transportation - | Commutation -- ^ Expense: Communication - | UtilitiesExpense -- ^ Expense: Utilities - | RentExpense -- ^ Expense: Rent - | AdvertisingExpense -- ^ Expense: Advertising - | DeliveryExpenses -- ^ Expense: Delivery - | SuppliesExpenses -- ^ Expense: Supplies - | MiscellaneousExpenses -- ^ Expense: Miscellaneous - | WageExpenditure -- ^ Expense: Wages - | InterestExpense -- ^ Expense: Interest expense - | TaxesExpense -- ^ Expense: Taxes - | ConsumptionExpenditure -- ^ Expense: Consumables - | SubsidyExpense -- ^ Expense: Subsidy expenditure - | CentralBankPaymentExpense -- ^ Expense - | Purchases -- ^ Expense: Purchases - | NetIncome -- ^ Expense: Net income - | ValueAdded -- ^ Revenue: Value added - | SubsidyIncome -- ^ Revenue: Subsidy income - | NationalBondInterestEarned -- ^ Revenue: National bond interest earned - | DepositInterestEarned -- ^ Revenue: Deposit interest earned - | GrossProfit -- ^ Revenue: Gross profit - | OrdinaryProfit -- ^ Revenue: Ordinary profit - | InterestEarned -- ^ Revenue: Interest earned - | ReceiptFee -- ^ Revenue: Receipt fee - | RentalIncome -- ^ Revenue: Rental income - | WageEarned -- ^ Revenue: Wage income - | TaxesRevenue -- ^ Revenue: Tax revenue - | CentralBankPaymentIncome -- ^ Revenue - | Sales -- ^ Revenue: Sales - | NetLoss -- ^ Revenue: Net loss - | AccountTitle -- ^ Wildcard - deriving (Show, Ord, Eq, Enum, Generic) +data AccountTitles = Cash -- ^ Asset: Cash (現金) + | Deposits -- ^ Asset: Savings deposits (普通預金) + | CurrentDeposits -- ^ Asset: Current deposits (当座預金) + | Securities -- ^ Asset: Securities (有価証券) + | InvestmentSecurities -- ^ Asset: Investment securities (投資有価証券) + | InvestmentInAssociate -- ^ Asset: Investment in associate (関係会社株式). Carrying amount under the equity method (持分法適用投資勘定). + | LongTermNationalBonds -- ^ Asset: Long-term national bonds (長期国債) + | ShortTermNationalBonds -- ^ Asset: Short-term national bonds (短期国債) + | Products -- ^ Asset: Products (商品)。分記法用。3 分法 (仕入\/売上\/繰越商品) では 'MerchandiseInventory' を使う + | Machinery -- ^ Asset: Machinery and equipment (機械装置) + | Building -- ^ Asset: Real estate (建物) + | Vehicle -- ^ Asset: Vehicles (車両運搬具) + | StockInvestment -- ^ Asset: Stock investment (株式投資) + | EquipmentInvestment -- ^ Asset: Equipment investment (設備投資) + | LongTermLoansReceivable -- ^ Asset: Long-term loans receivable (長期貸付金) + | AccountsReceivable -- ^ Asset: Accounts receivable (売掛金) + | ShortTermLoansReceivable -- ^ Asset: Short-term loans receivable (短期貸付金) + | ReserveDepositReceivable -- ^ Asset: Reserve deposits, asset side (準備預金, 資産側 — 市中銀行が中央銀行に置く準備預金。SNA\/マクロ系) + | Gold -- ^ Asset: Gold (金) + | GovernmentService -- ^ Asset: Government service (政府サービス。SNA\/マクロ系) + | CapitalStock -- ^ Equity: Capital stock (資本金) + | RetainedEarnings -- ^ Equity: Retained earnings (繰越利益剰余金) + | LongTermLoansPayable -- ^ Liability: Long-term loans payable (長期借入金) + | ShortTermLoansPayable -- ^ Liability: Short-term loans payable (短期借入金) + | LoansPayable -- ^ Liability: Loans payable (借入金) + | ReserveForDepreciation -- ^ Liability: Reserve for depreciation (減価償却引当金 — SNA\/マクロ系の旧称。簿記の間接法には 'AccumulatedDepreciation' (減価償却累計額) を使う) + | DepositPayable -- ^ Liability: Deposits accepted (受入預金 — 銀行側の負債としての預金。SNA\/マクロ系。従業員等からの預り金は 'DepositsReceived') + | LongTermNationalBondsPayable -- ^ Liability: Long-term national bonds payable (長期国債, 発行側) + | ShortTermNationalBondsPayable -- ^ Liability: Short-term national bonds payable (短期国債, 発行側) + | ReserveDepositPayable -- ^ Liability: Reserve deposits, liability side (準備預金, 負債側 — 中央銀行が受け入れる準備預金。SNA\/マクロ系)。※簿記の買掛金は 'AccountsPayable' を使うこと (旧 examples が本科目を買掛金の代用にしていた経緯あり) + | CentralBankNotePayable -- ^ Liability: Central bank notes (発行銀行券。SNA\/マクロ系) + | Depreciation -- ^ Expense: Depreciation (減価償却費) + | AmortizationExpense -- ^ Expense: Amortization expense for intangibles (無形固定資産償却費 — 特許権・商標権・ソフトウェア等の無形資産の償却費。有形の 'Depreciation' (減価償却費) と区別される) + | SalesCost -- ^ Expense: Cost of sales (売上原価) + | BusinessTrip -- ^ Expense: Travel and transportation (旅費交通費) + | Commutation -- ^ Expense: Communication (通信費 — 旧称。新規コードでは 'CommunicationExpenses' を使う) + | UtilitiesExpense -- ^ Expense: Utilities (水道光熱費) + | RentExpense -- ^ Expense: Rent (支払家賃) + | AdvertisingExpense -- ^ Expense: Advertising (広告宣伝費) + | DeliveryExpenses -- ^ Expense: Delivery (発送費) + | SuppliesExpenses -- ^ Expense: Supplies (消耗品費) + | MiscellaneousExpenses -- ^ Expense: Miscellaneous (雑費) + | WageExpenditure -- ^ Expense: Wages (給料) + | InterestExpense -- ^ Expense: Interest expense (支払利息) + | TaxesExpense -- ^ Expense: Taxes (租税公課) + | ConsumptionExpenditure -- ^ Expense: Consumption expenditure (消費支出。SNA\/マクロ系) + | SubsidyExpense -- ^ Expense: Subsidy expenditure (補助金支出。SNA\/マクロ系) + | CentralBankPaymentExpense -- ^ Expense: Central bank payment to treasury (国庫納付金支出。SNA\/マクロ系) + | Purchases -- ^ Expense: Purchases (仕入) + | NetIncome -- ^ Expense: Net income (当期純利益 — 決算振替用。借方側に立つため Expense 区分) + | ValueAdded -- ^ Revenue: Value added (付加価値。SNA\/マクロ系) + | SubsidyIncome -- ^ Revenue: Subsidy income (補助金収入。SNA\/マクロ系) + | NationalBondInterestEarned -- ^ Revenue: National bond interest earned (国債利息収入) + | DepositInterestEarned -- ^ Revenue: Deposit interest earned (預金利息収入) + | GrossProfit -- ^ Revenue: Gross profit (売上総利益 — 決算振替用) + | OrdinaryProfit -- ^ Revenue: Ordinary profit (経常利益 — 決算振替用) + | InterestEarned -- ^ Revenue: Interest earned (受取利息) + | ReceiptFee -- ^ Revenue: Receipt fee (受取手数料。支払側は 'PaymentFees') + | RentalIncome -- ^ Revenue: Rental income (受取家賃) + | WageEarned -- ^ Revenue: Wage income (賃金収入。SNA\/マクロ系) + | TaxesRevenue -- ^ Revenue: Tax revenue (租税収入。SNA\/マクロ系) + | CentralBankPaymentIncome -- ^ Revenue: Central bank payment to treasury (国庫納付金収入。SNA\/マクロ系) + | Sales -- ^ Revenue: Sales (売上) + | EquityInEarningsOfInvestee -- ^ Revenue: Equity in earnings of investee (持分法による投資利益). Recognised under the equity method. + | NetLoss -- ^ Revenue: Net loss (当期純損失 — 決算振替用。貸方側に立つため Revenue 区分) + -- Elementary bookkeeping (日商簿記 3 級水準) additions. + -- Appended before the 'AccountTitle' wildcard so that only the + -- wildcard's Enum/Binary ordinal shifts (existing serialized + -- bases remain compatible). + -- + -- Assets (資産) + | PettyCash -- ^ Asset: Petty cash (小口現金) + | NotesReceivable -- ^ Asset: Notes receivable (受取手形) + | ElectronicallyRecordedReceivable -- ^ Asset: Electronically recorded monetary claims (電子記録債権) + | CreditCardReceivable -- ^ Asset: Credit card receivable (クレジット売掛金) + | NotesLoansReceivable -- ^ Asset: Loans receivable on notes (手形貸付金) + | MerchandiseInventory -- ^ Asset: Merchandise inventory (繰越商品). Use under the periodic/3-account method (3 分法: Purchases\/Sales\/MerchandiseInventory). For the perpetual\/specific-identification method (分記法) use 'Products' instead. + | AdvancesPaid -- ^ Asset: Advances paid (前払金) + | PrepaidExpenses -- ^ Asset: Prepaid expenses (前払費用), deferral accrual account (経過勘定) + | AccruedRevenue -- ^ Asset: Accrued revenue (未収収益), deferral accrual account (経過勘定) + | OtherReceivables -- ^ Asset: Other receivables (未収入金) + | PaymentsOnBehalf -- ^ Asset: Payments made on behalf (立替金) + | SuspensePayments -- ^ Asset: Suspense payments (仮払金) + | ConsumptionTaxPaid -- ^ Asset: Consumption tax paid (仮払消費税) + | PrepaidCorporateIncomeTaxes -- ^ Asset: Prepaid corporate income taxes (仮払法人税等) + | Land -- ^ Asset: Land (土地) + | Fixtures -- ^ Asset: Fixtures and equipment (備品) + | Patent -- ^ Asset: Patent (特許権) + | Trademark -- ^ Asset: Trademark (商標権) + | Software -- ^ Asset: Software (ソフトウェア) + | CashOverShort -- ^ Asset: Cash over and short (現金過不足), a temporary/suspense account cleared at closing to MiscellaneousIncome\/MiscellaneousLoss + -- Liability (負債) + | AccountsPayable -- ^ Liability: Accounts payable (買掛金) + | NotesPayable -- ^ Liability: Notes payable (支払手形) + | ElectronicallyRecordedObligations -- ^ Liability: Electronically recorded monetary obligations (電子記録債務) + | NotesLoansPayable -- ^ Liability: Loans payable on notes (手形借入金) + | BankOverdraft -- ^ Liability: Bank overdraft (当座借越) + | AdvancesReceived -- ^ Liability: Advances received (前受金) + | UnearnedRevenue -- ^ Liability: Unearned revenue (前受収益), deferral accrual account (経過勘定) + | AccruedExpenses -- ^ Liability: Accrued expenses (未払費用), deferral accrual account (経過勘定) + | OtherPayables -- ^ Liability: Other payables (未払金) + | DepositsReceived -- ^ Liability: Deposits received (預り金) + | SuspenseReceipts -- ^ Liability: Suspense receipts (仮受金) + | ConsumptionTaxReceived -- ^ Liability: Consumption tax received (仮受消費税) + | AccruedConsumptionTax -- ^ Liability: Accrued (unpaid) consumption tax (未払消費税) + | AccruedCorporateIncomeTaxes -- ^ Liability: Accrued (unpaid) corporate income taxes (未払法人税等) + | UnpaidDividends -- ^ Liability: Unpaid dividends (未払配当金) + | AllowanceForDoubtfulAccounts -- ^ Asset (contra): Allowance for doubtful accounts (貸倒引当金), a credit-balance valuation account (評価勘定) deducted from receivables. Division is Assets with @isContra = True@ (Definition 7 amendment, 0.5.0.0); home side stays Credit, values stay non-negative, Hat\/Not structure intact. B\/S deduction (net) presentation is the Write side's job. + | AccumulatedDepreciation -- ^ Asset (contra): Accumulated depreciation (減価償却累計額), valuation account (評価勘定) under the indirect method (間接法), deducted from the related depreciable assets. Division is Assets with @isContra = True@ for the same reason as 'AllowanceForDoubtfulAccounts'. This is the canonical bookkeeping account for accumulated depreciation; the existing 'ReserveForDepreciation' is retained as the legacy SNA\/macro-accounting name. + -- Equity (資本) + | LegalRetainedEarnings -- ^ Equity: Legal (appropriated) retained earnings reserve (利益準備金) + | CumulativeTranslationAdjustment -- ^ Equity: Cumulative translation adjustment (為替換算調整勘定; 在外子会社等の外貨建財務諸表の換算差額を計上する OCI/資本の部の項目) + -- Cost (費用) + | ProvisionForDoubtfulAccounts -- ^ Cost: Provision for doubtful accounts (貸倒引当金繰入) + | BadDebtLoss -- ^ Cost: Bad debt loss (貸倒損失) + | LossOnSalesOfFixedAssets -- ^ Cost: Loss on sales of fixed assets (固定資産売却損) + | LossOnSalesOfNotesReceivable -- ^ Cost: Loss on sales of notes receivable (手形売却損) + | PaymentFees -- ^ Cost: Payment fees / fees paid (支払手数料), the debit counterpart of 'ReceiptFee' + | MiscellaneousLoss -- ^ Cost: Miscellaneous loss (雑損) + | CorporateIncomeTaxes -- ^ Cost: Corporate income taxes (法人税等) + | CommunicationExpenses -- ^ Cost: Communication expenses (通信費). Explicitly named counterpart of the legacy 'Commutation' (also "Communication"); 'Commutation' is retained for backward compatibility. + -- Revenue (収益) + | GainOnSalesOfFixedAssets -- ^ Revenue: Gain on sales of fixed assets (固定資産売却益) + | RecoveryOfBadDebts -- ^ Revenue: Recovery of bad debts written off (償却債権取立益) + | MiscellaneousIncome -- ^ Revenue: Miscellaneous income (雑益) + | ReversalOfAllowanceForDoubtfulAccounts -- ^ Revenue: Reversal of allowance for doubtful accounts (貸倒引当金戻入). Credit counterpart used by the 差額補充法/洗替法 when the estimated allowance is smaller than the existing balance (the excess of 'AllowanceForDoubtfulAccounts' is released). + -- V-Land 2: JCCI grade-2 commercial-bookkeeping vocabulary. + | TimeDeposits -- ^ Assets: Time deposits (定期預金) + | LoansReceivable -- ^ Assets: Loans receivable (貸付金) + | GiftCertificatesReceived -- ^ Assets: Gift certificates received (受取商品券) + | SecurityDepositsPaid -- ^ Assets: Guarantee deposits (差入保証金) + | SuppliesOnHand -- ^ Assets: Supplies (貯蔵品) + | ContractAssets -- ^ Assets: Contract assets (契約資産) + | IncomeTaxesRefundReceivable -- ^ Assets: Income taxes refund receivable (未収還付法人税等) + | WorkInProcess -- ^ Assets: Work in process (仕掛品) + | DeferredTaxAssets -- ^ Assets: Deferred tax assets (繰延税金資産) + | LeasedAssets -- ^ Assets: Leased assets (リース資産) + | ToolsAndInstruments -- ^ Assets: Tools and instruments (工具器具) + | ConstructionInProgress -- ^ Assets: Construction in progress (建設仮勘定) + | Goodwill -- ^ Assets: Goodwill (のれん) + | SoftwareInProgress -- ^ Assets: Software in progress (ソフトウェア仮勘定) + | LongTermPrepaidExpenses -- ^ Assets: Long-term prepaid expenses (長期前払費用) + | DishonoredNotesReceivable -- ^ Assets: Dishonored notes receivable (不渡手形) + | PrepaidPensionCost -- ^ Assets: Prepaid pension costs (前払年金費用) + | NetDefinedBenefitAsset -- ^ Assets: Retirement benefit asset (退職給付に係る資産) + | DepositsInSpecialAccounts -- ^ Assets: Deposits in special accounts (別段預金) + | Structures -- ^ Assets: Structures (構築物) + | LeaseholdRights -- ^ Assets: Leasehold interests in land (借地権) + | NonOperatingNotesReceivable -- ^ Assets: Non-operating notes receivable (営業外受取手形) + | NonOperatingElectronicallyRecordedReceivable -- ^ Assets: Electronically recorded monetary claims - non-operating (営業外電子記録債権) + | RefundLiabilities -- ^ Liability: Refund liabilities (返金負債) + | NonOperatingNotesPayable -- ^ Liability: Non-operating notes payable (営業外支払手形) + | NonOperatingElectronicallyRecordedObligations -- ^ Liability: Electronically recorded obligations - non-operating (営業外電子記録債務) + | BonusesPayable -- ^ Liability: Accrued bonuses (未払賞与) + | AllowanceForRepairs -- ^ Liability: Provision for repairs (修繕引当金) + | AllowanceForProductWarranties -- ^ Liability: Provision for warranties (商品保証引当金) + | AllowanceForBonuses -- ^ Liability: Provision for bonuses (賞与引当金) + | DeferredTaxLiabilities -- ^ Liability: Deferred tax liabilities (繰延税金負債) + | LeaseObligations -- ^ Liability: Lease liabilities (リース債務) + | GuaranteeDepositsReceived -- ^ Liability: Guarantee deposits received (預り保証金) + | AllowanceForRetirementBenefits -- ^ Liability: Provision for retirement benefits (退職給付引当金) + | LongTermOtherPayables -- ^ Liability: Long-term accounts payable - other (長期未払金) + | NetDefinedBenefitLiability -- ^ Liability: Retirement benefit liability (退職給付に係る負債) + | StockSubscriptionDeposits -- ^ Equity: Deposits for subscriptions of shares (株式申込証拠金) + | LegalCapitalSurplus -- ^ Equity: Legal capital surplus (資本準備金) + | OtherCapitalSurplus -- ^ Equity: Other capital surplus (その他資本剰余金) + | DividendEqualizationReserve -- ^ Equity: Reserve for dividend equalization (配当平均積立金) + | RepairFundReserve -- ^ Equity: Reserve for repairs (修繕積立金) + | ConstructionFundReserve -- ^ Equity: Reserve for new construction (新築積立金) + | GeneralReserve -- ^ Equity: General reserve (別途積立金) + | ValuationDifferenceOnOtherSecurities -- ^ Equity: Valuation difference on available-for-sale securities (その他有価証券評価差額金) + | NonControllingInterests -- ^ Equity: Non-controlling interests (非支配株主持分) + | CapitalSurplus -- ^ Equity: Capital surplus (資本剰余金) + | EarnedSurplus -- ^ Equity: Retained earnings (利益剰余金) + | ServiceRevenue -- ^ Revenue: Service revenue (役務収益) + | OperatingRevenue -- ^ Revenue: Operating revenue (営業収益) + | GainOnSalesOfSecurities -- ^ Revenue: Gain on sale of securities (有価証券売却益) + | GainOnValuationOfSecurities -- ^ Revenue: Gain on valuation of securities (有価証券評価益) + | DividendsReceived -- ^ Revenue: Dividend income (受取配当金) + | InterestOnSecurities -- ^ Revenue: Interest on securities (有価証券利息) + | GainOnSalesOfInvestmentSecurities -- ^ Revenue: Gain on sale of investment securities (投資有価証券売却益) + | InsuranceGain -- ^ Revenue: Gain on insurance claims (保険差益) + | GainOnBargainPurchase -- ^ Revenue: Gain on bargain purchase (負ののれん発生益) + | ReversalOfAllowanceForRepairs -- ^ Revenue: Reversal of provision for repairs (修繕引当金戻入) + | ReversalOfAllowanceForProductWarranties -- ^ Revenue: Reversal of provision for warranties (商品保証引当金戻入) + | GainOnDonationOfFixedAssets -- ^ Revenue: Gain on receipt of donated non-current assets (固定資産受贈益) + | GainOnNationalSubsidies -- ^ Revenue: Gain on receipt of national subsidies (国庫補助金受贈益) + | GainOnConstructionGrants -- ^ Revenue: Gain on contribution received for construction (工事負担金受贈益) + | LandRentReceived -- ^ Revenue: Rental income from land (受取地代) + | SalesRebates -- ^ Revenue: Sales rebates (売上割戻) + | CostOfServices -- ^ Cost: Cost of services (役務原価) + | OperatingExpenses -- ^ Cost: Operating expenses (営業費用) + | InventoryShrinkageLoss -- ^ Cost: Inventory shrinkage loss (棚卸減耗損) + | LossOnValuationOfMerchandise -- ^ Cost: Valuation loss on goods (商品評価損) + | Bonuses -- ^ Cost: Bonuses (賞与) + | RetirementBenefitExpenses -- ^ Cost: Retirement benefit expenses (退職給付費用) + | ProvisionForRepairs -- ^ Cost: Provision for repairs (修繕引当金繰入) + | ProvisionForBonuses -- ^ Cost: Provision for bonuses (賞与引当金繰入) + | ProvisionForProductWarranties -- ^ Cost: Provision for warranties (商品保証引当金繰入) + | ResearchAndDevelopmentExpenses -- ^ Cost: Research and development expenses (研究開発費) + | AmortizationOfGoodwill -- ^ Cost: Amortization of goodwill (のれん償却) + | AmortizationOfSoftware -- ^ Cost: Amortization of software (ソフトウェア償却) + | AmortizationOfPatents -- ^ Cost: Amortization of patent rights (特許権償却) + | LeaseExpenses -- ^ Cost: Lease expenses (支払リース料) + | IncorporationExpenses -- ^ Cost: Organization expenses (創立費) + | StockIssuanceCosts -- ^ Cost: Share issuance costs (株式交付費) + | BusinessCommencementExpenses -- ^ Cost: Business commencement expenses (開業費) + | DevelopmentExpenses -- ^ Cost: Development expenses (開発費) + | LossOnSalesOfElectronicallyRecordedReceivables -- ^ Cost: Loss on sale of electronically recorded monetary claims (電子記録債権売却損) + | LossOnSalesOfReceivables -- ^ Cost: Loss on sale of receivables (債権売却損) + | LossOnSalesOfSecurities -- ^ Cost: Loss on sale of securities (有価証券売却損) + | LossOnValuationOfSecurities -- ^ Cost: Loss on valuation of securities (有価証券評価損) + | LossOnSalesOfInvestmentSecurities -- ^ Cost: Loss on sale of investment securities (投資有価証券売却損) + | LossOnFire -- ^ Cost: Loss on fire (火災損失) + | LossOnRetirementOfFixedAssets -- ^ Cost: Loss on retirement of non-current assets (固定資産除却損) + | LossOnReductionOfFixedAssets -- ^ Cost: Loss on tax purpose reduction entry of non-current assets (固定資産圧縮損) + | AdditionalIncomeTaxesForPriorPeriods -- ^ Cost: Additional income taxes for prior periods (追徴法人税等) + | RefundOfIncomeTaxes -- ^ Cost: Refund of income taxes (還付法人税等) + | PurchaseRebates -- ^ Cost: Purchase rebates (仕入割戻) + | WelfareExpenses -- ^ Cost: Welfare expenses (福利厚生費) + | MaintenanceExpenses -- ^ Cost: Maintenance expenses (保守費) + | StatutoryWelfareExpenses -- ^ Cost: Legal welfare expenses (法定福利費) + | LandRentPaid -- ^ Cost: Rent expenses on land (支払地代) + | InsuranceExpense -- ^ Cost: Insurance expenses (保険料) + | RepairsExpense -- ^ Cost: Repair expenses (修繕費) + | StorageExpenses -- ^ Cost: Storage costs (保管費) + | MembershipFees -- ^ Cost: Membership fees (諸会費) + | IncomeSummary -- ^ Assets: Income summary (損益) + | SuspenseAccount -- ^ Assets: Suspense account (未決算) + | ForeignExchangeGains -- ^ Revenue: Foreign exchange gains (為替差益) + | ForeignExchangeLosses -- ^ Cost: Foreign exchange losses (為替差損) + | ContraAccountForGuaranteeObligations -- ^ Assets: Contra account for guarantee obligations (保証債務見返) + | GuaranteeObligations -- ^ Liability: Guarantee obligations (保証債務) + | IncomeTaxesAdjustment -- ^ Cost: Income taxes - deferred (法人税等調整額) + | BranchCurrentAccount -- ^ Assets: Branch current account (支店) + | HeadOfficeCurrentAccount -- ^ Assets: Head office current account (本店) + | NetIncomeAttributableToNCI -- ^ Cost: Profit attributable to non-controlling interests (非支配株主に帰属する当期純利益) + | NetLossAttributableToNCI -- ^ Revenue: Loss attributable to non-controlling interests (非支配株主に帰属する当期純損失) + | TradingSecurities -- ^ Assets: Trading securities (売買目的有価証券) + | HeldToMaturityBonds -- ^ Assets: Held-to-maturity bonds (満期保有目的債券) + | SubsidiaryStocks -- ^ Assets: Shares of subsidiaries (子会社株式) + | AffiliateStocks -- ^ Assets: Shares of associates (関連会社株式) + | AvailableForSaleSecurities -- ^ Assets: Available-for-sale securities (その他有価証券) + | ConsumptionTaxRefundReceivable -- ^ Assets: Consumption tax refund receivable (未収還付消費税) + | PropertyTaxPayable -- ^ Liability: Property tax payable (未払固定資産税) + | DepositsReceivedFromOfficers -- ^ Liability: Deposits received from officers (役員預り金) + | AccountTitle -- ^ Wildcard (ワイルドカード — 任意の科目にマッチ。projWithBase 等の問い合わせ用で, 実 posting には使わない) + deriving (Show, Ord, Eq, Enum, Generic, Bounded) +-- Commutation の実用法は examples の文脈から「通信費」であることが確認済 +-- (2026-06-11 調査)。Enum/Binary 序数の安定のため削除はせず, 新名称への移行を促す。 +{-# DEPRECATED Commutation "通信費 (communication expenses) — use 'CommunicationExpenses' instead" #-} + instance Hashable AccountTitles where {-# INLINE hashWithSalt #-} hashWithSalt salt x = hashWithSalt salt (fromEnum x) instance Binary.Binary AccountTitles where {-# INLINE put #-} - put = Binary.putWord8 . fromIntegral . fromEnum + put = BinaryPut.putWord16be . fromIntegral . fromEnum {-# INLINE get #-} - get = toEnum . fromIntegral <$> Binary.getWord8 + get = do + tag <- BinaryGet.getWord16be + let maxTag = fromIntegral (fromEnum (maxBound :: AccountTitles)) + if tag <= maxTag + then pure (toEnum (fromIntegral tag)) + else fail ("AccountTitles: invalid binary tag " ++ show tag) instance Element AccountTitles where - {-# INLINE wiledcard #-} - wiledcard = AccountTitle + {-# INLINE wildcard #-} + wildcard = AccountTitle @@ -310,8 +510,8 @@ type Subject = Text instance Element Text where - {-# INLINE wiledcard #-} - wiledcard = T.empty + {-# INLINE wildcard #-} + wildcard = T.empty -- | Currency unit or physical quantity data CountUnit = Yen @@ -334,45 +534,45 @@ instance Element CountUnit where - {-# INLINE wiledcard #-} - wiledcard = CountUnit + {-# INLINE wildcard #-} + wildcard = CountUnit -- TimeOfDay internally holds hour, minute, and second (Pico), so each is hashed individually instance Hashable TimeOfDay where - hashWithSalt salt (TimeOfDay hour min sec) = - salt `hashWithSalt` hour `hashWithSalt` min `hashWithSalt` sec + hashWithSalt salt (TimeOfDay hour minute sec) = + salt `hashWithSalt` hour `hashWithSalt` minute `hashWithSalt` sec -- Day internally holds an Integer in ModifiedJulianDay format, so that is used for hashing instance Hashable Day where hashWithSalt salt day = hashWithSalt salt (toModifiedJulianDay day) instance Element TimeOfDay where - wiledcard = Time.midnight + wildcard = Time.midnight instance Element Day where - wiledcard = ModifiedJulianDay 0 + wildcard = ModifiedJulianDay 0 instance (Element a ,Element b) => Element (a, b) where - {-# INLINE wiledcard #-} - wiledcard = (wiledcard, wiledcard) + {-# INLINE wildcard #-} + wildcard = (wildcard, wildcard) - {-# INLINE haveWiledcard #-} - haveWiledcard (a,b) - = isWiledcard a - || isWiledcard b + {-# INLINE haveWildcard #-} + haveWildcard (a,b) + = isWildcard a + || isWildcard b {-# INLINE equal #-} equal (a1, a2) (b1, b2) = (a1 .== b1) && (a2 .== b2) - {-# INLINE ignoreWiledcard #-} - ignoreWiledcard (a1, a2) (b1, b2) - = ( ignoreWiledcard a1 b1 - , ignoreWiledcard a2 b2) + {-# INLINE ignoreWildcard #-} + ignoreWildcard (a1, a2) (b1, b2) + = ( ignoreWildcard a1 b1 + , ignoreWildcard a2 b2) {-# INLINE compareElement #-} compareElement (a1, a2) (b1, b2) @@ -388,16 +588,16 @@ instance (Element a, Element b, Element c) => Element (a, b, c) where - {-# INLINE wiledcard #-} - wiledcard = ( wiledcard - , wiledcard - , wiledcard) + {-# INLINE wildcard #-} + wildcard = ( wildcard + , wildcard + , wildcard) - {-# INLINE haveWiledcard #-} - haveWiledcard (a,b,c) - = isWiledcard a - || isWiledcard b - || isWiledcard c + {-# INLINE haveWildcard #-} + haveWildcard (a,b,c) + = isWildcard a + || isWildcard b + || isWildcard c {-# INLINE equal #-} @@ -406,11 +606,11 @@ && (a2 .== b2) && (a3 .== b3) - {-# INLINE ignoreWiledcard #-} - ignoreWiledcard (a1, a2, a3) (b1, b2, b3) - = ( ignoreWiledcard a1 b1 - , ignoreWiledcard a2 b2 - , ignoreWiledcard a3 b3) + {-# INLINE ignoreWildcard #-} + ignoreWildcard (a1, a2, a3) (b1, b2, b3) + = ( ignoreWildcard a1 b1 + , ignoreWildcard a2 b2 + , ignoreWildcard a3 b3) {-# INLINE compareElement #-} compareElement (a1, a2, a3) (b1, b2, b3) @@ -426,19 +626,19 @@ instance (Element a, Element b, Element c, Element d) => Element (a, b, c, d) where - {-# INLINE wiledcard #-} - wiledcard = ( wiledcard - , wiledcard - , wiledcard - , wiledcard) + {-# INLINE wildcard #-} + wildcard = ( wildcard + , wildcard + , wildcard + , wildcard) - {-# INLINE haveWiledcard #-} - haveWiledcard (a,b,c,d) - = isWiledcard a - || isWiledcard b - || isWiledcard c - || isWiledcard d + {-# INLINE haveWildcard #-} + haveWildcard (a,b,c,d) + = isWildcard a + || isWildcard b + || isWildcard c + || isWildcard d {-# INLINE equal #-} equal (a1, a2, a3, a4) (b1, b2, b3, b4) @@ -447,12 +647,12 @@ && (a3 .== b3) && (a4 .== b4) - {-# INLINE ignoreWiledcard #-} - ignoreWiledcard (a1, a2, a3, a4) (b1, b2, b3, b4) - = ( ignoreWiledcard a1 b1 - , ignoreWiledcard a2 b2 - , ignoreWiledcard a3 b3 - , ignoreWiledcard a4 b4) + {-# INLINE ignoreWildcard #-} + ignoreWildcard (a1, a2, a3, a4) (b1, b2, b3, b4) + = ( ignoreWildcard a1 b1 + , ignoreWildcard a2 b2 + , ignoreWildcard a3 b3 + , ignoreWildcard a4 b4) {-# INLINE compareElement #-} compareElement (a1, a2, a3, a4) (b1, b2, b3, b4) @@ -468,21 +668,21 @@ instance (Element a, Element b, Element c, Element d, Element e) => Element (a, b, c, d, e) where - {-# INLINE wiledcard #-} - wiledcard = ( wiledcard - , wiledcard - , wiledcard - , wiledcard - , wiledcard) + {-# INLINE wildcard #-} + wildcard = ( wildcard + , wildcard + , wildcard + , wildcard + , wildcard) - {-# INLINE haveWiledcard #-} - haveWiledcard (a,b,c,d,e) - = isWiledcard a - || isWiledcard b - || isWiledcard c - || isWiledcard d - || isWiledcard e + {-# INLINE haveWildcard #-} + haveWildcard (a,b,c,d,e) + = isWildcard a + || isWildcard b + || isWildcard c + || isWildcard d + || isWildcard e {-# INLINE equal #-} equal (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5) @@ -492,13 +692,13 @@ && (a4 .== b4) && (a5 .== b5) - {-# INLINE ignoreWiledcard #-} - ignoreWiledcard (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5) - = ( ignoreWiledcard a1 b1 - , ignoreWiledcard a2 b2 - , ignoreWiledcard a3 b3 - , ignoreWiledcard a4 b4 - , ignoreWiledcard a5 b5) + {-# INLINE ignoreWildcard #-} + ignoreWildcard (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5) + = ( ignoreWildcard a1 b1 + , ignoreWildcard a2 b2 + , ignoreWildcard a3 b3 + , ignoreWildcard a4 b4 + , ignoreWildcard a5 b5) {-# INLINE compareElement #-} compareElement (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5) @@ -514,22 +714,22 @@ instance (Element a, Element b, Element c, Element d, Element e, Element f) => Element (a, b, c, d, e, f) where - {-# INLINE wiledcard #-} - wiledcard = ( wiledcard - , wiledcard - , wiledcard - , wiledcard - , wiledcard - , wiledcard) + {-# INLINE wildcard #-} + wildcard = ( wildcard + , wildcard + , wildcard + , wildcard + , wildcard + , wildcard) - {-# INLINE haveWiledcard #-} - haveWiledcard (a,b,c,d,e,f) - = isWiledcard a - || isWiledcard b - || isWiledcard c - || isWiledcard d - || isWiledcard e - || isWiledcard f + {-# INLINE haveWildcard #-} + haveWildcard (a,b,c,d,e,f) + = isWildcard a + || isWildcard b + || isWildcard c + || isWildcard d + || isWildcard e + || isWildcard f {-# INLINE equal #-} equal (a1, a2, a3, a4, a5, a6) (b1, b2, b3, b4, b5, b6) @@ -540,14 +740,14 @@ && (a5 .== b5) && (a6 .== b6) - {-# INLINE ignoreWiledcard #-} - ignoreWiledcard (a1, a2, a3, a4, a5, a6) (b1, b2, b3, b4, b5, b6) - = ( ignoreWiledcard a1 b1 - , ignoreWiledcard a2 b2 - , ignoreWiledcard a3 b3 - , ignoreWiledcard a4 b4 - , ignoreWiledcard a5 b5 - , ignoreWiledcard a6 b6) + {-# INLINE ignoreWildcard #-} + ignoreWildcard (a1, a2, a3, a4, a5, a6) (b1, b2, b3, b4, b5, b6) + = ( ignoreWildcard a1 b1 + , ignoreWildcard a2 b2 + , ignoreWildcard a3 b3 + , ignoreWildcard a4 b4 + , ignoreWildcard a5 b5 + , ignoreWildcard a6 b6) {-# INLINE compareElement #-} compareElement (a1, a2, a3, a4, a5, a6) (b1, b2, b3, b4, b5, b6) @@ -562,24 +762,24 @@ instance (Element a, Element b, Element c, Element d, Element e, Element f, Element g) => Element (a, b, c, d, e, f, g) where - {-# INLINE wiledcard #-} - wiledcard = ( wiledcard - , wiledcard - , wiledcard - , wiledcard - , wiledcard - , wiledcard - , wiledcard) + {-# INLINE wildcard #-} + wildcard = ( wildcard + , wildcard + , wildcard + , wildcard + , wildcard + , wildcard + , wildcard) - {-# INLINE haveWiledcard #-} - haveWiledcard (a,b,c,d,e,f,g) - = isWiledcard a - || isWiledcard b - || isWiledcard c - || isWiledcard d - || isWiledcard e - || isWiledcard f - || isWiledcard g + {-# INLINE haveWildcard #-} + haveWildcard (a,b,c,d,e,f,g) + = isWildcard a + || isWildcard b + || isWildcard c + || isWildcard d + || isWildcard e + || isWildcard f + || isWildcard g {-# INLINE equal #-} equal (a1, a2, a3, a4, a5, a6, a7) (b1, b2, b3, b4, b5, b6, b7) @@ -591,15 +791,15 @@ && (a6 .== b6) && (a7 .== b7) - {-# INLINE ignoreWiledcard #-} - ignoreWiledcard (a1, a2, a3, a4, a5, a6, a7) (b1, b2, b3, b4, b5, b6, b7) - = ( ignoreWiledcard a1 b1 - , ignoreWiledcard a2 b2 - , ignoreWiledcard a3 b3 - , ignoreWiledcard a4 b4 - , ignoreWiledcard a5 b5 - , ignoreWiledcard a6 b6 - , ignoreWiledcard a7 b7) + {-# INLINE ignoreWildcard #-} + ignoreWildcard (a1, a2, a3, a4, a5, a6, a7) (b1, b2, b3, b4, b5, b6, b7) + = ( ignoreWildcard a1 b1 + , ignoreWildcard a2 b2 + , ignoreWildcard a3 b3 + , ignoreWildcard a4 b4 + , ignoreWildcard a5 b5 + , ignoreWildcard a6 b6 + , ignoreWildcard a7 b7) {-# INLINE compareElement #-} compareElement (a1, a2, a3, a4, a5, a6, a7) (b1, b2, b3, b4, b5, b6, b7) diff --git a/src/ExchangeAlgebra/Algebra/Internal.hs b/src/ExchangeAlgebra/Algebra/Internal.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Algebra/Internal.hs @@ -0,0 +1,2062 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | + Module : ExchangeAlgebra.Algebra.Internal + Copyright : (c) Kaya Akagi. 2018-2026 + Maintainer : yakagika@icloud.com + Description : Internal representation of 'Alg' (all constructors, cache + fields and rebuild helpers). Not covered by the PVP contract; + import "ExchangeAlgebra.Algebra" instead unless you are + writing a test or an engine that must see 'Liner'. + + Released under the OWL license + + Package for Exchange Algebra defined by Hiroshi Deguchi. + + Exchange Algebra is an algebraic description of bookkeeping system. + Details are below. + + + + + +-} + + +module ExchangeAlgebra.Algebra.Internal + ( module ExchangeAlgebra.Algebra.Base + , Nearly(..) + , isNearlyNum + , nearlyEqScaled + , Redundant(..) + , Exchange(..) + , HatVal(..) + , Pair(..) + , Alg(..) + , isZero + , (.@) + , (<@) + , vals + , bases + , fromList + , toList + , foldEntries + , sigma + , sigma2When + , sigmaFromMap + , toASCList + , map + , mapPosting + , mapMaybePosting + , mapBasePart + , filter + , proj + , projCredit + , projDebit + , projByAccountTitle + , projNetNorm + , projNorm + , balanceBy + , balanceMapBy + , netPairMapBy + , foldEntriesToMap + , decBy + , postFromNetBy + , projCurrentAssets + , projFixedAssets + , projDeferredAssets + , projCurrentLiability + , projFixedLiability + , projCapitalStock + , projContraAssets + , projContra + , rounding + , unionsMerge)where + +import ExchangeAlgebra.Algebra.Base + +import qualified Data.List as L (foldl', sort,sortOn,any) +import Prelude hiding (map, head, filter,tail, traverse, mapM) +import qualified Data.HashMap.Strict as Map +import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map.Strict as M +import qualified Data.Foldable as Foldable (foldl',foldr) +import qualified Data.Sequence as Seq +import Data.Sequence (Seq) +import qualified Data.Maybe as Maybe +import qualified Number.NonNegative as NN -- Non-negative real numbers +import qualified Data.Scientific as D (fromFloatDigits, formatScientific, FPFormat(..)) +import Control.DeepSeq +import GHC.Stack (HasCallStack) +import qualified Data.Binary as Binary + +------------------------------------------------------------------ +-- * Approximate equality +------------------------------------------------------------------ + +-- | Type class providing approximate equality for numeric values. +-- Performs equality comparison with tolerance for floating-point rounding errors. +class (Eq a, Ord a) => Nearly a where + -- | @isNearly x y t@ : Returns True if the difference between x and y is within the tolerance t. + -- Complexity: O(1) + isNearly :: a -> a -> a -> Bool + +instance Nearly Int where + {-# INLINE isNearly #-} + isNearly = isNearlyNum + +instance Nearly Integer where + {-# INLINE isNearly #-} + isNearly = isNearlyNum + +instance Nearly Float where + {-# INLINE isNearly #-} + isNearly = isNearlyNum + +instance Nearly Double where + {-# INLINE isNearly #-} + isNearly = isNearlyNum + +instance Nearly NN.Double where + {-# INLINE isNearly #-} + isNearly = isNearlyNum + +{-# INLINE isNearlyNum #-} +-- | Complexity: O(1) +-- Assumes primitive numeric operations and comparisons are constant time. +-- +-- NOTE: this is an /absolute/-tolerance test (@|x - y| <= |t|@); it does not +-- scale with magnitude. For large values, rounding error easily exceeds a small +-- fixed @t@, while for small values it can swallow a real residual. Internal +-- accounting reconciliation uses 'nearlyEqScaled' instead. The final guard +-- returns 'False' (was: 'error') when a NaN makes every ordered comparison fail, +-- so a non-finite input can no longer crash the check. +isNearlyNum :: (Show a, Num a, Ord a) => a -> a -> a -> Bool +isNearlyNum x y t + | x == y = True + | x > y = abs (x - y) <= abs t + | x < y = abs (y - x) <= abs t + | otherwise = False -- NaN: not nearly-equal to anything + +{-# INLINE nearlyEqScaled #-} +-- | Scale-aware approximate equality for accounting reconciliation: +-- +-- @|x - y| <= atol + rtol * max |x| |y|@, with @atol = 1e-13@, @rtol = 1e-12@. +-- +-- The absolute floor @atol@ handles values near zero; the relative term @rtol@ +-- lets the threshold track magnitude, so the test stays meaningful for large +-- balances (where a fixed @1e-13@ was far too strict and retained pure rounding +-- noise as a spurious residual). Returns 'False' if either argument is a +-- non-finite error value (NaN/Inf), so error values never read as nearly equal. +-- +-- Complexity: O(1) +nearlyEqScaled :: (HatVal n) => n -> n -> Bool +nearlyEqScaled x y + | isErrorValue x || isErrorValue y = False + | otherwise = abs (x - y) <= atol + rtol * max (abs x) (abs y) + where + atol = 1e-13 + rtol = 1e-12 + +------------------------------------------------------------ +-- * Algebra +------------------------------------------------------------ +------------------------------------------------------------------ +-- ** Definition of Redundancy (subclassing this makes a redundant algebra) +------------------------------------------------------------------ + +-- | Type class for Redundant Algebra. +-- Provides fundamental exchange algebra operations: hat, bar, norm, scalar product, and compress. +-- +-- Redundant ⊃ Exchange +-- +-- hat calculation +-- >>> (.^) (10:@Not:>> x = 10:@Not:>> y = 5:@Hat:>> (.-) $ x .+ y +-- 5.00:@Not:>> norm $ 10:@Not:>> (.*) 5 $ 10:@Not:>> compress $ 10:@Not:= 0@) +-- 5. Norm additivity: @'norm' (x '.+' y) = 'norm' x + 'norm' y@ +-- +-- Derived lemmas (also property-tested): @'bar'@ idempotence +-- (@'bar' ('bar' x) = 'bar' x@), 'Zero' identity, and associativity of @('.+')@. +-- Note @('.+')@ accumulates same-base postings as an ordered sequence (the +-- /redundancy/), so 'Show' \/ 'Eq' observe that order; for the exact value type +-- t'ExchangeAlgebra.Value.MoneyDecimal', 'norm' \/ 'bar' are order-independent. +-- The order itself is furthermore /construction-path dependent/: the +-- pairwise-union path ('fromList'\/'mconcat') and the bulk-merge path +-- ('sigma'\/'unionsMerge') arrange the same multiset of postings differently. +-- Do not rely on @('==')@ to compare algebras built by different routes — +-- compare after 'compress'\/'bar', or use an exact value type and compare +-- the netted content. + +class (HatVal n, HatBaseClass b, Monoid (a n b)) => Redundant a n b where + -- | Hat operation. Flips Hat/Not on all elements. + -- Complexity: O(1) for singleton, O(n) for Liner (n is the number of base keys) + (.^) :: a n b -> a n b + + -- | Bar operation. Cancels Hat/Not on the same base and retains only the difference. + -- Complexity: O(n) (n is the number of base keys) + (.-) :: a n b -> a n b + + -- | Alias for bar operation. Identical to @(.-)@. + bar :: a n b -> a n b + bar = (.-) + + -- | Aggregates values on the same base. Sums while preserving the Hat/Not distinction. + -- Complexity: O(n) (n is the number of base keys) + compress :: a n b -> a n b + + -- | Addition of algebra elements. Alias for the Monoid @<>@ operation. + -- Complexity: O(union cost) + (.+) :: a n b -> a n b -> a n b + + -- | Scalar product. Multiplies all element values by a scalar. + -- Complexity: O(1) for singleton, O(n) for Liner + (.*) :: n -> a n b -> a n b + + -- | Norm. Sum of all element values (both Hat and Not sides), i.e. the + -- homomorphism from the algebra into the value domain @n@ (Akagi 2026, + -- Appendix A, Definition 6). It is /additive/: @norm (x '.+' y) = norm x + + -- norm y@ (axiom 5), and /homogeneous/: @norm (a '.*' x) = a * norm x@ for + -- @a >= 0@ (axiom 4). Because it sums both sides it does not cancel Hat + -- against Not; @norm ('bar' x) <= norm x@ (bar discards the cancelled part). + -- + -- >>> norm (100:@Not: n + + -- | Addition in an Applicative context. + -- Complexity: O(union cost) + {-# INLINE (<+) #-} + (<+) :: (Applicative f) => f (a n b) -> f (a n b) -> f (a n b) + (<+) x y = (.+) <$> x <*> y + + +infixr 7 .^ +infixr 2 .- +infixr 3 .+ +infixr 3 <+ + +------------------------------------------------------------ +-- ** Definition of Exchange Algebra +------------------------------------------------------------ + +-- | Type class for Exchange Algebra. In addition to Redundant Algebra, provides +-- the decomposition operators of Deguchi & Nakano (1986, Definition 2.16) and +-- balance checking. Following the original convention, __L = Left = Debit +-- (借方)__ and __R = Right = Credit (貸方)__: 'decL' extracts the debit side, +-- 'decR' the credit side. ('decP' \/ 'decM' split along the Hat\/Not label +-- instead of the debit\/credit side.) +class (Redundant a n b ) => Exchange a n b where + -- | Extracts only the credit-side elements (R = Right = Credit, 貸方), + -- i.e. those whose 'whichSide' is 'Credit'. Complexity: O(s) + decR :: a n b -> a n b + -- | Extracts only the debit-side elements (L = Left = Debit, 借方), + -- i.e. those whose 'whichSide' is 'Debit'. Complexity: O(s) + decL :: a n b -> a n b + -- | Extracts only the Hat-side elements (the P-projection of the + -- decomposition; @isHat@ holds). Complexity: O(s) + decP :: a n b -> a n b + -- | 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) + balance :: a n b -> Bool + -- | Returns the debit-credit difference as a (Side, difference) pair. Complexity: O(s) + diffRL :: a n b -> (Side, n) + + +------------------------------------------------------------------ +-- * Algebra +------------------------------------------------------------------ + +-- | Type class for algebra element values. +-- Provides zero-value / error-value predicates and a representation-specific +-- renderer ('showValue'). +-- +-- == Choosing an instance +-- +-- * 'Prelude.Double' — fast IEEE-754 (this module); the low-friction default. +-- * @MoneyDouble@ ("ExchangeAlgebra.Value") — same speed, dedicated money newtype. +-- * @MoneyDecimal@ ("ExchangeAlgebra.Value") — exact decimal, construction-order +-- independent totals; use for audited\/deterministic ledgers. +-- * @NN.Double@ (@Number.NonNegative.Double@) — __deprecated__ since 0.5.0.0, +-- to be removed in 0.6: its @(-)@ /errors/ on a negative intermediate +-- (e.g. inside @bar@\/@(.-)@ comparisons), and everything it offered is +-- covered by @MoneyDouble@. Migrate to @MoneyDouble@ or bare 'Prelude.Double'. +-- +-- DESIGN NOTE (2026-06-06, selectable value type — Double vs exact Decimal): +-- The @RealFloat@ superclass was intentionally *removed* so that exact, +-- non-floating-point value types (the planned @MoneyDecimal@ = non-negative +-- 'Data.Decimal.Decimal') can be 'HatVal' instances and give construction-order +-- -independent, exact summation. @RealFloat@ was only ever needed in two places: +-- * @showV@ (rendering via 'Data.Scientific.fromFloatDigits') — now replaced by +-- the per-instance 'showValue' method, so each representation formats itself; +-- * the @Double@/@NN.Double@ 'isErrorValue' (NaN/Infinity tests) — these stay +-- inside the floating-point instances, which may require @RealFloat@ locally. +-- @Fractional@ is *kept*: 'Data.Decimal' provides it (so numeric literals like +-- @0.08@ still work without wrapping), and only an @Integer@ instance would need +-- it dropped. @Integer@ is intentionally out of scope — it cannot represent the +-- fractional / relative prices that the ABM simulations depend on. +class ( Show n + , Ord n + , Eq n + , Nearly n + , Fractional n + , Num n) => HatVal n where + + -- | Zero value. Complexity: O(1) + zeroValue :: n + + -- | Tests whether the value is zero. Complexity: O(1) + isZeroValue :: n -> Bool + isZeroValue x + | zeroValue == x = True + | otherwise = False + + -- | Tests whether the value is an error value (NaN, Infinity, negative, …). + -- Complexity: O(1) + isErrorValue :: n -> Bool + + -- | Render the value for the 'Show' instance of 'Alg'. + -- Per-instance because formatting is representation-specific: floating-point + -- types format to a fixed number of decimal places via 'Data.Scientific', + -- whereas exact decimal types print their own canonical form. This replaces + -- the former floating-point-only @showV@, which hard-wired @RealFloat@ + -- through @fromFloatDigits@ and so blocked exact value types. + showValue :: n -> String + + +instance RealFloat NN.Double where + floatRadix = floatRadix . NN.toNumber + floatDigits = floatDigits . NN.toNumber + floatRange = floatRange . NN.toNumber + decodeFloat = decodeFloat . NN.toNumber + encodeFloat m e = NN.fromNumber (encodeFloat m e) + exponent = exponent . NN.toNumber + significand = NN.fromNumber . significand . NN.toNumber + scaleFloat n = NN.fromNumber . scaleFloat n . NN.toNumber + isNaN = isNaN . NN.toNumber + isInfinite = isInfinite . NN.toNumber + isDenormalized = isDenormalized . NN.toNumber + isNegativeZero = isNegativeZero . NN.toNumber + isIEEE = isIEEE . NN.toNumber + +-- | __Deprecated__ since 0.5.0.0 (removal planned for 0.6): @NN.Double@'s +-- @(-)@ errors on a negative intermediate, and @MoneyDouble@ covers the same +-- use case safely. Migrate to @MoneyDouble@ or bare 'Prelude.Double'. +-- (GHC cannot attach a @DEPRECATED@ pragma to an instance, so this notice +-- lives in the Haddock and the ChangeLog.) +instance HatVal NN.Double where + {-# INLINE zeroValue #-} + zeroValue = 0 + {-# INLINE isErrorValue #-} + isErrorValue x = isNaN (NN.toNumber x) + || isInfinite (NN.toNumber x) + -- Identical formatting to the old top-level @showV@ (fixed 2-decimal + -- Scientific rendering); moved here so the class no longer needs @RealFloat@. + {-# INLINE showValue #-} + showValue = D.formatScientific D.Generic (Just 2) . D.fromFloatDigits + +instance HatVal Prelude.Double where + {-# INLINE zeroValue #-} + zeroValue = 0 + + {-# INLINE isErrorValue #-} + isErrorValue x = isNaN x + || isInfinite x + || x < 0 + -- Identical formatting to the old top-level @showV@ (see NN.Double above). + {-# INLINE showValue #-} + showValue = D.formatScientific D.Generic (Just 2) . D.fromFloatDigits + +data Pair v where + Pair :: {_hatSide :: !(Seq v) + ,_notSide :: !(Seq v)} -> Pair v + deriving (Eq) + +instance (Binary.Binary v) => Binary.Binary (Pair v) where + {-# INLINABLE put #-} + {-# INLINABLE get #-} + put (Pair hs ns) = do + Binary.put (Seq.length hs :: Int) + Foldable.foldr (\x k -> Binary.put x >> k) (pure ()) hs + Binary.put (Seq.length ns :: Int) + Foldable.foldr (\x k -> Binary.put x >> k) (pure ()) ns + get = do + hsLen <- Binary.get :: Binary.Get Int + hs <- go hsLen Seq.empty + nsLen <- Binary.get :: Binary.Get Int + ns <- go nsLen Seq.empty + pure (Pair hs ns) + where + go :: Binary.Binary a => Int -> Seq a -> Binary.Get (Seq a) + go n !acc + | n <= 0 = pure acc + | otherwise = do + x <- Binary.get + go (n - 1) (acc Seq.|> x) + + +instance (HatVal v) => Ord (Pair v) where + {-# INLINE compare #-} + compare (Pair hs1 ns1) (Pair hs2 ns2) = compare ((sum hs1) - (sum ns1)) ((sum hs2) - (sum ns2)) + + (<) x y | compare x y == LT = True + | otherwise = False + + (>) x y | compare x y == GT = True + | otherwise = False + + (<=) x y | compare x y == LT = True + | compare x y == EQ = True + | otherwise = False + + (>=) x y | compare x y == GT = True + | compare x y == EQ = True + | otherwise = False + + max x y | x >= y = x + | otherwise = y + + min x y | x <= y = x + | otherwise = y + +{-# INLINE nullPair #-} +-- | Complexity: O(1) +nullPair :: Pair v +nullPair = Pair Seq.empty Seq.empty + +{-# INLINE pairAppend #-} +-- | Complexity: O(log(min(h1,h2)) + log(min(n1,n2))) +-- where h1/h2 and n1/n2 are the lengths of the appended 'Seq's on each side. +pairAppend :: Pair v -> Pair v -> Pair v +pairAppend (Pair x1 y1) (Pair x2 y2) = + let !hs = x1 Seq.>< x2 + !ns = y1 Seq.>< y2 + in Pair hs ns + +{-# INLINE pairUnion #-} +-- | Set-style merge of two single-base projection results. +-- +-- Used by the multi-pattern 'proj'/'projNetNorm' paths where a query list is +-- treated as a /set/: when several queries select the same posting (duplicate +-- bases, or an exact base overlapping a wildcard query), the selected sides +-- come from the /same/ underlying t'Pair' in @_realg@, so the per-side +-- sequences are identical. Taking each side from whichever operand supplies it +-- (and keeping a single copy) therefore unions the selections without double +-- counting. Contrast @pairAppend@, which concatenates and would duplicate. +-- +-- Each operand is a side-restricted projection ('choosePairByHat'), so at most +-- one of the two contributes a non-empty hat side and at most one a non-empty +-- not side for a given base; @pairUnion@ keeps the non-empty one per side. +-- +-- Complexity: O(1). +pairUnion :: Pair v -> Pair v -> Pair v +pairUnion (Pair x1 y1) (Pair x2 y2) = + let !hs = if Seq.null x1 then x2 else x1 + !ns = if Seq.null y1 then y2 else y1 + in Pair hs ns + +-- | Algebra element. An element of exchange algebra consisting of a value-base pair. +-- Zero is the zero element, @(:@)@ is a singleton, and Liner is a HashMap-based multi-element representation. +-- +-- __Invariants (do not hand-construct @Liner@).__ The @Liner@ constructor carries +-- internal cache\/index fields (@_axisPosting@, @_idToBp@, @_allBpIds@) that are +-- /derived from/ @_realg@ and must stay consistent with it: @_axisPosting@, +-- @_idToBp@ and @_allBpIds@ must be exactly the axis index, id↔base map and id set +-- built from the keys of @_realg@ (as the internal @linerFromMap@ does). The +-- wildcard projection path (@projWildMap@, @filterByAxis@) reads those indices and +-- will return wrong answers (silently, not an exception) if they disagree with +-- @_realg@. The fields @_bpToId@ and @_nextBpId@ are currently unmaintained +-- /poison/ (reserved for a dormant scheme) — forcing them throws. Always build +-- values via 'fromList' or the smart constructor '(.@)' rather than applying +-- @Liner@ (or @(:@)@) directly. +data Alg v b where + Zero :: Alg v b + (:@) :: {_val :: !v, _hatBase :: !b} -> Alg v b + Liner :: { _realg :: !(Map.HashMap (BasePart b) (Pair v)) + , _axisPosting :: ~(IntMap.IntMap (Map.HashMap AxisKey IntSet.IntSet)) + , _bpToId :: ~(Map.HashMap (BasePart b) Int) + , _idToBp :: ~(IntMap.IntMap (BasePart b)) + , _nextBpId :: ~Int + , _allBpIds :: ~IntSet.IntSet + } -> Alg v b + +instance ( HatBaseClass b + , Binary.Binary v + , Binary.Binary b + , Binary.Binary (BasePart b) + ) => Binary.Binary (Alg v b) where + {-# INLINABLE put #-} + {-# INLINABLE get #-} + put Zero = Binary.put (0 :: Int) + put (v :@ b) = do + Binary.put (1 :: Int) + Binary.put v + Binary.put b + put (Liner m _ _ _ _ _) = do + Binary.put (2 :: Int) + Binary.put (Map.size m :: Int) + Map.foldrWithKey + (\bp p k -> Binary.put bp >> Binary.put p >> k) + (pure ()) + m + + get = do + tag <- Binary.get + case (tag :: Int) of + 0 -> pure Zero + 1 -> (:@) <$> Binary.get <*> Binary.get + 2 -> do + n <- Binary.get :: Binary.Get Int + linerFromMap <$> go n Map.empty + _ -> fail ("Binary decode failure for Alg: unknown tag " ++ show tag) + where + go n !acc + | n <= 0 = pure acc + | otherwise = do + bp <- Binary.get + p <- Binary.get + go (n - 1) (Map.insert bp p acc) + +type AxisPosting = IntMap.IntMap (Map.HashMap AxisKey IntSet.IntSet) + +{-# INLINE emptyAxisPosting #-} +-- | Complexity: O(1) +emptyAxisPosting :: AxisPosting +emptyAxisPosting = IntMap.empty + +{-# INLINE insertAxisPosting #-} +-- | Complexity: O(d * (hash-insert + intset-insert)) +-- In practice this is near O(d), where d is the number of axes in the base part. +insertAxisPosting :: [AxisKey] -> Int -> AxisPosting -> AxisPosting +insertAxisPosting !keys !bpId !idx = + snd $ L.foldl' step (0 :: Int, idx) keys + where + step (!axis, !acc) !k = + let !axisMap = IntMap.findWithDefault Map.empty axis acc + !ids0 = Map.lookupDefault IntSet.empty k axisMap + !ids1 = IntSet.insert bpId ids0 + !axisMap' = Map.insert k ids1 axisMap + !acc' = IntMap.insert axis axisMap' acc + in (axis + 1, acc') + +{-# INLINE queryAxisPosting #-} +-- | Complexity: O(d + intersection cost) +-- d is the number of axes; intersections are performed in ascending set-size order. +queryAxisPosting :: [AxisKey] -> AxisPosting -> IntSet.IntSet -> IntSet.IntSet +queryAxisPosting !keys !idx !allIds = + case matchedSets of + Left () -> IntSet.empty + Right [] -> allIds + -- 'L.sortOn' preserves length, so a non-empty 'xs' sorts to a non-empty + -- list; matching @(x:rest)@ here (rather than on a lazy let-binding) makes + -- exhaustiveness explicit and avoids the partial pattern warning. + Right xs@(_:_) -> + case L.sortOn IntSet.size xs of + (x:rest) -> L.foldl' IntSet.intersection x rest + [] -> allIds -- unreachable: xs is non-empty + where + matchedSets = + L.foldl' collect (Right []) (zip [0 :: Int ..] keys) + + collect (Left ()) _ = Left () + collect (Right acc) (!axis, !k) + | axisIsWildcard k = Right acc + | otherwise = + case IntMap.lookup axis idx of + Nothing -> Left () + Just axisMap -> case Map.lookup k axisMap of + Nothing -> Left () + Just ids -> Right (ids : acc) + +{-# INLINE linerFromMap #-} +-- | Complexity: O(n * d * (hash-insert + intset-insert)) +-- n is the number of distinct base keys in the map. +linerFromMap :: (HatBaseClass b) + => Map.HashMap (BasePart b) (Pair v) + -> Alg v b +-- | @_bpToId@ and @_nextBpId@ are reserved for the (currently dormant) P1a +-- incremental-id scheme and are not consumed by any read path. We therefore skip +-- building them and leave them as lazy poison: nothing forces them in normal +-- operation (the wildcard 'proj' path uses @idx@/@idToBp@/@allIds@ only). Forcing +-- either field is a bug, surfaced loudly here instead of silently returning a +-- stale value. Guarded by a poison-field regression test. +-- +-- NOTE: the @error@ thunks are written inline in the constructor application (the +-- @Liner@ fields are lazy @~@) rather than as @where@-bindings, because this +-- module is compiled @{-\# LANGUAGE Strict \#-}@, under which a @where@-bound thunk +-- would be forced when 'linerFromMap' is evaluated. +linerFromMap m = + Liner m idx + (error "Liner internal: _bpToId is not maintained (reserved for P1a); do not force") + idToBp + (error "Liner internal: _nextBpId is not maintained (reserved for P1a); do not force") + allIds + where + ~(idx, idToBp, allIds) = + Map.foldlWithKey' + (\(!idxAcc, !idToBpAcc, !allIdsAcc) bp _ -> + let !bpId = IntMap.size idToBpAcc + !idx' = insertAxisPosting (toAxisKeys bp) bpId idxAcc + !idToBp' = IntMap.insert bpId bp idToBpAcc + !allIds' = IntSet.insert bpId allIdsAcc + in (idx', idToBp', allIds')) + (emptyAxisPosting, IntMap.empty, IntSet.empty) + m + +-- | Tests whether the algebra element is zero (empty). +-- +-- Complexity: O(1) +isZero :: Alg v b -> Bool +isZero Zero = True +isZero _ = False + +{-# INLINE singleton #-} +-- | Complexity: O(1) +singleton :: (HatVal v, HatBaseClass b) => v -> b -> Alg v b +singleton v b | isZeroValue v = Zero + | isErrorValue v = error $ "errorValue at (.@) val: " + ++ show v + ++ show ":@" + ++ show b + | otherwise = v :@ b + +{-# INLINE (.@) #-} +-- | Smart constructor that builds an algebra element from a value and a base. +-- Returns Zero for zero values, and throws an exception for error values. +-- +-- Complexity: O(1) +(.@) :: (HatVal n, HatBaseClass b) => n -> b -> Alg n b +(.@) v b = singleton v b + +-- | Constructs an algebra element in an Applicative context. Lifted version of @(.@)@. +-- +-- Complexity: O(1) + Applicative effects +(<@) :: (HatVal n, Applicative f, HatBaseClass b) + => f n -> b -> f (Alg n b) +(<@) v b = (.@) <$> v <*> (pure b) + + +infixr 6 :@ +infixr 6 .@ +infixr 6 <@ + +-- NOTE: the former top-level @showV@ (which hard-wired @RealFloat@ via +-- @fromFloatDigits@) has been replaced by the per-instance 'showValue' method of +-- 'HatVal', so that exact value types can render themselves. The 'Show' instance +-- of 'Alg' below now calls 'showValue'. The @Double@/@NN.Double@ 'showValue' +-- implementations reproduce the old formatting byte-for-byte. + +instance (HatVal v, HatBaseClass b) => Eq (Alg v b) where + (==) Zero Zero = True + (==) Zero _ = False + (==) _ Zero = False + (==) (v1:@b1) (v2:@b2) = (v1 == v2) && (b1 == b2) + (==) (Liner m1 _ _ _ _ _) (Liner m2 _ _ _ _ _) = m1 == m2 + (==) _ _ = False + (/=) x y = not (x == y) + +instance (HatVal v, HatBaseClass b) => Ord (Alg v b) where + {-# INLINE compare #-} + compare Zero Zero = EQ + compare Zero _ = LT + compare _ Zero = GT + + compare (_:@_) (Liner _ _ _ _ _ _) = LT + compare (Liner _ _ _ _ _ _) (_:@_) = GT + compare (v1:@b1) (v2:@b2) + | b1 == b2 = compare v1 v2 + | b1 > b2 = GT + | otherwise = LT -- b1 < b2 (Ord is total; otherwise keeps it exhaustive) + + compare (Liner m1 _ _ _ _ _) (Liner m2 _ _ _ _ _) = compare m1 m2 + + (<) x y | compare x y == LT = True + | otherwise = False + + (>) x y | compare x y == GT = True + | otherwise = False + + (<=) x y | compare x y == LT = True + | compare x y == EQ = True + | otherwise = False + + (>=) x y | compare x y == GT = True + | compare x y == EQ = True + | otherwise = False + + max x y | x >= y = x + | otherwise = y + + min x y | x <= y = x + | otherwise = y + +instance (HatVal v, HatBaseClass b) => Show (Alg v b) where + show Zero = "0" + show (v:@b) = (showValue v) ++ ":@" ++ show b + show xs = let ls = toASCList xs + in go ls + where + go [] = "0" + go [y] = show y + go (y:ys) = show y ++ " .+ " ++ go ys + + +instance NFData (Alg v b) where + rnf Zero = Zero `seq` () + rnf (v:@b) = v `seq` b `seq` () + rnf (Liner m _ _ _ _ _) = Map.foldrWithKey (\k v acc -> k `seq` v `seq` acc) () m +------------------------------------------------------------------ +-- Semigroup +------------------------------------------------------------------ + +instance (HatVal n, HatBaseClass b) => Semigroup (Alg n b) where + {-# INLINE (<>) #-} + -- | Associative law ;convert to right join + (<>) = union + + + +-- | union two trees +-- +-- >>> type Test = Alg Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Hat:>> union x y +-- 1.00:@Hat: Alg n b -> Alg n b -> Alg n b +union Zero x = x +union x Zero = x +-- singletons +-- NOTE: a zero-valued singleton contributes nothing, so the result must keep the +-- /nonzero/ value on its OWN base. Earlier code returned @v2:@b1@ / @v1:@b2@, +-- relabeling the surviving value onto the zero posting's base — this preserved +-- 'norm' but silently moved the value to the wrong base, corrupting per-base +-- projection and making construction order observable (raw @(:@)@ on a sparsified +-- zero coefficient builds an explicit @0:@base@ singleton). Keep @v2:@b2@ / @v1:@b1@. +union (v1:@b1) (v2:@b2) + | isZeroValue v1 = case isZeroValue v2 of + True -> Zero + False -> v2:@b2 + | isZeroValue v2 = v1:@b1 + | otherwise = insert b2 v2 (v1:@b1) +-- If one side is a singleton +union x (v:@b) = insert b v x +union (v:@b) x = insert b v x + +-- In the case of multiple elements +union (Liner m1 _ _ _ _ _) (Liner m2 _ _ _ _ _) = linerFromMap (Map.unionWith pairAppend m1 m2) + + +{-# INLINE insert #-} +-- | Complexity: +-- - into Zero or singleton: O(1) to O(d * index-build) +-- - into Liner: O(n * d * index-build) due to rebuilding 'linerFromMap' +-- where n is the number of distinct base keys after insertion. +insert :: (HatVal v,HatBaseClass b) => b -> v -> Alg v b -> Alg v b +insert _ v x | isZeroValue v = x +insert !b !v Zero = v .@ b +insert !b1 !v1 (v2:@b2) = case isHat b1 of + True -> insert b2 v2 + $ linerFromMap + $ Map.singleton (base b1) + $ nullPair {_hatSide = Seq.singleton v1} + False -> insert b2 v2 + $ linerFromMap + $ Map.singleton (base b1) + $ nullPair {_notSide = Seq.singleton v1} +insert !b !v (Liner m _ _ _ _ _) = case isHat b of + True -> insertLiner (nullPair {_hatSide = Seq.singleton v}) + False -> insertLiner (nullPair {_notSide = Seq.singleton v}) + where + !bp = base b + insertLiner !pairToInsert = + let !m' = Map.insertWith pairAppend bp pairToInsert m + in linerFromMap m' + +------------------------------------------------------------------ +-- Monoid +------------------------------------------------------------------ + +instance (HatVal n, HatBaseClass b) => Monoid (Alg n b) where + -- Identity element + mempty = Zero + mappend = (<>) + mconcat = unions + +{-# INLINE unions #-} +-- | Complexity: O(sum of HashMap union costs over the fold) +-- For a long list this is typically the dominant construction cost. +unions :: (HatVal n, Foldable f, HatBaseClass b) => f (Alg n b) -> Alg n b +unions ts = Foldable.foldl' union Zero ts + +{-# INLINE mergeAlgMap #-} +mergeAlgMap :: (HatVal n, HatBaseClass b) + => Map.HashMap (BasePart b) (Pair n) + -> Alg n b + -> Map.HashMap (BasePart b) (Pair n) +mergeAlgMap !acc Zero = acc +mergeAlgMap !acc (v :@ b) + | isZeroValue v = acc + | otherwise = + let !p = if isHat b + then nullPair {_hatSide = Seq.singleton v} + else nullPair {_notSide = Seq.singleton v} + in Map.insertWith pairAppend (base b) p acc +mergeAlgMap !acc (Liner m _ _ _ _ _) + | Map.null m = acc + | otherwise = Map.unionWith pairAppend acc m + +{-# INLINE mergeAlgMapIfNonZero #-} +mergeAlgMapIfNonZero :: (HatVal n, HatBaseClass b) + => Map.HashMap (BasePart b) (Pair n) + -> Alg n b + -> Map.HashMap (BasePart b) (Pair n) +mergeAlgMapIfNonZero !acc Zero = acc +mergeAlgMapIfNonZero !acc alg@(v :@ _) + | isZeroValue v = acc + | otherwise = mergeAlgMap acc alg +mergeAlgMapIfNonZero !acc alg = mergeAlgMap acc alg + +{-# INLINE unionsMerge #-} +-- | Merge multiple Algs by directly combining their internal HashMaps, +-- building the AxisPosting index only once at the end. +-- +-- Produces the same /multiset/ of postings as @unions@\/'mconcat', but the +-- same-base sequence order differs (the bulk-merge accumulates a new same-base +-- singleton in front of the previously merged values, whereas the pairwise +-- union path interleaves differently). 'Eq'\/@Binary@ observe that order, and +-- 'Double' observes it through the last ULP of 'norm'\/'bar'; see the +-- characterization test @testSameBaseSeqOrderPathDependence@. +unionsMerge :: (HatVal n, Foldable f, HatBaseClass b) => f (Alg n b) -> Alg n b +unionsMerge ts = + let !m = Foldable.foldl' mergeAlgMap Map.empty ts + in mkAlgFromMap m + +------------------------------------------------------------------ +-- Redundant +------------------------------------------------------------------ + +instance (HatVal n, HatBaseClass b) => Redundant Alg n b where + (.^) Zero = Zero + (.^) (n:@ b) = n :@ (revHat b) + (.^) (Liner ms idx bpToId idToBp nextBpId allIds) = Liner + (Map.map (\ (Pair hs ns) -> Pair ns hs) ms) + idx + bpToId + idToBp + nextBpId + allIds + + (.+) = mappend + + _ .* Zero = Zero + 0 .* _ = Zero + -- The algebra is over non-negative values: reject a negative / non-finite + -- scalar instead of silently producing out-of-domain (negative) postings. + -- One check on the scalar suffices — x >= 0 and the existing values are >= 0, + -- so x*v stays non-negative and the cheap raw fmap below is safe. + x .* _ | isErrorValue x = + error ("(.*): non-negative finite scalar required, got " ++ show x) + x .* (v:@b) = (x * v) :@ b + x .* (Liner ms idx bpToId idToBp nextBpId allIds) = Liner + (Map.map (\ (Pair hs ns) -> Pair (fmap (x *) hs) (fmap (x *) ns)) ms) + idx + bpToId + idToBp + nextBpId + allIds + + norm Zero = 0 + norm (v:@_) = v + norm (Liner ms _ _ _ _ _) = Map.foldl' (\ !x (Pair hs ns) -> x + Foldable.foldl' (+) 0 hs + Foldable.foldl' (+) 0 ns) 0 ms + + {-# INLINE (.-) #-} + (.-) Zero = Zero + (.-) (v:@b) = v:@b + (.-) (Liner m _ _ _ _ _) = let !res = Map.mapMaybe f m + in case null res of + True -> Zero + False -> linerFromMap res + where + {-# INLINE f #-} + f p@(Pair hs ns) = + let !h = Foldable.foldl' (+) 0 hs + !n = Foldable.foldl' (+) 0 ns + in case nearlyEqScaled h n of -- scale-aware tolerance (WI-11) + True -> Nothing + False -> case (Seq.length hs, Seq.length ns) of + -- Already in canonical form: singleton on winning side, empty on other + (1, 0) | h > n -> Just p + (0, 1) | n > h -> Just p + -- @EQ@ is unreachable here: this branch is only entered + -- when 'nearlyEqScaled' h n is False above, so h and n are + -- not (even approximately) equal; @compare h n@ is GT or + -- LT. The non-exhaustive @case@ is by design (audited) — a + -- defensive @EQ@ arm would be dead code with no canonical + -- result to return. + _ -> case compare h n of + GT -> Just (Pair (Seq.singleton (h - n)) Seq.empty) + LT -> Just (Pair Seq.empty (Seq.singleton (n - h))) + + {-# INLINE compress #-} + compress Zero = Zero + compress (v:@b) = v:@b + compress (Liner m idx bpToId idToBp nextBpId allIds) = Liner + (Map.map compressPair m) + idx + bpToId + idToBp + nextBpId + allIds + where + {-# INLINE compressPair #-} + compressPair p@(Pair hs ns) = case (Seq.length hs, Seq.length ns) of + (1, 1) -> p -- already singleton on both sides, reuse + (1, 0) -> p -- already singleton + empty, reuse + (0, 1) -> p -- already empty + singleton, reuse + _ -> Pair (Seq.singleton (Foldable.foldl' (+) 0 hs)) + (Seq.singleton (Foldable.foldl' (+) 0 ns)) + + +instance (HatVal n, ExBaseClass b) => Exchange Alg n b where + -- | filter Credit side + decR xs = filter (\x -> x /= Zero && (whichSide . _hatBase) x == Credit) xs + + -- | filter Debit side + decL xs = filter (\x -> x /= Zero && (whichSide . _hatBase) x == Debit) xs + + -- | filter Plus Stock + decP xs = filter (\x -> x /= Zero && (isHat . _hatBase ) x) xs + + -- | filter Minus Stock + decM xs = filter (\x -> x /= Zero && (not. isHat. _hatBase) x) xs + + -- | check Credit Debit balance (scale-aware tolerance, WI-12) + balance xs = nearlyEqScaled ((norm . decR) xs) ((norm . decL) xs) + + -- | (scale-aware tolerance, WI-12); near-equal sides report (Side, 0) + diffRL xs | nearlyEqScaled r l = (Side, 0) + | r > l = (Credit, r - l) + | otherwise = (Debit, l - r) + where + r = (norm . decR) xs + l = (norm . decL) xs + +------------------------------------------------------------------ +-- * Basic functions +------------------------------------------------------------------ + +-- | Returns all values contained in the algebra element as a list. +-- +-- Complexity: O(s) (s is the total number of scalar entries) +vals :: (HatVal v, HatBaseClass b) => Alg v b -> [v] +vals Zero = [] +vals (v:@_) = [v] +vals (Liner m _ _ _ _ _) = + reverse $ + Map.foldl' + (\acc (Pair hs ns) -> + Foldable.foldl' (flip (:)) + (Foldable.foldl' (flip (:)) acc hs) + ns + ) + [] + m + + +-- | Returns all bases contained in the algebra element as a list. +-- +-- Complexity: O(s) (s is the total number of scalar entries) +bases :: (HatVal v, HatBaseClass b) => Alg v b -> [b] +bases Zero = [] +bases (_:@b) = [b] +bases (Liner m _ _ _ _ _) = Map.foldlWithKey' f [] m + where + f :: (HatVal v, HatBaseClass b) => [b] -> BasePart b -> Pair v -> [b] + f xs b (Pair {_hatSide = hs, _notSide = ns}) + = Foldable.foldl' (g Not b) (Foldable.foldl' (g Hat b) xs hs) ns + + g :: (HatVal v, HatBaseClass b) => Hat -> BasePart b -> [b] -> v -> [b] + g h b ys _ = (merge h b):ys + +{-# INLINE fromList #-} +-- | convert List to Alg n b +-- Complexity: O(sum of HashMap union costs), because this is implemented via 'mconcat'. +-- +-- >>> type Test = Alg Double (HatBase AccountTitles) +-- >>> xs = [1:@Hat:>> fromList xs +-- 1.00:@Hat:>> type Test = Alg Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Hat:>> fromList [x,y] +-- 1.00:@Hat: [Alg v b] -> Alg v b +fromList = mconcat + + + +-- | Summation function that applies a function to each element of a list and sums the results. +-- Complexity: O(sum of HashMap union costs over produced elements). +-- +-- Uses the bulk-merge path ('unionsMerge'); see there for the same-base +-- sequence-order caveat relative to 'fromList'\/'mconcat'. +-- +-- >>> type Test = Alg Double (HatBase CountUnit) +-- >>> sigma [1,2] (\x -> x:@Hat: [a] -> (a -> Alg v b) -> Alg v b +sigma xs f = mkAlgFromMap $ L.foldl' step Map.empty xs + where + step !acc !x = mergeAlgMapIfNonZero acc (f x) + +-- | Conditional summation over a double loop. For all combinations of two lists, +-- applies the function only to pairs that satisfy the condition and sums the results. +-- +-- Complexity: O(|xs| * |ys| * union cost) +{-# INLINE sigma2When #-} +sigma2When :: (HatVal v, HatBaseClass b) + => [a] + -> [c] + -> (a -> c -> Bool) + -> (a -> c -> Alg v b) + -> Alg v b +sigma2When xs ys cond f = + mkAlgFromMap $ L.foldl' outer Map.empty xs + where + outer !acc !x = L.foldl' (inner x) acc ys + inner !x !acc !y + | cond x y = mergeAlgMapIfNonZero acc (f x y) + | otherwise = acc + +-- | Summation using keys and values from a Map. Skips entries with zero values. +-- +-- Complexity: O(|map| * union cost) +{-# INLINE sigmaFromMap #-} +sigmaFromMap :: (HatVal v, HatBaseClass b, Ord k) + => M.Map k v + -> (k -> v -> Alg v b) + -> Alg v b +sigmaFromMap kvs f = + mkAlgFromMap $ M.foldlWithKey' step Map.empty kvs + where + step !acc !k !v + | isZeroValue v = acc + | otherwise = mergeAlgMapIfNonZero acc (f k v) + +-- | Converts an algebra element to a list. +-- Complexity: O(s) (s is the total number of scalar entries) +-- +-- >>> toList (10:@Hat:<(Cash) .+ 10:@Hat:<(Deposits) .+ Zero :: Alg Double (HatBase AccountTitles)) +-- [10.00:@Hat:>> toList Zero :: [Alg Double (HatBase AccountTitles)] +-- [] +toList :: (HatVal v, HatBaseClass b) => Alg v b -> [Alg v b] +toList Zero = [] +toList (v:@b) = [v:@b] +toList (Liner m _ _ _ _ _) = Map.foldlWithKey' f [] m + where + f :: (HatVal v, HatBaseClass b) => [Alg v b] -> BasePart b -> Pair v -> [Alg v b] + f xs b Pair {_hatSide = hs, _notSide = ns} + = Foldable.foldl' (g Hat b) (Foldable.foldl' (g Not b) xs ns) hs + + g :: (HatVal v, HatBaseClass b) => Hat -> BasePart b -> [Alg v b] -> v -> [Alg v b] + g h b ys v + | isZeroValue v = ys + | otherwise = (v :@ (merge h b)):ys + +{-# INLINE foldEntries #-} +-- | Strict left fold over scalar entries without building an intermediate list. +-- +-- This is the implementation vehicle for the universal extension from the free +-- commutative monoid of entries when each step acts through an associative, +-- commutative accumulator operation (equivalently, entry updates commute). +-- Under that condition the result is independent of both the internal +-- @HashMap@ traversal and each side's sequence order. For a non-commutative +-- accumulator, such as list append, this is only an ordinary left fold: its +-- result records the actual traversal order and can distinguish different +-- sequence orders of the same entry multiset. +foldEntries :: (HatVal v, HatBaseClass b) + => (acc -> v -> b -> acc) + -> acc + -> Alg v b + -> acc +foldEntries _ !acc Zero = acc +foldEntries f !acc (v :@ b) + | isZeroValue v = acc + | otherwise = f acc v b +foldEntries f !acc (Liner m _ _ _ _ _) = + Map.foldlWithKey' step acc m + where + step !acc0 !bp (Pair hs ns) = + let !hatBase = merge Hat bp + !notBase = merge Not bp + !acc1 = Foldable.foldl' (\a v -> if isZeroValue v then a else f a v hatBase) acc0 hs + in Foldable.foldl' (\a v -> if isZeroValue v then a else f a v notBase) acc1 ns + +{-# INLINE toASCList #-} +-- | Complexity: O(s log s), dominated by sorting the list representation. +toASCList :: (HatVal v, HatBaseClass b) => Alg v b -> [Alg v b] +toASCList = L.sort . toList + + +-- | map +-- Complexity: O(s + c), where s is traversed scalar entries and c is transformed output size. +-- Typed alternatives: 'mapPosting' and 'mapMaybePosting'. +-- +-- >>> type Test = Alg Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Not:>> map (\ (x:@hb) -> x:@(toHat hb)) $ x .+ y +-- 1.00:@Hat:>> type Test = Alg Double Hat +-- >>> x = 1:@Hat .+ 1:@Not :: Test +-- >>> y = 2:@Not .+ 2:@Hat :: Test +-- >>> map (\ (x:@hb) -> (2 * x):@hb) $ x .+ y +-- 2.00:@Hat .+ 4.00:@Hat .+ 2.00:@Not .+ 4.00:@Not + +-- NB. 'map' applies its function to one singleton posting at a time and requires +-- the result to itself be a singleton @(v2 :@ b2)@ (or 'Zero', handled via the +-- 'isZeroValue' check / the 'r' helper below). The @let v2:@b2 = ...@ and the +-- @case fn (...)@ in 'r' therefore intentionally match only the @(:@)@ shape; a +-- 'Zero'\/'Liner' result is outside this contract, so the non-exhaustive patterns +-- are by design (audited). Adding catch-all arms would silently change behaviour. +map :: (HasCallStack,HatVal v, HatBaseClass b) + => (Alg v b -> Alg v b) -> Alg v b -> Alg v b +map _ Zero = Zero +map f (v:@b) = let v2:@b2 = f (v:@b) + in case isZeroValue v2 of + True -> Zero + False -> (v2 :@ b2) +map f (Liner m _ _ _ _ _) = mkAlgFromMap $ (Map.foldrWithKey (p f) dnilMap m) Map.empty + where + {-# INLINE dnilMap #-} + dnilMap = id + {-# INLINE dappendMap #-} + dappendMap = (.) + {-# INLINE dsingleMap #-} + dsingleMap (bp, p') = Map.insertWith pairAppend bp p' + + {-# INLINE p #-} + p :: (HatVal v, HatBaseClass b) + => (Alg v b -> Alg v b) + -> BasePart b + -> Pair v + -> DMap (BasePart b) (Pair v) + -> DMap (BasePart b) (Pair v) + p fn b Pair {_hatSide=hs, _notSide=ns} accDList = + let (dl1, hs2) = q fn Hat b hs + (dl2, ns2) = q fn Not b ns + prefix = dappendMap dl1 dl2 + in case (Seq.null hs2, Seq.null ns2) of + (True,True) -> dappendMap prefix accDList + (True,False) -> dappendMap prefix + . dappendMap (dsingleMap (b, nullPair{_notSide = ns2})) + $ accDList + (False,True) -> dappendMap prefix + . dappendMap (dsingleMap (b, nullPair{_hatSide = hs2})) + $ accDList + (False,False) -> dappendMap prefix + . dappendMap (dsingleMap (b, Pair hs2 ns2)) + $ accDList + {-# INLINE q #-} + q :: (HatVal v, HatBaseClass b) + => (Alg v b -> Alg v b) + -> Hat + -> BasePart b + -> Seq v + -> (DMap (BasePart b) (Pair v), Seq v) + q fn h b vs = Foldable.foldl' (r fn h b) (dnilMap, Seq.empty) vs + + {-# INLINE r #-} + r :: (HatVal v, HatBaseClass b) + => (Alg v b -> Alg v b) + -> Hat + -> BasePart b + -> (DMap (BasePart b) (Pair v), Seq v) + -> v + -> (DMap (BasePart b) (Pair v), Seq v) + r fn h b (dlAcc,vsAcc) v = case fn (v:@(merge h b)) of + Zero -> (dlAcc, vsAcc) + ------------------------------------------------------------------ + v2:@b2 + | isZeroValue v2 -> (dlAcc, vsAcc) + | b2 .== (merge h b) -> (dlAcc, v2 Seq.<| vsAcc) + | isHat (hat b2) -> (dappendMap dlAcc (dsingleMap ( base b2 + ,nullPair{_hatSide = Seq.singleton v2})) + ,vsAcc ) + | otherwise -> (dappendMap dlAcc (dsingleMap ( base b2 + ,nullPair{_notSide = Seq.singleton v2} )) + ,vsAcc ) + +-- | Map every posting to exactly one posting. The typed form of 'map'. +mapPosting :: (HatVal v, HatVal v2, HatBaseClass b, HatBaseClass b2) + => (v -> b -> (v2, b2)) -> Alg v b -> Alg v2 b2 +mapPosting f = mapMaybePosting (\v b -> Just (f v b)) + +-- | Map every posting to zero or one posting. A 'Nothing' drops the posting; +-- a zero value is normalised as by '(.@)'. +mapMaybePosting :: (HatVal v, HatVal v2, HatBaseClass b, HatBaseClass b2) + => (v -> b -> Maybe (v2, b2)) -> Alg v b -> Alg v2 b2 +mapMaybePosting _ Zero = Zero +mapMaybePosting f (v :@ b) = case f v b of + Nothing -> Zero + Just (v2, b2) -> v2 .@ b2 +mapMaybePosting f (Liner m _ _ _ _ _) = + mkAlgFromMap $ Map.foldrWithKey addPair id m Map.empty + where + {-# INLINE addPair #-} + addPair bp (Pair hs ns) accDMap = + mapSide Hat bp hs . mapSide Not bp ns . accDMap + + {-# INLINE mapSide #-} + mapSide h bp = Foldable.foldl' (mapOne (merge h bp)) id + + {-# INLINE mapOne #-} + mapOne b dlAcc v = case f v b of + Nothing -> dlAcc + Just (v2, b2) -> case v2 .@ b2 of + Zero -> dlAcc + v3 :@ b3 -> dlAcc . Map.insertWith pairAppend (base b3) (postingPair v3 b3) + Liner {} -> dlAcc + + {-# INLINE postingPair #-} + postingPair v b + | isHat (hat b) = nullPair {_hatSide = Seq.singleton v} + | otherwise = nullPair {_notSide = Seq.singleton v} + +-- Difference-map (endo) used by 'map' to accumulate Liner rebuilds in O(1). +-- NB. The plain difference-list helpers (dnil/dappend/dsingle/dToList/dFromList) +-- and the unused 'DList' type alias were removed as dead code: only the DMap +-- variants (dnilMap/dappendMap/dsingleMap, defined locally in 'map') are used. +type DMap k v = Map.HashMap k v -> Map.HashMap k v + +{-# INLINE filter #-} +-- | filter +-- Complexity: O(s), where s is total number of scalar entries. +-- +-- >>> type Test = Alg Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Not:>> filter (isHat . _hatBase) $ x .+ y +-- 1.00:@Hat:>> type Test = Alg Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Not:>> filter ((1 <). _val) $ x .+ y +-- 2.00:@Not: (Alg v b -> Bool) -> Alg v b -> Alg v b +filter _ Zero = Zero +filter f (v:@b) | f (v:@b) = v:@b + | otherwise = Zero + +filter f (Liner m _ _ _ _ _) = + -- Build a new Map using mapMaybeWithKey + let m' = Map.mapMaybeWithKey + (\basePart (Pair hs ns) -> + -- Filter each of hs and ns + let hs' = filterSide basePart Hat hs + ns' = filterSide basePart Not ns + in + -- Remove the entry (Nothing) if both become empty + if Seq.null hs' && Seq.null ns' + then Nothing + else Just (Pair hs' ns')) + m + in + -- If the resulting Map is empty, return Zero; otherwise Liner m' + if Map.null m' then Zero else linerFromMap m' + where + ---------------------------------------------------------------- + -- Filter function that constructs "v:@(merge h basePart)" from + -- basePart and Hat/Not, and tests whether it satisfies predicate f + ---------------------------------------------------------------- + -- filterSide :: BasePart b -> Hat -> Seq v -> Seq v + {-# INLINE filterSide #-} + filterSide bp h = Seq.filter (\val -> f (val :@ merge h bp)) + +------------------------------------------------------------ +-- | Relabel the /base part/ of every element, preserving the Hat\/Not structure +-- and the redundancy (the ordered Hat- and Not-side sequences). Only the +-- 'BasePart' is rewritten by @f@; the Hat\/Not side and the values are untouched. +-- When @f@ maps two distinct base parts onto the same target, their sequences are +-- concatenated (pair-append), so no value is lost — hence @'norm'@ is preserved. +-- Preserving wildcards (@(.#)@) is the caller's responsibility (in @f@). +-- +-- == Laws and their layer of validity +-- +-- On the full subcategory of 'HatBaseClass' bases, this relabelling is a +-- functor only after observing an algebra through ℘, where ℘ forgets sequence +-- order but retains, for every full Hat\/Not base, the multiset of values. +-- The functor and additive laws at this layer are: +-- +-- * @mapBasePart id x@ and @x@ are equal through ℘. Raw equality can fail when +-- @x@ is a one-key, one-value @Liner@ produced by 'bar' or filtering: +-- rebuilding it chooses the singleton @(:@)@ representation, and 'Eq' +-- distinguishes those constructors. +-- * @mapBasePart (g . f) x@ and +-- @mapBasePart g (mapBasePart f x)@ are equal through ℘, but need not be raw +-- equal. +-- * @mapBasePart f (x .+ y)@ and +-- @mapBasePart f x .+ mapBasePart f y@ are equal through ℘, but need not be +-- raw equal. +-- * @norm (mapBasePart f x) == norm x@ for exact additive value types. For +-- floating-point values, regrouping after collisions has the usual rounding +-- caveat. +-- * @mapBasePart f ((.^) x) == (.^) (mapBasePart f x)@ (raw). +-- * Algebraically, @bar (mapBasePart f (bar x))@ and +-- @bar (mapBasePart f x)@ are equal through ℘ whenever the implementation's +-- 'nearlyEqScaled' tolerance does not discard a source-base residual before +-- relabelling. Raw equality can additionally distinguish singleton from +-- one-key @Liner@. With tolerance-triggering magnitudes, even ℘ equality is +-- not guaranteed. +-- +-- In particular, @mapBasePart f (bar x) == bar (mapBasePart f x)@ is false in +-- general: distinct source bases may collide only after relabelling. When +-- collisions occur, @pairAppend@ preserves every value but the resulting +-- sequence order is a representation detail determined by @HashMap@ traversal; +-- callers must not attach semantics to it. +-- +-- Complexity: O(n) over distinct base keys (rebuilds the posting index once). +-- +-- >>> type T = Alg Double (HatBase CountUnit) +-- >>> mapBasePart id (10:@Hat:>> norm (mapBasePart (const Amount) (10:@Not: (BasePart b -> BasePart b') -> Alg v b -> Alg v b' +mapBasePart _ Zero = Zero +mapBasePart f (v :@ b) = singleton v (merge (hat b) (f (base b))) +mapBasePart f (Liner m _ _ _ _ _) = + mkAlgFromMap $ + Map.foldlWithKey' + (\acc bp p -> Map.insertWith pairAppend (f bp) p acc) + Map.empty + m + +------------------------------------------------------------ +-- | proj +-- +-- Projects an 'Alg' onto the bases matching a query list. The query list is +-- treated as a __set__: duplicate queries, or an exact base that also matches a +-- wildcard query in the same list, select each underlying posting __at most +-- once__ (no double counting). The result is the union of the selected +-- @(base, side)@ cells. +-- +-- Complexity: +-- exact single-key path: expected O(1) +-- wildcard single-key path: O(queryAxisPosting + c * verify) +-- multi-pattern path: O(sum pattern costs + union costs) +-- +-- where c is candidate count returned by the posting index. +-- >>> type Test = Alg Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Not:>> proj [Hat:>> type Test = Alg Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Not:>> proj [HatNot:>> 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 +-- >>> proj [Hat:<((.#),Yen)] $ x .+ y +-- 1.00:@Hat:<(Cash,Yen) .+ 2.00:@Hat:<(Deposits,Yen) +-- +-- >>> type Test = HatBase CountUnit +-- >>> compareHatBase (Not:<(.#) :: Test) (Not:>> type Test = Alg Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Not:>> proj [Not:<(.#)] $ x .+ y +-- 2.00:@Not: [b] -> Alg v b -> Alg v b +proj [] _ = Zero +proj _ Zero = Zero +proj [b] (v:@b2) + | b .== b2 = v:@b2 + | otherwise = Zero +-- Index fields bound lazily (@~@) so a concrete (non-wildcard) base never forces +-- the axis index (the module is @Strict@; see 'projExactMap'). +proj [b] (Liner m ~idx _ ~idToBp _ ~allIds) = + mkAlgFromMap $ + if haveWildcard (base b) + then projWildMap b m idx idToBp allIds + else projExactMap b m +proj (b:bs) (v:@b2) + | b .== b2 = v:@b2 + | otherwise = proj bs (v:@b2) +-- Multi-pattern path: the query list is treated as a /set/. Overlapping or +-- duplicate queries (e.g. a duplicated base, or an exact base subsumed by a +-- wildcard) select the same posting only once. Per-base results are merged +-- with 'pairUnion' (set union of the selected sides) rather than @pairAppend@ +-- (concatenation), so no posting is double counted. +proj (b:bs) (Liner m ~idx _ ~idToBp _ ~allIds) = + mkAlgFromMap $ + L.foldl' + (\acc q -> Map.unionWith pairUnion acc + (if haveWildcard (base q) + then projWildMap q m idx idToBp allIds + else projExactMap q m)) + Map.empty + (b:bs) + +{-# INLINE choosePairByHat #-} +-- | Complexity: O(1) +choosePairByHat :: Hat -> Pair v -> Pair v +choosePairByHat h Pair {_hatSide = hs, _notSide = ns} = + case h of + Hat -> nullPair {_hatSide = hs} + Not -> nullPair {_notSide = ns} + HatNot -> Pair {_hatSide = hs, _notSide = ns} + +{-# INLINE projExactMap #-} +-- | Exact (non-wildcard) single-base projection: a direct 'Map.lookup' on the +-- @_realg@ map. It does NOT reference the axis index, so the concrete projection +-- path can keep that lazy index unforced. +-- +-- This matters because the module is compiled @{-\# LANGUAGE Strict \#-}@: handing +-- the (lazy) index to a helper that takes it as a strict argument would force its +-- whole construction even for a concrete lookup that never needs it. Callers +-- therefore dispatch on 'haveWildcard' BEFORE touching the index, binding the +-- index fields lazily (@~@) and only mentioning them on the wildcard branch. +-- Guarded by the poison-index regression test in the test suite. +-- +-- Complexity: expected O(1). +projExactMap + :: (HatBaseClass b) + => b + -> Map.HashMap (BasePart b) (Pair v) + -> Map.HashMap (BasePart b) (Pair v) +projExactMap b m = case Map.lookup bp m of + Nothing -> Map.empty + Just p -> Map.singleton bp (choosePairByHat h p) + where + !bp = base b + !h = hat b + +{-# INLINE projWildMap #-} +-- | Wildcard single-base projection: resolves candidates through the axis index +-- ('queryAxisPosting'), so it necessarily forces the index. Only invoked when +-- 'haveWildcard' holds. +-- +-- Complexity: O(queryAxisPosting + c * verify). +projWildMap + :: (HatBaseClass b) + => b + -> Map.HashMap (BasePart b) (Pair v) + -> AxisPosting + -> IntMap.IntMap (BasePart b) + -> IntSet.IntSet + -> Map.HashMap (BasePart b) (Pair v) +projWildMap b m idx idToBp allIds = + let !ids = queryAxisPosting (toAxisKeys bp) idx allIds + in IntSet.foldl' + (\acc bpId -> case IntMap.lookup bpId idToBp of + Nothing -> acc + Just bp0 -> case Map.lookup bp0 m of + Nothing -> acc + Just p -> if bp .== bp0 + then Map.insert bp0 (choosePairByHat h p) acc + else acc) + Map.empty + ids + where + !bp = base b + !h = hat b + +{-# INLINE mkAlgFromMap #-} +-- | Complexity: O(n) to inspect shape and possibly rebuild index. +mkAlgFromMap :: (HatVal v, HatBaseClass b) => Map.HashMap (BasePart b) (Pair v) -> Alg v b +mkAlgFromMap m + | Map.null m = Zero + | otherwise = case Map.toList m of + [(b, p)] -> Maybe.fromMaybe (linerFromMap $ Map.singleton b p) (singlePairToAlg b p) + _ -> linerFromMap m + +{-# INLINE singlePairToAlg #-} +-- | Complexity: O(1) +singlePairToAlg :: (HatVal v, HatBaseClass b) => BasePart b -> Pair v -> Maybe (Alg v b) +singlePairToAlg b (Pair hs ns) = case (Seq.viewl hs, Seq.viewl ns) of + (Seq.EmptyL, n Seq.:< nsRest) | Seq.null nsRest -> Just (n :@ merge Not b) + (h Seq.:< hsRest, Seq.EmptyL) | Seq.null hsRest -> Just (h :@ merge Hat b) + _ -> Nothing + +------------------------------------------------------------------ + +-- | Projects only the credit-side elements. For 'Alg' this coincides with the +-- 'Exchange' class method 'decR' (R = Right = Credit, 貸方); the top-level name +-- makes the selected side explicit at call sites. (An earlier doc sentence +-- restricting this to non-'Enum' bases referred to long-removed 'Enum'-based +-- class defaults and no longer applies.) +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projCredit :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projCredit = filter (\x -> (whichSide . _hatBase) x == Credit) + +-- | Projects only the debit-side elements. For 'Alg' this coincides with the +-- 'Exchange' class method 'decL' (L = Left = Debit, 借方); the top-level name +-- makes the selected side explicit at call sites. (An earlier doc sentence +-- restricting this to non-'Enum' bases referred to long-removed 'Enum'-based +-- class defaults and no longer applies.) +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projDebit :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projDebit = filter (\x -> (whichSide . _hatBase) x == Debit) + +-- | Projects only the elements matching the specified account title. +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projByAccountTitle :: (HatVal n, ExBaseClass b) => AccountTitles -> Alg n b -> Alg n b +projByAccountTitle at alg = filter (f at) alg + where + f :: (HatVal n,ExBaseClass b) => AccountTitles -> Alg n b -> Bool + f _ Zero = False + f t x = ((getAccountTitle ._hatBase) x) .== t + +-- | Bar-netted norm of a projection. The query list is treated as a __set__ +-- (see 'proj'): overlapping or duplicate queries do not double count. +-- +-- Note the semantics include the @bar@ netting: each projected base is reduced +-- to the non-negative net of its hat and not sides (@barNormPair@). Hence +-- +-- @projNetNorm bs x == norm (bar (proj bs x))@ +-- +-- which is /not/ the same as @norm (proj bs x)@ when a base carries both sides. +-- +-- Complexity: O(cost(proj) + cost(bar) + cost(norm)). +projNetNorm :: (HatVal n, HatBaseClass b) => [b] -> Alg n b -> n +projNetNorm [] _ = 0 +projNetNorm _ Zero = 0 +projNetNorm bs (v :@ b) + | L.any (.== b) bs = v + | otherwise = 0 +-- Index fields bound lazily (@~@); a concrete base uses 'projExactMap' (a plain +-- 'Map.lookup') and never forces the axis index. See 'projExactMap'. +projNetNorm [b] (Liner m ~idx _ ~idToBp _ ~allIds) = + foldProjectedNorm $ + if haveWildcard (base b) + then projWildMap b m idx idToBp allIds + else projExactMap b m +-- Multi-pattern path: the query list is a /set/ (see 'proj'). Per-base results +-- are merged with 'pairUnion' so overlapping/duplicate queries do not double +-- count. Note 'projNetNorm' returns a bar-netted norm: 'foldProjectedNorm' applies +-- @barNormPair@ (net of hat/not sides) per base, so the result equals +-- @norm (bar (proj bs x))@, not @norm (proj bs x)@. +projNetNorm bs (Liner m ~idx _ ~idToBp _ ~allIds) = + foldProjectedNorm $ + L.foldl' + (\acc q -> Map.unionWith pairUnion acc + (if haveWildcard (base q) + then projWildMap q m idx idToBp allIds + else projExactMap q m)) + Map.empty + bs + +{-# DEPRECATED projNorm "renamed to 'projNetNorm': the result is the bar-netted norm (norm (bar (proj bs x))), which the old name concealed — 'norm (proj bs x)' is NOT what this computes. 'projNorm' will be removed in 0.6" #-} +-- | Deprecated alias for 'projNetNorm' (renamed in 0.5.0.0 so the name states +-- the bar-netting). +projNorm :: (HatVal n, HatBaseClass b) => [b] -> Alg n b -> n +projNorm = projNetNorm + +{-# INLINE foldProjectedNorm #-} +-- | Complexity: O(k), where k is the number of projected base keys. +foldProjectedNorm :: (HatVal n) => Map.HashMap k (Pair n) -> n +foldProjectedNorm = Map.foldl' (\acc p -> acc + barNormPair p) 0 + +{-# INLINE barNormPair #-} +-- | Complexity: O(h + n), where h/n are side lengths within the pair. +barNormPair :: (HatVal n) => Pair n -> n +barNormPair (Pair hs ns) = + let !h = Foldable.foldl' (+) 0 hs + !n = Foldable.foldl' (+) 0 ns + in if nearlyEqScaled h n + then 0 + else if h > n then h - n else n - h + + +-- | Compute the net balance as the difference of two projections. +-- @balanceBy plusBases minusBases alg@ computes +-- @projNetNorm plusBases alg - projNetNorm minusBases alg@. +-- +-- Useful for calculating stock quantities, profits, etc. +-- +-- >>> type T = Alg Double (HatBase AccountTitles) +-- >>> let alg = 100 :@ Not:>> balanceBy [Not:>> balanceBy [Hat: [b] -> [b] -> Alg n b -> n +balanceBy plusBases minusBases alg = + projNetNorm plusBases alg - projNetNorm minusBases alg + +-- | Aggregate the net balance of an 'Alg' by a key, in a single pass. +-- +-- @balanceMapBy keyOf@ is the bucketed form of 'balanceBy': for every entry it +-- projects the (side-stripped) 'BasePart' to a bucket key with @keyOf@ ('Nothing' +-- drops the entry), and nets each bucket using the Hat\/Not convention (Not adds, +-- Hat subtracts) — exactly @projNetNorm [Not:>> type T = Alg Double (HatBase AccountTitles) +-- >>> let alg = 100 :@ Not:>> balanceMapBy Just alg +-- fromList [(Cash,70.0),(Deposits,50.0)] +{-# INLINE balanceMapBy #-} +balanceMapBy :: (HatVal v, HatBaseClass b, Ord k) + => (BasePart b -> Maybe k) -> Alg v b -> M.Map k v +balanceMapBy keyOf = foldEntriesToMap step + where + step v b = case keyOf (base b) of + Nothing -> Nothing + Just k -> Just (k, if isHat b then negate v else v) + +-- | Aggregate the per-base /netted/ balance of an 'Alg' by a key, keeping the +-- winning side, in a single pass. +-- +-- This is the implementation counterpart of the paper's @def:class-net@ +-- (\(\nu_\kappa\)), the __pair__ read-out of the class-net operator: +-- 'balanceMapBy' is its /signed difference/ version +-- (@balanceMapBy kf == fmap (\\(n,h) -> n - h) . netPairMapBy kf@). +-- +-- @netPairMapBy keyOf@ projects each entry's (side-stripped) 'BasePart' to a +-- bucket key with @keyOf@ ('Nothing' drops the entry), and for every key +-- returns a pair @(notTotal, hatTotal)@ built as follows: for each base \(b\) +-- it first nets the two sides (@bar@-like cancellation of the redundant +-- sequences), keeping only the residual on the side that wins, then sums the +-- residuals across all bases mapping to the key — +-- +-- \[ \Big( \textstyle\sum_{n_b > h_b} (n_b - h_b),\ \sum_{h_b > n_b} (h_b - n_b) \Big). \] +-- +-- This per-base netting is named and documented here — it is /not/ an implicit +-- 'bar'; the function performs exactly the standard-element reduction the name +-- promises, mirroring how 'balanceMapBy' reports a netted read-out. +-- +-- __Both components are non-negative__ (consistent with the value domain +-- \(V \subseteq \mathbb{R}_{\ge 0}\)): a base contributes to at most one side, +-- whichever residual is larger. Bases whose two sides are equal (up to +-- 'nearlyEqScaled') contribute nothing. Because of the non-negativity, +-- @netPairMapBy@ is well behaved for non-negative-only value types, whereas the +-- @n - h@ identity with 'balanceMapBy' only holds on a /signed/ value type +-- (e.g. 'Double', @MoneyDouble@, @MoneyDecimal@) where the difference can be +-- negative. +-- +-- Complexity: O(total number of entries) — a single fold over the entries, +-- followed by one collapse over the distinct bases. +-- +-- >>> type T = Alg Double (HatBase AccountTitles) +-- >>> let alg = 100 :@ Not:>> netPairMapBy Just alg +-- fromList [(Cash,(70.0,0.0)),(Deposits,(50.0,0.0))] +{-# INLINE netPairMapBy #-} +netPairMapBy :: (HatVal v, HatBaseClass b, Ord k) + => (BasePart b -> Maybe k) -> Alg v b -> M.Map k (v, v) +netPairMapBy keyOf alg = + -- collapse the per-base (notSum, hatSum) accumulator into per-key residuals + Map.foldlWithKey' collapse M.empty perBase + where + -- pass 1: accumulate (notSum, hatSum) per BasePart in one fold + perBase = foldEntries step Map.empty alg + step !acc v b = + let !bp = base b + !(notV, hatV) = if isHat b then (zeroValue, v) else (v, zeroValue) + in Map.insertWith addPair bp (notV, hatV) acc + addPair (!n1, !h1) (!n2, !h2) = (n1 + n2, h1 + h2) + collapse !acc bp (!n, !h) = case keyOf bp of + Nothing -> acc + Just k + | nearlyEqScaled h n -> acc + | n > h -> M.insertWith addPair k (n - h, zeroValue) acc + | otherwise -> M.insertWith addPair k (zeroValue, h - n) acc + +-- | Fold algebra entries into a @Map@, combining values with @(+)@. +-- +-- The selector function examines each entry @(v, b)@ and optionally returns +-- a @(key, value)@ pair. Values for duplicate keys are summed. +-- +-- >>> type T = Alg Double (HatBase AccountTitles) +-- >>> let alg = 10 :@ Hat:>> let f v (Hat :< a) = Just (a, v); f _ _ = Nothing +-- >>> foldEntriesToMap f alg +-- fromList [(Cash,15.0),(Deposits,20.0)] +foldEntriesToMap :: (HatVal v, HatBaseClass b, Ord k) + => (v -> b -> Maybe (k, v)) + -> Alg v b + -> M.Map k v +foldEntriesToMap f = foldEntries step M.empty + where + step acc v b = case f v b of + Just (k, v') -> M.insertWith (+) k v' acc + Nothing -> acc + +-- | Quotient decomposition (dec_κ): partition an algebra along the equivalence +-- classes induced by a classifier on the full 'HatBase', in a single pass. +-- +-- For each entry, @keyOf@ maps its base (Hat\/Not state included) to a class +-- key; @Nothing@ drops the entry as residual. Each class is returned as an +-- 'Alg' that is exactly the restriction of the input to that class: +-- __redundancy (the per-base value sequences) is fully preserved__ — no 'bar', +-- no 'norm', no aggregation. The pieces reconstruct the input: +-- @mconcat (M.elems (decBy keyOf x)) .+ residual == x@ (up to per-base +-- sequence order). +-- +-- This generalizes the decomposition operators of Deguchi & Nakano (1986) +-- ('decR'\/'decL'\/'decP'\/'decM' are two-class special cases) and replaces +-- per-class projection loops: one pass over the entries instead of one +-- projection query per class. +-- +-- Choosing between the per-key family: +-- +-- +--------------------+----------------------------------+---------------------+ +-- | function | returns | redundancy | +-- +====================+==================================+=====================+ +-- | 'decBy' | @Map k (Alg v b)@ (structure) | preserved | +-- +--------------------+----------------------------------+---------------------+ +-- | 'balanceMapBy' | @Map k v@ (signed net per key) | lost (bar-like) | +-- +--------------------+----------------------------------+---------------------+ +-- | 'netPairMapBy' | @Map k (v,v)@ (non-neg net pair) | lost (bar-like) | +-- +--------------------+----------------------------------+---------------------+ +-- | 'foldEntriesToMap' | @Map k v@ (custom collection) | lost | +-- +--------------------+----------------------------------+---------------------+ +-- | 'mapBasePart' | @Alg v b'@ (base coarsening π_κ) | preserved | +-- +--------------------+----------------------------------+---------------------+ +-- +-- Note on 'bar': @bar@ commutes with 'decBy' componentwise iff @keyOf@ does not +-- distinguish Hat\/Not (i.e. factors through 'base'). Side-sensitive classifiers +-- (such as the ones underlying 'decP'\/'decM' or 'decL'\/'decR') do not commute +-- with @bar@ — netting before or after such a split is a semantic choice. +-- +-- Complexity: O(m) over distinct bases (single fold; per-class insert costs +-- O(log k) in the result 'M.Map'). +-- +-- >>> type T = Alg Double (HatBase AccountTitles) +-- >>> let alg = 100 :@ Not:>> M.toList (M.map norm (decBy (\(_ :< a) -> Just a) alg)) +-- [(Cash,130.0),(Deposits,50.0)] +-- +-- >>> M.toList (M.map norm (decBy (\b -> if isHat b then Just () else Nothing) alg)) +-- [((),30.0)] +{-# INLINE decBy #-} +decBy :: (HatVal v, HatBaseClass b, Ord k) + => (b -> Maybe k) + -> Alg v b + -> M.Map k (Alg v b) +decBy _ Zero = M.empty +decBy kf a@(v :@ b) + | isZeroValue v = M.empty + | otherwise = case kf b of + Nothing -> M.empty + Just k -> M.singleton k a +decBy kf (Liner m _ _ _ _ _) = + M.map mkAlgFromMap (Map.foldlWithKey' step M.empty m) + where + step !acc !bp (Pair hs ns) = + let !acc1 = if Seq.null hs + then acc + else insertSide (merge Hat bp) bp (nullPair {_hatSide = hs}) acc + in if Seq.null ns + then acc1 + else insertSide (merge Not bp) bp (nullPair {_notSide = ns}) acc1 + {-# INLINE insertSide #-} + insertSide hb bp p acc = case kf hb of + Nothing -> acc + Just k -> M.insertWith (Map.unionWith (flip pairAppend)) k (Map.singleton bp p) acc + +-- | Classify-net-post, fused: net the algebra per base ('bar' — explicit in the +-- name), classify each netted entry with @keyOf@ (class totals are summed with +-- @(+)@), then generate postings per class and bulk-merge them. +-- +-- @postFromNetBy keyOf post x == sigmaFromMap (foldEntriesToMap collect (bar x)) post@ +-- where @collect@ pairs each netted entry with its class. The common +-- \"shortage detection → purchase postings\" pattern becomes a single call: +-- +-- @ +-- purchases = postFromNetBy shortageKey purchasePosting termAlg +-- @ +-- +-- and runs in one pass over the netted entries — no per-pair projection loop +-- (the naive all-pairs formulation costs O(N²) queries; this costs O(m)). +-- +-- __This function applies 'bar' internally__ (per-base netting, the standard +-- positive-part normalization). Redundancy of the input is not preserved in the +-- intermediate; the output is whatever @post@ builds. If you need the +-- redundancy-preserving split itself, use 'decBy'. +-- Thus it factors through the quotient induced by 'bar': it is not the free +-- extension that acts independently on entries in the redundant layer. +-- +-- Complexity: O(m + Σ cost(post)). +-- +-- >>> type T = Alg Double (HatBase AccountTitles) +-- >>> let stock = 100 :@ Not:>> let shortageKey b = case b of { Hat :< Products -> Just () ; _ -> Nothing } +-- >>> norm (postFromNetBy shortageKey (\_ v -> v :@ Not: (b -> Maybe k) + -> (k -> v -> Alg v b) + -> Alg v b + -> Alg v b +postFromNetBy kf post x = + sigmaFromMap (foldEntriesToMap (\v b -> (\k -> (k, v)) <$> kf b) ((.-) x)) post + +-- | Projects only current assets. +-- Extracts asset items classified as current from the debit side. +-- +-- Selection predicate (over every scalar entry @x@ of the input, on the debit side): +-- @whatDiv (_hatBase x) == Assets && fixedCurrent (_hatBase x) == Current && not (isContra (_hatBase x))@. +-- Contra accounts are excluded, so the result is the /gross/ figure of this +-- class; the net figure is @norm (projCurrentAssets x) - norm ('bar' (contra x))@ where +-- @contra@ is 'projContraAssets' (Assets) or 'projContra' (any division). +-- See 'projContraAssets' for the rationale (Definition 7 amendment, Land 2). +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projCurrentAssets :: ( HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projCurrentAssets = (filter (\x -> (fixedCurrent . _hatBase) x == Current)) + . (filter (\x -> (whatDiv . _hatBase) x == Assets)) + . (filter (not . isContra . _hatBase)) + . projDebit + +-- | Projects only fixed assets. +-- Extracts asset items classified as fixed from the debit side. +-- +-- Selection predicate (over every scalar entry @x@ of the input, on the debit side): +-- @whatDiv (_hatBase x) == Assets && fixedCurrent (_hatBase x) == Fixed && not (isContra (_hatBase x))@. +-- Contra accounts are excluded, so the result is the /gross/ figure of this +-- class; the net figure is @norm (projFixedAssets x) - norm ('bar' (contra x))@ where +-- @contra@ is 'projContraAssets' (Assets) or 'projContra' (any division). +-- See 'projContraAssets' for the rationale (Definition 7 amendment, Land 2). +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projFixedAssets :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projFixedAssets = (filter (\x -> (fixedCurrent . _hatBase) x == Fixed)) + . (filter (\x -> (whatDiv . _hatBase) x == Assets)) + . (filter (not . isContra . _hatBase)) + . projDebit + +-- | Projects only deferred assets. +-- Tax-specific deferred assets are presented under "investments and other assets" with appropriate items such as long-term prepaid expenses. +-- +-- Selection predicate (over every scalar entry @x@ of the input, on the debit side): +-- @whatDiv (_hatBase x) == Assets && fixedCurrent (_hatBase x) == Other && not (isContra (_hatBase x))@. +-- Contra accounts are excluded, so the result is the /gross/ figure of this +-- class; the net figure is @norm (projDeferredAssets x) - norm ('bar' (contra x))@ where +-- @contra@ is 'projContraAssets' (Assets) or 'projContra' (any division). +-- See 'projContraAssets' for the rationale (Definition 7 amendment, Land 2). +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projDeferredAssets :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projDeferredAssets = (filter (\x -> (fixedCurrent . _hatBase) x == Other)) + . (filter (\x -> (whatDiv . _hatBase) x == Assets)) + . (filter (not . isContra . _hatBase)) + . projDebit + +-- | Projects only current liabilities. +-- Extracts liability items classified as current from the credit side. +-- +-- Selection predicate (over every scalar entry @x@ of the input, on the credit side): +-- @whatDiv (_hatBase x) == Liability && fixedCurrent (_hatBase x) == Current && not (isContra (_hatBase x))@. +-- Contra accounts are excluded, so the result is the /gross/ figure of this +-- class; the net figure is @norm (projCurrentLiability x) - norm ('bar' (contra x))@ where +-- @contra@ selects the Liability-division entries of 'projContra' (the current +-- registry has no contra liability account, so gross and net coincide today). +-- See 'projContraAssets' for the rationale (Definition 7 amendment, Land 2). +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projCurrentLiability :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projCurrentLiability = (filter (\x -> (fixedCurrent . _hatBase) x == Current)) + . (filter (\x -> (whatDiv . _hatBase) x == Liability)) + . (filter (not . isContra . _hatBase)) + . projCredit + +-- | Projects only fixed liabilities. +-- Extracts liability items classified as fixed from the credit side. +-- +-- Selection predicate (over every scalar entry @x@ of the input, on the credit side): +-- @whatDiv (_hatBase x) == Liability && fixedCurrent (_hatBase x) == Fixed && not (isContra (_hatBase x))@. +-- Contra accounts are excluded, so the result is the /gross/ figure of this +-- class; the net figure is @norm (projFixedLiability x) - norm ('bar' (contra x))@ where +-- @contra@ selects the Liability-division entries of 'projContra' (the current +-- registry has no contra liability account, so gross and net coincide today). +-- See 'projContraAssets' for the rationale (Definition 7 amendment, Land 2). +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projFixedLiability :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projFixedLiability = (filter (\x -> (fixedCurrent . _hatBase) x == Fixed)) + . (filter (\x -> (whatDiv . _hatBase) x == Liability)) + . (filter (not . isContra . _hatBase)) + . projCredit + +-- | Projects only capital stock (equity). +-- Extracts items classified under the 'Equity' division from the credit side. +-- +-- Selection predicate (over every scalar entry @x@ of the input, on the credit side): +-- @whatDiv (_hatBase x) == Equity && not (isContra (_hatBase x))@. +-- Contra accounts are excluded, so the result is the /gross/ figure of this +-- class; the net figure is @norm (projCapitalStock x) - norm ('bar' (contra x))@ where +-- @contra@ selects the Equity-division entries of 'projContra' (the current +-- registry has no contra equity account, so gross and net coincide today). +-- See 'projContraAssets' for the rationale (Definition 7 amendment, Land 2). +-- +-- Complexity: O(s) (s is the total number of scalar entries) +-- +-- >>> type Test = Alg Double (HatBase AccountTitles) +-- >>> x = 100:@Not:>> norm (projCapitalStock x) +-- 120.0 +projCapitalStock :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projCapitalStock = (filter (\x -> (whatDiv . _hatBase) x == Equity)) + . (filter (not . isContra . _hatBase)) + . projCredit + +-- | Projects contra-asset entries (@whatDiv == Assets && isContra@, e.g. +-- 貸倒引当金\/減価償却累計額) — an /attribute/ selection, not a physical-side +-- one: both Hat and Not postings of the contra account are kept, and normal +-- assets' credit-side (Hat) postings are NOT included. The division +-- projections (@proj*Assets@\/@proj*Liability@\/'projCapitalStock') +-- exclude ALL contra accounts, so within the Assets division this projection +-- is the sole selector — no double counting when combining them. A net +-- figure is @gross - contra balance@, e.g. +-- @norm (projCurrentAssets x) - norm ('ExchangeAlgebra.Algebra.bar' (projContraAssets x))@ +-- when the contra accounts hold normal (credit) balances; deduction\/netting +-- /presentation/ policy is the Write side's job (Land 3). +-- +-- NOTE: this selects the Assets division only. In the current registry every +-- contra account is an asset, but the type class does not forbid contra +-- accounts in other divisions (e.g. a future treasury-stock contra equity) — +-- those are excluded from the division projections too and must be selected +-- with the generic 'projContra'. Consumers that need a +-- net asset figure combine the gross @proj*Assets@ family with this +-- projection themselves; deduction\/netting presentation policy is the +-- Write side's job (Land 3 of the Definition 7 amendment). +-- +-- Complexity: O(s) (s is the total number of scalar entries) +-- +-- >>> type Test = Alg Double (HatBase AccountTitles) +-- >>> x = 100:@Not:>> projContraAssets x +-- 20.00:@Hat: Alg n b -> Alg n b +projContraAssets = filter + (\x -> (whatDiv . _hatBase) x == Assets && (isContra . _hatBase) x) + +-- | Projects ALL contra entries regardless of division — the exact +-- complement, w.r.t. contra-ness, of the six division projections (which all +-- exclude contra accounts). Use this when the chart may contain contra +-- accounts outside the Assets division; @'projContraAssets' = filter by +-- Assets ∘ projContra@. +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projContra :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projContra = filter (isContra . _hatBase) + + +-- * Rounding + +-- | Rounding (ceiling), fixed to @NN.Double@ and to whole units. +-- +-- Superseded by the explicit, value-type-appropriate rounding functions in +-- "ExchangeAlgebra.Value": 'ExchangeAlgebra.Value.bankersRound' (unbiased +-- financial default) and 'ExchangeAlgebra.Value.ceilingRound' (this function's +-- behaviour, with a decimal-places argument). There is no single correct +-- rounding rule, so the rule should be chosen explicitly at the call site. +-- +-- Complexity: O(1) +rounding :: NN.Double -> NN.Double +rounding = fromIntegral . ceiling + +{-# DEPRECATED rounding "NN.Double-only whole-unit ceiling; use ExchangeAlgebra.Value.ceilingRound / bankersRound (explicit, value-type-appropriate) instead" #-} diff --git a/src/ExchangeAlgebra/Algebra/Transfer.hs b/src/ExchangeAlgebra/Algebra/Transfer.hs --- a/src/ExchangeAlgebra/Algebra/Transfer.hs +++ b/src/ExchangeAlgebra/Algebra/Transfer.hs @@ -31,7 +31,7 @@ module ExchangeAlgebra.Algebra.Transfer ( Size - , TransTable (..) + , TransTable , isNullTable , transfer , table @@ -51,26 +51,17 @@ import qualified ExchangeAlgebra.Algebra as EA import ExchangeAlgebra.Algebra - -import qualified Number.NonNegative as NN ( Double - , fromNumber - , toNumber,T) -- Non-negative real numbers -import qualified Data.Maybe as Maybe import Text.Show.Unicode ( ushow) import GHC.Exts ( reallyUnsafePtrEquality# , isTrue# - , build , lazy) import Data.Semigroup ( Semigroup(stimes) , stimesIdempotentMonoid) -import Data.Monoid ( Monoid(..)) import qualified Data.Foldable as Foldable -import Data.Foldable ( Foldable()) import Data.Bits ( shiftL , shiftR) import qualified Data.HashMap.Strict as HM import Utils.Containers.Internal.StrictPair -import Debug.Trace ------------------------------------------------------------------ -- * Core computation @@ -100,7 +91,7 @@ instance (HatBaseClass b) => Show (TransTable n b) where show NullTable = "[]" - show (TransTable s b f a l r) = "[(" ++ ushow b + show (TransTable _ b _ a l r) = "[(" ++ ushow b ++ "," ++ ushow a ++ ",)" @@ -174,11 +165,6 @@ unions :: (HatVal n, Foldable f, HatBaseClass b) => f (TransTable n b) -> TransTable n b unions ts = Foldable.foldl' union NullTable ts -{-# INLINE null #-} -null :: (HatBaseClass b) => TransTable n b -> Bool -null NullTable = True -null (TransTable _ _ _ _ _ _) = False - {-# INLINE size #-} size :: (HatBaseClass b) => TransTable n b -> Size size NullTable = 0 @@ -215,7 +201,7 @@ -- >>> 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 wiledcard = -1 +-- >>> 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 @@ -258,7 +244,7 @@ LT -> resolveByTree l hb1 GT -> resolveByTree r hb1 EQ -> error $ "transfer: " ++ show hb1 ++ "," ++ show hb2 - | otherwise = Just (f, ignoreWiledcard hb1 a) + | otherwise = Just (f, ignoreWildcard hb1 a) {-# INLINE ruleEntries #-} ruleEntries :: TransTable n b -> [(b, n -> n, b)] @@ -269,8 +255,8 @@ {-# INLINE baseKey #-} baseKey :: (ExBaseClass b) => b -> Maybe (Hat, AccountTitles) baseKey b - | isWiledcard h = Nothing - | haveWiledcard at = Nothing + | isWildcard h = Nothing + | haveWildcard at = Nothing | otherwise = Just (h, at) where h = hat b @@ -301,7 +287,7 @@ resolveByIndex idx hb = case baseKey hb >>= (`HM.lookup` tiByHatTitle idx) of Just (IndexedUnique before f after) - | hb .== before -> Just (f, ignoreWiledcard hb after) + | hb .== before -> Just (f, ignoreWildcard hb after) | otherwise -> resolveByTree (tiTree idx) hb _ -> resolveByTree (tiTree idx) hb @@ -349,24 +335,9 @@ where !r' = go orig bx fx ax r EQ -> t --- | Update the transformation function in the table -updateFunction:: (HatVal n,HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b -updateFunction 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 !kx fx x t@(TransTable sz ky fy y l r) = - case compareElement kx ky of - LT | l' `ptrEq` l -> t - | otherwise -> balanceL ky fy y l' r - where !l' = go orig kx fx x l - GT | r' `ptrEq` r -> t - | otherwise -> balanceR ky fy y l r' - where !r' = go orig kx fx x r - EQ | x `ptrEq` y && (lazy orig `seq` (orig `ptrEq` ky)) -> t - | otherwise -> TransTable sz (lazy orig) (fx . fy) x l r - +-- 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 @@ -433,21 +404,12 @@ (_, _) -> error "Failure in Data.Map.balanceR" | otherwise -> TransTable (1+ls+rs) b f a l r -lookup :: (HatVal n, HatBaseClass b) => b -> TransTable n b -> Maybe (TransTable n b) -lookup k = k `seq` go - where - go NullTable = Nothing - go (TransTable s b f a l r) = - case compare k b of - LT -> go l - GT -> go r - EQ -> Just (TransTable s 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 :: NN.Double -> NN.Double) ),(Not:<(Building),Not:<(Cash),id)] +-- >>> ExchangeAlgebra.Algebra.Transfer.fromList [(Hat:<(Cash),Hat:<(Building),(id :: Double -> Double) ),(Not:<(Building),Not:<(Cash),id)] -- [(Hat:),(Not:)] fromList :: (HatVal n, HatBaseClass b) => [(b,b,(n -> n))] -> TransTable n b @@ -487,7 +449,7 @@ -- | make TransTable from list -- same as fromList --- >>> table $ Hat:<(Cash) :-> Hat:<(Building) |% (id :: NN.Double -> NN.Double) ++ Hat:<(Building) :-> Hat:<(Cash) |% id +-- >>> table $ Hat:<(Cash) :-> Hat:<(Building) |% (id :: Double -> Double) ++ Hat:<(Building) :-> Hat:<(Cash) |% id -- [(Hat:),(Hat:)] {-# INLINE table #-} table :: (HatVal n, HatBaseClass b) => [(b,b,(n -> n))] -> TransTable n b @@ -509,8 +471,8 @@ -- | Syntax to make list for makeList -- --- >>> Hat:<(Yen,Cash):-> Hat:<(Yen,Building) |% (id :: NN.Double -> NN.Double) ++ Not:<(Yen,Building) :-> Not:<(Yen, Cash) |% id --- [(Hat:<(Yen,Cash),Hat:<(Yen,Building),),(Not:<(Yen,Building),Not:<(Yen,Cash),)] +-- >>> 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)] @@ -519,8 +481,10 @@ infixr 8 :-> infixr 7 |% -instance (HatVal n) => Show (n -> n) where - show f = "" +-- 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 @@ without it. -- | Build an indexed fast transfer function from a list of transfer rules. -- More efficient than @transfer@ when repeatedly applying the same TransTable. @@ -536,12 +500,17 @@ -- | Income Summary Account: compute net income for the current period. -- When the ledger is balanced (credit == debit, net income is zero), @diffRL@ --- reports the wildcard 'Side'; in that case the input is returned unchanged. +-- 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". 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 wiledcard) .~ NetIncome) - Debit -> alg .+ (diff :@ (toNot wiledcard) .~ NetLoss) + Credit -> alg .+ (diff :@ (toNot wildcard) .~ NetIncome) + Debit -> alg .+ (diff :@ (toNot wildcard) .~ NetLoss) Side -> alg -- | Net income transfer. Transfers NetIncome/NetLoss to RetainedEarnings. @@ -549,36 +518,43 @@ -- Complexity: O(s) (s = total number of scalar entries) netIncomeTransfer :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b netIncomeTransfer = createTransfer - $ (toNot wiledcard) .~ NetIncome :-> (toNot wiledcard) .~ RetainedEarnings |% id - ++ (toHat wiledcard) .~ NetIncome :-> (toHat wiledcard) .~ RetainedEarnings |% id - ++ (toNot wiledcard) .~ NetLoss :-> (toHat wiledcard) .~ RetainedEarnings |% id - ++ (toHat wiledcard) .~ NetLoss :-> (toNot wiledcard) .~ RetainedEarnings |% id + $ (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 --- | Transfer to Gross Profit. --- Consolidates Sales, Purchases, WageExpenditure, Depreciation, and ValueAdded into GrossProfit. +-- | Historical SNA/simulation transfer to the legacy GrossProfit coordinate. +-- 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 wiledcard) .~ WageExpenditure :-> (toHat wiledcard) .~ GrossProfit |% id - ++ (toHat wiledcard) .~ WageExpenditure :-> (toNot wiledcard) .~ GrossProfit |% id + $ (toNot wildcard) .~ WageExpenditure :-> (toHat wildcard) .~ GrossProfit |% id + ++ (toHat wildcard) .~ WageExpenditure :-> (toNot wildcard) .~ GrossProfit |% id ------------------------------------------------------------------ - ++ (toNot wiledcard) .~ Depreciation :-> (toHat wiledcard) .~ GrossProfit |% id - ++ (toHat wiledcard) .~ Depreciation :-> (toNot wiledcard) .~ GrossProfit |% id + ++ (toNot wildcard) .~ Depreciation :-> (toHat wildcard) .~ GrossProfit |% id + ++ (toHat wildcard) .~ Depreciation :-> (toNot wildcard) .~ GrossProfit |% id ------------------------------------------------------------------ - ++ (toNot wiledcard) .~ ValueAdded :-> (toNot wiledcard) .~ GrossProfit |% id - ++ (toHat wiledcard) .~ ValueAdded :-> (toHat wiledcard) .~ GrossProfit |% id + ++ (toNot wildcard) .~ ValueAdded :-> (toNot wildcard) .~ GrossProfit |% id + ++ (toHat wildcard) .~ ValueAdded :-> (toHat wildcard) .~ GrossProfit |% id ------------------------------------------------------------------ - ++ (toNot wiledcard) .~ Sales :-> (toNot wiledcard) .~ GrossProfit |% id - ++ (toHat wiledcard) .~ Sales :-> (toHat wiledcard) .~ GrossProfit |% id + ++ (toNot wildcard) .~ Sales :-> (toNot wildcard) .~ GrossProfit |% id + ++ (toHat wildcard) .~ Sales :-> (toHat wildcard) .~ GrossProfit |% id ------------------------------------------------------------------ - ++ (toNot wiledcard) .~ Purchases :-> (toHat wiledcard) .~ GrossProfit |% id - ++ (toHat wiledcard) .~ Purchases :-> (toNot wiledcard) .~ GrossProfit |% id + ++ (toNot wildcard) .~ Purchases :-> (toHat wildcard) .~ GrossProfit |% id + ++ (toHat wildcard) .~ Purchases :-> (toNot wildcard) .~ GrossProfit |% id --- | Ordinary Profit Transfer +-- | Historical SNA/simulation transfer to the legacy OrdinaryProfit +-- 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 @@ -588,45 +564,45 @@ ordinaryProfitTransfer :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b ordinaryProfitTransfer = createTransfer - $ (toNot wiledcard) .~ GrossProfit :-> (toNot wiledcard) .~ OrdinaryProfit |% id - ++ (toHat wiledcard) .~ GrossProfit :-> (toHat wiledcard) .~ OrdinaryProfit |% id + $ (toNot wildcard) .~ GrossProfit :-> (toNot wildcard) .~ OrdinaryProfit |% id + ++ (toHat wildcard) .~ GrossProfit :-> (toHat wildcard) .~ OrdinaryProfit |% id ------------------------------------------------------------------ - ++ (toNot wiledcard) .~ InterestEarned :-> (toNot wiledcard) .~ OrdinaryProfit |% id - ++ (toHat wiledcard) .~ InterestEarned :-> (toHat wiledcard) .~ OrdinaryProfit |% id + ++ (toNot wildcard) .~ InterestEarned :-> (toNot wildcard) .~ OrdinaryProfit |% id + ++ (toHat wildcard) .~ InterestEarned :-> (toHat wildcard) .~ OrdinaryProfit |% id ------------------------------------------------------------------ - ++ (toNot wiledcard) .~ InterestExpense :-> (toHat wiledcard) .~ OrdinaryProfit |% id - ++ (toHat wiledcard) .~ InterestExpense :-> (toNot wiledcard) .~ OrdinaryProfit |% id + ++ (toNot wildcard) .~ InterestExpense :-> (toHat wildcard) .~ OrdinaryProfit |% id + ++ (toHat wildcard) .~ InterestExpense :-> (toNot wildcard) .~ OrdinaryProfit |% id ------------------------------------------------------------------ - ++ (toNot wiledcard) .~ SubsidyIncome :-> (toNot wiledcard) .~ OrdinaryProfit |% id - ++ (toHat wiledcard) .~ SubsidyIncome :-> (toHat wiledcard) .~ OrdinaryProfit |% id + ++ (toNot wildcard) .~ SubsidyIncome :-> (toNot wildcard) .~ OrdinaryProfit |% id + ++ (toHat wildcard) .~ SubsidyIncome :-> (toHat wildcard) .~ OrdinaryProfit |% id ------------------------------------------------------------------ - ++ (toNot wiledcard) .~ TaxesExpense :-> (toHat wiledcard) .~ OrdinaryProfit |% id - ++ (toHat wiledcard) .~ TaxesExpense :-> (toNot wiledcard) .~ OrdinaryProfit |% id + ++ (toNot wildcard) .~ TaxesExpense :-> (toHat wildcard) .~ OrdinaryProfit |% id + ++ (toHat wildcard) .~ TaxesExpense :-> (toNot wildcard) .~ OrdinaryProfit |% id -- Government - ++ (toNot wiledcard) .~ TaxesRevenue :-> (toNot wiledcard) .~ OrdinaryProfit |% id - ++ (toHat wiledcard) .~ TaxesRevenue :-> (toHat wiledcard) .~ OrdinaryProfit |% id + ++ (toNot wildcard) .~ TaxesRevenue :-> (toNot wildcard) .~ OrdinaryProfit |% id + ++ (toHat wildcard) .~ TaxesRevenue :-> (toHat wildcard) .~ OrdinaryProfit |% id ------------------------------------------------------------------ - ++ (toNot wiledcard) .~ CentralBankPaymentIncome :-> (toNot wiledcard) .~ OrdinaryProfit |% id - ++ (toHat wiledcard) .~ CentralBankPaymentIncome :-> (toHat wiledcard) .~ OrdinaryProfit |% id + ++ (toNot wildcard) .~ CentralBankPaymentIncome :-> (toNot wildcard) .~ OrdinaryProfit |% id + ++ (toHat wildcard) .~ CentralBankPaymentIncome :-> (toHat wildcard) .~ OrdinaryProfit |% id ------------------------------------------------------------------ - ++ (toNot wiledcard) .~ Depreciation :-> (toHat wiledcard) .~ OrdinaryProfit |% id - ++ (toHat wiledcard) .~ Depreciation :-> (toNot wiledcard) .~ OrdinaryProfit |% id + ++ (toNot wildcard) .~ Depreciation :-> (toHat wildcard) .~ OrdinaryProfit |% id + ++ (toHat wildcard) .~ Depreciation :-> (toNot wildcard) .~ OrdinaryProfit |% id ------------------------------------------------------------------ - ++ (toNot wiledcard) .~ WageExpenditure :-> (toHat wiledcard) .~ OrdinaryProfit |% id - ++ (toHat wiledcard) .~ WageExpenditure :-> (toNot wiledcard) .~ OrdinaryProfit |% id + ++ (toNot wildcard) .~ WageExpenditure :-> (toHat wildcard) .~ OrdinaryProfit |% id + ++ (toHat wildcard) .~ WageExpenditure :-> (toNot wildcard) .~ OrdinaryProfit |% id ------------------------------------------------------------------ - ++ (toNot wiledcard) .~ SubsidyExpense :-> (toHat wiledcard) .~ OrdinaryProfit |% id - ++ (toHat wiledcard) .~ SubsidyExpense :-> (toNot wiledcard) .~ OrdinaryProfit |% id + ++ (toNot wildcard) .~ SubsidyExpense :-> (toHat wildcard) .~ OrdinaryProfit |% id + ++ (toHat wildcard) .~ SubsidyExpense :-> (toNot wildcard) .~ OrdinaryProfit |% id ------------------------------------------------------------------ -- Household - ++ (toNot wiledcard) .~ WageEarned :-> (toNot wiledcard) .~ OrdinaryProfit |% id - ++ (toHat wiledcard) .~ WageEarned :-> (toHat wiledcard) .~ OrdinaryProfit |% id + ++ (toNot wildcard) .~ WageEarned :-> (toNot wildcard) .~ OrdinaryProfit |% id + ++ (toHat wildcard) .~ WageEarned :-> (toHat wildcard) .~ OrdinaryProfit |% id ------------------------------------------------------------------ - ++ (toNot wiledcard) .~ ConsumptionExpenditure :-> (toHat wiledcard) .~ OrdinaryProfit |% id - ++ (toHat wiledcard) .~ ConsumptionExpenditure :-> (toNot wiledcard) .~ OrdinaryProfit |% id + ++ (toNot wildcard) .~ ConsumptionExpenditure :-> (toHat wildcard) .~ OrdinaryProfit |% id + ++ (toHat wildcard) .~ ConsumptionExpenditure :-> (toNot wildcard) .~ OrdinaryProfit |% id -- CentralBank - ++ (toNot wiledcard) .~ CentralBankPaymentExpense :-> (toHat wiledcard) .~ OrdinaryProfit |% id - ++ (toHat wiledcard) .~ CentralBankPaymentExpense :-> (toNot wiledcard) .~ OrdinaryProfit |% id + ++ (toNot wildcard) .~ CentralBankPaymentExpense :-> (toHat wildcard) .~ OrdinaryProfit |% id + ++ (toHat wildcard) .~ CentralBankPaymentExpense :-> (toNot wildcard) .~ OrdinaryProfit |% id -- | Transfer to Retained Earnings. @@ -636,38 +612,43 @@ retainedEarningTransfer :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b retainedEarningTransfer = createTransfer - $ (toNot wiledcard) .~ OrdinaryProfit :-> (toNot wiledcard) .~ RetainedEarnings |% id - ++ (toHat wiledcard) .~ OrdinaryProfit :-> (toHat wiledcard) .~ RetainedEarnings |% id + $ (toNot wildcard) .~ OrdinaryProfit :-> (toNot wildcard) .~ RetainedEarnings |% id + ++ (toHat wildcard) .~ OrdinaryProfit :-> (toHat wildcard) .~ RetainedEarnings |% id data FinalStockSide = FinalStockKeep | FinalStockFlip +-- The closing side is derived from the account's PIMO direction (which is +-- contra-aware), not from the bare division: IN (flow in — non-contra +-- Revenue, and contra Cost such as purchase rebates) transfers as-is +-- (Keep); OUT (flow out — non-contra Cost, and contra Revenue such as +-- sales rebates) transfers with Hat\/Not flipped (Flip). Deriving from the +-- division alone would invert the transfer sign for contra P\/L accounts. +-- For the current chart (no contra P\/L accounts) this is extensionally +-- identical to the former division-based rule, which the +-- pre-vocab fixture test verifies. {-# INLINE finalStockRule #-} finalStockRule :: AccountTitles -> Maybe FinalStockSide -finalStockRule title = case title of - WageExpenditure -> Just FinalStockFlip - Depreciation -> Just FinalStockFlip - Purchases -> Just FinalStockFlip - InterestExpense -> Just FinalStockFlip - TaxesExpense -> Just FinalStockFlip - SubsidyExpense -> Just FinalStockFlip - ConsumptionExpenditure -> Just FinalStockFlip - CentralBankPaymentExpense -> Just FinalStockFlip - ValueAdded -> Just FinalStockKeep - Sales -> Just FinalStockKeep - GrossProfit -> Just FinalStockKeep - InterestEarned -> Just FinalStockKeep - SubsidyIncome -> Just FinalStockKeep - TaxesRevenue -> Just FinalStockKeep - CentralBankPaymentIncome -> Just FinalStockKeep - WageEarned -> Just FinalStockKeep - OrdinaryProfit -> Just FinalStockKeep - _ -> Nothing +finalStockRule title = case accountSpec title of + Nothing -> Nothing + Just spec -> case asClosing spec of + NoClose -> Nothing + CloseByDivision -> + let pimo0 = pimoFromDivision (classifyAccountDivision title) + pimo = if classifyAccountContra title then pimoFlip pimo0 else pimo0 + in case pimo of + IN -> Just FinalStockKeep + OUT -> Just FinalStockFlip + _ -> Nothing -- | Internal step of the final stock transfer from income statement to retained earnings. -- Cost accounts are transferred to RetainedEarnings with Hat/Not flipped; --- revenue accounts are transferred to RetainedEarnings as-is. +-- 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 #-} @@ -683,7 +664,8 @@ go x = x -- | Final Stock Transfer (closing entries). --- Transfers all cost and revenue accounts to RetainedEarnings and cancels via the bar operation. +-- 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 diff --git a/src/ExchangeAlgebra/Assist.hs b/src/ExchangeAlgebra/Assist.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Assist.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : ExchangeAlgebra.Assist +Description : Assistance helpers for LLM-facing account selection and validation feedback. + +This module provides a small deterministic assistance layer for generated +journal-entry workflows. It exposes account-title metadata from the canonical +account registry, with semantic descriptions for technical and derived titles, +plus one-line explanations for validation errors from +"ExchangeAlgebra.Convert.Checked". +-} +module ExchangeAlgebra.Assist + ( AccountInfo(..) + , describeAccount + , allAccountInfos + , suggestAccounts + , explainEntryError + , explainJournalErrors + , explainSourceErrors + ) where + +import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (mapMaybe) +import Data.Ord (Down(..)) +import Data.Text (Text) +import qualified Data.Text as T + +import ExchangeAlgebra.Algebra.Base + ( AccountRole + , AccountSemantics(..) + , AccountSpec(..) + , AccountTitles(..) + , DivisionSemantics + , HomeSideSemantics + , PostingCapability + , ReportingEligibility + , accountSemantics + , accountSpec + , concreteAccountTitles + ) +import ExchangeAlgebra.Convert + ( ConvError(..) ) +import ExchangeAlgebra.Convert.Checked + ( EntryError(..) + , JournalError(..) + , SourceError(..) + ) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.List.NonEmpty (NonEmpty(..)) +-- >>> import ExchangeAlgebra.Algebra.Base (AccountTitles(..), PostingCapability(..)) +-- >>> import ExchangeAlgebra.Convert (ConvError(..)) +-- >>> import ExchangeAlgebra.Convert.Checked (ProcessingContext(..), EntryError(..), JournalError(..), SourceError(..)) + +-- | Account-title metadata for LLM-facing lookup. +data AccountInfo = AccountInfo + { aiTitle :: AccountTitles + , aiRoles :: [AccountRole] + , aiPostingCapability :: PostingCapability + , aiDivisionSemantics :: DivisionSemantics + , aiHomeSideSemantics :: HomeSideSemantics + , aiReportingEligibility :: ReportingEligibility + , aiNameEn :: Text + , aiNameJa :: Text + , aiDesc :: Text + } deriving (Show, Eq) + +-- | Describe a concrete account title. +-- +-- The wildcard 'AccountTitle' is rejected because +-- 'ExchangeAlgebra.Algebra.Base.classifyAccountDivision' is intentionally +-- undefined for it. +-- +-- >>> fmap ((== "現金") . aiNameJa) (describeAccount Cash) +-- Just True +-- >>> fmap aiDivisionSemantics (describeAccount Cash) +-- Just (StatementDivision Assets) +-- >>> fmap aiDivisionSemantics (describeAccount IncomeSummary) +-- Just (DirectionEncoding Assets) +-- >>> describeAccount AccountTitle +-- Nothing +describeAccount :: AccountTitles -> Maybe AccountInfo +describeAccount title = do + spec <- accountSpec title + semantics <- accountSemantics title + pure (toInfo title spec semantics) + +-- | All concrete account-title descriptions in 'Enum' order. +-- +-- >>> length allAccountInfos +-- 235 +-- >>> take 1 (map aiTitle allAccountInfos) +-- [Cash] +-- >>> aiTitle (last allAccountInfos) +-- DepositsReceivedFromOfficers +allAccountInfos :: [AccountInfo] +allAccountInfos = mapMaybe describeAccount concreteAccountTitles + +toInfo :: AccountTitles -> AccountSpec -> AccountSemantics -> AccountInfo +toInfo title spec semantics = AccountInfo + { aiTitle = title + , aiRoles = asemRoles semantics + , aiPostingCapability = asemPostingCapability semantics + , aiDivisionSemantics = asemDivisionSemantics semantics + , aiHomeSideSemantics = asemHomeSideSemantics semantics + , aiReportingEligibility = asemReportingEligibility semantics + , aiNameEn = asNameEn spec + , aiNameJa = safeNameJa title spec + , aiDesc = safeDescription title spec + } + +-- | LLM-facing names use the cleaned statement label from the registry. +safeNameJa :: AccountTitles -> AccountSpec -> Text +safeNameJa _ spec = asLabelJa spec + +-- | Semantic descriptions for technical, derived, and contextual titles. +-- Ordinary statement accounts retain their canonical registry description. +safeDescription :: AccountTitles -> AccountSpec -> Text +safeDescription NetIncome _ = + "Period result: net income (当期純利益). Engine-generated only; the legacy Cost value is an internal direction encoding, not an expense classification." +safeDescription NetLoss _ = + "Period result: net loss (当期純損失). Engine-generated only; the legacy Revenue value is an internal direction encoding, not a revenue classification." +safeDescription GrossProfit _ = + "Legacy engine coordinate: gross profit (売上総利益). Engine-generated only; the legacy Revenue value is an internal direction encoding, not a statement subtotal definition." +safeDescription OrdinaryProfit _ = + "Legacy engine coordinate: ordinary profit (経常利益). Engine-generated only; the legacy Revenue value is an internal direction encoding, not a statement subtotal definition." +safeDescription IncomeSummary _ = + "Closing device: income summary (損益). Available only during closing; the legacy Assets value is an internal direction encoding, not a balance-sheet classification." +safeDescription SuspensePayments _ = + "Temporary account: suspense payments (仮払金). Its legacy Assets value is a bookkeeping control class; unresolved balances require review before presentation." +safeDescription SuspenseReceipts _ = + "Temporary account: suspense receipts (仮受金). Its legacy Liability value is a bookkeeping control class; unresolved balances require review before presentation." +safeDescription CashOverShort _ = + "Temporary account: cash over and short (現金過不足). It must be cleared at closing and is not presented in financial statements." +safeDescription SuspenseAccount _ = + "Temporary account: suspense account (未決算). Its legacy Assets value is a bookkeeping control class; unresolved balances require review before presentation." +safeDescription BranchCurrentAccount _ = + "Reciprocal account: branch current account (支店). It may remain in head-office books but is eliminated when head-office and branch balances are combined." +safeDescription HeadOfficeCurrentAccount _ = + "Reciprocal account: head-office current account (本店). It may remain in branch books but is eliminated when head-office and branch balances are combined." +safeDescription NetIncomeAttributableToNCI _ = + "Consolidation attribution result: profit attributable to non-controlling interests (非支配株主に帰属する当期純利益). Available only in consolidation worksheets; the legacy Cost value is an internal direction encoding." +safeDescription NetLossAttributableToNCI _ = + "Consolidation attribution result: loss attributable to non-controlling interests (非支配株主に帰属する当期純損失). Available only in consolidation worksheets; the legacy Revenue value is an internal direction encoding." +safeDescription EquityInEarningsOfInvestee _ = + "Consolidation result: equity in earnings of investee (持分法による投資利益). Available only in consolidation worksheets." +safeDescription CumulativeTranslationAdjustment _ = + "Consolidation adjustment: cumulative translation adjustment (為替換算調整勘定). Available only in consolidation worksheets." +safeDescription _ spec = asDescription spec + +-- | Suggest account titles by deterministic substring matching. +-- +-- The query is split with 'T.words'. Each token is matched case-insensitively +-- against the constructor name, English name, Japanese name, and full +-- description. Results are ranked by the number of matched tokens, with 'Enum' +-- order as the tie-breaker. +-- +-- >>> map aiTitle (take 3 (suggestAccounts "cash")) +-- [Cash,PettyCash,CashOverShort] +-- >>> map aiTitle (take 3 (suggestAccounts "現金")) +-- [Cash,PettyCash,CashOverShort] +-- >>> suggestAccounts "" +-- [] +-- >>> suggestAccounts "zzzznomatch" +-- [] +suggestAccounts :: Text -> [AccountInfo] +suggestAccounts query + | null tokens = [] + | otherwise = + map snd + . sortOn (\(rank, info) -> (Down rank, fromEnum (aiTitle info))) + . filter ((> 0) . fst) + $ [ (matchRank info, info) | info <- allAccountInfos ] + where + tokens = map T.toCaseFold (T.words query) + + matchRank info = + length + [ token + | token <- tokens + , any (T.isInfixOf token) (searchFields info) + ] + + searchFields info = map T.toCaseFold + [ T.pack (show (aiTitle info)) + , aiNameEn info + , aiNameJa info + , aiDesc info + ] + +-- | Explain one checked-entry validation error as one English line. +-- +-- >>> explainEntryError (Imbalanced 1500 1400 :: EntryError Int) +-- "entry is not balanced: debit total 1500 /= credit total 1400" +-- >>> explainEntryError (NonPositiveAmount 2 Cash (0 :: Int)) +-- "posting 2 (Cash): amount must be > 0, got 0" +-- >>> explainEntryError (EntryParse 0 (UnknownAccount "Supplies") :: EntryError Int) +-- "posting 0: account \"Supplies\" does not resolve to a ledger account" +-- >>> explainEntryError (PostingNotAllowed 1 NetIncome EngineGeneratedOnly OrdinaryJournal :: EntryError Int) +-- "posting 1 (NetIncome): EngineGeneratedOnly is not allowed in OrdinaryJournal" +explainEntryError :: (Show v) => EntryError v -> Text +explainEntryError (EntryParse i err) = + postingOnly i <> ": " <> explainConvError err +explainEntryError (NonPositiveAmount i account amount) = + postingAccount i account <> ": amount must be > 0, got " <> showText amount +explainEntryError (WildcardAccount i) = + postingOnly i <> ": wildcard AccountTitle is not a ledger account" +explainEntryError (WildcardSide i) = + postingOnly i <> ": wildcard Side is not debit or credit" +explainEntryError (PostingNotAllowed i account capability context) = + postingAccount i account + <> ": " <> showText capability + <> " is not allowed in " <> showText context +explainEntryError EmptyEntry = + "entry has no postings" +explainEntryError (Imbalanced debitTotal creditTotal) = + "entry is not balanced: debit total " + <> showText debitTotal + <> " /= credit total " + <> showText creditTotal + +-- | Explain checked-journal errors, one line per error. +-- +-- >>> explainJournalErrors (EntryErrors "tx1" (Imbalanced 1500 1400 :| []) :| [] :: NonEmpty (JournalError String Int)) +-- "transaction \"tx1\": entry is not balanced: debit total 1500 /= credit total 1400" +-- >>> explainJournalErrors (DuplicateTxId "tx1" :| [] :: NonEmpty (JournalError String Int)) +-- "transaction \"tx1\" appears more than once" +explainJournalErrors :: (Show n, Show v) => NonEmpty (JournalError n v) -> Text +explainJournalErrors = + T.intercalate "\n" . concatMap explainJournalError . NE.toList + +-- | Explain source-coverage errors, one line per error. +-- +-- >>> explainSourceErrors [MissingSource "tx7" :: SourceError String Int] +-- "source transaction \"tx7\" has no journal entry" +-- >>> explainSourceErrors [AmountMismatch "tx7" 1500 1400 :: SourceError String Int] +-- "source transaction \"tx7\" amount mismatch: expected 1500, journal entry has 1400" +explainSourceErrors :: (Show n, Show v) => [SourceError n v] -> Text +explainSourceErrors = T.intercalate "\n" . map explainSourceError + +explainJournalError :: (Show n, Show v) => JournalError n v -> [Text] +explainJournalError (EntryErrors txid errs) = + [ "transaction " <> showText txid <> ": " <> explainEntryError err + | err <- NE.toList errs + ] +explainJournalError (DuplicateTxId txid) = + [ "transaction " <> showText txid <> " appears more than once" ] + +explainSourceError :: (Show n, Show v) => SourceError n v -> Text +explainSourceError (MissingSource txid) = + "source transaction " <> showText txid <> " has no journal entry" +explainSourceError (UnknownSource txid) = + "journal entry " <> showText txid <> " has no source transaction" +explainSourceError (AmountMismatch txid expected actual) = + "source transaction " + <> showText txid + <> " amount mismatch: expected " + <> showText expected + <> ", journal entry has " + <> showText actual + +explainConvError :: ConvError -> Text +explainConvError (UnknownAccount account) = + "account " <> showText account <> " does not resolve to a ledger account" +explainConvError (AmbiguousAccount account candidates) = + "account " + <> showText account + <> " is ambiguous; candidates: " + <> T.intercalate ", " (map showText candidates) +explainConvError (UnknownSide sideText) = + "side " <> showText sideText <> " is not debit or credit" +explainConvError (MalformedCsv message) = + "malformed CSV input: " <> showText message +explainConvError (BadAmount message) = + "amount field is invalid: " <> showText message + +postingOnly :: Int -> Text +postingOnly i = "posting " <> showText i + +postingAccount :: Int -> AccountTitles -> Text +postingAccount i account = + postingOnly i <> " (" <> showText account <> ")" + +showText :: (Show a) => a -> Text +showText = T.pack . show diff --git a/src/ExchangeAlgebra/Assist/Descriptions.hs b/src/ExchangeAlgebra/Assist/Descriptions.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Assist/Descriptions.hs @@ -0,0 +1,9 @@ +{- | +Module : ExchangeAlgebra.Assist.Descriptions +Description : Compatibility projection of the canonical account registry. +-} +module ExchangeAlgebra.Assist.Descriptions + ( accountDescriptions + ) where + +import ExchangeAlgebra.Algebra.Base.Account.Registry (accountDescriptions) diff --git a/src/ExchangeAlgebra/Bookkeeping.hs b/src/ExchangeAlgebra/Bookkeeping.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Bookkeeping.hs @@ -0,0 +1,609 @@ +{- | + Module : ExchangeAlgebra.Bookkeeping + Copyright : (c) Kaya Akagi. 2018-2026 + Maintainer : yakagika@icloud.com + + Released under the OWL license + + Package for Exchange Algebra defined by Hiroshi Deguchi. + + Exchange Algebra is an algebraic description of bookkeeping systems. + Details are below. + + + + + + == Closing-adjustment entry builders (決算整理仕訳) + + This module provides /posting builders/ (journal-entry templates) for the + closing adjustments taught at the elementary-bookkeeping (日商簿記 3 級) level: + cost of goods sold under the periodic (3-account) method, depreciation, the + allowance for doubtful accounts, deferral\/accrual (経過勘定) entries, and the + settlement of consumption\/corporate income tax. + + Unlike "ExchangeAlgebra.Algebra.Transfer" (which /relabels existing ledger + balances/), most closing adjustments record /new postings whose amounts come + from outside the ledger/ (period-end inventory, estimated allowance, + depreciation expense, …). Each builder here therefore returns a fresh, + balanced @'Alg' v b@ value. + + === Design + + * Every builder is constructed exclusively with the smart constructor + @('.@')@, so a zero amount normalises to @Zero@ and a negative\/non-finite + amount is rejected by @('.@')@'s @error@ path. No implicit @bar@\/@compress@ + is performed — builders only /generate/ new postings. + + * The base polymorphism is absorbed by an injection function @'MkBase'@ that + the caller supplies once (see below). + + * The Hat\/Not label of each line follows the /accounting meaning/ of that + line: an account that /increases/ uses @Not@ (so it lands on its home side), + an account that /decreases/ uses @Hat@ (the opposite side). 'whichSide' + then places each line on the correct debit\/credit side. Consequently every + builder is debit-credit balanced: @'norm' ('decL' x) == 'norm' ('decR' x)@. +-} + +{-# LANGUAGE FlexibleContexts #-} + +module ExchangeAlgebra.Bookkeeping + ( -- * Base injection + MkBase + -- * Cost of goods sold (売上原価, 3 分法) + , cogsAdjustmentEntries + -- * Depreciation (減価償却) + , depreciationIndirectEntry + , depreciationDirectEntry + -- * Allowance for doubtful accounts (貸倒引当金) + , allowanceReplenishmentEntry + , allowanceResetEntries + -- * Deferral / accrual (経過勘定) + , prepaidExpenseEntry + , unearnedRevenueEntry + , accruedRevenueEntry + , accruedExpenseEntry + , reversingEntry + -- * Tax settlement (消費税・法人税等) + , consumptionTaxSettlementEntry + , corporateTaxInterimEntry + , corporateTaxSettlementEntries + -- * Equity method (持分法) + , equityMethodEarningsEntry + , equityMethodDividendEntry + , equityMethodEntries + , equityMethodBalance + -- * Prior-period error correction (前期修正) + , priorPeriodErrorCorrection + ) where + +import ExchangeAlgebra.Algebra +-- @MoneyDecimal@ is used only by the Haddock doctest examples (which run in this +-- module's import scope), not the module body; keep it imported for the doctests. +import ExchangeAlgebra.Value (MoneyDecimal) +import GHC.Stack (HasCallStack) + +-- | Injection that tells a builder how to wrap a @(v'Hat', 'AccountTitles')@ pair +-- into the concrete base @b@ in use. The caller supplies it once. +-- +-- @ +-- -- single-axis base (account title only): +-- mk1 :: MkBase (HatBase AccountTitles) +-- mk1 = (':<') +-- +-- -- multi-axis base, filling the extra axes with fixed values: +-- mk4 :: MkBase (HatBase (AccountTitles, Name, CountUnit, Subject)) +-- mk4 h t = h :< (t, \"\", Yen, \"\") +-- @ +type MkBase b = Hat -> AccountTitles -> b + +-- | (借) debit-meaning convenience: the account /increases/, so it carries 'Not' +-- and lands on its home side. +{-# INLINE up #-} +up :: (HatVal v, ExBaseClass b) => MkBase b -> v -> AccountTitles -> Alg v b +up mk v t = v .@ mk Not t + +-- | The account /decreases/, so it carries v'Hat' (the opposite of its home side). +{-# INLINE down #-} +down :: (HatVal v, ExBaseClass b) => MkBase b -> v -> AccountTitles -> Alg v b +down mk v t = v .@ mk Hat t + +------------------------------------------------------------------ +-- * Cost of goods sold (売上原価, 3 分法) +------------------------------------------------------------------ + +-- | Cost-of-goods-sold adjustment under the periodic\/3-account method +-- (3 分法; lecture ch.10, 24), the four "しいくりくりしい" postings: +-- +-- > (借) 仕入 beg (貸) 繰越商品 beg -- opening inventory +-- > (借) 繰越商品 end (貸) 仕入 end -- closing inventory +-- +-- After this entry the @Purchases@ balance equals cost of goods sold and the +-- @MerchandiseInventory@ balance equals the closing inventory. +-- +-- The result is debit-credit balanced (each side sums to @beg + end@): +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = cogsAdjustmentEntries mk 100 50 :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- >>> norm (decL e) +-- 150 +-- +-- Complexity: O(1) +cogsAdjustmentEntries :: (HatVal v, ExBaseClass b) + => MkBase b -- ^ base injection + -> v -- ^ beginning inventory (期首商品棚卸高) + -> v -- ^ ending inventory (期末商品棚卸高) + -> Alg v b +cogsAdjustmentEntries mk beg end = + up mk beg Purchases -- (借) 仕入 期首 + .+ down mk beg MerchandiseInventory -- (貸) 繰越商品 期首 + .+ up mk end MerchandiseInventory -- (借) 繰越商品 期末 + .+ down mk end Purchases -- (貸) 仕入 期末 + +------------------------------------------------------------------ +-- * Depreciation (減価償却) +------------------------------------------------------------------ + +-- | Indirect-method depreciation (間接法; lecture ch.18): +-- +-- > (借) 減価償却費 amt (貸) 減価償却累計額 amt +-- +-- 'AccumulatedDepreciation' is a credit-balance valuation account (評価勘定). +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = depreciationIndirectEntry mk 150 :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- +-- Complexity: O(1) +depreciationIndirectEntry :: (HatVal v, ExBaseClass b) + => MkBase b -> v -> Alg v b +depreciationIndirectEntry mk amt = + up mk amt Depreciation -- (借) 減価償却費 + .+ up mk amt AccumulatedDepreciation -- (貸) 減価償却累計額 + +-- | Direct-method depreciation (直接法; lecture ch.18): +-- +-- > (借) 減価償却費 amt (貸) amt +-- +-- The asset's carrying amount is reduced directly. @assetTitle@ is the fixed +-- asset being depreciated (e.g. 'Fixtures', 'Building', 'Vehicle'). +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = depreciationDirectEntry mk 90 Fixtures :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- +-- Complexity: O(1) +depreciationDirectEntry :: (HatVal v, ExBaseClass b) + => MkBase b + -> v -- ^ depreciation amount + -> AccountTitles -- ^ asset being depreciated + -> Alg v b +depreciationDirectEntry mk amt assetTitle = + up mk amt Depreciation -- (借) 減価償却費 + .+ down mk amt assetTitle -- (貸) + +------------------------------------------------------------------ +-- * Allowance for doubtful accounts (貸倒引当金) +------------------------------------------------------------------ + +-- | Allowance for doubtful accounts under the /差額補充法/ (replenishment; +-- lecture ch.16). Only the difference between the estimate and the current +-- balance is recorded: +-- +-- * @estimate > current@: provide the shortfall — +-- @(借) 貸倒引当金繰入 / (貸) 貸倒引当金@. +-- * @estimate < current@: release the excess — +-- @(借) 貸倒引当金 / (貸) 貸倒引当金戻入@ (uses 'ReversalOfAllowanceForDoubtfulAccounts'). +-- * @estimate == current@: no entry (@Zero@). +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = allowanceReplenishmentEntry mk 1400 1000 :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- >>> norm (decL e) +-- 400 +-- >>> allowanceReplenishmentEntry mk 2000 2000 == (Zero :: Alg MoneyDecimal (HatBase AccountTitles)) +-- True +-- +-- Complexity: O(1) +allowanceReplenishmentEntry :: (HatVal v, ExBaseClass b) + => MkBase b + -> v -- ^ estimated allowance (当期末貸倒見積額) + -> v -- ^ current allowance balance (貸倒引当金残高) + -> Alg v b +allowanceReplenishmentEntry mk estimate current + | estimate >= current = + let diff = estimate - current + in up mk diff ProvisionForDoubtfulAccounts -- (借) 貸倒引当金繰入 + .+ up mk diff AllowanceForDoubtfulAccounts -- (貸) 貸倒引当金 + | otherwise = + let diff = current - estimate + in down mk diff AllowanceForDoubtfulAccounts -- (借) 貸倒引当金 + .+ up mk diff ReversalOfAllowanceForDoubtfulAccounts -- (貸) 貸倒引当金戻入 + +-- | Allowance for doubtful accounts under the /洗替法/ (reset; lecture ch.16): +-- release the whole current balance, then provide the whole estimate. +-- +-- > (借) 貸倒引当金 current (貸) 貸倒引当金戻入 current +-- > (借) 貸倒引当金繰入 estimate (貸) 貸倒引当金 estimate +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = allowanceResetEntries mk 2400 1000 :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- >>> norm (decL e) +-- 3400 +-- +-- Complexity: O(1) +allowanceResetEntries :: (HatVal v, ExBaseClass b) + => MkBase b + -> v -- ^ estimated allowance for this period + -> v -- ^ current allowance balance to release + -> Alg v b +allowanceResetEntries mk estimate current = + down mk current AllowanceForDoubtfulAccounts -- (借) 貸倒引当金 + .+ up mk current ReversalOfAllowanceForDoubtfulAccounts -- (貸) 貸倒引当金戻入 + .+ up mk estimate ProvisionForDoubtfulAccounts -- (借) 貸倒引当金繰入 + .+ up mk estimate AllowanceForDoubtfulAccounts -- (貸) 貸倒引当金 + +------------------------------------------------------------------ +-- * Deferral / accrual (経過勘定; lecture ch.21) +------------------------------------------------------------------ + +-- | Deferral of a prepaid expense (費用の前払; 前払費用): +-- +-- > (借) 前払費用 amt (貸) amt +-- +-- Moves the unexpired portion of @expenseTitle@ out to 'PrepaidExpenses'. The +-- opening reversing entry of the next period is @'reversingEntry'@ of this. +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = prepaidExpenseEntry mk 4000 RentExpense :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- +-- Complexity: O(1) +prepaidExpenseEntry :: (HatVal v, ExBaseClass b) + => MkBase b + -> v -- ^ prepaid amount + -> AccountTitles -- ^ expense being deferred + -> Alg v b +prepaidExpenseEntry mk amt expenseTitle = + up mk amt PrepaidExpenses -- (借) 前払費用 + .+ down mk amt expenseTitle -- (貸) + +-- | Deferral of unearned revenue (収益の前受; 前受収益): +-- +-- > (借) amt (貸) 前受収益 amt +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = unearnedRevenueEntry mk 4000 RentalIncome :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- +-- Complexity: O(1) +unearnedRevenueEntry :: (HatVal v, ExBaseClass b) + => MkBase b + -> v -- ^ unearned amount + -> AccountTitles -- ^ revenue being deferred + -> Alg v b +unearnedRevenueEntry mk amt revenueTitle = + down mk amt revenueTitle -- (借) + .+ up mk amt UnearnedRevenue -- (貸) 前受収益 + +-- | Accrual of accrued revenue (収益の未収; 未収収益): +-- +-- > (借) 未収収益 amt (貸) amt +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = accruedRevenueEntry mk 2500 InterestEarned :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- +-- Complexity: O(1) +accruedRevenueEntry :: (HatVal v, ExBaseClass b) + => MkBase b + -> v -- ^ accrued amount + -> AccountTitles -- ^ revenue being accrued + -> Alg v b +accruedRevenueEntry mk amt revenueTitle = + up mk amt AccruedRevenue -- (借) 未収収益 + .+ up mk amt revenueTitle -- (貸) + +-- | Accrual of an accrued expense (費用の未払; 未払費用): +-- +-- > (借) amt (貸) 未払費用 amt +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = accruedExpenseEntry mk 2500 InterestExpense :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- +-- Complexity: O(1) +accruedExpenseEntry :: (HatVal v, ExBaseClass b) + => MkBase b + -> v -- ^ accrued amount + -> AccountTitles -- ^ expense being accrued + -> Alg v b +accruedExpenseEntry mk amt expenseTitle = + up mk amt expenseTitle -- (借) + .+ up mk amt AccruedExpenses -- (貸) 未払費用 + +-- | Reversing\/cancelling entry, a vocabulary alias for the Hat operation +-- @('.^')@ (lecture ch.20-21, 再振替仕訳\/訂正仕訳). This is the direct +-- application of /Hat involution/: flipping Hat\/Not on every posting turns an +-- entry into its exact reversal. +-- +-- * Opening reversal (再振替仕訳): @reversingEntry deferral@ at the start of the +-- next period undoes a deferral\/accrual entry. +-- +-- * Correction (訂正仕訳): a mistaken entry @wrong@ is corrected by +-- @reversingEntry wrong '.+' correct@. Because @('.+')@ keeps same-base +-- postings as an ordered /sequence/ (the redundancy), the wrong entry and its +-- reversal both remain in the algebra as an /audit trail/ of the correction; +-- @'bar'@ then nets them out to the corrected balance. +-- +-- @reversingEntry@ is an involution (@reversingEntry . reversingEntry = id@) and +-- @'bar' (x '.+' reversingEntry x) = Zero@ (an entry plus its reversal cancels). +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let x = accruedExpenseEntry mk 2500 InterestExpense :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> reversingEntry (reversingEntry x) == x +-- True +-- >>> bar (x .+ reversingEntry x) == Zero +-- True +-- +-- Complexity: O(1) for a singleton, O(n) for an +-- 'ExchangeAlgebra.Algebra.Internal.Liner' (n base keys). +{-# INLINE reversingEntry #-} +reversingEntry :: (Redundant a v b) => a v b -> a v b +reversingEntry = (.^) + +------------------------------------------------------------------ +-- * Tax settlement (消費税・法人税等; lecture ch.23) +------------------------------------------------------------------ + +-- | Consumption-tax settlement at closing (税抜処理方式; lecture ch.23): offset +-- consumption tax received against consumption tax paid and book the unpaid +-- balance. +-- +-- > (借) 仮受消費税 received (貸) 仮払消費税 paid +-- > (貸) 未払消費税 received - paid +-- +-- __Out of 3-級 scope:__ @received < paid@ (a tax refund, 還付) is rejected with +-- @error@. At the elementary level the consumption tax received always exceeds +-- the consumption tax paid. +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = consumptionTaxSettlementEntry mk 1000 20000 :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- >>> norm (projByAccountTitle AccruedConsumptionTax e) +-- 19000 +-- +-- Complexity: O(1) +consumptionTaxSettlementEntry :: (HasCallStack, HatVal v, ExBaseClass b) + => MkBase b + -> v -- ^ consumption tax paid (仮払消費税) + -> v -- ^ consumption tax received (仮受消費税) + -> Alg v b +consumptionTaxSettlementEntry mk paid received + | received < paid = + error $ "consumptionTaxSettlementEntry: received (" ++ show received + ++ ") < paid (" ++ show paid + ++ "); a consumption-tax refund is out of 日商簿記 3 級 scope." + | otherwise = + let unpaid = received - paid + in down mk received ConsumptionTaxReceived -- (借) 仮受消費税 + .+ down mk paid ConsumptionTaxPaid -- (貸) 仮払消費税 + .+ up mk unpaid AccruedConsumptionTax -- (貸) 未払消費税 + +-- | Interim (mid-year) payment of corporate income tax (中間納付; lecture ch.23): +-- +-- > (借) 仮払法人税等 amt (貸) 現金 amt +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = corporateTaxInterimEntry mk 500000 :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- +-- Complexity: O(1) +corporateTaxInterimEntry :: (HatVal v, ExBaseClass b) + => MkBase b -> v -> Alg v b +corporateTaxInterimEntry mk amt = + up mk amt PrepaidCorporateIncomeTaxes -- (借) 仮払法人税等 + .+ down mk amt Cash -- (貸) 現金 + +-- | Corporate income tax settlement at closing (lecture ch.23): book the total +-- tax expense, credit the interim payment already made, and recognise the +-- unpaid balance. +-- +-- > (借) 法人税等 total (貸) 仮払法人税等 interim +-- > (貸) 未払法人税等 total - interim +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = corporateTaxSettlementEntries mk 800000 500000 :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- >>> norm (projByAccountTitle AccruedCorporateIncomeTaxes e) +-- 300000 +-- +-- Complexity: O(1) +corporateTaxSettlementEntries :: (HasCallStack, HatVal v, ExBaseClass b) + => MkBase b + -> v -- ^ total corporate income tax (法人税等) + -> v -- ^ interim payment already made (仮払法人税等) + -> Alg v b +corporateTaxSettlementEntries mk total interim + -- Same guard style as 'consumptionTaxSettlementEntry': an over-prepayment + -- (refund position) is out of 3-級 scope, so reject it with a clear error + -- instead of letting the negative @unpaid@ hit @('.@')@'s generic one. + | interim > total = + error $ "corporateTaxSettlementEntries: interim (" ++ show interim + ++ ") > total (" ++ show total + ++ "); a corporate-tax refund (over-prepayment) is out of 日商簿記 3 級 scope." + | otherwise = + let unpaid = total - interim + in up mk total CorporateIncomeTaxes -- (借) 法人税等 + .+ down mk interim PrepaidCorporateIncomeTaxes -- (貸) 仮払法人税等 + .+ up mk unpaid AccruedCorporateIncomeTaxes -- (貸) 未払法人税等 + +------------------------------------------------------------------ +-- * Equity method (持分法; lecture T4b) +------------------------------------------------------------------ + +-- | Equity-method earnings accrual (持分法による投資利益の計上): +-- +-- > (借) 関係会社株式 share (貸) 持分法による投資利益 share +-- +-- @share@ is the investor's proportionate share of the investee's net income +-- (= investee NI × ownership %). The investment carrying amount increases by +-- @share@. +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = equityMethodEarningsEntry mk 438000 :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- >>> norm (decL e) +-- 438000 +-- +-- Complexity: O(1) +equityMethodEarningsEntry :: (HatVal v, ExBaseClass b) + => MkBase b + -> v -- ^ investor's share of investee NI (持分利益) + -> Alg v b +equityMethodEarningsEntry mk share = + up mk share InvestmentInAssociate -- (借) 関係会社株式 + .+ up mk share EquityInEarningsOfInvestee -- (貸) 持分法による投資利益 + +-- | Equity-method dividend received (受取配当による投資簿価の減額): +-- +-- > (借) 現金 div (貸) 関係会社株式 div +-- +-- Under the equity method a dividend received from the investee is /not/ income; +-- it reduces the carrying amount of the investment. +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = equityMethodDividendEntry mk 800000 :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- >>> norm (decL e) +-- 800000 +-- +-- Complexity: O(1) +equityMethodDividendEntry :: (HatVal v, ExBaseClass b) + => MkBase b + -> v -- ^ dividend received (受取配当金) + -> Alg v b +equityMethodDividendEntry mk div' = + up mk div' Cash -- (借) 現金 + .+ down mk div' InvestmentInAssociate -- (貸) 関係会社株式 + +-- | Combined equity-method closing entries: record the earnings accrual +-- then the dividend reduction. +-- +-- > (借) 関係会社株式 share (貸) 持分法による投資利益 share +-- > (借) 現金 div (貸) 関係会社株式 div +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = equityMethodEntries mk 438000 800000 :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- +-- Complexity: O(1) +equityMethodEntries :: (HatVal v, ExBaseClass b) + => MkBase b + -> v -- ^ investor's share of investee NI (持分利益) + -> v -- ^ dividend received (受取配当金) + -> Alg v b +equityMethodEntries mk share div' = + equityMethodEarningsEntry mk share + .+ equityMethodDividendEntry mk div' + +-- | Equity-method carrying-amount balance (関係会社株式の簿価残高). +-- +-- Projects all @'InvestmentInAssociate'@ postings from an accumulated @'Alg'@ +-- and returns their @'norm'@ (= net carrying amount). The caller accumulates +-- the initial acquisition entry plus any 'equityMethodEarningsEntry' and +-- 'equityMethodDividendEntry' calls; this function reads the result without +-- recomputing it by hand — /correct-by-construction/. +-- +-- Example (#18 anchor doctest): +-- acquisition cost 2,400,000 + share of NI 0.30 × 1,460,000 (= 438,000) +-- − dividend received 800,000 = carrying amount 2,038,000. +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> -- initial acquisition: Dr 関係会社株式 2,400,000 / Cr Cash 2,400,000 +-- >>> let acq = up mk 2400000 InvestmentInAssociate .+ down mk 2400000 Cash :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> let entries = equityMethodEntries mk 438000 800000 :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> let ledger = acq .+ entries +-- >>> equityMethodBalance ledger +-- 2038000 +-- +-- Complexity: O(s) (s = number of scalar entries in the accumulated algebra) +equityMethodBalance :: (HatVal v, ExBaseClass b) => Alg v b -> v +equityMethodBalance = norm . bar . projByAccountTitle InvestmentInAssociate + +------------------------------------------------------------------ +-- * Prior-period error correction (前期修正) +------------------------------------------------------------------ + +-- | Prior-period error correction (前期修正・誤謬訂正; #15 Briggs anchor). +-- +-- Records the correction of an error discovered in a prior period: +-- the current-period portion goes to an expense account, while the +-- prior-period portion bypasses the income statement and is charged +-- directly to 'RetainedEarnings' (繰越利益剰余金) — conforming to +-- IAS 8 \/ ASC 250-10 retrospective-restatement treatment. +-- +-- > (借) \ current (貸) \ current + prior +-- > (借) RetainedEarnings prior +-- +-- Structural guarantee (thesis property): the prior-period amount is +-- /always/ routed to 'RetainedEarnings'; the caller cannot accidentally +-- book it to an income-statement account — the parameter type forces the +-- split. +-- +-- 'RetainedEarnings' is a credit-balance equity account (@home = Credit@), +-- so a reduction (debit-side charge) is recorded with @down@ (@Hat@), +-- which places it on the debit side — correct-by-construction. +-- +-- The credit leg (asset reduction) is collapsed into one posting +-- @down mk (current + prior) assetAcc@ because @'Num' v@ is available +-- from the @'HatVal'@ superclass, making value addition clean; the +-- two-line @.+@ alternative is equally valid under the seq-redundancy +-- principle but the single line is more readable here. +-- +-- === Example (#15 anchor: patent 55,000 \/ 10 yr, discovered in 2028) +-- +-- * Patent cost 55,000, useful life 10 years → annual amortisation 5,500. +-- * Error discovered in 2028: 2 prior years (2026, 2027) were not amortised. +-- * Current-year amortisation 5,500 → expense (@AmortizationExpense@). +-- * Prior 2 years 11,000 → directly to @RetainedEarnings@ (前期修正). +-- * Credit @Patent@ 16,500 total. +-- +-- >>> let mk = (:<) :: MkBase (HatBase AccountTitles) +-- >>> let e = priorPeriodErrorCorrection mk 5500 11000 AmortizationExpense Patent :: Alg MoneyDecimal (HatBase AccountTitles) +-- >>> norm (decL e) == norm (decR e) +-- True +-- >>> norm (decR e) +-- 16500 +-- >>> norm (decL e) +-- 16500 +-- +-- Complexity: O(1) +priorPeriodErrorCorrection :: (HatVal v, ExBaseClass b) + => MkBase b + -> v -- ^ current-period portion (当期費用; → @expenseAcc@) + -> v -- ^ prior-period portion (前期修正; → 'RetainedEarnings') + -> AccountTitles -- ^ current-period expense account (e.g. 'AmortizationExpense') + -> AccountTitles -- ^ affected asset credited (e.g. 'Patent') + -> Alg v b +priorPeriodErrorCorrection mk current prior expenseAcc assetAcc = + up mk current expenseAcc -- (借) 当期費用 (expense 増, home=Debit → Not) + .+ down mk prior RetainedEarnings -- (借) 繰越利益剰余金 (equity 減, home=Credit → Hat=debit側) + .+ down mk (current + prior) assetAcc -- (貸) 資産 (合計 current+prior 分だけ減額) diff --git a/src/ExchangeAlgebra/Consolidation/Worksheet.hs b/src/ExchangeAlgebra/Consolidation/Worksheet.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Consolidation/Worksheet.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wincomplete-patterns -Werror=incomplete-patterns #-} + +{- | +Module : ExchangeAlgebra.Consolidation.Worksheet +Description : Validation boundary for consolidation worksheets. + +A consolidation worksheet is not an entity's journal. Its adjustments are +therefore accepted as exchange-algebra elements, while this module checks that +each adjustment is independently balanced before any aggregation takes place. +This prevents two malformed adjustments from cancelling each other only at the +worksheet total. + +The validated value retains source trial balances and adjustments separately. +'combinedWorksheet' is an explicit projection and uses redundant-algebra +addition, so same-base postings remain separate sequences until a caller asks +for normalization. The projection itself does not carry per-posting provenance; +use 'validatedSources' and 'validatedAdjustments' when that provenance is +required. + +Validation uses exact equality, consistently with the checked-conversion +boundary. Prefer an exact value type such as @MoneyDecimal@ for deterministic +worksheet validation rather than a floating-point representation. +-} +module ExchangeAlgebra.Consolidation.Worksheet + ( PeriodResult(..) + , AccountBalance(..) + , LinkField(..) + , TrialBalanceSource(..) + , WorksheetAdjustment(..) + , WorksheetLinkage(..) + , WorksheetInput(..) + , WorksheetError(..) + , ValidatedWorksheet + , validateConsolidationWorksheet + , validatedSources + , validatedAdjustments + , validatedLinkage + , combinedWorksheet + ) where + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List as L +import qualified Data.Map.Strict as M + +import ExchangeAlgebra.Algebra + ( Alg + , Exchange(decL, decR) + , HatVal(..) + , Redundant((.+), norm) + , bases + , vals + ) +import ExchangeAlgebra.Accounting.PostingPolicy + ( ProcessingContext(ConsolidationWorksheet) + , postingAllowedIn + , postingCapabilityFor + ) +import ExchangeAlgebra.Algebra.Base + ( AccountTitles(..) + , Hat(..) + , HatBase((:<)) + , PostingCapability + ) +import ExchangeAlgebra.Reporting.Metric (PeriodResult(..)) +import ExchangeAlgebra.TrialBalance.Balance + ( AccountBalance(..) + , balanceAmount + , balancePair + ) + +-- | Named linkage fields, used when reporting an invalid non-negative amount. +data LinkField + = ProfitOrLossNetIncome + | ProfitOrLossNetIncomeAttributableToOwners + | StatementOfChangesNetIncomeAttributableToOwners + | OpeningRetainedEarnings + | RetainedEarningsDividends + | StatementOfChangesClosingRetainedEarnings + | BalanceSheetRetainedEarnings + | OpeningNonControllingInterests + | NonControllingInterestsPeriodShare + | NonControllingInterestsDividends + | StatementOfChangesClosingNonControllingInterests + | BalanceSheetNonControllingInterests + deriving (Show, Eq, Ord) + +-- | One entity trial balance and its provenance identifier. A source trial +-- balance is accepted as historical input and is therefore not restricted by +-- a processing-context posting-capability gate; it is still checked for +-- structural coordinates, valid values, and exact balance. +data TrialBalanceSource source v = TrialBalanceSource + { _sourceId :: source + , _sourceTrialBalance :: Alg v (HatBase AccountTitles) + } + deriving (Show) + +-- | One atomic worksheet adjustment. The algebra element need not originate +-- from a journal entry, but it must be independently balanced and use only +-- coordinates admitted by the consolidation processing context. +data WorksheetAdjustment source adjustment v = WorksheetAdjustment + { _adjustmentId :: adjustment + , _adjustmentSourceIds :: NonEmpty source + , _adjustmentElement :: Alg v (HatBase AccountTitles) + } + deriving (Show) + +-- | Cross-column equations for the statement of profit or loss (P/L), +-- statement of changes in equity (S/S), and balance sheet (B/S). +-- +-- The P/L total is checked against its owners-of-parent and NCI attribution, +-- and the owners amount is then linked to S/S. Retained earnings and NCI +-- balances keep credit/debit position structural, so accumulated deficits do +-- not require negative scalar values. +-- +-- These values are caller-supplied worksheet-column facts. This Land 2b type +-- validates their equations but cannot derive them from the unlabelled 'Alg' +-- alone; anchoring statement columns to a reporting projection is a later +-- reporting-layer responsibility. The roll-forwards model period result and +-- dividends only; worksheets with OCI, ownership changes, reserve transfers, +-- or other equity movements require a later reporting-layer extension. +data WorksheetLinkage v = WorksheetLinkage + { _profitOrLossNetIncome :: PeriodResult v + , _profitOrLossNetIncomeAttributableToOwners :: PeriodResult v + , _statementOfChangesNetIncomeAttributableToOwners :: PeriodResult v + , _openingRetainedEarnings :: AccountBalance v + , _retainedEarningsDividends :: v + , _statementOfChangesClosingRetainedEarnings :: AccountBalance v + , _balanceSheetRetainedEarnings :: AccountBalance v + , _openingNonControllingInterests :: AccountBalance v + , _nonControllingInterestsPeriodShare :: PeriodResult v + , _nonControllingInterestsDividends :: v + , _statementOfChangesClosingNonControllingInterests + :: AccountBalance v + , _balanceSheetNonControllingInterests :: AccountBalance v + } + deriving (Show, Eq) + +-- | Unvalidated consolidation worksheet input. +data WorksheetInput source adjustment v = WorksheetInput + { _worksheetSources :: NonEmpty (TrialBalanceSource source v) + , _worksheetAdjustments :: [WorksheetAdjustment source adjustment v] + , _worksheetLinkage :: WorksheetLinkage v + } + deriving (Show) + +-- | Every rejected invariant is tied to a source, adjustment, or linkage. +data WorksheetError source adjustment v + = DuplicateSourceId source + | DuplicateAdjustmentId adjustment + | DuplicateAdjustmentSource adjustment source + | UnknownAdjustmentSource adjustment source + | InvalidSourceValue source v + | WildcardSourceAccount source + | WildcardSourceSide source + | UnbalancedSourceTrialBalance source v v + | EmptyAdjustment adjustment + | InvalidAdjustmentValue adjustment v + | WildcardAdjustmentAccount adjustment + | WildcardAdjustmentSide adjustment + | AdjustmentPostingNotAllowed adjustment AccountTitles PostingCapability + | UnbalancedAdjustment adjustment v v + | InvalidLinkAmount LinkField v + | NetIncomeAttributionMismatch v v + | OwnersPeriodResultLinkMismatch (PeriodResult v) (PeriodResult v) + | RetainedEarningsRollForwardMismatch v v + | BalanceSheetRetainedEarningsMismatch + (AccountBalance v) (AccountBalance v) + | NonControllingInterestsRollForwardMismatch v v + | BalanceSheetNonControllingInterestsMismatch + (AccountBalance v) (AccountBalance v) + deriving (Show, Eq) + +-- | A worksheet whose provenance, atomic balance, processing capability, and +-- cross-column linkage have all passed validation. The constructor is hidden. +data ValidatedWorksheet source adjustment v = ValidatedWorksheet + (NonEmpty (TrialBalanceSource source v)) + [WorksheetAdjustment source adjustment v] + (WorksheetLinkage v) + +-- | Validate a consolidation worksheet without normalizing any algebra term. +validateConsolidationWorksheet + :: (HatVal v, Ord source, Ord adjustment) + => WorksheetInput source adjustment v + -> Either (NonEmpty (WorksheetError source adjustment v)) + (ValidatedWorksheet source adjustment v) +validateConsolidationWorksheet input = + case errors of + [] -> Right (ValidatedWorksheet sources adjustments linkage) + e : es -> Left (e :| es) + where + sources = _worksheetSources input + adjustments = _worksheetAdjustments input + linkage = _worksheetLinkage input + errors = duplicateIdErrors sources adjustments + ++ concatMap validateSource (toListNE sources) + ++ concatMap (validateAdjustment (sourceIds sources)) adjustments + ++ validateWorksheetLinkage linkage + +-- | Recover the source trial balances with their provenance intact. +validatedSources + :: ValidatedWorksheet source adjustment v + -> NonEmpty (TrialBalanceSource source v) +validatedSources (ValidatedWorksheet sources _ _) = sources + +-- | Recover the atomic adjustments with their provenance intact. +validatedAdjustments + :: ValidatedWorksheet source adjustment v + -> [WorksheetAdjustment source adjustment v] +validatedAdjustments (ValidatedWorksheet _ adjustments _) = adjustments + +-- | Recover the validated cross-column linkage values. +validatedLinkage + :: ValidatedWorksheet source adjustment v + -> WorksheetLinkage v +validatedLinkage (ValidatedWorksheet _ _ linkage) = linkage + +-- | Explicitly combine source trial balances and atomic adjustments. +-- Redundant-algebra addition preserves same-base posting sequences. This is a +-- calculation projection; inspect the validated source and adjustment lists +-- when provenance is required. +combinedWorksheet + :: (HatVal v) + => ValidatedWorksheet source adjustment v + -> Alg v (HatBase AccountTitles) +combinedWorksheet (ValidatedWorksheet sources adjustments _) = + L.foldl' (.+) mempty + (map _sourceTrialBalance (toListNE sources) + ++ map _adjustmentElement adjustments) + +duplicateIdErrors + :: (Ord source, Ord adjustment) + => NonEmpty (TrialBalanceSource source v) + -> [WorksheetAdjustment source adjustment v] + -> [WorksheetError source adjustment v] +duplicateIdErrors sources adjustments = + [ DuplicateSourceId sourceId + | (sourceId, count) <- M.toList sourceCounts + , count > 1 + ] + ++ [ DuplicateAdjustmentId adjustmentId + | (adjustmentId, count) <- M.toList adjustmentCounts + , count > 1 + ] + where + sourceCounts = M.fromListWith (+) + [ (_sourceId source, 1 :: Int) | source <- toListNE sources ] + adjustmentCounts = M.fromListWith (+) + [ (_adjustmentId adjustment, 1 :: Int) | adjustment <- adjustments ] + +sourceIds :: Ord source + => NonEmpty (TrialBalanceSource source v) + -> M.Map source () +sourceIds = M.fromList . map (\source -> (_sourceId source, ())) . toListNE + +validateSource + :: HatVal v + => TrialBalanceSource source v + -> [WorksheetError source adjustment v] +validateSource source = structuralErrors ++ balanceErrors + where + sourceId = _sourceId source + alg = _sourceTrialBalance source + structuralErrors = + [ InvalidSourceValue sourceId value + | value <- vals alg + , isErrorValue value + ] + ++ [ WildcardSourceAccount sourceId + | _ :< AccountTitle <- bases alg + ] + ++ [ WildcardSourceSide sourceId + | HatNot :< _ <- bases alg + ] + balanceErrors + | not (null structuralErrors) = [] + | debit /= credit = [UnbalancedSourceTrialBalance sourceId debit credit] + | otherwise = [] + where + (debit, credit) = sideTotals alg + +validateAdjustment + :: (HatVal v, Ord source) + => M.Map source () + -> WorksheetAdjustment source adjustment v + -> [WorksheetError source adjustment v] +validateAdjustment knownSources adjustment = + provenanceErrors ++ structuralErrors ++ balanceErrors + where + adjustmentId = _adjustmentId adjustment + alg = _adjustmentElement adjustment + structuralErrors = + [ EmptyAdjustment adjustmentId | null (vals alg) ] + ++ [ InvalidAdjustmentValue adjustmentId value + | value <- vals alg + , isErrorValue value || not (value > 0) + ] + ++ [ WildcardAdjustmentAccount adjustmentId + | _ :< AccountTitle <- bases alg + ] + ++ [ WildcardAdjustmentSide adjustmentId + | HatNot :< _ <- bases alg + ] + ++ [ AdjustmentPostingNotAllowed adjustmentId account capability + | _ :< account <- bases alg + , account /= AccountTitle + , let capability = postingCapabilityFor account + , not (postingAllowedIn ConsolidationWorksheet capability) + ] + refs = toListNE (_adjustmentSourceIds adjustment) + refCounts = M.fromListWith (+) [ (sourceId, 1 :: Int) | sourceId <- refs ] + provenanceErrors = + [ DuplicateAdjustmentSource adjustmentId sourceId + | (sourceId, count) <- M.toList refCounts + , count > 1 + ] + ++ [ UnknownAdjustmentSource adjustmentId sourceId + | sourceId <- M.keys refCounts + , M.notMember sourceId knownSources + ] + balanceErrors + | not (null structuralErrors) = [] + | debit /= credit = [UnbalancedAdjustment adjustmentId debit credit] + | otherwise = [] + where + (debit, credit) = sideTotals alg + +validateWorksheetLinkage + :: HatVal v + => WorksheetLinkage v + -> [WorksheetError source adjustment v] +validateWorksheetLinkage linkage + | not (null invalidAmounts) = invalidAmounts + | otherwise = attributionErrors + ++ ownersLinkErrors + ++ retainedEarningsErrors + ++ balanceSheetErrors + ++ nciErrors + where + invalidAmounts = + [ InvalidLinkAmount field value + | (field, value) <- linkageAmounts linkage + , isErrorValue value + ] + + totalResult = _profitOrLossNetIncome linkage + ownersPlResult = _profitOrLossNetIncomeAttributableToOwners linkage + ownersSsResult = _statementOfChangesNetIncomeAttributableToOwners linkage + nciResult = _nonControllingInterestsPeriodShare linkage + + (attributionLeft, attributionRight) = attributionSides + totalResult ownersPlResult nciResult + attributionErrors = + [ NetIncomeAttributionMismatch attributionLeft attributionRight + | attributionLeft /= attributionRight + ] + + ownersLinkErrors = + [ OwnersPeriodResultLinkMismatch ownersPlResult ownersSsResult + | not (periodResultEquivalent ownersPlResult ownersSsResult) + ] + + (retainedLeft, retainedRight) = rollForwardSides + (_openingRetainedEarnings linkage) + ownersSsResult + (_retainedEarningsDividends linkage) + (_statementOfChangesClosingRetainedEarnings linkage) + retainedEarningsErrors = + [ RetainedEarningsRollForwardMismatch retainedLeft retainedRight + | retainedLeft /= retainedRight + ] + + ssClosing = _statementOfChangesClosingRetainedEarnings linkage + bsClosing = _balanceSheetRetainedEarnings linkage + balanceSheetErrors = + [ BalanceSheetRetainedEarningsMismatch ssClosing bsClosing + | not (balancePositionEquivalent ssClosing bsClosing) + ] + + (nciLeft, nciRight) = rollForwardSides + (_openingNonControllingInterests linkage) + nciResult + (_nonControllingInterestsDividends linkage) + (_statementOfChangesClosingNonControllingInterests linkage) + nciErrors = + [ NonControllingInterestsRollForwardMismatch nciLeft nciRight + | nciLeft /= nciRight + ] + ++ [ BalanceSheetNonControllingInterestsMismatch + ssClosingNci bsNci + | not (balancePositionEquivalent ssClosingNci bsNci) + ] + ssClosingNci = + _statementOfChangesClosingNonControllingInterests linkage + bsNci = _balanceSheetNonControllingInterests linkage + +linkageAmounts :: Num v => WorksheetLinkage v -> [(LinkField, v)] +linkageAmounts linkage = + [ (ProfitOrLossNetIncome, periodAmount (_profitOrLossNetIncome linkage)) + , (ProfitOrLossNetIncomeAttributableToOwners, + periodAmount (_profitOrLossNetIncomeAttributableToOwners linkage)) + , (StatementOfChangesNetIncomeAttributableToOwners, + periodAmount (_statementOfChangesNetIncomeAttributableToOwners linkage)) + , (OpeningRetainedEarnings, + balanceAmount (_openingRetainedEarnings linkage)) + , (RetainedEarningsDividends, _retainedEarningsDividends linkage) + , (StatementOfChangesClosingRetainedEarnings, + balanceAmount (_statementOfChangesClosingRetainedEarnings linkage)) + , (BalanceSheetRetainedEarnings, + balanceAmount (_balanceSheetRetainedEarnings linkage)) + , (OpeningNonControllingInterests, + balanceAmount (_openingNonControllingInterests linkage)) + , (NonControllingInterestsPeriodShare, + periodAmount (_nonControllingInterestsPeriodShare linkage)) + , (NonControllingInterestsDividends, + _nonControllingInterestsDividends linkage) + , (StatementOfChangesClosingNonControllingInterests, + balanceAmount + (_statementOfChangesClosingNonControllingInterests linkage)) + , (BalanceSheetNonControllingInterests, + balanceAmount (_balanceSheetNonControllingInterests linkage)) + ] + +periodAmount :: Num v => PeriodResult v -> v +periodAmount (PeriodProfit value) = value +periodAmount (PeriodLoss value) = value +periodAmount PeriodBreakEven = 0 + +periodSides :: Num v => PeriodResult v -> (v, v) +periodSides (PeriodProfit value) = (value, 0) +periodSides (PeriodLoss value) = (0, value) +periodSides PeriodBreakEven = (0, 0) + +-- Total result equals owners' attribution plus NCI attribution. Moving all +-- loss-side values across the equation avoids signed scalars. +attributionSides :: Num v + => PeriodResult v + -> PeriodResult v + -> PeriodResult v + -> (v, v) +attributionSides total owners nci = + (totalProfit + ownersLoss + nciLoss, + totalLoss + ownersProfit + nciProfit) + where + (totalProfit, totalLoss) = periodSides total + (ownersProfit, ownersLoss) = periodSides owners + (nciProfit, nciLoss) = periodSides nci + +periodResultEquivalent :: (Eq v, Num v) + => PeriodResult v -> PeriodResult v -> Bool +periodResultEquivalent left right = + leftProfit + rightLoss == leftLoss + rightProfit + where + (leftProfit, leftLoss) = periodSides left + (rightProfit, rightLoss) = periodSides right + +balancePositionEquivalent :: (Eq v, Num v) + => AccountBalance v -> AccountBalance v -> Bool +balancePositionEquivalent left right = + leftCredit + rightDebit == leftDebit + rightCredit + where + (leftDebit, leftCredit) = balancePair left + (rightDebit, rightCredit) = balancePair right + +rollForwardSides :: Num v + => AccountBalance v + -> PeriodResult v + -> v + -> AccountBalance v + -> (v, v) +rollForwardSides opening result dividends closing = case result of + PeriodProfit amount -> + (openingCredit + amount + closingDebit, + openingDebit + dividends + closingCredit) + PeriodLoss amount -> + (openingCredit + closingDebit, + openingDebit + amount + dividends + closingCredit) + PeriodBreakEven -> + (openingCredit + closingDebit, + openingDebit + dividends + closingCredit) + where + (openingDebit, openingCredit) = balancePair opening + (closingDebit, closingCredit) = balancePair closing + +sideTotals :: HatVal v => Alg v (HatBase AccountTitles) -> (v, v) +sideTotals alg = (norm (decL alg), norm (decR alg)) + +toListNE :: NonEmpty a -> [a] +toListNE (x :| xs) = x : xs diff --git a/src/ExchangeAlgebra/Convert.hs b/src/ExchangeAlgebra/Convert.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Convert.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +-- The alias table intentionally references the deprecated 'Commutation' +-- constructor so that its legacy Japanese label ("通信費") is recognised and +-- flagged as ambiguous against 'CommunicationExpenses'; silence the warning. +{-# OPTIONS_GHC -Wno-deprecations #-} + +{- | +Module : ExchangeAlgebra.Convert +Description : Pure conversion between external (side, account-name, amount) data and + exchange-algebra terms. No serialization dependency (Text only). + +This module is the dependency-free core of the input-conversion layer: it turns +externally supplied postings---a debit\/credit t'Side', an account name as 'Text', +and an amount---into exchange-algebra 'Alg' terms, and back. The format glue +(JSON\/XML, i.e. @aeson@) deliberately lives outside the published library +(see @examples\/audit-eval\/runner@), so the algebra core stays serialization-free. + +The mapping from a debit\/credit side to the @Hat@\/@Not@ marker is derived from +the library's own 'whichSide', so the credit\/debit semantics are never duplicated. +Unknown or wildcard account names are rejected (a /correct-by-construction/ guard +against hallucinated accounts). Account names that are genuinely ambiguous (one +Japanese label shared by several constructors, e.g. @準備預金@ for both the asset +and liability side of reserve deposits) are also rejected, with the candidate +accounts reported, so callers must disambiguate by canonical name. + +A fixed-schema CSV reader (@side,account,amount@, optional @note@ column) is +provided in "ExchangeAlgebra.Convert.Csv". +-} +module ExchangeAlgebra.Convert + ( ConvError(..) + -- $concreteAccountTitles + , concreteAccountTitles + , normalizeTitle + , parseAccountTitle + , parseSide + , markerForSide + , postingFromSide + , journalFromSides + ) where + +import Data.Char (isAlphaNum, isSpace) +import qualified Data.List as L +import Data.Text (Text) +import qualified Data.Text as T + +import ExchangeAlgebra.Algebra ( Alg, HatVal, Redundant((.+)), (.@) ) +import ExchangeAlgebra.Algebra.Base ( AccountTitles(..) + , HatBase(..) + , Hat(..) + , Side(..) + , accountAliases + , whichSide ) +import ExchangeAlgebra.Algebra.Base.Account.Registry ( concreteAccountTitles ) + +-- $setup +-- The examples use 'Text' literals, so enable @OverloadedStrings@ in doctest. +-- >>> :set -XOverloadedStrings + +-- | Conversion errors. Kept structural so callers can report precisely. +data ConvError = UnknownAccount Text -- ^ name matched no concrete account title + | AmbiguousAccount Text [AccountTitles] -- ^ name matched several accounts (disambiguate by canonical name) + | UnknownSide Text -- ^ side string was not debit\/credit + | MalformedCsv Text -- ^ CSV header\/row was structurally invalid (see "ExchangeAlgebra.Convert.Csv") + | BadAmount Text -- ^ amount field was not a valid non-negative number + deriving (Eq, Show) + +-- $concreteAccountTitles +-- 'concreteAccountTitles' lists all concrete account titles, /excluding/ the +-- wildcard 'AccountTitle', in stable Enum order. It is re-exported from +-- "ExchangeAlgebra.Algebra.Base.Account.Registry", which is the single +-- definition; external input must never resolve to the wildcard, so callers +-- should use this safe range rather than @[minBound .. maxBound]@. +-- +-- >>> take 1 concreteAccountTitles +-- [Cash] +-- >>> Cash `elem` concreteAccountTitles && Sales `elem` concreteAccountTitles +-- True +-- >>> AccountsPayable `elem` concreteAccountTitles +-- True +-- >>> AccountTitle `elem` concreteAccountTitles +-- False + +-- | Account-name lookup table: every key (canonical constructor names and the +-- Japanese\/abbreviation aliases below) is run through 'normalizeTitle', so matching is +-- case-, whitespace-, and symbol-insensitive. Keys are tagged so that a single +-- alias shared by several accounts is reported as 'AmbiguousAccount' rather than +-- silently resolving to whichever entry happens to come first. +-- +-- The canonical English names (derived from 'show' over 'concreteAccountTitles') +-- are always unique, so they are never ambiguous and always resolve. +accountTable :: [(Text, [AccountTitles])] +accountTable = collapse [ (normalizeTitle k, a) | (k, a) <- entries ] + where + -- Group entries by normalised key, accumulating every account that key maps + -- to (so genuine collisions become ambiguous, not first-wins). + collapse kvs = + [ (k, L.nub as) + | k <- L.nub (L.map fst kvs) + , let as = [ a | (k', a) <- kvs, k' == k ] ] + + entries :: [(Text, AccountTitles)] + entries = canonical ++ aliases + + -- Canonical: the constructor name. Always unique. + canonical = [ (T.pack (show a), a) | a <- concreteAccountTitles ] + + -- Aliases: Japanese labels (from the Element.hs translation Haddock, which is + -- the canonical bilingual reference) plus a few English abbreviations. + -- Genuinely shared labels are listed for each account; lookup then returns + -- 'AmbiguousAccount' for those, forcing the caller to use a canonical name. + aliases = + [ (alias, title) + | title <- aliasTitleOrder + , alias <- accountAliases title + ] + + -- Preserve the historical candidate order for the one shared label whose + -- alias table order differs from Enum order: "通信費" reports the modern + -- title before the deprecated one. + aliasTitleOrder = CommunicationExpenses + : L.delete CommunicationExpenses concreteAccountTitles + +-- | Normalise an account name for matching: case-fold, drop punctuation\/symbols +-- (keep only alphanumerics and spaces), and collapse internal whitespace to +-- single spaces (also trimming). So @\"A\/R\"@ and @\"ar\"@ coincide, and +-- @\"Accounts Receivable\"@ matches @\"accounts receivable\"@. CJK characters +-- are alphanumeric (Unicode @Lo@), so Japanese labels survive unchanged. +-- +-- (Renamed from @norm@: that name collides with the core value-domain +-- homomorphism 'ExchangeAlgebra.Algebra.norm', which is an entirely unrelated +-- operation — the two must not be confusable in downstream imports.) +-- +-- >>> normalizeTitle " Accounts Receivable " +-- "accounts receivable" +-- >>> normalizeTitle "A/R" +-- "ar" +normalizeTitle :: Text -> Text +normalizeTitle = T.unwords . T.words . T.filter (\c -> isAlphaNum c || isSpace c) . T.toLower + +-- | Parse an account name into a concrete 'AccountTitles'. Unknown names and the +-- wildcard are rejected; ambiguous Japanese labels (shared by several accounts) +-- are rejected with the candidates reported. +-- +-- >>> parseAccountTitle "Cash" +-- Right Cash +-- >>> parseAccountTitle " accounts receivable " +-- Right AccountsReceivable +-- >>> parseAccountTitle "Accounts Receivable" +-- Right AccountsReceivable +-- >>> parseAccountTitle "A/R" +-- Right AccountsReceivable +-- >>> parseAccountTitle "売掛金" +-- Right AccountsReceivable +-- +-- A label shared by two accounts (here the asset and liability side of reserve +-- deposits) is rejected as ambiguous, listing the candidates so the caller can +-- pick a canonical name: +-- +-- >>> case parseAccountTitle "準備預金" of { Left (AmbiguousAccount _ as) -> as; _ -> [] } +-- [ReserveDepositReceivable,ReserveDepositPayable] +-- >>> parseAccountTitle "Goodwill_X" +-- Left (UnknownAccount "Goodwill_X") +-- >>> parseAccountTitle "AccountTitle" +-- Left (UnknownAccount "AccountTitle") +parseAccountTitle :: Text -> Either ConvError AccountTitles +parseAccountTitle t = + case lookup (normalizeTitle t) accountTable of + Just [a] -> Right a + Just as -> Left (AmbiguousAccount t as) + Nothing -> Left (UnknownAccount t) + +-- | Parse a side string (@"debit"@\/@"credit"@, case-insensitive) into t'Side'. +-- +-- >>> parseSide "debit" +-- Right Debit +-- >>> parseSide "CREDIT" +-- Right Credit +-- >>> parseSide "left" +-- Left (UnknownSide "left") +parseSide :: Text -> Either ConvError Side +parseSide t = case normalizeTitle t of + "debit" -> Right Debit + "credit" -> Right Credit + _ -> Left (UnknownSide t) + +-- | The @Hat@\/@Not@ marker that places @account@ on the requested debit\/credit +-- @side@. Derived from the library's 'whichSide' so the credit\/debit rule is not +-- duplicated: an account sits on its \"natural\" side under 'Not'; if the +-- requested side differs, the v'Hat' (reversal) marker is used. +-- +-- >>> markerForSide Debit Cash +-- Not +-- >>> markerForSide Credit Cash +-- Hat +-- >>> markerForSide Credit Sales +-- Not +-- >>> markerForSide Debit Sales +-- Hat +markerForSide :: Side -> AccountTitles -> Hat +markerForSide side account + | whichSide (Not :< account) == side = Not + | otherwise = Hat + +-- | Build a single posting term: @amount .\@ (marker :< account)@, with the +-- marker chosen so the posting lands on @side@. Built through the smart +-- constructor '(.@)' so the non-negative\/non-error value invariant is enforced. +-- +-- >>> postingFromSide Debit Cash (1000 :: Double) +-- 1000.00:@Not:>> postingFromSide Credit Sales (1000 :: Double) +-- 1000.00:@Not: Side -> AccountTitles -> v -> Alg v (HatBase AccountTitles) +postingFromSide side account amount = + amount .@ (markerForSide side account :< account) + +-- | Fold a list of @(side, account, amount)@ postings into one algebra term. +-- Balance (debit == credit) is /not/ enforced here; check it with the library's +-- balance functions after conversion. +-- +-- >>> journalFromSides [(Debit, Cash, 1000), (Credit, Sales, 1000)] :: Alg Double (HatBase AccountTitles) +-- 1000.00:@Not: [(Side, AccountTitles, v)] -> Alg v (HatBase AccountTitles) +journalFromSides = foldr (\(s, a, v) acc -> postingFromSide s a v .+ acc) mempty diff --git a/src/ExchangeAlgebra/Convert/Checked.hs b/src/ExchangeAlgebra/Convert/Checked.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Convert/Checked.hs @@ -0,0 +1,570 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wincomplete-patterns -Werror=incomplete-patterns #-} + +{- | +Module : ExchangeAlgebra.Convert.Checked +Description : Checked construction for externally generated journal entries. + +This module adds a validation layer for LLM- or runner-generated postings before +they are admitted as exchange-algebra terms. The unchecked constructor +'ExchangeAlgebra.Convert.journalFromSides' deliberately preserves its historical +semantics and does not enforce balance; the functions here reject malformed +entries with structural errors instead. +-} +module ExchangeAlgebra.Convert.Checked + ( -- $postingPolicy + ProcessingContext(..) + , EntryError(..) + , JournalError(..) + , JournalCert(..) + , SourceError(..) + , postingAllowedIn + , exactBalanced + , checkedEntryIn + , checkedEntry + , checkedEntryTextIn + , checkedEntryText + , checkedJournalIn + , checkedJournal + , certifyJournalTextIn + , certifyJournalText + , reconcileSources + ) where + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.HashMap.Strict as HM +import qualified Data.List as L +import qualified Data.Map.Strict as M +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T + +import ExchangeAlgebra.Algebra + ( Alg + , ExBaseClass + , Exchange(decL, decR) + , HatVal(..) + , Redundant((.+), norm) + ) +import ExchangeAlgebra.Accounting.PostingPolicy + ( ProcessingContext(..) + , postingAllowedIn + , postingCapabilityFor + ) +import ExchangeAlgebra.Algebra.Base + ( AccountTitles(..) + , HatBase + , PostingCapability(..) + , Side(..) + ) +import ExchangeAlgebra.Convert + ( ConvError + , journalFromSides + , normalizeTitle + , parseAccountTitle + , parseSide + ) +import ExchangeAlgebra.Journal + ( Journal + , Note + , (.|) + , toMap + ) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.List.NonEmpty (NonEmpty) +-- >>> import ExchangeAlgebra.Algebra (Alg, Redundant((.+), norm), Exchange(decL)) +-- >>> import ExchangeAlgebra.Algebra.Base (HatBase, AccountTitles(..), Side(..)) +-- >>> import ExchangeAlgebra.Convert (journalFromSides) +-- >>> import ExchangeAlgebra.Journal (Journal) + +-- $postingPolicy +-- 'ProcessingContext' and 'postingAllowedIn' are defined in +-- "ExchangeAlgebra.Accounting.PostingPolicy" and re-exported here so the +-- historical import path keeps working. The gate itself is accounting-domain +-- policy, not an input-adapter concern. + +-- | Validation errors for a single generated entry. +-- +-- Posting positions are 0-origin indices in the input entry. +data EntryError v + = EntryParse Int ConvError + | NonPositiveAmount Int AccountTitles v + | WildcardAccount Int + | WildcardSide Int + | PostingNotAllowed Int AccountTitles PostingCapability ProcessingContext + | EmptyEntry + | Imbalanced { _debitTotal :: v, _creditTotal :: v } + deriving (Show, Eq) + +-- | Validation errors for a txid-indexed journal batch. +data JournalError n v + = EntryErrors n (NonEmpty (EntryError v)) + | DuplicateTxId n + deriving (Show, Eq) + +-- | Staged certification of a text-originated journal batch. +-- +-- A batch can be fully admitted, rejected for accounting or structural +-- reasons, or certified as structurally valid and balanced while retaining +-- account-title resolution failures for a later vocabulary pass. +-- +-- The distinction that motivates the type: an externally generated journal can +-- be double-entry valid and still name accounts this chart does not carry. Folding +-- both into one 'Either' makes a correct journal in an unsupported vocabulary +-- indistinguishable from a wrong one. +-- +-- Note the two totals are /batch/ totals, whereas the balance test that gates +-- 'BalancedUnresolved' is applied per entry (per txid), matching 'checkedEntry'. +-- Per-entry balance implies batch balance, so the invariant +-- @_certDebitTotal == _certCreditTotal@ holds, but the converse does not: the +-- batch totals alone would not have been a sufficient gate. +data JournalCert n v + = FullyResolved (Journal n v (HatBase AccountTitles)) + | BalancedUnresolved + { _certResolved :: [(n, [(Side, AccountTitles, v)])] + , _certUnresolved :: [(n, [(Int, Text, ConvError)])] + , _certDebitTotal :: v + , _certCreditTotal :: v + } + | Rejected (NonEmpty (JournalError n v)) + deriving (Show) + +instance (HatVal v, Note n) => Eq (JournalCert n v) where + FullyResolved left == FullyResolved right = toMap left == toMap right + BalancedUnresolved resolvedLeft unresolvedLeft debitLeft creditLeft + == BalancedUnresolved resolvedRight unresolvedRight debitRight creditRight = + resolvedLeft == resolvedRight + && unresolvedLeft == unresolvedRight + && debitLeft == debitRight + && creditLeft == creditRight + Rejected left == Rejected right = left == right + _ == _ = False + +-- | Source-coverage errors between input transactions and a checked journal. +data SourceError n v + = MissingSource n + | UnknownSource n + | AmountMismatch n v v + deriving (Show, Eq) + +-- | Exact debit-credit balance using strict equality. +-- +-- Unlike the existing 'ExchangeAlgebra.Algebra.balance', this uses @(==)@ over +-- the value type and therefore does not admit tolerance-based near-matches. +-- +-- >>> let Right ok = checkedEntry [(Debit, Cash, 100), (Credit, Sales, 100)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles)) +-- >>> exactBalanced ok +-- True +-- >>> let raw = journalFromSides [(Debit, Cash, 100), (Credit, Sales, 90)] :: Alg Double (HatBase AccountTitles) +-- >>> exactBalanced raw +-- False +exactBalanced :: (HatVal v, ExBaseClass b) => Alg v b -> Bool +exactBalanced x = norm (decL x) == norm (decR x) + +-- | Construct one checked entry from parsed postings in a processing context. +-- +-- The success value is built with 'journalFromSides', so accepted entries keep +-- the same posting semantics as the unchecked conversion path. +-- +-- >>> fmap exactBalanced (checkedEntry [(Debit, Cash, 100), (Credit, Sales, 100)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles))) +-- Right True +-- >>> checkedEntry [] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles)) +-- Left (EmptyEntry :| []) +-- >>> checkedEntry [(Debit, Cash, 0), (Credit, Sales, 0)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles)) +-- Left (NonPositiveAmount 0 Cash 0.0 :| [NonPositiveAmount 1 Sales 0.0]) +-- >>> checkedEntry [(Debit, AccountTitle, 1), (Side, Cash, 1)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles)) +-- Left (WildcardAccount 0 :| [WildcardSide 1,Imbalanced {_debitTotal = 1.0, _creditTotal = 0.0}]) +-- >>> checkedEntry [(Debit, Cash, 100), (Credit, Sales, 90)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles)) +-- Left (Imbalanced {_debitTotal = 100.0, _creditTotal = 90.0} :| []) +-- >>> fmap exactBalanced (checkedEntryIn ClosingProcess [(Debit, Sales, 100), (Credit, IncomeSummary, 100)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles))) +-- Right True +checkedEntryIn :: (HatVal v) + => ProcessingContext + -> [(Side, AccountTitles, v)] + -> Either (NonEmpty (EntryError v)) (Alg v (HatBase AccountTitles)) +checkedEntryIn context rows = + case validateIndexed context (null rows) indexed of + [] -> Right (journalFromSides rows) + e : es -> Left (e :| es) + where + indexed = zip [0..] rows + +-- | Construct one ordinary-journal entry. This compatibility API delegates +-- to 'checkedEntryIn' and therefore rejects closing-only, consolidation-only, +-- engine-generated, and non-postable coordinates. +checkedEntry :: (HatVal v) + => [(Side, AccountTitles, v)] + -> Either (NonEmpty (EntryError v)) (Alg v (HatBase AccountTitles)) +checkedEntry = checkedEntryIn OrdinaryJournal + +-- | Parse text-side runner input and then apply 'checkedEntry' validation. +-- +-- Parse errors are accumulated as 'EntryParse' instead of failing fast. +-- +-- >>> fmap exactBalanced (checkedEntryText [("debit", "Cash", 100), ("credit", "Sales", 100)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles))) +-- Right True +-- >>> checkedEntryText [("left", "Cash", 100)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles)) +-- Left (EntryParse 0 (UnknownSide "left") :| []) +-- >>> checkedEntryText [("debit", "Goodwill_X", 100)] :: Either (NonEmpty (EntryError Double)) (Alg Double (HatBase AccountTitles)) +-- Left (EntryParse 0 (UnknownAccount "Goodwill_X") :| [Imbalanced {_debitTotal = 100.0, _creditTotal = 0.0}]) +checkedEntryTextIn :: (HatVal v) + => ProcessingContext + -> [(Text, Text, v)] + -> Either (NonEmpty (EntryError v)) (Alg v (HatBase AccountTitles)) +checkedEntryTextIn context rows = + case parseErrors ++ structuralErrors ++ textImbalanceErrors of + [] -> Right (journalFromSides (map snd parsedRows)) + e : es -> Left (e :| es) + where + parsed = map parseIndexed (zip [0..] rows) + parseErrors = concatMap first parsed + parsedRows = mapMaybe second parsed + sideAmounts = mapMaybe third parsed + structuralErrors = filter (not . isImbalance) + (validateIndexed context (null rows) parsedRows) + + -- Account vocabulary resolution and arithmetic balance are independent. + -- Retain every successfully parsed side/amount pair so an unknown account + -- does not make an otherwise balanced entry look imbalanced. + textImbalanceErrors + | null rows = [] + | length sideAmounts /= length rows = [] + | any invalidSideAmount sideAmounts = [] + | debitTotal == creditTotal = [] + | otherwise = [Imbalanced debitTotal creditTotal] + where + debitTotal = L.foldl' (+) 0 + [ amount | (Debit, amount) <- sideAmounts ] + creditTotal = L.foldl' (+) 0 + [ amount | (Credit, amount) <- sideAmounts ] + + invalidSideAmount (side, amount) = + side == Side || isErrorValue amount || not (amount > 0) + + isImbalance Imbalanced{} = True + isImbalance _ = False + + first (x, _, _) = x + second (_, x, _) = x + third (_, _, x) = x + + parseIndexed (i, (sideText, accountText, amount)) = + let sideResult = parseSide sideText + accountResult = parseAccountTitle accountText + errs = + (case sideResult of + Left err -> [EntryParse i err] + Right _ -> []) + ++ (case accountResult of + Left err -> [EntryParse i err] + Right _ -> []) + parsedRow = case (sideResult, accountResult) of + (Right side, Right account) -> Just (i, (side, account, amount)) + _ -> Nothing + sideAmount = case sideResult of + Right side -> Just (side, amount) + Left _ -> Nothing + in (errs, parsedRow, sideAmount) + +-- | Parse and check an ordinary-journal entry. +checkedEntryText :: (HatVal v) + => [(Text, Text, v)] + -> Either (NonEmpty (EntryError v)) (Alg v (HatBase AccountTitles)) +checkedEntryText = checkedEntryTextIn OrdinaryJournal + +-- | Construct a checked txid-indexed journal. +-- +-- Duplicate txids are detected before entry construction, because the 'Journal' +-- representation merges equal notes. +-- +-- >>> fmap (norm . decL) (checkedJournal [("tx1", [(Debit, Cash, 100), (Credit, Sales, 100)])] :: Either (NonEmpty (JournalError String Double)) (Journal String Double (HatBase AccountTitles))) +-- Right 100.0 +-- >>> checkedJournal [("tx1", [(Debit, Cash, 100), (Credit, Sales, 100)]), ("tx1", [(Debit, Cash, 5), (Credit, Sales, 5)])] :: Either (NonEmpty (JournalError String Double)) (Journal String Double (HatBase AccountTitles)) +-- Left (DuplicateTxId "tx1" :| []) +-- >>> checkedJournal [("bad", [(Debit, Cash, 1)])] :: Either (NonEmpty (JournalError String Double)) (Journal String Double (HatBase AccountTitles)) +-- Left (EntryErrors "bad" (Imbalanced {_debitTotal = 1.0, _creditTotal = 0.0} :| []) :| []) +checkedJournalIn :: (HatVal v, Note n, Ord n) + => ProcessingContext + -> [(n, [(Side, AccountTitles, v)])] + -> Either (NonEmpty (JournalError n v)) (Journal n v (HatBase AccountTitles)) +checkedJournalIn context entries = + case duplicateErrors ++ entryErrors of + [] -> Right (L.foldl' (.+) mempty journals) + e : es -> Left (e :| es) + where + counts = M.fromListWith (+) [ (txid, 1 :: Int) | (txid, _) <- entries ] + isDuplicate txid = M.findWithDefault 0 txid counts > 1 + + duplicateErrors = + [ DuplicateTxId txid + | (txid, count) <- M.toList counts + , count > 1 + ] + + checkedUnique = + [ (txid, checkedEntryIn context rows) + | (txid, rows) <- entries + , not (isDuplicate txid) + ] + + entryErrors = + [ EntryErrors txid errs + | (txid, Left errs) <- checkedUnique + ] + + journals = + [ alg .| txid + | (txid, Right alg) <- checkedUnique + ] + +-- | Construct an ordinary-journal batch. +checkedJournal :: (HatVal v, Note n, Ord n) + => [(n, [(Side, AccountTitles, v)])] + -> Either (NonEmpty (JournalError n v)) (Journal n v (HatBase AccountTitles)) +checkedJournal = checkedJournalIn OrdinaryJournal + +-- | Certify a text-originated journal in stages. +-- +-- Duplicate txids and structural errors are rejected before balance is +-- considered. Balance is then checked using only parsed sides and amounts, +-- independently of account-title resolution. Consequently, a structurally +-- valid and balanced batch whose only remaining failures are unknown or +-- ambiguous account titles is returned as 'BalancedUnresolved'. +certifyJournalTextIn :: (HatVal v, Note n, Ord n) + => ProcessingContext + -> [(n, [(Text, Text, v)])] + -> JournalCert n v +certifyJournalTextIn context entries = + case duplicateErrors of + e : es -> Rejected (e :| es) + [] -> case structuralErrors of + e : es -> Rejected (e :| es) + [] -> case imbalanceErrors of + e : es -> Rejected (e :| es) + [] + | null unresolvedPostings -> + FullyResolved (L.foldl' (.+) mempty journals) + | otherwise -> + BalancedUnresolved + { _certResolved = resolvedEntries + , _certUnresolved = unresolvedEntries + , _certDebitTotal = debitTotal + , _certCreditTotal = creditTotal + } + where + counts = M.fromListWith (+) [ (txid, 1 :: Int) | (txid, _) <- entries ] + duplicateErrors = + [ DuplicateTxId txid + | (txid, count) <- M.toList counts + , count > 1 + ] + + parsedEntries = + [ (txid, map parseCertPosting (zip [0..] rows)) + | (txid, rows) <- entries + ] + + structuralErrors = + [ EntryErrors txid (err :| errs) + | (txid, rows) <- parsedEntries + , let entryErrors = certStructuralErrors context rows + , err : errs <- [entryErrors] + ] + + imbalanceErrors = + [ EntryErrors txid (Imbalanced debit credit :| []) + | (txid, rows) <- parsedEntries + , let (debit, credit) = certTotals rows + , debit /= credit + ] + + resolvedEntries = + [ (txid, resolved) + | (txid, rows) <- parsedEntries + , let resolved = + [ (side, account, amount) + | (_, _, amount, Right side, Right account) <- rows + ] + , not (null resolved) + ] + + unresolvedEntries = + [ (txid, unresolved) + | (txid, rows) <- parsedEntries + , let unresolved = + [ (i, accountText, err) + | (i, accountText, _, Right _, Left err) <- rows + ] + , not (null unresolved) + ] + + unresolvedPostings = concatMap snd unresolvedEntries + + (debitTotal, creditTotal) = + L.foldl' addTotals (0, 0) (map (certTotals . snd) parsedEntries) + + addTotals (debits, credits) (entryDebits, entryCredits) = + (debits + entryDebits, credits + entryCredits) + + journals = + [ journalFromSides rows .| txid + | (txid, rows) <- resolvedEntries + ] + +-- | Certify an ordinary-journal batch in stages. +certifyJournalText :: (HatVal v, Note n, Ord n) + => [(n, [(Text, Text, v)])] + -> JournalCert n v +certifyJournalText = certifyJournalTextIn OrdinaryJournal + +-- The tuple retains the original account text so resolution failures can be +-- reported without reconstructing user input. +type CertPosting v = + (Int, Text, v, Either ConvError Side, Either ConvError AccountTitles) + +-- Wildcard names have to be recognised here rather than delegated to the +-- parsers: 'parseAccountTitle' and 'parseSide' reject the wildcard +-- constructors by design (the /correct-by-construction/ guard documented in +-- "ExchangeAlgebra.Convert"), so on the text path a wildcard is indistinguishable +-- from an unknown name. Certification must tell them apart, because a wildcard +-- is a structural defect ('Rejected') whereas an unknown name is a vocabulary +-- gap ('BalancedUnresolved'). Matching uses the parsers' own 'normalizeTitle', +-- so the two paths cannot drift apart. +parseCertPosting :: (Int, (Text, Text, v)) -> CertPosting v +parseCertPosting (i, (sideText, accountText, amount)) = + ( i + , accountText + , amount + , if normalizeTitle sideText == T.pack "side" + then Right Side + else parseSide sideText + , if normalizeTitle accountText == T.pack "accounttitle" + then Right AccountTitle + else parseAccountTitle accountText + ) + +certStructuralErrors :: (HatVal v) + => ProcessingContext + -> [CertPosting v] + -> [EntryError v] +certStructuralErrors context rows = + [ EmptyEntry | null rows ] ++ concatMap rowErrors rows + where + rowErrors (i, _, amount, sideResult, accountResult) = + [ EntryParse i err | Left err <- [sideResult] ] + ++ [ NonPositiveAmount i (resolvedOrWildcard accountResult) amount + | isErrorValue amount || not (amount > 0) + ] + ++ [ WildcardAccount i | Right AccountTitle <- [accountResult] ] + ++ [ WildcardSide i | Right Side <- [sideResult] ] + ++ [ PostingNotAllowed i account capability context + | Right account <- [accountResult] + , account /= AccountTitle + , let capability = postingCapabilityFor account + , not (postingAllowedIn context capability) + ] + + resolvedOrWildcard (Right account) = account + resolvedOrWildcard (Left _) = AccountTitle + +certTotals :: (HatVal v) => [CertPosting v] -> (v, v) +certTotals rows = + ( L.foldl' (+) 0 + [ amount | (_, _, amount, Right Debit, _) <- rows ] + , L.foldl' (+) 0 + [ amount | (_, _, amount, Right Credit, _) <- rows ] + ) + +-- | Compare source transactions against the note-indexed journal coverage. +-- +-- The journal side is inspected with 'toMap', giving the per-note 'Alg'. The +-- actual amount is each note's debit-side total, @norm . decL@. +-- +-- >>> let Right j = checkedJournal [("tx1", [(Debit, Cash, 100), (Credit, Sales, 100)])] :: Either (NonEmpty (JournalError String Double)) (Journal String Double (HatBase AccountTitles)) +-- >>> reconcileSources [("tx1", 100)] j +-- [] +-- >>> reconcileSources [("tx1", 90)] j +-- [AmountMismatch "tx1" 90.0 100.0] +-- >>> reconcileSources [("tx1", 100), ("tx2", 5)] j +-- [MissingSource "tx2"] +-- >>> let Right j2 = checkedJournal [("tx2", [(Debit, Cash, 5), (Credit, Sales, 5)])] :: Either (NonEmpty (JournalError String Double)) (Journal String Double (HatBase AccountTitles)) +-- >>> reconcileSources [("tx1", 100)] (j .+ j2) +-- [UnknownSource "tx2"] +reconcileSources :: (HatVal v, Note n, Ord n) + => [(n, v)] + -> Journal n v (HatBase AccountTitles) + -> [SourceError n v] +reconcileSources sources journal = + missing ++ unknown ++ mismatched + where + expected = M.fromList sources + actual = M.fromList (HM.toList (toMap journal)) + + missing = + [ MissingSource txid + | (txid, _) <- sources + , M.notMember txid actual + ] + + unknown = + [ UnknownSource txid + | txid <- M.keys actual + , M.notMember txid expected + ] + + mismatched = + [ AmountMismatch txid expectedAmount actualAmount + | (txid, expectedAmount) <- sources + , Just alg <- [M.lookup txid actual] + , let actualAmount = norm (decL alg) + , expectedAmount /= actualAmount + ] + +validateIndexed :: (HatVal v) + => ProcessingContext + -> Bool + -> [(Int, (Side, AccountTitles, v))] + -> [EntryError v] +validateIndexed context rawEmpty rows = + emptyErrors ++ rowErrors ++ imbalanceErrors + where + emptyErrors = [ EmptyEntry | rawEmpty ] + + rowErrors = concatMap validateRow rows + + validateRow (i, (side, account, amount)) = + [ NonPositiveAmount i account amount + | invalidAmount amount + ] + ++ [ WildcardAccount i | account == AccountTitle ] + ++ [ WildcardSide i | side == Side ] + ++ [ PostingNotAllowed i account capability context + | account /= AccountTitle + , let capability = postingCapabilityFor account + , not (postingAllowedIn context capability) + ] + + invalidAmount amount = isErrorValue amount || not (amount > 0) + + imbalanceErrors + | null rows = [] + | otherwise = + let (debitTotal, creditTotal) = totals rows rowErrors + in [ Imbalanced debitTotal creditTotal | debitTotal /= creditTotal ] + +totals :: (HatVal v) + => [(Int, (Side, AccountTitles, v))] + -> [EntryError v] + -> (v, v) +totals rows rowErrors + | null rowErrors = + let alg = journalFromSides (map snd rows) + in (norm (decL alg), norm (decR alg)) + | otherwise = + let debitTotal = L.foldl' (+) 0 + [ amount | (_, (Debit, _, amount)) <- rows ] + creditTotal = L.foldl' (+) 0 + [ amount | (_, (Credit, _, amount)) <- rows ] + in (debitTotal, creditTotal) diff --git a/src/ExchangeAlgebra/Convert/Csv.hs b/src/ExchangeAlgebra/Convert/Csv.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Convert/Csv.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : ExchangeAlgebra.Convert.Csv +Description : Fixed-schema CSV reader for general journal postings. + +A deliberately tiny, dependency-free (Text + scientific only) reader for a fixed +journal CSV schema, building on the pure normalisation\/parsing in +"ExchangeAlgebra.Convert". It is the read counterpart of the report\/ledger CSV +writers in "ExchangeAlgebra.Write" (writing is /not/ handled here). + +The schema is a header line @side,account,amount@ with an optional trailing +@note@ column: + +> side,account,amount +> debit,Cash,1000 +> credit,Sales,1000 + +Blank lines and lines whose first non-space character is @#@ are skipped; +surrounding whitespace on each field is trimmed; there is no quoting. The field +splitter 'splitTrim' is exported and shared with the equally minimal +@parseEdgeCsv@\/@parseCoefCsv@ readers in "ExchangeAlgebra.Simulate.Network", so +the two readers cannot drift apart on how a line is split. + +@account@ is resolved with 'parseAccountTitle' (canonical English names or the +Japanese\/abbreviation aliases), so unknown and ambiguous account names are +rejected. @side@ is resolved with 'parseSide'. @amount@ is parsed by a +caller-supplied function so the value type @v@ stays open; 'scientificAmount' +covers the common case (a non-negative decimal literal via 'Data.Scientific'). +All values are placed through the non-negative smart constructor @(.@)@ inside +'postingFromSide'. +-} +module ExchangeAlgebra.Convert.Csv + ( -- * Parsing journal CSV + parseJournalCsv + , parseJournalCsvWith + -- * Note-keyed journal (when the optional @note@ column is present) + , parseNotedJournalCsv + -- * Amount parsers + , scientificAmount + -- * Field splitting + , splitTrim + ) where + +import qualified Data.Scientific as Sci +import Data.Text (Text) +import qualified Data.Text as T + +import ExchangeAlgebra.Algebra ( Alg, HatVal, Redundant((.+)) ) +import ExchangeAlgebra.Algebra.Base ( AccountTitles, HatBase, Side ) +import ExchangeAlgebra.Convert ( ConvError(..) + , parseAccountTitle + , parseSide + , postingFromSide ) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import ExchangeAlgebra.Algebra (Alg) +-- >>> import ExchangeAlgebra.Algebra.Base (HatBase, AccountTitles) + +-- | Parse a non-negative decimal amount via 'Data.Scientific' (e.g. @"1000"@, +-- @"1000.50"@, @"1.5e3"@), converting to the value type @v@ exactly through +-- 'toRational' (so exact-decimal types such as @MoneyDecimal@ keep their +-- precision for terminating decimals). Negative amounts are rejected here so the +-- error is reported as a 'BadAmount' rather than surfacing later from @(.@)@. +-- +-- >>> scientificAmount "1000.50" :: Either ConvError Double +-- Right 1000.5 +-- >>> scientificAmount "-3" :: Either ConvError Double +-- Left (BadAmount "-3") +-- >>> scientificAmount "1,000" :: Either ConvError Double +-- Left (BadAmount "1,000") +scientificAmount :: (Fractional v) => Text -> Either ConvError v +scientificAmount t = + case reads (T.unpack (T.strip t)) :: [(Sci.Scientific, String)] of + [(s, "")] | s >= 0 -> Right (fromRational (toRational s)) + | otherwise -> Left (BadAmount t) + _ -> Left (BadAmount t) + +-- | Parse a fixed-schema journal CSV into a single algebra term, using +-- 'scientificAmount' for the amount column. The note column, if present, is +-- ignored at the 'Alg' level (use 'parseNotedJournalCsv' to keep notes). +-- +-- >>> let csv = "side,account,amount\ndebit,Cash,1000\ncredit,Sales,1000\n" +-- >>> parseJournalCsv csv :: Either ConvError (Alg Double (HatBase AccountTitles)) +-- Right 1000.00:@Not: Text -> Either ConvError (Alg v (HatBase AccountTitles)) +parseJournalCsv = parseJournalCsvWith scientificAmount + +-- | As 'parseJournalCsv', but with a caller-supplied amount parser, so the value +-- type @v@ need not be 'Fractional' (e.g. an integral or fixed-point reader). +parseJournalCsvWith :: (HatVal v) + => (Text -> Either ConvError v) + -> Text + -> Either ConvError (Alg v (HatBase AccountTitles)) +parseJournalCsvWith amount txt = do + rows <- parseRows amount txt + Right (foldr (\(s, a, v) acc -> postingFromSide s a v .+ acc) mempty rows) + +-- | Parse the rows of a journal CSV into @(Side, AccountTitles, value, note)@ +-- tuples, where @note@ is the optional 4th column (empty 'Text' if absent). The +-- note is returned as raw 'Text' so the caller can key an +-- 'ExchangeAlgebra.Journal.Journal' by it (the +-- 'ExchangeAlgebra.Journal.Note' instance for 'Text' makes the @(.|)@ operator +-- immediately applicable); this reader deliberately stays at the algebra +-- level and does not construct an 'ExchangeAlgebra.Journal.Journal' itself, to +-- avoid pulling the Journal module into the dependency-light conversion layer. +-- +-- >>> let csv = "side,account,amount,note\ndebit,Cash,1000,opening\n" +-- >>> parseNotedJournalCsv scientificAmount csv :: Either ConvError [(Side, AccountTitles, Double, Text)] +-- Right [(Debit,Cash,1000.0,"opening")] +parseNotedJournalCsv :: (HatVal v) + => (Text -> Either ConvError v) + -> Text + -> Either ConvError [(Side, AccountTitles, v, Text)] +parseNotedJournalCsv amount txt = do + keptHeader <- splitHeader txt + traverse (rowNoted amount) keptHeader + +-- | Split one line on commas and strip surrounding whitespace from each field. +-- No quoting is recognised, so a comma inside a field always separates. An +-- empty line yields a single empty field, matching 'T.splitOn'. +splitTrim :: Text -> [Text] +splitTrim = map T.strip . T.splitOn "," + +------------------------------------------------------------------ +-- Internal: minimal CSV plumbing (no quoting), header check, row parse. +------------------------------------------------------------------ + +-- Parse to bare (Side, AccountTitles, v) triples (note dropped). +parseRows :: (Text -> Either ConvError v) + -> Text + -> Either ConvError [(Side, AccountTitles, v)] +parseRows amount txt = do + keptHeader <- splitHeader txt + traverse (\fs -> (\(s, a, v, _) -> (s, a, v)) <$> rowNoted amount fs) keptHeader + +-- | Drop blank\/comment lines, validate the header (@side,account,amount@ with an +-- optional @note@ column), and return the remaining data rows as already-split, +-- trimmed field lists. +splitHeader :: Text -> Either ConvError [[Text]] +splitHeader txt = + case keptLines of + [] -> Left (MalformedCsv "empty CSV (no header)") + (h : body) + | header == ["side", "account", "amount"] + || header == ["side", "account", "amount", "note"] + -> Right (map splitTrim body) + | otherwise -> Left (MalformedCsv + ("unexpected header: " <> T.intercalate "," header + <> " (expected side,account,amount[,note])")) + where header = map T.toLower (splitTrim h) + where + keptLines = filter keep (T.lines txt) + keep l = let s = T.strip l in not (T.null s) && not ("#" `T.isPrefixOf` s) + +-- | Parse one already-split row into @(Side, AccountTitles, value, note)@. +rowNoted :: (Text -> Either ConvError v) + -> [Text] + -> Either ConvError (Side, AccountTitles, v, Text) +rowNoted amount fields = case fields of + [s, a, v] -> build s a v "" + [s, a, v, n] -> build s a v n + other -> Left (MalformedCsv + ("row expected 3 or 4 fields, got " + <> T.pack (show (length other)) <> ": " + <> T.intercalate "," other)) + where + build s a v n = do + side <- parseSide s + account <- parseAccountTitle a + value <- amount v + Right (side, account, value, n) diff --git a/src/ExchangeAlgebra/Journal.hs b/src/ExchangeAlgebra/Journal.hs --- a/src/ExchangeAlgebra/Journal.hs +++ b/src/ExchangeAlgebra/Journal.hs @@ -39,8 +39,9 @@ , Note(..) , NoteAxisKey(..) , NoteAxisPosting - , Journal(..) + , Journal , pattern ExchangeAlgebra.Journal.Zero + , mkJournal , (.|) , toAlg , toMap @@ -50,12 +51,16 @@ , sigma2When , sigmaOn , sigmaOnFromMap + , decTo , sigmaM , map + , replaceNotes , insert , projWithNote , projWithBase , projWithNoteBase + , projWithBaseNetNorm + , projWithNoteBaseNetNorm , projWithBaseNorm , projWithNoteNorm , filterWithNote @@ -66,7 +71,6 @@ import qualified ExchangeAlgebra.Algebra as EA import ExchangeAlgebra.Algebra.Base import ExchangeAlgebra.Algebra ( HatVal(..) - , HatBaseClass(..) , Alg(..) , Redundant(..) , Exchange(..) @@ -78,11 +82,11 @@ import Data.IntMap.Strict (IntMap) import qualified Data.HashSet as HSet import Data.HashSet (HashSet) -import Control.Parallel.Strategies (using, parTraversable, rdeepseq, NFData) +import Control.Parallel.Strategies (NFData) +import Control.DeepSeq (rnf) import qualified Data.Set as S import qualified Data.List as L import qualified Data.Map.Strict as M -import Data.Hashable import qualified Data.Text as T import qualified Control.Monad as CM import qualified Data.Binary as Binary @@ -176,6 +180,30 @@ -- indexing, mirroring how @toAxisKeys@ works for basis elements. -- For tuple Note types, each component becomes a separate axis. -- The default returns a single axis containing the Note itself. +-- +-- == Prefer an ADT note over @String@ +-- +-- A note's /event/ axis is best modelled as a small enumeration (an ADT) +-- rather than a @String@. A @String@ tag is a __stringly-typed semantic key__: +-- the same literal must appear at the write site (@.| (\"trade\", t)@) and at +-- every read site (@projWithNote [(\"trade\", t)]@), and a typo on either side +-- still type-checks — the projection just /silently matches nothing/. With an +-- ADT a mistyped constructor is a __compile error__, so reads and writes can +-- never drift apart. Add 'plank' as its own explicit constructor (the note is a +-- pointed set, so the blank tag is a distinguished element, not the empty +-- string): +-- +-- @ +-- data MTag = PlankTag | Trade | Production | Report | Closing | Carryover +-- deriving (Show, Eq, Ord, Enum, Bounded, Generic) +-- instance Hashable MTag +-- instance Note MTag where plank = PlankTag +-- type MNote = (MTag, Int) -- the tuple instance keeps the (event, term) index +-- @ +-- +-- (The @marketEx1@ example and the @SimEvent@ note in the test suite follow +-- this pattern.) If the ledger is ever spilled\/restored, also give the tag a +-- @Binary@ instance (structurally derivable from @Generic@). class (Show a, Eq a, Ord a, Hashable a, Typeable a) => Note a where plank :: a isPlank :: a -> Bool @@ -227,11 +255,18 @@ -- Stored in a base + delta two-layer structure with per-axis indices. -- Base index is lazy (built on first axis query), while delta index is updated incrementally. -- Updates are appended only to delta and periodically compacted into base. +-- +-- __Invariants.__ The constructor is not exported; build with 'mkJournal', +-- '(.|)' or 'fromList'. Its internal cache\/index fields @_jBaseAxis@ and +-- @_jDeltaAxis@ must be +-- exactly the Note axis indices (@buildNoteAxisPosting@) of @_jBase@ and +-- @_jDelta@ respectively. The axis-filtered query path ('filterByAxis') reads +-- those indices, so a value whose indices disagree with its maps yields wrong +-- answers silently (not an exception). data Journal n v b where Journal :: (Note n, HatVal v, HatBaseClass b) => { _jBase :: !(Map.HashMap n (Alg v b)) , _jDelta :: !(Map.HashMap n (Alg v b)) - , _jVersion :: !Int , _jBaseAxis :: NoteAxisPosting n , _jDeltaAxis :: !(NoteAxisPosting n) } -> Journal n v b @@ -247,14 +282,16 @@ (\acc n _ -> insertNoteAxisPosting (toNoteAxisKeys n) n acc) emptyNoteAxisPosting --- | Smart constructor for Journal. --- Base axis index is lazy; delta axis index is built eagerly. +-- | The only safe way to build a t'Journal' from a base layer and a delta +-- layer. It keeps the Note-axis indices consistent with both layers; see the +-- invariants note on t'Journal'. The base axis index is lazy, while the delta +-- axis index is built eagerly. {-# INLINE mkJournal #-} mkJournal :: (Note n, HatVal v, HatBaseClass b) - => Map.HashMap n (Alg v b) -> Map.HashMap n (Alg v b) -> Int -> Journal n v b -mkJournal base delta ver = Journal base delta ver baseIdx deltaIdx + => Map.HashMap n (Alg v b) -> Map.HashMap n (Alg v b) -> Journal n v b +mkJournal bs delta = Journal bs delta baseIdx deltaIdx where - ~baseIdx = buildNoteAxisPosting base + ~baseIdx = buildNoteAxisPosting bs !deltaIdx = buildNoteAxisPosting delta -- | Construct a Journal from a HashMap. @@ -263,7 +300,7 @@ {-# INLINE fromMap #-} fromMap :: (HatVal v, HatBaseClass b, Note n) => Map.HashMap n (Alg v b) -> Journal n v b -fromMap m = mkJournal m Map.empty 0 +fromMap m = mkJournal m Map.empty -- | Retrieve all entries of a Journal as a HashMap. -- Merges the base and delta layers. @@ -275,16 +312,24 @@ toMap = materializeMap {-# INLINE materializeMap #-} +-- Short-circuits when one layer is empty: returns the other layer verbatim +-- instead of building a fresh map via 'Map.unionWith'. This is the common +-- case for @fromMap@ products (delta empty — the Lite @sigma msgs id@ shape) +-- and for freshly @(.|)@-built journals (base empty). Values are untouched, +-- so the result is identical to the unconditional union +-- (audit R5 / ROAD_MAP P1b). materializeMap :: (HatVal v, HatBaseClass b, Note n) => Journal n v b -> Map.HashMap n (Alg v b) -materializeMap (Journal base delta _ _ _) = - Map.unionWith (.+) base delta +materializeMap (Journal bs delta _ _) + | Map.null delta = bs + | Map.null bs = delta + | otherwise = Map.unionWith (.+) bs delta {-# INLINE lookupNote #-} lookupNote :: (HatVal v, HatBaseClass b, Note n) => n -> Journal n v b -> Maybe (Alg v b) -lookupNote n (Journal base delta _ _ _) = - case (Map.lookup n delta, Map.lookup n base) of +lookupNote n (Journal bs delta _ _) = + case (Map.lookup n delta, Map.lookup n bs) of (Nothing, Nothing) -> Nothing (Just d, Nothing) -> Just d (Nothing, Just b) -> Just b @@ -293,27 +338,39 @@ {-# INLINE compactIfNeeded #-} compactIfNeeded :: (HatVal v, HatBaseClass b, Note n) => Journal n v b -> Journal n v b -compactIfNeeded j@(Journal base delta ver _ _) +compactIfNeeded j@(Journal bs delta _ _) | Map.size delta < deltaCompactThreshold = j - | otherwise = mkJournal (Map.unionWith (.+) base delta) Map.empty (ver + 1) + | otherwise = mkJournal (Map.unionWith (.+) bs delta) Map.empty {-# INLINE appendMap #-} appendMap :: (HatVal v, HatBaseClass b, Note n) => Map.HashMap n (Alg v b) -> Journal n v b -> Journal n v b -appendMap rhs j@(Journal base delta ver baseAxis deltaAxis) +appendMap rhs j@(Journal bs delta baseAxis deltaAxis) | Map.null rhs = j - | otherwise = compactIfNeeded $ Journal base delta' (ver + 1) baseAxis deltaAxis' + | otherwise = compactIfNeeded $ Journal bs delta' baseAxis deltaAxis' where (delta', deltaAxis') = Map.foldlWithKey' step (delta, deltaAxis) rhs step (!dAcc, !idxAcc) !k !v = - let !dMerged = case Map.lookup k dAcc of - Nothing -> v - Just dv -> dv .+ v - !keys = toNoteAxisKeys k - in if EA.isZero dMerged - then (Map.delete k dAcc, deleteNoteAxisPosting keys k idxAcc) - else (Map.insert k dMerged dAcc, insertNoteAxisPosting keys k idxAcc) + case Map.lookup k dAcc of + -- New note key: index it (insert) unless the value is zero. + Nothing + | EA.isZero v -> (dAcc, idxAcc) + | otherwise -> + ( Map.insert k v dAcc + , insertNoteAxisPosting (toNoteAxisKeys k) k idxAcc ) + -- Existing note key: 'k' is already in the delta axis index + -- (the index tracks exactly the keys present in delta, and the + -- note IS the key, so its axis keys are unchanged). The + -- re-insert was therefore idempotent — skip it. Only a result + -- that collapses to zero changes the index, via delete + -- (audit R5 / ROAD_MAP P1b). + Just dv -> + let !dMerged = dv .+ v + in if EA.isZero dMerged + then ( Map.delete k dAcc + , deleteNoteAxisPosting (toNoteAxisKeys k) k idxAcc ) + else ( Map.insert k dMerged dAcc, idxAcc ) instance ( Note n , HatVal v @@ -346,19 +403,19 @@ -- Complexity: O(1) isZero :: (HatVal v, HatBaseClass b, Note n) => Journal n v b -> Bool -isZero (Journal base delta _ _ _) = Map.null base && Map.null delta +isZero (Journal bs delta _ _) = Map.null bs && Map.null delta pattern Zero :: (HatVal v, HatBaseClass b, Note n) => Journal n v b pattern Zero <- (isZero -> True) where - Zero = mkJournal Map.empty Map.empty 0 + Zero = mkJournal Map.empty Map.empty -- | Smart constructor that attaches a Note (annotation) to an algebra element to build a Journal. -- -- Complexity: O(1) (.|) :: (HatVal v, HatBaseClass b, Note n) => Alg v b -> n -> Journal n v b -(.|) alg n = mkJournal Map.empty (Map.singleton n alg) 1 +(.|) alg n = mkJournal Map.empty (Map.singleton n alg) infixr 2 .| @@ -398,9 +455,24 @@ addJournal lhs rhs = appendMap (toMap rhs) lhs instance (HatVal v, HatBaseClass b, Note n) => Monoid (Journal n v b) where - mempty = mkJournal Map.empty Map.empty 0 + mempty = mkJournal Map.empty Map.empty mappend = (<>) +-- | Shallow-structural 'NFData', mirroring the @'Alg' v b@ instance in +-- "ExchangeAlgebra.Algebra": it forces the two-layer @base@ / @delta@ maps to +-- WHNF on their spines and forces every contained 'Alg' (via the 'Alg' 'NFData' +-- instance), but does not touch the lazily built axis indices (@_jBaseAxis@ / +-- @_jDeltaAxis@), which are derived caches. This is enough for +-- 'Control.Parallel.Strategies.rdeepseq' to fully evaluate journal "messages" +-- before merging them in parallel. +instance NFData (Journal n v b) where + rnf (Journal bs delta _ _) = + Map.foldr (\alg acc -> rnf alg `seq` acc) + (Map.foldr (\alg acc -> rnf alg `seq` acc) + () + bs) + delta + instance (HatVal v, HatBaseClass b, Note n) => Redundant (Journal n) v b where (.^) = map (.^) (.+) = mappend @@ -427,23 +499,44 @@ l = (norm . decL) xs ------------------------------------------------------------------ --- | fromList +-- | Build a t'Journal' from a list of postings. @O(N)@ via a strict left fold +-- (@L.foldl' (.+) mempty@). -- +-- == Why a strict left fold +-- +-- This was previously a lazy right fold (@foldr (.+) mempty@), kept that way to +-- freeze the same-base accumulation order for 'Double' (whose addition is +-- non-associative, so reordering shifts the last-ULP of 'norm'). The strict left +-- fold is far cheaper at scale — the lazy right fold builds a deep right-nested +-- thunk that is expensive to force (≈40x at N=20000, ~15x at N=10000 in the core +-- benchmark). The fold direction was switched to the fast version once the +-- audited/exact path moved to t'ExchangeAlgebra.Value.MoneyDecimal'; see +-- plans/in-progress/LAZY_EVAL_AUDIT.md and SELECTABLE_VALUE_TYPE_PLAN.md. +-- +-- == Behaviour contract +-- +-- 'fromList' preserves the /multiset/ of postings exactly (no posting is added, +-- dropped, or merged across bases that would otherwise be kept apart). When two +-- postings collide on the /same note key and same base/ (and therefore land in +-- one 'ExchangeAlgebra.Algebra.Alg' sequence) the strict left fold orders that +-- @Seq@ opposite to the old lazy right fold. That order is observable through +-- 'Eq' \/ 'Show' \/ 'toAlg' \/ @Binary@, and for 'Double' through the last-ULP of +-- 'norm' \/ 'bar' (IEEE-754 addition is non-associative). Postings that differ in +-- note or base land in separate map entries and are unaffected. +-- +-- For an /exact/ value type (t'ExchangeAlgebra.Value.MoneyDecimal') addition is +-- associative, so 'norm' \/ 'bar' \/ balance are independent of construction order +-- (the fold direction here, parallel merges, etc.). Use +-- t'ExchangeAlgebra.Value.MoneyDecimal' when you need +-- deterministic, auditable totals. +-- -- >>> type Test = Journal String Double (HatBase AccountTitles) -- >>> x = [(1.00:@Hat:>> fromList x -- 1.00:@Hat: [Journal n v b] -> Journal n v b -fromList = foldr (.+) mempty +fromList = L.foldl' (.+) mempty ------------------------------------------------------------------ {-# INLINE mergeJournalMap #-} @@ -451,10 +544,10 @@ => Map.HashMap n (Alg v b) -> Journal n v b -> Map.HashMap n (Alg v b) -mergeJournalMap !acc (Journal base delta _ _ _) - | Map.null base && Map.null delta = acc +mergeJournalMap !acc (Journal bs delta _ _) + | Map.null bs && Map.null delta = acc | otherwise = - let !acc1 = Map.foldlWithKey' mergeOne acc base + let !acc1 = Map.foldlWithKey' mergeOne acc bs in Map.foldlWithKey' mergeOne acc1 delta where mergeOne !m !n !alg @@ -531,13 +624,49 @@ then mempty else alg .| n +-- | Quotient decomposition into the Journal (dec_κ landing on the graded +-- carrier): partition an 'Alg' along the classes induced by a classifier and +-- return the family as a t'Journal' keyed by the class 'Note'. +-- +-- A t'Journal' is exactly a finite map @Note → Alg@ (paper Definition 12), i.e. +-- the library's native \"keyed family of algebras\" — so the decomposition +-- stays inside the algebra vocabulary (no external container in the result). +-- Each note's entry is the redundancy-preserving restriction of the input to +-- that class (same guarantees as 'EA.decBy'): no 'bar', no aggregation, and +-- @norm (decTo keyOf x) + norm residual == norm x@ (norm additivity of the +-- decomposition). +-- +-- Entries classified to @Nothing@ or to 'plank' are dropped as residual +-- ('plank' is the blank note and cannot carry a class). +-- +-- Complexity: O(m) single pass (via 'EA.decBy') + O(k) journal construction. +-- +-- >>> type TJ = Journal String Double (HatBase AccountTitles) +-- >>> let alg = 100 :@ Not:>> let j = decTo (\(_ :< a) -> Just (if a == Cash then "cash" else "other")) alg :: TJ +-- >>> norm j +-- 180.0 +-- +-- >>> norm (projWithNote ["cash"] j) +-- 130.0 +{-# INLINE decTo #-} +decTo :: (HatVal v, HatBaseClass b, Note n) + => (b -> Maybe n) + -> Alg v b + -> Journal n v b +decTo kf x = + fromMap $ Map.fromList + [ (n, alg) + | (n, alg) <- M.toList (EA.decBy kf x) + , not (isPlank n) ] + -- | Summation in a monadic context. Applies a monadic function to each element and mconcats the results. -- -- Complexity: O(|xs| * cost(f)) -- -- NOTE: kept as @mconcat <$> forM xs f@ deliberately. A strict @foldM@ left fold -- was tried (plan WI-3) but it changes the '<>' association order, which for --- 'Alg'/'Journal' reorders the audit-trail sequence and (via non-associative +-- 'Alg'/t'Journal' reorders the audit-trail sequence and (via non-associative -- 'Double' addition) shifts 'norm' results. Although the 'Monoid' laws make the -- value equal in exact arithmetic, it is observably different under floating point. -- See plans/in-progress/LAZY_EVAL_AUDIT.md (WI-3). @@ -550,11 +679,11 @@ -- Complexity: O(total number of base keys across all Notes) toAlg :: (HatVal v, HatBaseClass b, Note n) => Journal n v b -> Alg v b -toAlg (Journal base delta _ _ _) = +toAlg (Journal bs delta _ _) = -- Fold base's elements directly onto delta's element list instead of -- @Map.elems base ++ Map.elems delta@, which avoids materializing the -- separate @Map.elems base@ list and the @(++)@ traversal. - EA.unionsMerge (Map.foldr (:) (Map.elems delta) base) + EA.unionsMerge (Map.foldr (:) (Map.elems delta) bs) ------------------------------------------------------------------ -- | Apply function f to the entry of each Note in the Journal. @@ -565,14 +694,21 @@ => (Alg v b -> Alg v b) -> Journal n v b -> Journal n v b map f = fromMap . Map.map f . toMap -parallelMap :: (NFData b, Ord k) => (a -> b) -> Map.HashMap k a -> Map.HashMap k b -parallelMap f m = Map.map f m `using` parTraversable rdeepseq +-- NB. The unused 'parallelMap'\/'parMap' helpers (a 'Control.Parallel.Strategies' +-- based variant of 'map') were removed as dead code: neither was exported nor +-- called. Reintroduce from history if a parallel journal map is needed. -parMap :: (HatVal v, HatBaseClass b, Note n) - => (Alg v b -> Alg v b) -> Journal n v b -> Journal n v b -parMap f = fromMap . parallelMap f . toMap +-- | Left-biased replacement of whole Notes. If a Note in the left Journal also +-- exists in the right Journal, the complete left value replaces the right +-- value. This is not redundant addition; contrast with '(.+)'. +-- +-- Complexity: O(n + m) where n, m are the number of Notes in each Journal +replaceNotes :: (HatVal v, HatBaseClass b, Note n) + => Journal n v b -> Journal n v b -> Journal n v b +replaceNotes x y = fromMap (Map.union (toMap x) (toMap y)) --- | Insert x into y. If x's Note already exists in y, it is overwritten with x's value. +{-# DEPRECATED insert "Use replaceNotes; insert replaces whole notes and is not the redundant (.+)" #-} +-- | Deprecated alias for 'replaceNotes'. -- -- >>> type Test = Journal String Double (HatBase AccountTitles) -- >>> x = 10.00:@Not: Journal n v b -> Journal n v b -> Journal n v b --- Complexity: O(n + m) where n, m are the number of Notes in each Journal -insert x y = fromMap (Map.union (toMap x) (toMap y)) +insert = replaceNotes ------------------------------------------------------------------ -- | projWithNote -- Projecting with Note. -- +-- A query list containing 'plank' acts as a __wildcard__: the journal is +-- returned unchanged (the blank note matches every note). +-- -- >>> type Test = Journal String Double (HatBase CountUnit) -- >>> x = 1.00:@Hat:>> y = 2.00:@Hat: [b] -> Journal n v b -> Journal n v b -{-# INLINE [0] projWithBase #-} +{-# INLINE projWithBase #-} projWithBase [] _ = mempty projWithBase bs js = fromMap $ Map.map (EA.proj bs) (toMap js) --- | Directly compute the norm after filtering by the specified bases. --- Equivalent to @norm (projWithBase bs js)@ but without constructing an intermediate Journal. +-- | Directly compute the /bar-netted/ norm of a base projection, without +-- constructing an intermediate Journal. Per note this applies 'EA.projNetNorm', +-- which nets each projected base's hat and not sides (the positive-part +-- normalization); hence -- +-- @projWithBaseNetNorm bs js == norm (map bar (projWithBase bs js))@ +-- +-- which is __not__ the same as @norm (projWithBase bs js)@ when a query +-- (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'. +-- -- Complexity: O(j * proj cost) where j is the number of Notes -projWithBaseNorm :: (HatVal v, HatBaseClass b, Note n) +projWithBaseNetNorm :: (HatVal v, HatBaseClass b, Note n) => [b] -> Journal n v b -> v -projWithBaseNorm [] _ = 0 -projWithBaseNorm bs js = - Map.foldl' (\acc alg -> acc + EA.projNorm bs alg) 0 (toMap js) +projWithBaseNetNorm [] _ = 0 +projWithBaseNetNorm bs js = + Map.foldl' (\acc alg -> acc + EA.projNetNorm bs alg) 0 (toMap js) ------------------------------------------------------------------ -- | projWithNoteBase -- Projecting with Note and Base. -- +-- 'plank' in the note list acts as a note-wildcard: the projection widens to +-- all notes (falls back to 'projWithBase'). +-- -- >>> type Test = Journal String Double (HatBase CountUnit) -- >>> x = 1.00:@Hat:>> y = 2.00:@Not: [n] -> [b] -> Journal n v b -> Journal n v b -{-# INLINE [0] projWithNoteBase #-} +{-# INLINE projWithNoteBase #-} projWithNoteBase _ [] _ = mempty projWithNoteBase ns bs js | any isPlank ns = projWithBase bs js @@ -666,34 +816,59 @@ Map.empty (S.fromList ns) --- | Directly compute the norm after filtering by the specified Notes and bases. --- Equivalent to @norm (projWithNoteBase ns bs js)@ but without constructing an intermediate Journal. +-- | Directly compute the /bar-netted/ norm of a note-and-base projection, +-- without constructing an intermediate Journal. Like 'projWithBaseNetNorm' this +-- goes through 'EA.projNetNorm', so per note each projected base is netted +-- (positive-part normalization): -- +-- @projWithNoteBaseNetNorm ns bs js == norm (map bar (projWithNoteBase ns bs js))@ +-- +-- 'plank' in the note list acts as a note-wildcard (widens to all notes, like +-- 'projWithNote'). +-- +-- which is __not__ the same as @norm (projWithNoteBase ns bs js)@ when a query +-- selects both sides of one base (see 'projWithBaseNetNorm'). +-- -- Complexity: O(|ns| * proj cost) -projWithNoteNorm :: (HatVal v, HatBaseClass b, Note n) +projWithNoteBaseNetNorm :: (HatVal v, HatBaseClass b, Note n) => [n] -> [b] -> Journal n v b -> v -projWithNoteNorm _ [] _ = 0 -projWithNoteNorm ns bs js - | any isPlank ns = projWithBaseNorm bs js -projWithNoteNorm [n] bs js = case lookupNote n js of +projWithNoteBaseNetNorm _ [] _ = 0 +projWithNoteBaseNetNorm ns bs js + | any isPlank ns = projWithBaseNetNorm bs js +projWithNoteBaseNetNorm [n] bs js = case lookupNote n js of Nothing -> 0 - Just a -> EA.projNorm bs a -projWithNoteNorm [] bs js = projWithBaseNorm bs js -projWithNoteNorm ns bs js = + Just a -> EA.projNetNorm bs a +projWithNoteBaseNetNorm [] bs js = projWithBaseNetNorm bs js +projWithNoteBaseNetNorm ns bs js = S.foldl' (\acc n -> case lookupNote n js of Nothing -> acc - Just a -> acc + EA.projNorm bs a) + Just a -> acc + EA.projNetNorm bs a) 0 (S.fromList ns) -{-# RULES -"EJ.projWithBaseNorm/from-norm-projWithBase" - forall bs js. norm (projWithBase bs js) = projWithBaseNorm bs js -"EJ.projWithNoteNorm/from-norm-projWithNoteBase" - forall ns bs js. norm (projWithNoteBase ns bs js) = projWithNoteNorm ns bs js - #-} +-- NB. Two RULES that rewrote @norm (projWithBase bs js)@ to 'projWithBaseNetNorm' +-- (and the note-base analogue) were REMOVED here: the equation is false whenever +-- a query selects both sides of one base (e.g. a @HatNot@ wildcard) — the +-- left-hand side sums both sides, the right-hand side bar-nets them (verified: +-- 14.0 vs 6.0 on a both-sided base). A rewrite rule must be semantics-preserving; +-- callers who want the fused netted read-out call 'projWithBaseNetNorm' \/ +-- 'projWithNoteBaseNetNorm' explicitly. +{-# DEPRECATED projWithBaseNorm "renamed to 'projWithBaseNetNorm': the result is bar-netted per base, which the old name concealed. Will be removed in 0.6" #-} +-- | Deprecated alias for 'projWithBaseNetNorm' (renamed in 0.5.0.0 so the name +-- states the bar-netting). +projWithBaseNorm :: (HatVal v, HatBaseClass b, Note n) + => [b] -> Journal n v b -> v +projWithBaseNorm = projWithBaseNetNorm + +{-# DEPRECATED projWithNoteNorm "renamed to 'projWithNoteBaseNetNorm': it takes note AND base queries and the result is bar-netted per base — both were missing from the old name. Will be removed in 0.6" #-} +-- | Deprecated alias for 'projWithNoteBaseNetNorm' (renamed in 0.5.0.0 so the +-- name states both the base argument and the bar-netting). +projWithNoteNorm :: (HatVal v, HatBaseClass b, Note n) + => [n] -> [b] -> Journal n v b -> v +projWithNoteNorm = projWithNoteBaseNetNorm + ------------------------------------------------------------------ -- | Filter by a predicate on Note-entry pairs. -- Applies the filter to both the base and delta layers. @@ -701,10 +876,10 @@ -- Complexity: O(n) where n is the number of Notes filterWithNote :: (HatVal v, HatBaseClass b, Note n) => (n -> Alg v b -> Bool) -> Journal n v b -> Journal n v b -filterWithNote f (Journal base delta ver _ _) = - let !base' = Map.filterWithKey f base +filterWithNote f (Journal bs delta _ _) = + let !base' = Map.filterWithKey f bs !delta' = Map.filterWithKey f delta - in mkJournal base' delta' ver + in mkJournal base' delta' -- | Efficiently filter a Journal to entries whose Note matches on the specified axis. -- Uses base/delta NoteAxisPosting indices for O(|result|) retrieval after index construction. @@ -730,7 +905,7 @@ {-# INLINE filterByAxis #-} filterByAxis :: (HatVal v, HatBaseClass b, Note n) => Int -> NoteAxisKey -> Journal n v b -> Journal n v b -filterByAxis axis key j@(Journal _ _ _ baseIdx deltaIdx) = +filterByAxis axis key j@(Journal _ _ baseIdx deltaIdx) = let !matched = HSet.union (queryNoteAxisPosting axis key baseIdx) (queryNoteAxisPosting axis key deltaIdx) diff --git a/src/ExchangeAlgebra/Journal/Transfer.hs b/src/ExchangeAlgebra/Journal/Transfer.hs --- a/src/ExchangeAlgebra/Journal/Transfer.hs +++ b/src/ExchangeAlgebra/Journal/Transfer.hs @@ -28,58 +28,37 @@ module ExchangeAlgebra.Journal.Transfer - ( TransTable (..) + ( TransTable , isNullTable , table , TransTableParts , (.->) , (|%) , ExchangeAlgebra.Journal.Transfer.transfer + , ExchangeAlgebra.Journal.Transfer.createTransfer , ExchangeAlgebra.Journal.Transfer.incomeSummaryAccount , ExchangeAlgebra.Journal.Transfer.netIncomeTransfer , ExchangeAlgebra.Journal.Transfer.grossProfitTransfer , ExchangeAlgebra.Journal.Transfer.ordinaryProfitTransfer , ExchangeAlgebra.Journal.Transfer.retainedEarningTransfer + , ExchangeAlgebra.Journal.Transfer.finalStockTransferAggregated , ExchangeAlgebra.Journal.Transfer.finalStockTransfer ) where -import qualified ExchangeAlgebra.Algebra as EA import ExchangeAlgebra.Algebra hiding (map) import qualified ExchangeAlgebra.Algebra.Transfer as EAT -import ExchangeAlgebra.Algebra.Transfer (TransTable (..) +import ExchangeAlgebra.Algebra.Transfer (TransTable , isNullTable , table , TransTableParts , (.->) , (|%) - , finalStockTransferStep - , retainedEarningTransfer - , ordinaryProfitTransfer - , grossProfitTransfer) + , finalStockTransferStep) import qualified ExchangeAlgebra.Journal as EJ import ExchangeAlgebra.Journal hiding () -import qualified Number.NonNegative as NN ( Double - , fromNumber - , toNumber,T) -- Non-negative real numbers -import qualified Data.Maybe as Maybe -import Text.Show.Unicode ( ushow) -import GHC.Exts ( reallyUnsafePtrEquality# - , isTrue# - , build - , lazy) -import Data.Semigroup ( Semigroup(stimes) - , stimesIdempotentMonoid) -import Data.Monoid ( Monoid(..)) -import qualified Data.Foldable as Foldable -import Data.Foldable ( Foldable()) -import Data.Bits ( shiftL - , shiftR) -import Utils.Containers.Internal.StrictPair -import Debug.Trace - -- | Apply transfer transformations to each Note entry in a Journal. -- Wildcard portions within tuples are not transformed and retain their original values. -- @@ -98,14 +77,20 @@ -- | Compute net income for the current period (Income Summary Account). -- Calculate the debit-credit difference and add it as NetIncome or NetLoss to the plank Note. -- When the ledger is balanced (credit == debit, net income is zero), @diffRL@ reports the --- wildcard 'Side'; in that case the journal is returned unchanged. +-- wildcard v'Side'; in that case the journal is returned unchanged (balanced ledger = +-- identity). Appending @Zero .| plank@ is not an identity for t'Journal' because @(.|)@ builds +-- a @Map.singleton plank Zero@ and drives version/compaction, so the input is returned directly. +-- 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". -- -- Complexity: O(s) (s = total number of scalar entries) incomeSummaryAccount :: (Note n, HatVal v, ExBaseClass b) => Journal n v b -> Journal n v b incomeSummaryAccount js = let (dc,diff) = diffRL js in case dc of - Credit -> js .+ ((diff :@ (toNot wiledcard) .~ NetIncome) .| plank) - Debit -> js .+ ((diff :@ (toNot wiledcard) .~ NetLoss) .| plank) + Credit -> js .+ ((diff :@ (toNot wildcard) .~ NetIncome) .| plank) + Debit -> js .+ ((diff :@ (toNot wildcard) .~ NetLoss) .| plank) Side -> js -- | Net income transfer (Journal version). Transfer NetIncome/NetLoss to RetainedEarnings for each Note. @@ -116,13 +101,15 @@ -- ** Journalizing --- | Gross profit transfer (Journal version). Aggregate sales and cost accounts into GrossProfit for each Note. +-- | Historical SNA/simulation gross-profit transfer (Journal version). +-- This delegates to the legacy fixed-list rule and is not a JGAAP subtotal. -- -- Complexity: O(j * s) grossProfitTransfer :: (Note n, HatVal v, ExBaseClass b) => Journal n v b -> Journal n v b grossProfitTransfer = EJ.map EAT.grossProfitTransfer --- | Ordinary Profit Transfer +-- | Historical SNA/simulation ordinary-profit transfer (Journal version). +-- The fixed list predates the JCCI chart and is not a JGAAP subtotal. -- -- >>> type Test = Journal String Double (HatBase (CountUnit, AccountTitles)) -- >>> x = 2279.0:@Not:<(Yen,Depreciation) .| "A" :: Test @@ -139,9 +126,18 @@ retainedEarningTransfer :: (Note n, HatVal v, ExBaseClass b) => Journal n v b -> Journal n v b retainedEarningTransfer = EJ.map EAT.retainedEarningTransfer --- | Income summary account (Journal version). Transfer all cost and revenue accounts to RetainedEarnings, then offset using the Bar operation. +-- | Apply the Algebra-level closing to every Note and then fold the Note axis +-- onto the plank via the Journal's '(.-)'. The per-Note lift without folding is +-- @EJ.map EAT.finalStockTransfer@. -- -- Complexity: O(j * s) -finalStockTransfer ::(Note n, HatVal v, ExBaseClass b) => Journal n v b -> Journal n v b -finalStockTransfer = (.-) . EJ.map finalStockTransferStep +finalStockTransferAggregated ::(Note n, HatVal v, ExBaseClass b) => Journal n v b -> Journal n v b +finalStockTransferAggregated = (.-) . EJ.map finalStockTransferStep +-- | Compatibility name for 'finalStockTransferAggregated'. +-- Its behaviour is unchanged: it closes each Note and folds the Note axis onto +-- the plank. +-- +-- Complexity: O(j * s) +finalStockTransfer ::(Note n, HatVal v, ExBaseClass b) => Journal n v b -> Journal n v b +finalStockTransfer = finalStockTransferAggregated diff --git a/src/ExchangeAlgebra/Optimize.hs b/src/ExchangeAlgebra/Optimize.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Optimize.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE TypeFamilies #-} + +{- | + Module : ExchangeAlgebra.Optimize + Copyright : (c) Kaya Akagi. 2026 + License : OtherLicense + + A pluggable optimization solver interface. + + This module defines the strategy-agnostic 'Solver' class. Concrete + strategies live in sibling modules: + + * "ExchangeAlgebra.Optimize.Annealing" — simulated annealing over an + arbitrary candidate type. + * "ExchangeAlgebra.Optimize.GA" — a real-coded genetic algorithm over + numeric vector chromosomes. + + New strategies (differential evolution, particle swarm, CMA-ES, ...) + are added by defining a new strategy type with a 'Solver' instance; + the interface itself does not change. + + == Design notes + + * The objective is monadic (@'Candidate' strategy -> m Double@) so that + it can run stateful simulations, e.g. the @ST s@ state spaces of + "ExchangeAlgebra.Simulate". Solvers only require 'Monad', nothing + stronger. + * Randomness is threaded internally by each solver from a seed in its + 'Config' (a pure generator, sequentially updated), so no random-monad + constraint leaks into the objective. Runs are reproducible given the + same seed /provided the objective itself is deterministic/ (same + state transitions, no external randomness, clocks or concurrency). + * The returned 'Double' is the objective value observed when the + returned candidate was evaluated, in the user's orientation. + Solvers never re-evaluate a candidate they have already scored + (re-evaluation would be a visible side effect for stateful + objectives such as @ST s@ simulations). + * Objective values must be finite: solvers reject @NaN@ and + infinities with a call to 'error' as soon as they are observed, + because non-finite energies silently break comparisons, sorting + and best-candidate tracking. Configurations are also validated + up front (fail-fast; invalid settings are never clamped). + * This subsystem is a generic numeric layer: it does not touch the + redundant-algebra core ("ExchangeAlgebra.Algebra", + "ExchangeAlgebra.Journal") and imposes no Hat\/Not or non-negativity + semantics on candidates. Objective values are plain 'Double's in the + user's orientation (see 'Direction'). + * Parallel evaluation of candidates is deliberately left to the caller + (e.g. run several 'optimize' calls with different seeds and pick the + best); solvers themselves evaluate sequentially. +-} +module ExchangeAlgebra.Optimize + ( -- * Solver interface + Solver (..) + -- * Optimization direction + , Direction (..) + , orient + ) where + +-- | Whether the objective is to be maximized or minimized. +-- +-- Solvers convert objective values to an internal /minimization energy/ +-- ('orient') and report the final score back in the user's orientation. +data Direction = Maximize | Minimize + deriving (Show, Eq) + +-- | Convert a score in the user's orientation to a minimization energy. +-- +-- >>> orient Minimize 3.0 +-- 3.0 +-- +-- >>> orient Maximize 3.0 +-- -3.0 +orient :: Direction -> Double -> Double +orient Minimize = id +orient Maximize = negate +{-# INLINE orient #-} + +-- | A pluggable optimization strategy. +-- +-- @strategy@ is a dispatch value carrying no data of its own — a +-- /proxy/ such as @GA@ ("ExchangeAlgebra.Optimize.GA") or @Annealing@ +-- ("ExchangeAlgebra.Optimize.Annealing"). The associated types fix what +-- a candidate solution looks like and what configuration the strategy +-- needs. +class Solver strategy where + -- | Candidate solution type searched by this strategy. + type Candidate strategy + -- | Strategy-specific configuration (schedules, rates, seed, + -- 'Direction', ...). + type Config strategy + + -- | Run the optimizer: given a configuration, a monadic objective and + -- an initial candidate, return the best candidate found together + -- with its objective value (in the user's orientation). + optimize :: Monad m + => strategy + -> Config strategy + -> (Candidate strategy -> m Double) -- ^ objective + -> Candidate strategy -- ^ initial candidate + -> m (Candidate strategy, Double) diff --git a/src/ExchangeAlgebra/Optimize/Annealing.hs b/src/ExchangeAlgebra/Optimize/Annealing.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Optimize/Annealing.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} + +{- | + Module : ExchangeAlgebra.Optimize.Annealing + Copyright : (c) Kaya Akagi. 2026 + License : OtherLicense + + Simulated annealing over an arbitrary candidate type. + + The candidate type is free (@a@ in @t'Annealing' a@): investment + schedules, parameter records, vectors, ... — anything the + 'acNeighbor' move can perturb. The objective may be stateful + (e.g. run an @ST s@ simulation); see "ExchangeAlgebra.Optimize" + for the interface contract. + + == Example + + Minimize @(x - 3)^2@ over 'Double': + + > import ExchangeAlgebra.Optimize + > import ExchangeAlgebra.Optimize.Annealing + > import System.Random (uniformR) + > import Data.Functor.Identity (runIdentity) + > + > cfg :: AnnealingConfig Double + > cfg = AnnealingConfig + > { acDirection = Minimize + > , acSteps = 2000 + > , acSchedule = geometricCooling 1.0 0.995 + > , acNeighbor = \g x -> let (d, g') = uniformR (-0.5, 0.5) g + > in (x + d, g') + > , acAccept = metropolis + > , acSeed = 42 + > } + > + > best :: (Double, Double) + > best = runIdentity (optimize Annealing cfg (\x -> pure ((x - 3)^2)) 0) +-} +module ExchangeAlgebra.Optimize.Annealing + ( -- * Strategy + Annealing (..) + , AnnealingConfig (..) + -- * Standard building blocks + , geometricCooling + , metropolis + ) where + +import ExchangeAlgebra.Optimize +import System.Random (StdGen, mkStdGen, uniformR) + +-- | Simulated-annealing strategy proxy. The phantom @a@ is the candidate +-- type; it is inferred from the t'AnnealingConfig' at the call site, so +-- plain @'optimize' Annealing cfg obj x0@ needs no annotation. +data Annealing a = Annealing + +-- | Configuration of one annealing run. +-- +-- Energies passed to 'acAccept' are /minimization-oriented/ ('orient' +-- applied), regardless of 'acDirection'. +data AnnealingConfig a = AnnealingConfig + { acDirection :: Direction + -- ^ Whether the objective is maximized or minimized. + , acSteps :: Int + -- ^ Total number of proposal steps (@>= 0@; @0@ evaluates the + -- initial candidate once and returns it). + , acSchedule :: Int -> Double + -- ^ Cooling schedule: 1-based step number to temperature. + -- Each temperature must be finite and @>= 0@ (@0@ acts as greedy + -- acceptance); anything else is rejected with 'error'. + , acNeighbor :: StdGen -> a -> (a, StdGen) + -- ^ Proposal move: perturb the current candidate, threading the + -- solver's random generator. + , acAccept :: Double -> Double -> Double -> Double + -- ^ Acceptance rule: @temperature -> current energy -> proposed + -- energy -> probability@. The probability must be finite and in + -- @[0, 1]@ (validated at every step). See 'metropolis'. + , acSeed :: Int + -- ^ Seed of the solver's internal random generator. + } + +-- | Geometric cooling: @geometricCooling t0 alpha step = t0 * alpha^(step-1)@. +-- +-- Typical use: @'geometricCooling' 1.0 0.995@. +geometricCooling :: Double -- ^ initial temperature @t0@ + -> Double -- ^ decay factor @alpha@ (usually just below 1) + -> Int -- ^ 1-based step + -> Double +geometricCooling t0 alpha step = t0 * alpha ^^ (step - 1) + +-- | The Metropolis acceptance rule: always accept an improvement, +-- otherwise accept with probability @exp ((e - e') / t)@. +-- At @t = 0@ this degenerates to greedy acceptance. +metropolis :: Double -- ^ temperature + -> Double -- ^ current energy + -> Double -- ^ proposed energy + -> Double +metropolis t e e' + | e' <= e = 1 + | t <= 0 = 0 + | otherwise = exp ((e - e') / t) + +instance Solver (Annealing a) where + type Candidate (Annealing a) = a + type Config (Annealing a) = AnnealingConfig a + + optimize _ cfg obj x0 + | acSteps cfg < 0 + = error ("ExchangeAlgebra.Optimize.Annealing: acSteps must be >= 0, got " + ++ show (acSteps cfg)) + | otherwise + = do e0 <- energyOf dir "initial candidate" (obj x0) + go 1 (mkStdGen (acSeed cfg)) x0 e0 x0 e0 + where + dir = acDirection cfg + go !step !g !cur !eCur !best !eBest + | step > acSteps cfg = return (best, orient dir eBest) + -- orient is self-inverse: energy back to the user's score. + | otherwise = do + let t = checkTemperature step (acSchedule cfg step) + (cand, g1) = acNeighbor cfg g cur + eCand <- energyOf dir ("step " ++ show step) (obj cand) + let p = checkProbability step (acAccept cfg t eCur eCand) + (u, g2) = uniformR (0 :: Double, 1) g1 + accepted = p >= 1 || u < p + (cur', eCur') | accepted = (cand, eCand) + | otherwise = (cur, eCur) + (best', eBest') | eCand < eBest = (cand, eCand) + | otherwise = (best, eBest) + go (step + 1) g2 cur' eCur' best' eBest' + +-- | Evaluate the objective and convert to minimization energy, rejecting +-- non-finite scores (see the contract in "ExchangeAlgebra.Optimize"). +energyOf :: Monad m => Direction -> String -> m Double -> m Double +energyOf dir what mScore = do + s <- mScore + if isNaN s || isInfinite s + then error ("ExchangeAlgebra.Optimize.Annealing: objective returned " + ++ "a non-finite score (" ++ show s ++ ") at " ++ what) + else return (orient dir s) + +checkTemperature :: Int -> Double -> Double +checkTemperature step t + | isNaN t || isInfinite t || t < 0 + = error ("ExchangeAlgebra.Optimize.Annealing: acSchedule returned an " + ++ "invalid temperature (" ++ show t ++ ") at step " ++ show step) + | otherwise = t + +checkProbability :: Int -> Double -> Double +checkProbability step p + | isNaN p || isInfinite p || p < 0 || p > 1 + = error ("ExchangeAlgebra.Optimize.Annealing: acAccept returned an " + ++ "invalid probability (" ++ show p ++ ") at step " ++ show step) + | otherwise = p diff --git a/src/ExchangeAlgebra/Optimize/GA.hs b/src/ExchangeAlgebra/Optimize/GA.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Optimize/GA.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} + +{- | + Module : ExchangeAlgebra.Optimize.GA + Copyright : (c) Kaya Akagi. 2026 + License : OtherLicense + + A real-coded genetic algorithm over numeric vector chromosomes + (@'U.Vector' 'Double'@). + + Generational scheme with elitism: tournament selection, uniform + crossover and per-gene Gaussian mutation. The initial population is + the (clamped) initial candidate plus Gaussian perturbations of it + ('gaInitSpread'), so 'optimize' needs no separate population input. + Elites carry their already-observed scores into the next generation + and are never re-evaluated. + + Blend/simulated-binary crossover (BLX-alpha, SBX) are deliberately + /not/ options of t'GAConfig'; if needed they should become separate + strategies so each strategy's rates keep one clear meaning. + + == Example + + Minimize the 3-dimensional sphere function @sum (v - 1)^2@: + + > import ExchangeAlgebra.Optimize + > import ExchangeAlgebra.Optimize.GA + > import qualified Data.Vector.Unboxed as U + > import Data.Functor.Identity (runIdentity) + > + > sphere :: U.Vector Double -> Double + > sphere v = U.sum (U.map (\x -> (x - 1) ^ 2) v) + > + > best :: (U.Vector Double, Double) + > best = runIdentity + > (optimize GA defaultGAConfig (pure . sphere) (U.replicate 3 0)) +-} +module ExchangeAlgebra.Optimize.GA + ( -- * Strategy + GA (..) + , GAConfig (..) + , defaultGAConfig + ) where + +import ExchangeAlgebra.Optimize +import qualified Data.List as L +import Data.Ord (comparing) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import System.Random (StdGen, mkStdGen, uniformR) + +-- | Genetic-algorithm strategy proxy. +data GA = GA + +-- | Configuration of one GA run. See 'defaultGAConfig' for a starting +-- point; all fields are validated up front (fail-fast 'error', never +-- clamped). +data GAConfig = GAConfig + { gaDirection :: Direction + -- ^ Whether the objective is maximized or minimized. + , gaPopulationSize :: Int + -- ^ Number of individuals per generation (@>= 1@). + , gaGenerations :: Int + -- ^ Number of generations (@>= 0@; @0@ evaluates only the initial + -- population). + , gaCrossoverRate :: Double + -- ^ Probability that a selected pair undergoes uniform crossover + -- (in @[0, 1]@); otherwise the first parent is copied. + , gaMutationRate :: Double + -- ^ Per-gene mutation probability (in @[0, 1]@). + , gaMutationScale :: Double + -- ^ Standard deviation of the Gaussian gene perturbation (@>= 0@). + , gaTournamentSize :: Int + -- ^ Tournament size for parent selection (@>= 1@; @1@ degenerates + -- to uniform random selection, which barely selects at all). + , gaEliteCount :: Int + -- ^ Number of best individuals carried over unchanged + -- (@0 <= gaEliteCount <= gaPopulationSize@). + , gaInitSpread :: Double + -- ^ Standard deviation of the Gaussian spread used to build the + -- initial population around the initial candidate (@>= 0@). + , gaBounds :: Maybe (U.Vector (Double, Double)) + -- ^ Optional per-gene @(low, high)@ box constraints. Must have the + -- same length as the chromosome; every generated gene (initial + -- spread and mutation) is clamped into its interval. + , gaSeed :: Int + -- ^ Seed of the solver's internal random generator. + } + +-- | A reasonable starting configuration: minimization, population 50, +-- 100 generations, crossover rate 0.9, per-gene mutation rate 0.1 with +-- scale 0.1, tournament size 3, 2 elites, initial spread 1.0, no +-- bounds, seed 42. Override fields as needed. +defaultGAConfig :: GAConfig +defaultGAConfig = GAConfig + { gaDirection = Minimize + , gaPopulationSize = 50 + , gaGenerations = 100 + , gaCrossoverRate = 0.9 + , gaMutationRate = 0.1 + , gaMutationScale = 0.1 + , gaTournamentSize = 3 + , gaEliteCount = 2 + , gaInitSpread = 1.0 + , gaBounds = Nothing + , gaSeed = 42 + } + +instance Solver GA where + type Candidate GA = U.Vector Double + type Config GA = GAConfig + + optimize _ cfg obj x0 = do + validateConfig cfg x0 + let x0' = clampTo (gaBounds cfg) x0 + (rest, g1) = initialPopulation cfg x0' (mkStdGen (gaSeed cfg)) + pop0 <- mapM evalOne (x0' : rest) + let best0 = L.minimumBy (comparing snd) pop0 + (bc, be) <- go 1 g1 pop0 best0 + return (bc, orient dir be) + where + dir = gaDirection cfg + + evalOne c = do + s <- obj c + if isNaN s || isInfinite s + then error ("ExchangeAlgebra.Optimize.GA: objective returned " + ++ "a non-finite score (" ++ show s ++ ")") + else return (c, orient dir s) + + go !gen !g !pop !best + | gen > gaGenerations cfg = return best + | otherwise = do + let sorted = L.sortBy (comparing snd) pop + elites = take (gaEliteCount cfg) sorted + nChildren = gaPopulationSize cfg - gaEliteCount cfg + pool = V.fromList sorted + (childs, g') = makeChildren cfg pool nChildren g + children <- mapM evalOne childs + let pop' = elites ++ children + best' = L.minimumBy (comparing snd) (best : pop') + go (gen + 1) g' pop' best' + +-- ------------------------------------------------------------------ +-- Pure genetics (random generator threaded explicitly) +-- ------------------------------------------------------------------ + +-- | Initial population (without the seed candidate itself): Gaussian +-- perturbations of the seed candidate, clamped to the bounds. +initialPopulation :: GAConfig -> U.Vector Double -> StdGen + -> ([U.Vector Double], StdGen) +initialPopulation cfg x0 = goN (gaPopulationSize cfg - 1) + where + goN 0 g = ([], g) + goN k g = let (v, g1) = perturbAll x0 g + (vs, g2) = goN (k - 1) g1 + in (v : vs, g2) + perturbAll v g = + let (genes, g') = threadGenes step (U.toList v) g + in (clampTo (gaBounds cfg) (U.fromList genes), g') + where + step x gg = let (z, gg') = gauss gg + in (x + gaInitSpread cfg * z, gg') + +-- | Produce @k@ children by tournament selection, uniform crossover and +-- Gaussian mutation. +makeChildren :: GAConfig -> V.Vector (U.Vector Double, Double) -> Int -> StdGen + -> ([U.Vector Double], StdGen) +makeChildren cfg pool = goN + where + goN 0 g = ([], g) + goN k g = let (c, g1) = makeOne g + (cs, g2) = goN (k - 1) g1 + in (c : cs, g2) + + makeOne g0 = + let (p1, g1) = tournament g0 + (p2, g2) = tournament g1 + (u, g3) = uniformR (0 :: Double, 1) g2 + (raw, g4) = if u < gaCrossoverRate cfg + then crossover p1 p2 g3 + else (p1, g3) + (mut, g5) = mutate raw g4 + in (clampTo (gaBounds cfg) mut, g5) + + -- Tournament selection: best (lowest energy) of k uniform picks. + tournament g0 = go (gaTournamentSize cfg) g0 Nothing + where + go 0 g acc = case acc of + Just (c, _) -> (c, g) + Nothing -> error "ExchangeAlgebra.Optimize.GA: empty tournament" + go k g acc = + let (i, g') = uniformR (0, V.length pool - 1) g + cand = pool V.! i + acc' = case acc of + Just (_, e) | e <= snd cand -> acc + _ -> Just cand + in go (k - 1 :: Int) g' acc' + + -- Uniform crossover: each gene comes from either parent with p = 1/2. + crossover p1 p2 g0 = + let (genes, g') = crossGenes (U.toList p1) (U.toList p2) g0 + in (U.fromList genes, g') + crossGenes [] _ g = ([], g) + crossGenes _ [] g = ([], g) + crossGenes (a:as) (b:bs) g = + let (u, g1) = uniformR (0 :: Double, 1) g + (rest, g2) = crossGenes as bs g1 + in ((if u < 0.5 then a else b) : rest, g2) + + -- Per-gene Gaussian mutation. + mutate v g0 = + let (genes, g') = threadGenes step (U.toList v) g0 + in (U.fromList genes, g') + where + step x g = + let (u, g1) = uniformR (0 :: Double, 1) g + in if u < gaMutationRate cfg + then let (z, g2) = gauss g1 + in (x + gaMutationScale cfg * z, g2) + else (x, g1) + +-- | Thread the generator through a per-gene transformation. +threadGenes :: (Double -> StdGen -> (Double, StdGen)) + -> [Double] -> StdGen -> ([Double], StdGen) +threadGenes _ [] g = ([], g) +threadGenes f (x:xs) g = + let (y, g1) = f x g + (ys, g2) = threadGenes f xs g1 + in (y : ys, g2) + +-- | One standard-normal draw via Box–Muller. The first uniform is lifted +-- away from zero so @log u1@ stays finite. (The unguarded @normal@ in +-- "ExchangeAlgebra.Simulate" has a @log 0@ failure mode and must not be +-- copied here.) +gauss :: StdGen -> (Double, StdGen) +gauss g0 = + let (u1raw, g1) = uniformR (0 :: Double, 1) g0 + u1 = max 2.2250738585072014e-308 u1raw -- smallest normal + (u2, g2) = uniformR (0 :: Double, 1) g1 + in (sqrt (-2 * log u1) * cos (2 * pi * u2), g2) + +-- | Clamp each gene into its bound interval (identity without bounds). +clampTo :: Maybe (U.Vector (Double, Double)) -> U.Vector Double -> U.Vector Double +clampTo Nothing v = v +clampTo (Just bs) v = U.zipWith (\(lo, hi) x -> max lo (min hi x)) bs v + +-- ------------------------------------------------------------------ +-- Fail-fast configuration validation (see ExchangeAlgebra.Optimize) +-- ------------------------------------------------------------------ + +validateConfig :: Monad m => GAConfig -> U.Vector Double -> m () +validateConfig cfg x0 + | gaPopulationSize cfg < 1 + = bad ("gaPopulationSize must be >= 1, got " ++ show (gaPopulationSize cfg)) + | gaGenerations cfg < 0 + = bad ("gaGenerations must be >= 0, got " ++ show (gaGenerations cfg)) + | gaEliteCount cfg < 0 || gaEliteCount cfg > gaPopulationSize cfg + = bad ("gaEliteCount must be in [0, gaPopulationSize], got " + ++ show (gaEliteCount cfg)) + | gaTournamentSize cfg < 1 + = bad ("gaTournamentSize must be >= 1, got " ++ show (gaTournamentSize cfg)) + | badRate (gaCrossoverRate cfg) + = bad ("gaCrossoverRate must be a finite value in [0,1], got " + ++ show (gaCrossoverRate cfg)) + | badRate (gaMutationRate cfg) + = bad ("gaMutationRate must be a finite value in [0,1], got " + ++ show (gaMutationRate cfg)) + | badScale (gaMutationScale cfg) + = bad ("gaMutationScale must be finite and >= 0, got " + ++ show (gaMutationScale cfg)) + | badScale (gaInitSpread cfg) + = bad ("gaInitSpread must be finite and >= 0, got " + ++ show (gaInitSpread cfg)) + | U.null x0 + = bad "the initial candidate (chromosome) must be non-empty" + | Just bs <- gaBounds cfg, U.length bs /= U.length x0 + = bad ("gaBounds length (" ++ show (U.length bs) + ++ ") does not match the chromosome length (" ++ show (U.length x0) ++ ")") + | Just bs <- gaBounds cfg + , Just (i, (lo, hi)) <- badBound bs + = bad ("gaBounds at index " ++ show i ++ " is invalid: " + ++ show (lo, hi) ++ " (need finite lo <= hi)") + | otherwise = return () + where + bad msg = error ("ExchangeAlgebra.Optimize.GA: " ++ msg) + badRate r = isNaN r || isInfinite r || r < 0 || r > 1 + badScale s = isNaN s || isInfinite s || s < 0 + badBound bs = U.ifoldr + (\i b acc -> if invalid b then Just (i, b) else acc) Nothing bs + where invalid (lo, hi) = + isNaN lo || isInfinite lo || isNaN hi || isInfinite hi || lo > hi diff --git a/src/ExchangeAlgebra/Reporting/Group.hs b/src/ExchangeAlgebra/Reporting/Group.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Reporting/Group.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wincomplete-patterns -Werror=incomplete-patterns #-} + +{- | +Module : ExchangeAlgebra.Reporting.Group +Description : Presentation groups and the contra netting policy (Definition 7, Land 3). + +A /presentation group/ is a statement block made of one or more __gross__ +account titles and the __contra__ (評価勘定) titles that are deducted from +them, rendered as @gross lines → deduction lines → net line@. It is the +mechanism the Definition 7 contra amendment left open: Land 2 fixed the +classification (contra assets are @Assets@ with @isContra = True@) but kept a +display-compatibility shim so that the contra accounts still /appeared/ in the +liability column; this module supplies the real deduction presentation and +lets that shim be removed. + +This module is deliberately free of both the CSV writers and the validated +reporting pipeline: it is the __single implementation__ of grouping and +netting, and "ExchangeAlgebra.Write" ('ExchangeAlgebra.Write.bsRows', +'ExchangeAlgebra.Write.plRows') is its consumer. Placing it here rather than +inside "ExchangeAlgebra.Reporting.Presentation" is forced by the type of the +legacy writers: they are total, base-polymorphic functions +(@ExBaseClass b => Alg n b -> [[Text]]@), whereas @present@ is specialised to +@HatBase AccountTitles@, is gated by an opaque +@ValidatedTrialBalance@, and answers in @Either@. Routing @bsRows@ through +@present@ would therefore change it from a pure formatter into a partial, +validation-gated one; duplicating the netting rule in both places is exactly +what this module exists to prevent. + +=== Value domain + +Statement amounts are held as a @(debit gross, credit gross)@ pair and only +netted at the last moment, into a t'RelativeAmount' carrying a __non-negative__ +magnitude plus a direction flag. Stored and rendered magnitudes therefore stay +in \(\mathbb{R}_0^+\), including for soft-invariant value types such as +@MoneyDecimal@. A minus sign exists only in rendered text, never in a stored +t'RelativeAmount'. + +=== Block invariant + +Within one block the displayed amounts sum to the net line: + +> Σ (gross rows) + Σ (subgroup rows) + Σ (deduction rows) = net row + +A deduction row is stated /relative to the group's normal side/, so an +ordinary contra balance is already negative there and the sum above is a plain +addition, not a subtraction. A contra that exceeds its gross members simply +makes the net row negative (that is the @contra > parent@ edge case); a group +whose gross members are absent entirely nets to the negated deduction (the +@parent absent@ edge case). Both are handled by the same arithmetic. +-} +module ExchangeAlgebra.Reporting.Group + ( -- * Groups + PresentationGroup(..) + , PresentationGroupDef(..) + , defaultPresentationGrouping + , presentationGroupOf + , lookupGroupDef + , groupNormalSide + , groupingForDivisions + -- * Amounts + , RelativeAmount(..) + , relativeTo + , addGross + -- * Grouped rows + , GroupRowKind(..) + , GroupRow(..) + , GroupedPresentation(..) + , presentGroups + ) where + +import qualified Data.List as L +import qualified Data.Map.Strict as M +import Data.Map.Strict (Map) +import qualified Data.Set as S +import Data.Set (Set) +import Data.Text (Text) + +import ExchangeAlgebra.Algebra (HatVal(zeroValue), nearlyEqScaled) +import ExchangeAlgebra.Algebra.Base + ( AccountDivision(..) + , AccountTitles(..) + , Side(..) + , defaultSide + ) + +------------------------------------------------------------------ +-- Groups +------------------------------------------------------------------ + +-- | Identity of a statement presentation block. These are reporting +-- identities, never posting coordinates: they name a group of account titles, +-- not an account. +data PresentationGroup + = TradeReceivablesGroup -- ^ 売上債権 − 貸倒引当金 + | DepreciableAssetsGroup -- ^ 償却性有形固定資産 − 減価償却累計額 + | NetSalesGroup -- ^ 総売上高 − 売上割戻 + | NetPurchasesGroup -- ^ 総仕入高 − 仕入割戻 + | IncomeTaxesGroup -- ^ 法人税等 − 還付法人税等 + deriving (Show, Eq, Ord, Enum, Bounded) + +-- | One block of a statement: the gross titles, the contra titles deducted +-- from them, and (optionally) the group this block rolls up into. +-- +-- @pgGross@ and @pgDeductions@ are ordered; rows are emitted in that order so +-- that the output is deterministic. Every @pgDeductions@ member is expected to +-- be a registry contra account of the same division as @pgDivision@, and no +-- @pgGross@ member is; the test-suite pins both, together with the disjointness +-- of the membership sets and the fact that every registry contra account +-- belongs to exactly one group. +data PresentationGroupDef = PresentationGroupDef + { pgKey :: PresentationGroup + , pgDivision :: AccountDivision + -- ^ Statement column the block belongs to. Fixes the group's normal + -- side via 'groupNormalSide'. + , pgLabel :: Text + -- ^ Label of the net line (and of the carried subtotal when this block + -- rolls up into another one). + , pgGross :: [AccountTitles] + , pgDeductions :: [AccountTitles] + , pgParent :: Maybe PresentationGroup + -- ^ When set, this block's net is carried into the named block as a + -- 'SubgroupRow' and only the outermost block contributes to the column + -- total. The default grouping is flat; nesting exists so that a caller + -- can state a multi-level statement without a second netting rule. + } + deriving (Show, Eq) + +-- | Normal (deduction-free) side of a group, i.e. the side its net line is +-- stated against. +groupNormalSide :: PresentationGroupDef -> Side +groupNormalSide = defaultSide . pgDivision + +-- | The grouping applied by 'ExchangeAlgebra.Write.bsRows' and +-- 'ExchangeAlgebra.Write.plRows' unless a caller supplies its own. +-- +-- The membership lists are presentation policy, not algebra: they say which +-- gross titles a single undifferentiated valuation account is deducted from +-- under JGAAP's indirect method (間接控除法). The registry keeps exactly five +-- contra accounts, so there are exactly five blocks. All blocks are flat — +-- a nested default would assert a subtotal structure that the chart does not +-- yet carry. +defaultPresentationGrouping :: [PresentationGroupDef] +defaultPresentationGrouping = + [ PresentationGroupDef + { pgKey = TradeReceivablesGroup + , pgDivision = Assets + , pgLabel = "TradeReceivablesNet" + , pgGross = + [ NotesReceivable + , AccountsReceivable + , ElectronicallyRecordedReceivable + , CreditCardReceivable + ] + , pgDeductions = [AllowanceForDoubtfulAccounts] + , pgParent = Nothing + } + , PresentationGroupDef + { pgKey = DepreciableAssetsGroup + , pgDivision = Assets + , pgLabel = "DepreciableAssetsNet" + , pgGross = + [ Building + , Structures + , Machinery + , Vehicle + , ToolsAndInstruments + , Fixtures + ] + , pgDeductions = [AccumulatedDepreciation] + , pgParent = Nothing + } + , PresentationGroupDef + { pgKey = NetSalesGroup + , pgDivision = Revenue + , pgLabel = "NetSales" + , pgGross = [Sales] + , pgDeductions = [SalesRebates] + , pgParent = Nothing + } + , PresentationGroupDef + { pgKey = NetPurchasesGroup + , pgDivision = Cost + , pgLabel = "NetPurchases" + , pgGross = [Purchases] + , pgDeductions = [PurchaseRebates] + , pgParent = Nothing + } + , PresentationGroupDef + { pgKey = IncomeTaxesGroup + , pgDivision = Cost + , pgLabel = "IncomeTaxesNet" + , pgGross = [CorporateIncomeTaxes, AdditionalIncomeTaxesForPriorPeriods] + , pgDeductions = [RefundOfIncomeTaxes] + , pgParent = Nothing + } + ] + +-- | Block a title belongs to under 'defaultPresentationGrouping', if any. +presentationGroupOf :: AccountTitles -> Maybe PresentationGroup +presentationGroupOf title = fmap pgKey (L.find member defaultPresentationGrouping) + where + member def = title `elem` pgGross def || title `elem` pgDeductions def + +-- | Look one block up in the grouping in force. +lookupGroupDef :: [PresentationGroupDef] -> PresentationGroup -> Maybe PresentationGroupDef +lookupGroupDef defs key = L.find ((== key) . pgKey) defs + +-- | Restrict a grouping to the statement columns a writer renders. A balance +-- sheet must not net revenue accounts, and a profit and loss statement must +-- not net asset accounts. +groupingForDivisions :: [AccountDivision] -> [PresentationGroupDef] -> [PresentationGroupDef] +groupingForDivisions divisions = filter ((`elem` divisions) . pgDivision) + +------------------------------------------------------------------ +-- Amounts +------------------------------------------------------------------ + +-- | An amount stated relative to a group's normal side. @raMagnitude@ is +-- always non-negative; @raBelowZero@ says whether the amount sits on the +-- opposite side (a deduction, or a net that its deductions pushed past zero). +-- Callers render the direction — as a leading @-@, a triangle (△), or a move +-- to the other column — and never negate the value itself. +data RelativeAmount v = RelativeAmount + { raBelowZero :: !Bool + , raMagnitude :: !v + } + deriving (Show, Eq) + +-- | Net a @(debit gross, credit gross)@ pair against a side. Uses the same +-- 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. +relativeTo :: HatVal v => Side -> (v, v) -> RelativeAmount v +relativeTo side (debit, credit) + | nearlyEqScaled debit credit = RelativeAmount False zeroValue + | otherwise = case side of + Credit -> orient credit debit + -- 'defaultSide' only ever answers Debit or Credit, so the wildcard + -- cannot arise from a group; orient it like Debit rather than + -- inventing a third direction. + Debit -> orient debit credit + Side -> orient debit credit + where + orient toward away + | toward >= away = RelativeAmount False (toward - away) + | otherwise = RelativeAmount True (away - toward) + +-- | Accumulate @(debit gross, credit gross)@ pairs. +addGross :: Num v => (v, v) -> (v, v) -> (v, v) +addGross (leftDebit, leftCredit) (rightDebit, rightCredit) = + (leftDebit + rightDebit, leftCredit + rightCredit) + +------------------------------------------------------------------ +-- Grouped rows +------------------------------------------------------------------ + +-- | What one row of a block states. +data GroupRowKind + = GrossRow AccountTitles + -- ^ A constituent account, before deduction. + | SubgroupRow PresentationGroup + -- ^ The net of a nested block, carried into this one. + | DeductionRow AccountTitles + -- ^ A contra account. Its amount is already stated relative to the + -- group's normal side, so it is normally 'raBelowZero'. + | NetRow PresentationGroup + -- ^ The block's net. Equals the sum of the rows above it. + deriving (Show, Eq) + +data GroupRow v = GroupRow + { grKind :: GroupRowKind + , grAmount :: RelativeAmount v + } + deriving (Show, Eq) + +-- | Result of applying a grouping to a set of per-title balances. +data GroupedPresentation v = GroupedPresentation + { gpBlocks :: [(PresentationGroupDef, [GroupRow v])] + -- ^ Blocks in render order: nested blocks precede the block they roll + -- up into, roots follow the order of the grouping list. + , gpRootTotals :: Map AccountDivision (v, v) + -- ^ Per-division @(debit, credit)@ contribution of the __outermost__ + -- blocks only. A caller adds this to the ungrouped part of the column; + -- adding nested blocks as well would double count. + , gpConsumed :: Set AccountTitles + -- ^ Titles the blocks have taken over. The caller must not render these + -- again through its ordinary per-entry path. + } + deriving (Show, Eq) + +-- | Apply a grouping to per-title @(debit gross, credit gross)@ totals. +-- +-- A block is /active/ when one of its own contra titles carries non-zero gross +-- activity, or when a nested block is active: a group with nothing to deduct is +-- not a group, and leaving it inactive is what keeps output identical to the +-- pre-amendment behaviour for charts that contain no contra posting. Testing +-- gross activity rather than the net balance also keeps a fully offset contra +-- title inside its group instead of leaking one side into the ordinary rows. +-- +-- Complexity: O(g · m + g²) for @g@ blocks of @m@ members (the grouping is a +-- fixed, small table). +presentGroups + :: HatVal v + => [PresentationGroupDef] + -> Map AccountTitles (v, v) + -> GroupedPresentation v +presentGroups defs balances = GroupedPresentation + { gpBlocks = blocks + , gpRootTotals = rootTotals + , gpConsumed = consumed + } + where + grossOf title = M.findWithDefault (zeroValue, zeroValue) title balances + hasBalance title = not (uncurry nearlyEqScaled (grossOf title)) + hasActivity title = case M.lookup title balances of + Nothing -> False + Just (debit, credit) -> + not (nearlyEqScaled debit zeroValue) + || not (nearlyEqScaled credit zeroValue) + + memberTitles def = pgGross def ++ pgDeductions def + + -- Children of a block, in grouping order. 'pgParent' is followed with a + -- visited set so that a malformed (cyclic) grouping is truncated instead + -- of diverging. + childrenOf visited key = + [ def + | def <- defs + , pgParent def == Just key + , not (S.member (pgKey def) visited) + ] + + ownPair def = L.foldl' addGross (zeroValue, zeroValue) + (map grossOf (memberTitles def)) + + subtreePair visited def = L.foldl' addGross (ownPair def) + (map (subtreePair visited') (activeChildrenOf visited' def)) + where + visited' = S.insert (pgKey def) visited + + ownActive def = any hasActivity (pgDeductions def) + + isActive visited def = ownActive def + || any (isActive visited') (childrenOf visited' (pgKey def)) + where + visited' = S.insert (pgKey def) visited + + activeChildrenOf visited def = + [ child + | child <- childrenOf visited (pgKey def) + , pgDivision child == pgDivision def + , isActive visited child + ] + + -- A block is a root when it has no usable parent, or when it is the stable + -- representative of a malformed parent cycle. Cross-division parents are + -- unusable because a carried subtotal and its root total must share a + -- statement column. + isRoot def = case pgParent def of + Nothing -> True + Just parent -> case lookupGroupDef defs parent of + Nothing -> True + Just parentDef + | pgDivision parentDef /= pgDivision def -> True + | otherwise -> case parentCycle def of + Nothing -> False + Just keys -> pgKey def == minimum keys + + parentCycle def = follow [] (pgKey def) + where + follow path key + | key `elem` path = Just (dropWhile (/= key) path) + | otherwise = case lookupGroupDef defs key >>= pgParent of + Nothing -> Nothing + Just parent -> follow (path ++ [key]) parent + + activeRoots = [def | def <- defs, isRoot def, isActive S.empty def] + + -- Depth-first: nested blocks are rendered before the block that carries + -- their net, so a reader meets a subtotal only after its constituents. + blocksOf visited def = + concatMap (blocksOf visited') activeChildren + ++ [(def, rowsOf visited' def activeChildren)] + where + visited' = S.insert (pgKey def) visited + activeChildren = activeChildrenOf visited' def + + rowsOf visited def activeChildren = + [ GroupRow (GrossRow title) (relative (grossOf title)) + | title <- pgGross def, hasBalance title ] + ++ + [ GroupRow (SubgroupRow (pgKey child)) (relative (subtreePair visited child)) + | child <- activeChildren ] + ++ + [ GroupRow (DeductionRow title) (relative (grossOf title)) + | title <- pgDeductions def, hasBalance title ] + ++ + [ GroupRow (NetRow (pgKey def)) (relative (subtreePair visited def)) ] + where + relative = relativeTo (groupNormalSide def) + + blocks = concatMap (blocksOf S.empty) activeRoots + + rootTotals = M.fromListWith addGross + [ (pgDivision def, subtreePair S.empty def) | def <- activeRoots ] + + consumed = S.fromList + [ title | (def, _) <- blocks, title <- memberTitles def ] diff --git a/src/ExchangeAlgebra/Reporting/Metric.hs b/src/ExchangeAlgebra/Reporting/Metric.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Reporting/Metric.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wincomplete-patterns -Werror=incomplete-patterns #-} + +{- | +Module : ExchangeAlgebra.Reporting.Metric +Description : Typed, read-only metrics derived from exchange-algebra coordinates. + +Derived metrics are not posting coordinates. In particular, profit and loss +are two directions of one period-result identity, represented by +'PeriodProfit' and 'PeriodLoss' with non-negative values. The legacy +@AccountTitles@ constructors remain available for the established transfer +pipeline, but new reporting code should derive values without inserting those +coordinates. +-} +module ExchangeAlgebra.Reporting.Metric + ( MetricId + , mkMetricId + , metricIdText + , DerivedMetric(..) + , PeriodResult(..) + , MetricError(..) + , metricForLegacyTitle + , legacyTitlesForMetric + , periodResultOfAlg + , periodResultOf + ) where + +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T + +import ExchangeAlgebra.Algebra + ( Alg, HatVal(isErrorValue), foldEntries ) +import ExchangeAlgebra.Algebra.Base + ( AccountDivision(..) + , AccountSemantics(asemDivisionSemantics) + , AccountTitles(..) + , DivisionSemantics(..) + , ExBaseClass(getAccountTitle, whichSide) + , Hat(..) + , HatBaseClass(hat) + , Side(..) + , accountSemantics + ) +import qualified ExchangeAlgebra.TrialBalance.Validation as TB + +-- | Stable identity for a caller-defined metric. Display labels are supplied +-- separately by a reporting context. +newtype MetricId = MetricId Text + deriving (Show, Eq, Ord) + +-- | Construct a non-blank custom metric identity. +mkMetricId :: Text -> Maybe MetricId +mkMetricId raw + | T.null normalized = Nothing + | otherwise = Just (MetricId normalized) + where + normalized = T.strip raw + +metricIdText :: MetricId -> Text +metricIdText (MetricId value) = value + +-- | Identity of a value derived for reporting. Profit versus loss is carried +-- by the result value, not duplicated as two metric identities. +data DerivedMetric + = PeriodResultMetric + | GrossProfitMetric + | OrdinaryProfitMetric + | CustomMetric MetricId + deriving (Show, Eq, Ord) + +-- | A period result with structural direction and a non-negative amount. +data PeriodResult v + = PeriodProfit v + | PeriodLoss v + | PeriodBreakEven + deriving (Show, Eq) + +data MetricError + = MetricNotAvailableAtStage TB.TrialBalanceStage + | ResidualDerivedCoordinate AccountTitles + | WildcardMetricSide AccountTitles + | InvalidMetricValue AccountTitles + deriving (Show, Eq) + +-- | Map an engine-only legacy coordinate to its reporting identity. +metricForLegacyTitle :: AccountTitles -> Maybe DerivedMetric +metricForLegacyTitle title = case title of + NetIncome -> Just PeriodResultMetric + NetLoss -> Just PeriodResultMetric + GrossProfit -> Just GrossProfitMetric + OrdinaryProfit -> Just OrdinaryProfitMetric + _ -> Nothing + +-- | Legacy coordinates retained for one metric. This is a migration aid, +-- not a list of statement lines. +legacyTitlesForMetric :: DerivedMetric -> [AccountTitles] +legacyTitlesForMetric metric = case metric of + PeriodResultMetric -> [NetIncome, NetLoss] + GrossProfitMetric -> [GrossProfit] + OrdinaryProfitMetric -> [OrdinaryProfit] + CustomMetric _ -> [] + +-- | Derive period profit or loss without adding a balancing coordinate. +-- Only genuine statement-classified Cost and Revenue titles participate; +-- direction-encoding legacy coordinates are therefore excluded structurally. +-- Invalid values and wildcard sides are returned as explicit errors. For +-- externally sourced trial balances, prefer 'periodResultOf'. +periodResultOfAlg + :: (HatVal v, ExBaseClass b) + => Alg v b + -> Either MetricError (PeriodResult v) +periodResultOfAlg alg + | (_, base) : _ <- invalidEntries = + Left (InvalidMetricValue (getAccountTitle base)) + | (_, base) : _ <- wildcardEntries = + Left (WildcardMetricSide (getAccountTitle base)) + | credit == debit = Right PeriodBreakEven + | credit > debit = Right (PeriodProfit (credit - debit)) + | otherwise = Right (PeriodLoss (debit - credit)) + where + entries = foldEntries (\current value base -> (value, base) : current) [] alg + invalidEntries = filter (isErrorValue . fst) entries + wildcardEntries = filter ((== HatNot) . hat . snd) entries + (debit, credit) = foldEntries collect (0, 0) alg + collect totals value base + | isStatementNominal (getAccountTitle base) = + addOnSide (whichSide base) value totals + | otherwise = totals + +-- | Derive a period result from an accepted before-closing trial balance. +-- A non-zero legacy derived coordinate is rejected to prevent a caller from +-- treating an already-derived balancing item as another nominal account. +-- Consolidation attribution coordinates do not participate, so the result is +-- the period result before attribution to owners and non-controlling interests. +periodResultOf + :: HatVal v + => TB.ValidatedTrialBalance v + -> Either MetricError (PeriodResult v) +periodResultOf validated + | TB.validatedStage validated /= TB.BeforeClosing = + Left (MetricNotAvailableAtStage (TB.validatedStage validated)) + | legacy : _ <- nonZeroLegacyTitles alg = + Left (ResidualDerivedCoordinate legacy) + | otherwise = periodResultOfAlg alg + where + alg = TB.validatedTrialBalance validated + +isStatementNominal :: AccountTitles -> Bool +isStatementNominal title = case accountSemantics title of + Just semantics -> case asemDivisionSemantics semantics of + StatementDivision Cost -> True + StatementDivision Revenue -> True + _ -> False + Nothing -> False + +addOnSide :: Num v => Side -> v -> (v, v) -> (v, v) +addOnSide Debit value (debit, credit) = (debit + value, credit) +addOnSide Credit value (debit, credit) = (debit, credit + value) +addOnSide Side _ totals = totals + +nonZeroLegacyTitles + :: (HatVal v, ExBaseClass b) + => Alg v b + -> [AccountTitles] +nonZeroLegacyTitles alg = + [ title + | (title, (debit, credit)) <- M.toList totals + , debit /= credit + ] + where + totals = foldEntries collect M.empty alg + collect current value base = case metricForLegacyTitle title of + Nothing -> current + Just _ -> M.insertWith add title (sidePair (whichSide base) value) current + where + title = getAccountTitle base + add (newDebit, newCredit) (oldDebit, oldCredit) = + (newDebit + oldDebit, newCredit + oldCredit) + sidePair Debit value = (value, 0) + sidePair Credit value = (0, value) + sidePair Side _ = (0, 0) diff --git a/src/ExchangeAlgebra/Reporting/Presentation.hs b/src/ExchangeAlgebra/Reporting/Presentation.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Reporting/Presentation.hs @@ -0,0 +1,788 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wincomplete-patterns -Werror=incomplete-patterns #-} + +{- | +Module : ExchangeAlgebra.Reporting.Presentation +Description : Context-sensitive JGAAP presentation from validated trial balances. + +This module is the reporting boundary: presentation accepts only an opaque +'TB.ValidatedTrialBalance'. Bookkeeping coordinates remain unchanged; all +eliminations, relabelings, maturity allocations, netting decisions, and +subtotals are recorded as presentation audit events. +-} +module ExchangeAlgebra.Reporting.Presentation + ( AccountingFramework(..) + , ReportingScope(..) + , PresentationProfile(..) + , StatementSection(..) + , StatementLine(..) + , PresentationAllocation(..) + , PresentationRelabel(..) + , MaterialityTreatment(..) + , MaterialityDecision(..) + , ContraPresentationRule(..) + , CustomMetricLabel(..) + , SubtotalCoverage(..) + , SubtotalDefinition(..) + , StatementSubtotal(..) + , ReportingContext(..) + , jcciSecondGradeContext + , PresentationAuditEvent(..) + , PresentationIssue(..) + , FinancialStatements(..) + , presentationLabel + , metricLabel + , present + ) where + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Map.Strict as M +import Data.Map.Strict (Map) +import qualified Data.Set as S +import Data.Set (Set) +import Data.Text (Text) +import qualified Data.Text as T + +import ExchangeAlgebra.Algebra (HatVal) +import ExchangeAlgebra.Algebra.Base + ( AccountDivision(..) + , AccountRole(..) + , AccountSemantics(asemDivisionSemantics, + asemReportingEligibility, asemRoles) + , AccountTitles(..) + , DivisionSemantics(..) + , FixedCurrent(..) + , ReportingEligibility(..) + , Side(..) + ) +import qualified ExchangeAlgebra.Algebra.Base.Account.Registry as Registry +import ExchangeAlgebra.Reporting.Metric + ( DerivedMetric(..), MetricId ) +import qualified ExchangeAlgebra.TrialBalance.Validation as TB +import ExchangeAlgebra.TrialBalance.Balance + ( accountBalances + , balanceAmount + , balanceFor + , balancePair + , balanceSide + , combineBalances + , netPair + ) + +-- | Land 4 deliberately supports JGAAP only. +data AccountingFramework = JGAAP + deriving (Show, Eq) + +data ReportingScope = Standalone | Combined + deriving (Show, Eq) + +data PresentationProfile + = JcciSecondGradeReport + | CanonicalJapanese + | CanonicalEnglish + deriving (Show, Eq) + +data StatementSection + = CurrentAssetsSection + | NoncurrentAssetsSection + | CurrentLiabilitiesSection + | NoncurrentLiabilitiesSection + | EquitySection + | RevenueSection + | ExpenseSection + | ContextualDebitSection + | ContextualCreditSection + deriving (Show, Eq) + +data StatementLine v = StatementLine + { _lineAccount :: AccountTitles + , _lineLabel :: Text + , _lineSection :: StatementSection + , _lineSide :: Side + , _lineAmount :: v + , _lineIsDeduction :: Bool + } + deriving (Show, Eq) + +-- | Evidence-backed split of one title without creating new bookkeeping +-- coordinates. Current and non-current parts must sum exactly to its balance. +data PresentationAllocation v = PresentationAllocation + { _allocationAccount :: AccountTitles + , _allocationCurrent :: v + , _allocationNoncurrent :: v + , _allocationEvidence :: Text + } + deriving (Show, Eq) + +data PresentationRelabel = PresentationRelabel + { _relabelSource :: AccountTitles + , _relabelTarget :: AccountTitles + , _relabelRationale :: Text + } + deriving (Show, Eq) + +data MaterialityTreatment + = PresentGross + | PresentSeparately + | NetAgainst AccountTitles + deriving (Show, Eq) + +data MaterialityDecision = MaterialityDecision + { _materialityAccount :: AccountTitles + , _materialityTreatment :: MaterialityTreatment + , _materialityRationale :: Text + } + deriving (Show, Eq) + +data ContraPresentationRule + = PresentContraSeparately AccountTitles Text + | NetContraAgainst AccountTitles AccountTitles Text + deriving (Show, Eq) + +-- | Profile-specific display labels for a caller-defined metric. The metric +-- identity remains separate from these labels. +data CustomMetricLabel = CustomMetricLabel + { _customMetricIdentity :: MetricId + , _customMetricLabelJapanese :: Text + , _customMetricLabelEnglish :: Text + } + deriving (Show, Eq) + +data SubtotalCoverage + = RequireAllTitlesPresent + | TreatAbsentAsZero + deriving (Show, Eq) + +-- | A subtotal is a typed reporting definition, never an account-basis title. +data SubtotalDefinition = SubtotalDefinition + { _subtotalMetric :: DerivedMetric + , _subtotalCreditTitles :: [AccountTitles] + , _subtotalDebitTitles :: [AccountTitles] + , _subtotalCoverage :: SubtotalCoverage + } + deriving (Show, Eq) + +data StatementSubtotal v = StatementSubtotal + { _statementSubtotalMetric :: DerivedMetric + , _statementSubtotalLabel :: Text + , _statementSubtotalBalance :: TB.AccountBalance v + } + deriving (Show, Eq) + +data ReportingContext v = ReportingContext + { _reportingFramework :: AccountingFramework + , _reportingScope :: ReportingScope + , _presentationProfile :: PresentationProfile + , _maturitySensitiveTitles :: Set AccountTitles + , _presentationAllocations :: [PresentationAllocation v] + , _presentationRelabels :: [PresentationRelabel] + , _materialityDecisions :: [MaterialityDecision] + , _contraPresentationRules :: [ContraPresentationRule] + , _subtotalDefinitions :: [SubtotalDefinition] + , _customMetricLabels :: [CustomMetricLabel] + } + deriving (Show, Eq) + +jcciSecondGradeContext :: ReportingScope -> ReportingContext v +jcciSecondGradeContext scope = ReportingContext + { _reportingFramework = JGAAP + , _reportingScope = scope + , _presentationProfile = JcciSecondGradeReport + , _maturitySensitiveTitles = S.empty + , _presentationAllocations = [] + , _presentationRelabels = [] + , _materialityDecisions = [] + , _contraPresentationRules = [] + , _subtotalDefinitions = [] + , _customMetricLabels = [] + } + +data PresentationAuditEvent v + = ReciprocalAccountsEliminated + (TB.AccountBalance v) (TB.AccountBalance v) + | AccountRelabeled + AccountTitles AccountTitles (TB.AccountBalance v) Text + | BalanceAllocated AccountTitles v v Text + | MaterialityApplied + AccountTitles MaterialityTreatment (TB.AccountBalance v) Text + | ContraPresentationApplied + AccountTitles (Maybe AccountTitles) (TB.AccountBalance v) Text + | SubtotalCalculated DerivedMetric (TB.AccountBalance v) + | LabelOverridden AccountTitles Text Text + deriving (Show, Eq) + +data PresentationIssue v + = ValidationFindingBlocks (TB.TBFinding v) + | MissingPresentationAllocation AccountTitles + | DuplicatePresentationAllocation AccountTitles + | InvalidPresentationAllocation + AccountTitles (TB.AccountBalance v) v v + | BlankPresentationEvidence AccountTitles + | UnexpectedPresentationAllocation AccountTitles + | ConflictingPresentationInstruction AccountTitles + | MissingPresentationAccount AccountTitles + | BlankPresentationRationale AccountTitles + | UnpresentableBalance AccountTitles (TB.AccountBalance v) + | InvalidSubtotalDefinition DerivedMetric + | DuplicateMetricIdentity DerivedMetric + | UnlabelledCustomMetric MetricId + | UnreconciledPresentation v v + deriving (Show, Eq) + +data FinancialStatements v = FinancialStatements + { _statementFramework :: AccountingFramework + , _statementScope :: ReportingScope + , _statementProfile :: PresentationProfile + , _statementTrialBalanceStage :: TB.TrialBalanceStage + , _statementLines :: [StatementLine v] + , _statementSubtotals :: [StatementSubtotal v] + , _presentationAudit :: [PresentationAuditEvent v] + } + deriving (Show, Eq) + +-- | Profile-specific Japanese display-label overrides. +jcciSecondGradeLabelOverrides :: Map AccountTitles Text +jcciSecondGradeLabelOverrides = M.fromList + [ (AdvancesReceived, T.pack "契約負債") + ] + +-- | Profile-specific display label. Japanese profiles use the registry's +-- cleaned statement label, with the JCCI grade-2 overrides applied first. +presentationLabel :: PresentationProfile -> AccountTitles -> Text +presentationLabel profile title = case Registry.accountSpec title of + Nothing -> T.pack (show title) + Just spec -> case profile of + JcciSecondGradeReport -> M.findWithDefault + (Registry.asLabelJa spec) title jcciSecondGradeLabelOverrides + CanonicalJapanese -> Registry.asLabelJa spec + CanonicalEnglish -> Registry.asNameEn spec + +-- | Resolve a metric's display label independently of its stable identity. +-- Profit/loss wording follows the structural balance direction. +metricLabel + :: ReportingContext v + -> DerivedMetric + -> TB.AccountBalance v + -> Maybe Text +metricLabel context metric balance = case metric of + PeriodResultMetric -> Just (builtinLabel + "当期純損益" "当期純利益" "当期純損失" + "Net result" "Net income" "Net loss") + GrossProfitMetric -> Just (builtinLabel + "売上総損益" "売上総利益" "売上総損失" + "Gross result" "Gross profit" "Gross loss") + OrdinaryProfitMetric -> Just (builtinLabel + "経常損益" "経常利益" "経常損失" + "Ordinary result" "Ordinary profit" "Ordinary loss") + CustomMetric metricId -> customLabel metricId + where + english = _presentationProfile context == CanonicalEnglish + builtinLabel neutralJa creditJa debitJa neutralEn creditEn debitEn = + case (english, balance) of + (False, TB.NoBalance) -> neutralJa + (False, TB.CreditBalance _) -> creditJa + (False, TB.DebitBalance _) -> debitJa + (True, TB.NoBalance) -> neutralEn + (True, TB.CreditBalance _) -> creditEn + (True, TB.DebitBalance _) -> debitEn + customLabel metricId = case filter + ((== metricId) . _customMetricIdentity) + (_customMetricLabels context) of + [label] -> Just (if english + then _customMetricLabelEnglish label + else _customMetricLabelJapanese label) + _ -> Nothing + +present + :: HatVal v + => ReportingContext v + -> TB.ValidatedTrialBalance v + -> Either (NonEmpty (PresentationIssue v)) (FinancialStatements v) +present context validated = case issues of + issue : rest -> Left (issue :| rest) + [] -> Right FinancialStatements + { _statementFramework = framework + , _statementScope = _reportingScope context + , _statementProfile = _presentationProfile context + , _statementTrialBalanceStage = TB.validatedStage validated + , _statementLines = statementLines + , _statementSubtotals = subtotals + , _presentationAudit = eliminationAudit + ++ relabelAudit ++ materialityAudit ++ contraAudit + ++ allocationAudit ++ subtotalAudit ++ labelAudit + } + where + framework = case _reportingFramework context of + JGAAP -> JGAAP + initial = accountBalances (TB.validatedTrialBalance validated) + gatePolicy = case _reportingScope context of + Standalone -> TB.standaloneTrialBalancePolicy + Combined -> TB.strictTrialBalancePolicy + gateIssues = map ValidationFindingBlocks + (filter (TB.findingBlocksPresentation gatePolicy) + (TB.validatedFindings validated)) + (eliminated, eliminationAudit) = eliminateReciprocals context initial + (relabeled, relabelAudit) = applyRelabels context eliminated + (materialized, materialityAudit) = applyMateriality context relabeled + (transformed, contraAudit) = applyContraRules context materialized + explicitRequired = S.union + (TB.validatedMaturityRequiredTitles validated) + (_maturitySensitiveTitles context) + requiredMaturity = S.union explicitRequired + (implicitMaturityTitles transformed) + statementLines = renderLines context transformed + contextIssues = instructionIssues explicitRequired context initial + ++ allocationIssues requiredMaturity context transformed + ++ subtotalIssues context initial transformed + ++ coverageIssues transformed + ++ reconciliationIssues statementLines + issues = gateIssues ++ contextIssues + allocationAudit = + [ BalanceAllocated title current noncurrent evidence + | PresentationAllocation title current noncurrent evidence + <- _presentationAllocations context + , balanceFor title transformed /= TB.NoBalance + ] + subtotals = + [ StatementSubtotal metric label balance + | SubtotalDefinition metric credits debits _ <- + _subtotalDefinitions context + , let balance = subtotalBalance transformed credits debits + , Just label <- [metricLabel context metric balance] + ] + subtotalAudit = + [ SubtotalCalculated metric balance + | StatementSubtotal metric _ balance <- subtotals + ] + labelAudit = + [ LabelOverridden title canonical displayed + | _presentationProfile context == JcciSecondGradeReport + , (title, _) <- M.toList jcciSecondGradeLabelOverrides + , title `elem` map _lineAccount statementLines + , let canonical = presentationLabel CanonicalJapanese title + , let displayed = presentationLabel JcciSecondGradeReport title + , canonical /= displayed + ] + +eliminateReciprocals + :: Eq v => ReportingContext v + -> Map AccountTitles (TB.AccountBalance v) + -> (Map AccountTitles (TB.AccountBalance v), [PresentationAuditEvent v]) +eliminateReciprocals context balances = case _reportingScope context of + Standalone -> (balances, []) + Combined -> + ( M.delete BranchCurrentAccount + (M.delete HeadOfficeCurrentAccount balances) + , [ ReciprocalAccountsEliminated branch headOffice + | branch /= TB.NoBalance || headOffice /= TB.NoBalance + ] + ) + where + branch = balanceFor BranchCurrentAccount balances + headOffice = balanceFor HeadOfficeCurrentAccount balances + +applyRelabels + :: (Ord v, Num v) + => ReportingContext v + -> Map AccountTitles (TB.AccountBalance v) + -> (Map AccountTitles (TB.AccountBalance v), [PresentationAuditEvent v]) +applyRelabels context balances0 = + Prelude.foldl applyOne (balances0, []) (_presentationRelabels context) + where + applyOne (balances, events) (PresentationRelabel source target rationale) = + let sourceBalance = balanceFor source balances + targetBalance = balanceFor target balances + next = M.insert target (combineBalances targetBalance sourceBalance) + (M.delete source balances) + in (next, events ++ + [AccountRelabeled source target sourceBalance rationale]) + +applyMateriality + :: (Ord v, Num v) + => ReportingContext v + -> Map AccountTitles (TB.AccountBalance v) + -> (Map AccountTitles (TB.AccountBalance v), [PresentationAuditEvent v]) +applyMateriality context balances0 = + Prelude.foldl applyOne (balances0, []) (_materialityDecisions context) + where + applyOne (balances, events) decision = + let source = _materialityAccount decision + treatment = _materialityTreatment decision + next = case treatment of + PresentGross -> balances + PresentSeparately -> balances + NetAgainst target -> moveBalance source target balances + event = MaterialityApplied source treatment + (balanceFor source balances) (_materialityRationale decision) + in (next, events ++ [event]) + +applyContraRules + :: (Ord v, Num v) + => ReportingContext v + -> Map AccountTitles (TB.AccountBalance v) + -> (Map AccountTitles (TB.AccountBalance v), [PresentationAuditEvent v]) +applyContraRules context balances0 = + Prelude.foldl applyOne (balances0, []) + (_contraPresentationRules context) + where + applyOne (balances, events) rule = case rule of + PresentContraSeparately source rationale -> + (balances, events ++ [ContraPresentationApplied source Nothing + (balanceFor source balances) rationale]) + NetContraAgainst source target rationale -> + ( moveBalance source target balances + , events ++ [ContraPresentationApplied source (Just target) + (balanceFor source balances) rationale] + ) + +moveBalance + :: (Ord v, Num v) + => AccountTitles -> AccountTitles + -> Map AccountTitles (TB.AccountBalance v) + -> Map AccountTitles (TB.AccountBalance v) +moveBalance source target balances = + if source == target + then balances + else M.insert target + (combineBalances (balanceFor target balances) + (balanceFor source balances)) + (M.delete source balances) + +allocationIssues + :: HatVal v + => Set AccountTitles + -> ReportingContext v + -> Map AccountTitles (TB.AccountBalance v) + -> [PresentationIssue v] +allocationIssues required context balances = concatMap checkTitle checkedTitles + ++ [ DuplicatePresentationAllocation title + | title <- duplicateTitles (map _allocationAccount allocations) + ] + ++ map UnexpectedPresentationAllocation + (S.toList (allocationTitles `S.difference` required)) + where + allocations = _presentationAllocations context + allocationTitles = S.fromList (map _allocationAccount allocations) + checkedTitles = S.toList (required `S.union` allocationTitles) + checkTitle title = case balanceFor title balances of + TB.NoBalance + | title `S.member` allocationTitles -> + [MissingPresentationAccount title] + | otherwise -> [] + balance -> case filter ((== title) . _allocationAccount) allocations of + [] -> [MissingPresentationAllocation title] + [allocation] + | T.null (T.strip (_allocationEvidence allocation)) -> + [BlankPresentationEvidence title] + | allocationMatches balance allocation -> [] + | otherwise -> [InvalidPresentationAllocation title balance + (_allocationCurrent allocation) + (_allocationNoncurrent allocation)] + _ -> [] + +allocationMatches + :: (Ord v, Num v) + => TB.AccountBalance v -> PresentationAllocation v -> Bool +allocationMatches TB.NoBalance _ = False +allocationMatches (TB.DebitBalance value) allocation = + _allocationCurrent allocation >= 0 + && _allocationNoncurrent allocation >= 0 + && _allocationCurrent allocation + _allocationNoncurrent allocation == value +allocationMatches (TB.CreditBalance value) allocation = + _allocationCurrent allocation >= 0 + && _allocationNoncurrent allocation >= 0 + && _allocationCurrent allocation + _allocationNoncurrent allocation == value + +instructionIssues + :: HatVal v + => Set AccountTitles + -> ReportingContext v + -> Map AccountTitles (TB.AccountBalance v) + -> [PresentationIssue v] +instructionIssues explicitRequired context balances = + duplicateInstructionIssues + ++ concatMap relabelIssue (_presentationRelabels context) + ++ concatMap materialityIssue (_materialityDecisions context) + ++ concatMap contraIssue (_contraPresentationRules context) + where + duplicateInstructionIssues = + map ConflictingPresentationInstruction + (duplicateTitles instructionSources) + ++ [ ConflictingPresentationInstruction title + | _reportingScope context == Combined + , title <- [BranchCurrentAccount, HeadOfficeCurrentAccount] + , title `elem` instructionSources + ] + instructionSources = concatMap relabelTitles (_presentationRelabels context) + ++ concatMap materialityTitles (_materialityDecisions context) + ++ concatMap contraTitles (_contraPresentationRules context) + relabelIssue rule + | T.null (T.strip (_relabelRationale rule)) = + [BlankPresentationRationale (_relabelSource rule)] + | balanceFor (_relabelSource rule) balances == TB.NoBalance = + [MissingPresentationAccount (_relabelSource rule)] + | _relabelSource rule `S.member` explicitRequired = + [ConflictingPresentationInstruction (_relabelSource rule)] + | not (presentableTarget (_relabelTarget rule)) = + [ConflictingPresentationInstruction (_relabelTarget rule)] + | otherwise = [] + materialityIssue decision + | T.null (T.strip (_materialityRationale decision)) = + [BlankPresentationRationale (_materialityAccount decision)] + | balanceFor (_materialityAccount decision) balances == TB.NoBalance = + [MissingPresentationAccount (_materialityAccount decision)] + | otherwise = case _materialityTreatment decision of + NetAgainst target + | _materialityAccount decision `S.member` explicitRequired -> + [ConflictingPresentationInstruction + (_materialityAccount decision)] + | target == _materialityAccount decision -> + [ConflictingPresentationInstruction target] + | not (presentableTarget target) -> + [ConflictingPresentationInstruction target] + | M.notMember target balances -> + [MissingPresentationAccount target] + _ -> [] + contraIssue rule = case rule of + PresentContraSeparately source rationale + | T.null (T.strip rationale) -> + [BlankPresentationRationale source] + | balanceFor source balances == TB.NoBalance -> + [MissingPresentationAccount source] + | otherwise -> [] + NetContraAgainst source target rationale + | T.null (T.strip rationale) -> + [BlankPresentationRationale source] + | balanceFor source balances == TB.NoBalance -> + [MissingPresentationAccount source] + | source `S.member` explicitRequired -> + [ConflictingPresentationInstruction source] + | source == target -> + [ConflictingPresentationInstruction source] + | not (presentableTarget target) -> + [ConflictingPresentationInstruction target] + | M.notMember target balances -> + [MissingPresentationAccount target] + | otherwise -> [] + relabelTitles rule = [_relabelSource rule, _relabelTarget rule] + materialityTitles decision = _materialityAccount decision : case + _materialityTreatment decision of + NetAgainst target -> [target] + PresentGross -> [] + PresentSeparately -> [] + contraTitles (PresentContraSeparately source _) = [source] + contraTitles (NetContraAgainst source target _) = [source, target] + +duplicateTitles :: [AccountTitles] -> [AccountTitles] +duplicateTitles titles = S.toList + (S.fromList [title | title <- titles, count title titles > 1]) + where + count needle = length . filter (== needle) + +presentableTarget :: AccountTitles -> Bool +presentableTarget title = case Registry.accountSemantics title of + Just semantics -> asemReportingEligibility semantics `elem` + [StatementEligible, ContextualPresentation] + Nothing -> False + +implicitMaturityTitles + :: Map AccountTitles (TB.AccountBalance v) -> Set AccountTitles +implicitMaturityTitles balances = S.fromList + [ title + | (title, balance) <- M.toList balances + , balanceSide balance /= Side + , fixedCurrent title == Other + , Just semantics <- [Registry.accountSemantics title] + , StatementDivision division <- [asemDivisionSemantics semantics] + , division `elem` [Assets, Liability] + ] + +coverageIssues + :: Map AccountTitles (TB.AccountBalance v) -> [PresentationIssue v] +coverageIssues balances = + [ UnpresentableBalance title balance + | (title, balance) <- M.toList balances + , balanceSide balance /= Side + , not (presentableTarget title) + ] + +reconciliationIssues + :: (Eq v, Num v) => [StatementLine v] -> [PresentationIssue v] +reconciliationIssues lines0 = + [ UnreconciledPresentation debit credit | debit /= credit ] + where + debit = sum [_lineAmount line | line <- lines0, _lineSide line == Debit] + credit = sum [_lineAmount line | line <- lines0, _lineSide line == Credit] + +subtotalIssues + :: HatVal v + => ReportingContext v + -> Map AccountTitles (TB.AccountBalance v) + -> Map AccountTitles (TB.AccountBalance v) + -> [PresentationIssue v] +subtotalIssues context initial balances = duplicateDefinitionIssues + ++ duplicateCustomLabelIssues + ++ concatMap check definitions + where + definitions = _subtotalDefinitions context + definitionMetrics = map _subtotalMetric definitions + duplicateDefinitionIssues = + [ DuplicateMetricIdentity metric + | metric <- duplicateMetrics definitionMetrics + ] + customLabelIds = map _customMetricIdentity (_customMetricLabels context) + duplicateCustomLabelIssues = + [ DuplicateMetricIdentity (CustomMetric metricId) + | metricId <- duplicateMetricIds customLabelIds + ] + check (SubtotalDefinition metric credits debits coverage) + | null credits && null debits = [InvalidSubtotalDefinition metric] + | not (null (duplicateTitles (credits ++ debits))) = + [InvalidSubtotalDefinition metric] + | customMetricUnlabelled metric = [customMetricIssue metric] + | coverage == RequireAllTitlesPresent + && any (`M.notMember` balances) (credits ++ debits) = + [InvalidSubtotalDefinition metric] + | coverage == TreatAbsentAsZero + && any removedNonZeroTitle (credits ++ debits) = + [InvalidSubtotalDefinition metric] + | any (wrongSide Credit coverage) credits = + [InvalidSubtotalDefinition metric] + | any (wrongSide Debit coverage) debits = + [InvalidSubtotalDefinition metric] + | otherwise = [] + removedNonZeroTitle title = + balanceFor title initial /= TB.NoBalance && M.notMember title balances + wrongSide expected coverage title = case balanceFor title balances of + TB.NoBalance -> coverage == RequireAllTitlesPresent + balance -> balanceSide balance /= expected + customMetricUnlabelled metric = case metric of + CustomMetric metricId -> case customLabels metricId of + [label] -> T.null (T.strip (_customMetricLabelJapanese label)) + || T.null (T.strip (_customMetricLabelEnglish label)) + _ -> True + _ -> False + customMetricIssue metric = case metric of + CustomMetric metricId -> UnlabelledCustomMetric metricId + _ -> InvalidSubtotalDefinition metric + customLabels metricId = filter + ((== metricId) . _customMetricIdentity) + (_customMetricLabels context) + +duplicateMetrics :: [DerivedMetric] -> [DerivedMetric] +duplicateMetrics metrics = S.toList + (S.fromList [metric | metric <- metrics, count metric metrics > 1]) + where + count needle = length . filter (== needle) + +duplicateMetricIds :: [MetricId] -> [MetricId] +duplicateMetricIds metricIds = S.toList + (S.fromList [metricId | metricId <- metricIds, count metricId metricIds > 1]) + where + count needle = length . filter (== needle) + +renderLines + :: (Eq v, Num v) + => ReportingContext v + -> Map AccountTitles (TB.AccountBalance v) + -> [StatementLine v] +renderLines context balances = concatMap renderOne (M.toList balances) + where + renderOne (_, TB.NoBalance) = [] + renderOne (title, balance) = case allocationFor title of + Just allocation -> allocatedLines context title balance allocation + Nothing -> case reportingSection title balance of + Nothing -> [] + Just section -> [lineFor context title section balance] + allocationFor title = case filter ((== title) . _allocationAccount) + (_presentationAllocations context) of + allocation : _ -> Just allocation + [] -> Nothing + +allocatedLines + :: (Eq v, Num v) + => ReportingContext v -> AccountTitles -> TB.AccountBalance v + -> PresentationAllocation v -> [StatementLine v] +allocatedLines context title balance allocation = + [ StatementLine title (presentationLabel (_presentationProfile context) title) + section side amount (isContraTitle title) + | (section, amount) <- + [ (currentSection title balance, _allocationCurrent allocation) + , (noncurrentSection title balance, _allocationNoncurrent allocation) + ] + , amount /= 0 + ] + where + side = balanceSide balance + +lineFor + :: Num v => ReportingContext v -> AccountTitles -> StatementSection + -> TB.AccountBalance v -> StatementLine v +lineFor context title section balance = StatementLine + title (presentationLabel (_presentationProfile context) title) + section (balanceSide balance) (balanceAmount balance) (isContraTitle title) + +isContraTitle :: AccountTitles -> Bool +isContraTitle title = case Registry.accountSemantics title of + Just semantics -> ContraAccount `elem` asemRoles semantics + Nothing -> False + +reportingSection + :: AccountTitles -> TB.AccountBalance v -> Maybe StatementSection +reportingSection title balance = do + semantics <- Registry.accountSemantics title + case asemReportingEligibility semantics of + DerivedPresentation -> Nothing + NotPresented -> Nothing + ContextualPresentation -> Just (contextualSection balance) + StatementEligible -> case asemDivisionSemantics semantics of + StatementDivision division -> Just (divisionSection title division) + _ -> Nothing + +divisionSection :: AccountTitles -> AccountDivision -> StatementSection +divisionSection title division = case division of + Assets -> case fixedCurrent title of + Fixed -> NoncurrentAssetsSection + _ -> CurrentAssetsSection + Liability -> case fixedCurrent title of + Fixed -> NoncurrentLiabilitiesSection + _ -> CurrentLiabilitiesSection + Equity -> EquitySection + Revenue -> RevenueSection + Cost -> ExpenseSection + +fixedCurrent :: AccountTitles -> FixedCurrent +fixedCurrent title = case Registry.accountSpec title of + Just spec -> Registry.asFixedCurrent spec + Nothing -> Other + +contextualSection :: TB.AccountBalance v -> StatementSection +contextualSection (TB.DebitBalance _) = ContextualDebitSection +contextualSection (TB.CreditBalance _) = ContextualCreditSection +contextualSection TB.NoBalance = ContextualDebitSection + +currentSection :: AccountTitles -> TB.AccountBalance v -> StatementSection +currentSection title balance = case Registry.accountSemantics title of + Just semantics -> case asemDivisionSemantics semantics of + StatementDivision Liability -> CurrentLiabilitiesSection + StatementDivision Assets -> CurrentAssetsSection + _ -> contextualSection balance + Nothing -> contextualSection balance + +noncurrentSection :: AccountTitles -> TB.AccountBalance v -> StatementSection +noncurrentSection title balance = case Registry.accountSemantics title of + Just semantics -> case asemDivisionSemantics semantics of + StatementDivision Liability -> NoncurrentLiabilitiesSection + StatementDivision Assets -> NoncurrentAssetsSection + _ -> contextualSection balance + Nothing -> contextualSection balance + +subtotalBalance + :: (Ord v, Num v) + => Map AccountTitles (TB.AccountBalance v) + -> [AccountTitles] -> [AccountTitles] -> TB.AccountBalance v +subtotalBalance balances creditTitles debitTitles = netPair + ( sum [balanceAmount (balanceFor title balances) | title <- debitTitles] + , sum [balanceAmount (balanceFor title balances) | title <- creditTitles] + ) diff --git a/src/ExchangeAlgebra/Simulate.hs b/src/ExchangeAlgebra/Simulate.hs --- a/src/ExchangeAlgebra/Simulate.hs +++ b/src/ExchangeAlgebra/Simulate.hs @@ -76,7 +76,7 @@ ,update ,initAll ,updateAll - ,StateSpace(event,randomSeeds) + ,StateSpace(event,randomSeeds,initT,lastT) ,normal ,normal' ,updateGen @@ -88,11 +88,17 @@ ,eventAll ,SpillOptions(..) ,SpillDeletePolicy(..) + ,stepBackWith + ,spillDeleteDecision ,mkSpillOptions ,mkBinarySpillOptions ,defaultSpillWriter ,defaultBinarySpillWriter + ,SpillReadError(..) + ,SpillRangeIssue(..) + ,renderSpillReadError ,readBinarySpillFile + ,readBinarySpillFileChecked ,runSimulation ,runSimulationWithSpill ,runScenarios @@ -112,11 +118,9 @@ import Data.Array.IO hiding (modifyArray) import Data.STRef import qualified Control.Monad as CM -import Data.Array import qualified Data.Map.Strict as M -import System.IO (Handle, IOMode(..), withFile, hPutStrLn, hPutStr) -import qualified Data.ByteString.Lazy as BL -import qualified Data.Binary as Binary +import System.IO (IOMode(..), withFile) +import ExchangeAlgebra.Simulate.Spill ------------------------------------------------------------------ -- | Type class defining the time axis for simulations. @@ -185,11 +189,11 @@ {-# INLINE copy #-} copy :: StdGen -> t -> v -> (a s) -> ST s () - copy _ _ _ _ = undefined + copy _ _ _ _ = error "Updatable.copy: default method not overridden" {-# INLINE modify #-} modify :: StdGen -> t -> v -> (a s) -> ST s () - modify _ _ _ _ = undefined + modify _ _ _ _ = error "Updatable.modify: default method not overridden" {-# INLINE update #-} update :: StdGen -> t -> v -> (a s) -> ST s () @@ -217,6 +221,10 @@ -- -- _unwrapURef (SP x) = x -- -- _wrapURef x = SP x -- @ +-- +-- The underscore-prefixed methods are exported because defining a +-- (non-Coercible) instance requires naming them; they are instance wiring, +-- not a user-facing API — call 'readURef'\/'writeURef'\/'modifyURef' instead. class UpdatableSTRef wrapper s b | wrapper s -> b where -- | Unwrap to the inner @STRef@. -- For newtype wrappers, the @Coercible@ default is used. @@ -346,98 +354,6 @@ eventAll wld t = CM.forM_ [fstEvent .. lastEvent] $ \e -> event wld t e --- | Spill configuration for periodic external logging. --- `spillExtract` selects accounting payload from world. --- `spillWriteChunk` controls on-disk format. -data SpillOptions t a payload = SpillOptions - { spillEveryTerms :: !Int - , spillFilePath :: FilePath - , spillExtract :: a RealWorld -> ST RealWorld payload - , spillExtractChunk :: Maybe ((t, t) -> a RealWorld -> ST RealWorld payload) - , spillWriteChunk :: Handle -> (t, t) -> payload -> IO () - , spillDeletePolicy :: SpillDeletePolicy t - , spillDeleteRange :: (t, t) -> a RealWorld -> ST RealWorld () - } - --- | Policy to decide which term range to evict after each spill. -data SpillDeletePolicy t - = NoDelete - | DeleteSpilledChunk - | KeepRecentTerms Int - --- | Construct text-format SpillOptions. --- interval is the spill interval (in terms), path is the output file path. --- --- Complexity: O(1) -mkSpillOptions :: (Show t) - => Int - -> FilePath - -> (a RealWorld -> ST RealWorld String) - -> SpillOptions t a String -mkSpillOptions interval path extractF = - SpillOptions - { spillEveryTerms = max 1 interval - , spillFilePath = path - , spillExtract = extractF - , spillExtractChunk = Nothing - , spillWriteChunk = defaultSpillWriter - , spillDeletePolicy = NoDelete - , spillDeleteRange = \_ _ -> pure () - } - --- | Construct binary-format SpillOptions. --- Spills in a format that can be restored with 'readBinarySpillFile'. --- --- Complexity: O(1) -mkBinarySpillOptions :: (Binary.Binary t, Binary.Binary payload) - => Int - -> FilePath - -> (a RealWorld -> ST RealWorld payload) - -> SpillOptions t a payload -mkBinarySpillOptions interval path extractF = - SpillOptions - { spillEveryTerms = max 1 interval - , spillFilePath = path - , spillExtract = extractF - , spillExtractChunk = Nothing - , spillWriteChunk = defaultBinarySpillWriter - , spillDeletePolicy = NoDelete - , spillDeleteRange = \_ _ -> pure () - } - --- | Default text-format spill writer. --- Writes the chunk range and payload as text to the handle. -defaultSpillWriter :: (Show t) => Handle -> (t, t) -> String -> IO () -defaultSpillWriter h (tStart, tEnd) payload = do - hPutStrLn h ("# chunk " ++ show tStart ++ " " ++ show tEnd) - hPutStr h payload - hPutStrLn h "\n# end-chunk" - --- | Default binary-format spill writer. --- Writes the chunk range and payload to the handle using 'Binary.encode'. -defaultBinarySpillWriter :: (Binary.Binary t, Binary.Binary payload) - => Handle -> (t, t) -> payload -> IO () -defaultBinarySpillWriter h range payload = - BL.hPut h $ Binary.encode (range, payload) - --- | Read a binary spill file and return it as a list of chunks. --- Used to restore files written by 'defaultBinarySpillWriter'. --- When decoding fails, the remaining data is truncated. --- --- Complexity: O(file size) -readBinarySpillFile :: (Binary.Binary t, Binary.Binary payload) - => FilePath - -> IO [((t, t), payload)] -readBinarySpillFile path = do - bytes <- BL.readFile path - pure (go bytes) - where - go bs - | BL.null bs = [] - | otherwise = case Binary.decodeOrFail bs of - Left _ -> [] - Right (rest, _, entry) -> entry : go rest - -- | Simulation {-# INLINE simulate #-} simulate :: (StateSpace t v e a s) @@ -447,12 +363,12 @@ {-# INLINE loop #-} loop :: (StateSpace t v e a s) => StdGen -> a s -> t -> v -> ST s () - loop g wld t v - | t == lastTerm = updateAll g t v wld >> eventAll wld t + loop g' wld' t v' + | t == lastTerm = updateAll g' t v' wld' >> eventAll wld' t | otherwise = do - updateAll g t v wld - eventAll wld t - loop g wld (nextTerm t) v + updateAll g' t v' wld' + eventAll wld' t + loop g' wld' (nextTerm t) v' -- | Run a simulation from initialization through the final term. -- Build the world state with initAll, then repeat updateAll followed by eventAll for each term. @@ -485,25 +401,13 @@ shouldSpill chunkStart t isLast = isLast || (fromEnum t - fromEnum chunkStart + 1 >= spillEveryTerms opts) - backBy n x - | n <= 0 = x - | otherwise = backBy (n - 1) (prevTerm x) - - deleteRangeForChunk (chunkStart, chunkEnd) = case spillDeletePolicy opts of - NoDelete -> Nothing - DeleteSpilledChunk -> Just (chunkStart, chunkEnd) - KeepRecentTerms keepN -> - let deleteEnd = backBy keepN chunkEnd - in if deleteEnd < chunkStart - then Nothing - else Just (chunkStart, deleteEnd) - spillChunk h chunkStart t wld = do payload <- case spillExtractChunk opts of Just extractChunk -> stToIO $ extractChunk (chunkStart, t) wld Nothing -> stToIO $ spillExtract opts wld spillWriteChunk opts h (chunkStart, t) payload - case deleteRangeForChunk (chunkStart, t) of + -- delete decision is single-sourced in 'spillDeleteDecision' (C4) + case spillDeleteDecision prevTerm (spillDeletePolicy opts) (chunkStart, t) of Nothing -> pure () Just delRange -> stToIO $ spillDeleteRange opts delRange wld @@ -616,6 +520,9 @@ inverse :: IOArray (Int, Int) Double -> IO (IOArray (Int, Int) Double) inverse mat = do bnds <- getBounds mat + -- 'inverse' is only ever called on a 1-indexed square matrix, so the bounds + -- are @((1,1),(n,n))@; matching @((1,1),(n,_))@ is intentionally partial + -- (audited invariant) — a non-1-indexed matrix is a programmer error here. let ((1,1),(n,_)) = bnds inv <- identity n diff --git a/src/ExchangeAlgebra/Simulate/Lite.hs b/src/ExchangeAlgebra/Simulate/Lite.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Simulate/Lite.hs @@ -0,0 +1,742 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +{- | + Module : ExchangeAlgebra.Simulate.Lite + Copyright : (c) Kaya Akagi. 2018-2026 + Maintainer : yakagika@icloud.com + + Released under the OWL license + + == What this module is + + @Simulate.Lite@ is a small, additive front-end for agent-based bookkeeping + simulations. It sits /beside/ the classic "ExchangeAlgebra.Simulate" engine + (which is left completely unchanged) and trades some of its flexibility for + much less boilerplate and a clearer, /bulk-synchronous parallel/ (BSP) + semantics. + + A model is described by three things: + + 1. a __product-only HKD world__ @w@ (one record, sibling fields, no + nesting, no sum types) whose fields are tagged by a /role/ + (@'InitT'@, @'RefT' s@, @'SnapT'@) via the 'HK' type family; + 2. a list of __stages__ ('Stage'); each stage maps its agents to + /messages/ (t'Journal') purely from a read-only world snapshot; and + 3. a t'SimSpec' bundling the term range, seed, the ledger field selector, + the stages, and a parallelism policy. + + 'runLite' drives the BSP loop: per term, per stage, it freezes the world to + a snapshot, runs every agent against /that same snapshot/, and then commits + the merged messages to the ledger in one shot. + + == Correspondence with the classic "ExchangeAlgebra.Simulate" + + +--------------------------+----------------------------------+----------------------------------+ + | concept | classic @Simulate@ | @Simulate.Lite@ | + +==========================+==================================+==================================+ + | world state | @StateSpace@ + @Updatable@ | product-only HKD @w@ + 'HK' | + | | instances per field | (no per-field class instances) | + +--------------------------+----------------------------------+----------------------------------+ + | mutable cell access | @UpdatableSTRef@ plumbed by hand | 'HK' @('RefT' s)@ = @STRef s@, | + | | | generated by 'gInit' | + +--------------------------+----------------------------------+----------------------------------+ + | read-only view | read each ref where needed | one 'gFreeze' = @w 'SnapT'@ | + +--------------------------+----------------------------------+----------------------------------+ + | per-agent step | imperative @ST@ that may read | pure @w 'SnapT' -> ... -> | + | | /and write/ shared refs | Journal@ (a /message/) | + +--------------------------+----------------------------------+----------------------------------+ + | term boundary update | bespoke @Updatable@ logic | declarative 'Field' rule | + | | | (Carry\/ResetEach\/UpdateEach) | + +--------------------------+----------------------------------+----------------------------------+ + + == BSP semantics (differs from the classic engine) + + Within a single stage every agent observes the __same snapshot__, taken once + at the start of the stage. An agent /cannot/ see the messages emitted by + earlier agents in the same stage (intra-stage invisibility). Messages from a + stage become visible only to /later/ stages (same term) and to later terms, + because the ledger commit happens after the whole stage has run. This is the + BSP "superstep" rule; the classic engine, by contrast, lets an imperative + step read mutations made earlier in the same step. Models ported from the + classic engine must respect this: split a read-then-write dependency into two + stages. + + == Determinism + + Each agent's 'StdGen' is derived deterministically from + @('specSeed', term index, stage index, agent index)@ only — never from + wall-clock, thread scheduling, or the chosen 'Par' policy. Consequently a + 'Sequential' run and a 'ParChunk' run of the same t'SimSpec' produce the same + observable ledger (see the @DET-2@ test), and re-running is reproducible + (@DET-1@). + + == Reading HKD type errors + + If a world field is given the wrong element type, GHC reports the mismatch + with the 'HK' family already reduced to the field representation, e.g. + annotating @wPrice :: 'HK' f Double@ but using it as a @String@ yields: + + > • Couldn't match type ‘[Char]’ with ‘Double’ + > Expected: HK SnapT String + > Actual: Double + > • In the ‘wPrice’ field of a record + + Read the @Expected@/@Actual@ lines as "this field is a @String@ here but a + @Double@ was expected" — the family is shown reduced, so there is no + instance-resolution wall to wade through. + + == Scope + + World records must be __product-only and non-nested__ (the generic traversal + in this module only handles @M1@ \/ @:*:@ \/ @K1@). Ledger retention, spill + and compaction are not decided in this module: they are supplied + declaratively as a t'LedgerPolicy' ("ExchangeAlgebra.Simulate.Policy") and + applied by 'runLiteWithPolicy'. Snapshot-dependent term-boundary + recomputation and parallel speedup measurement remain out of scope. +-} + +module ExchangeAlgebra.Simulate.Lite + ( -- * Term-boundary field rules + Field(..) + , carry + , resetEach + , updateEach + -- * Role tags and the HK field family + , InitT + , RefT + , SnapT + , HK + -- * Generic world traversal + -- The GLite* classes are exported name-only: their primed methods are the + -- Generic-Rep plumbing (instances for M1/(:*:)/K1 live in this module); + -- user code only ever names the classes in constraints. + , GLiteInit + , GLiteFreeze + , GLiteCommit + , LiteWorld + , gInit + , gFreeze + , gCommit + -- * Stages + -- 'Stage' is exported name-only: build stages with the smart constructors + -- ('stageFor'/'stage'/'stageOf') and read the name via 'stageName'. + , Stage + , stageFor + , stage + , stageOf + , stageName + -- * Simulation specification + , Par(..) + , SimSpec(..) + , mkSimSpec + -- * Runner + , runLite + -- * Policy-driven runner + , runLiteWithPolicy + ) where + +import GHC.Generics +import Data.Kind (Type) +import Control.Monad (forM_, when) +import Control.Monad.ST (ST, runST, RealWorld, stToIO) +import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef, modifySTRef') +import Data.Hashable (hash) +import Data.IORef (newIORef, readIORef, writeIORef) +import System.IO (Handle, IOMode(WriteMode), withFile) +import System.Random (StdGen, mkStdGen) +import Control.Parallel.Strategies (parListChunk, rdeepseq, using) +import Control.DeepSeq (deepseq) +import qualified Data.Binary as Binary +import qualified Data.HashMap.Strict as HM + +import ExchangeAlgebra.Journal ( Journal + , Note + , HatVal + , HatBaseClass + , sigma + , toMap + , fromMap + , (.|) + , filterWithNote ) +import ExchangeAlgebra.Algebra (Alg) +import qualified ExchangeAlgebra.Algebra as EA ((.+), compress) +import ExchangeAlgebra.Simulate (StateTime) +import ExchangeAlgebra.Simulate.Spill (defaultBinarySpillWriter, stepBackWith) +import ExchangeAlgebra.Simulate.Policy ( LedgerPolicy(..) + , Retention(..) + , Compaction(..) + , HasTermAxis(..) ) + +------------------------------------------------------------------ +-- * Term-boundary field rules +------------------------------------------------------------------ + +-- | How a world field is updated at a /term boundary/ (between superstep +-- sweeps of all stages). The constructor also carries the field's initial +-- value, so a single @w 'InitT'@ value fully describes both the starting world +-- and its boundary dynamics. +-- +-- Note: within a term, a field only changes through the ledger commit of a +-- stage (for the ledger field) or not at all (for parameter fields). The +-- 'Field' rule fires exactly once per term, after every stage has run. +data Field a + = Carry !a -- ^ Keep the current ref value across the boundary + -- (the usual choice for an accumulating ledger). + | ResetEach !a -- ^ Overwrite with this value at every boundary. + | UpdateEach !a (a -> a) -- ^ Start from this value; apply the function at + -- every boundary (e.g. a decaying price). + +-- | Smart constructor for 'Carry'. +carry :: a -> Field a +carry = Carry + +-- | Smart constructor for 'ResetEach'. +resetEach :: a -> Field a +resetEach = ResetEach + +-- | Smart constructor for 'UpdateEach'. +updateEach :: a -> (a -> a) -> Field a +updateEach = UpdateEach + +------------------------------------------------------------------ +-- * Role tags and the HK field family +------------------------------------------------------------------ + +-- | Role tag: a field as an /initial value + boundary rule/ ('Field'). +data InitT + +-- | Role tag: a field as a mutable @'STRef' s@ cell during a run. The state +-- region @s@ lives only on this tag (snapshots and inits are region-free), so +-- stages stay plain (non-rank-2) functions. +data RefT s + +-- | Role tag: a field as a bare, read-only value — the BSP snapshot view. No +-- @Identity@ wrapper, so @w 'SnapT'@ reads exactly like an ordinary record. +data SnapT + +-- | @'HK' f a@ chooses the representation of a world field of element type @a@ +-- under role tag @f@. +type family HK (f :: Type) a where + HK InitT a = Field a + HK (RefT s) a = STRef s a + HK SnapT a = a + +------------------------------------------------------------------ +-- * Generic world traversal (product-only) +------------------------------------------------------------------ +-- +-- Three hand-written classes over the GHC.Generics product structure +-- (@M1@ / @:*:@ / @K1@ only — no @barbies@ or other HKD dependency). The +-- per-field leaf instances pattern-match on the concrete field shape +-- (@Field a@, @STRef s a@, bare @a@) so GHC never has to invert 'HK'. + +-- | Build the @'RefT' s@ world from the @'InitT'@ world by allocating one +-- 'STRef' per field, seeded with the field's initial value. +class GLiteInit s i o where + gInit' :: i x -> ST s (o x) + +instance GLiteInit s i o => GLiteInit s (M1 t m i) (M1 t m o) where + gInit' (M1 a) = M1 <$> gInit' a +instance (GLiteInit s i1 o1, GLiteInit s i2 o2) + => GLiteInit s (i1 :*: i2) (o1 :*: o2) where + gInit' (a :*: b) = (:*:) <$> gInit' a <*> gInit' b +instance GLiteInit s (K1 r (Field a)) (K1 r (STRef s a)) where + gInit' (K1 fld) = K1 <$> newSTRef (initialOf fld) + +-- | The starting value carried by a 'Field', regardless of its boundary rule. +initialOf :: Field a -> a +initialOf (Carry a) = a +initialOf (ResetEach a) = a +initialOf (UpdateEach a _) = a + +-- | Freeze the @'RefT' s@ world to a bare-value snapshot (@'SnapT'@). Each +-- field is a single 'readSTRef'; immutable structures (arrays, maps) are shared +-- O(1), not copied. +class GLiteFreeze s i o where + gFreeze' :: i x -> ST s (o x) + +instance GLiteFreeze s i o => GLiteFreeze s (M1 t m i) (M1 t m o) where + gFreeze' (M1 a) = M1 <$> gFreeze' a +instance (GLiteFreeze s i1 o1, GLiteFreeze s i2 o2) + => GLiteFreeze s (i1 :*: i2) (o1 :*: o2) where + gFreeze' (a :*: b) = (:*:) <$> gFreeze' a <*> gFreeze' b +instance GLiteFreeze s (K1 r (STRef s a)) (K1 r a) where + gFreeze' (K1 ref) = K1 <$> readSTRef ref + +-- | Apply each field's 'Field' boundary rule to the live refs, zipping the +-- @'InitT'@ structure (rules + initial values) against the @'RefT' s@ structure. +class GLiteCommit s i r where + gCommit' :: i x -> r x -> ST s () + +instance GLiteCommit s i r => GLiteCommit s (M1 t m i) (M1 t m r) where + gCommit' (M1 a) (M1 b) = gCommit' a b +instance (GLiteCommit s i1 r1, GLiteCommit s i2 r2) + => GLiteCommit s (i1 :*: i2) (r1 :*: r2) where + gCommit' (a :*: b) (c :*: d) = gCommit' a c >> gCommit' b d +instance GLiteCommit s (K1 k (Field a)) (K1 k (STRef s a)) where + gCommit' (K1 fld) (K1 ref) = + case fld of + Carry _ -> pure () + ResetEach a0 -> writeSTRef ref a0 + UpdateEach _ f -> modifySTRef' ref f + +-- | Constraint bundling everything a world type @w@ must satisfy to be driven +-- by 'runLite' in the @s@ region. It is a single (method-less) class so that it +-- can be used under a @forall s.@ quantified constraint in 'runLite' (a bare +-- @ConstraintKinds@ tuple synonym cannot). A product-only @deriving Generic@ +-- on @w@ is all the user has to supply; the catch-all instance discharges the +-- rest automatically. +class ( Generic (w InitT) + , Generic (w (RefT s)) + , Generic (w SnapT) + , GLiteInit s (Rep (w InitT)) (Rep (w (RefT s))) + , GLiteFreeze s (Rep (w (RefT s))) (Rep (w SnapT)) + , GLiteCommit s (Rep (w InitT)) (Rep (w (RefT s))) + ) => LiteWorld w s + +instance ( Generic (w InitT) + , Generic (w (RefT s)) + , Generic (w SnapT) + , GLiteInit s (Rep (w InitT)) (Rep (w (RefT s))) + , GLiteFreeze s (Rep (w (RefT s))) (Rep (w SnapT)) + , GLiteCommit s (Rep (w InitT)) (Rep (w (RefT s))) + ) => LiteWorld w s + +-- | Allocate the live (ref) world from the initial world. +gInit :: (Generic (w InitT), Generic (w (RefT s)), GLiteInit s (Rep (w InitT)) (Rep (w (RefT s)))) + => w InitT -> ST s (w (RefT s)) +gInit w = to <$> gInit' (from w) + +-- | Take a read-only snapshot of the live world. +gFreeze :: (Generic (w (RefT s)), Generic (w SnapT), GLiteFreeze s (Rep (w (RefT s))) (Rep (w SnapT))) + => w (RefT s) -> ST s (w SnapT) +gFreeze w = to <$> gFreeze' (from w) + +-- | Apply every field's term-boundary 'Field' rule to the live world. +gCommit :: (Generic (w InitT), Generic (w (RefT s)), GLiteCommit s (Rep (w InitT)) (Rep (w (RefT s)))) + => w InitT -> w (RefT s) -> ST s () +gCommit wi wr = gCommit' (from wi) (from wr) + +------------------------------------------------------------------ +-- * Stages +------------------------------------------------------------------ + +-- | A BSP stage: a named, pure mapping from agents to /messages/. Every agent +-- runs against the same snapshot @w 'SnapT'@, the current term @t@, and a +-- deterministically derived 'StdGen'. The agent element type @a@ is +-- existential, so different stages may use different agent populations. +-- +-- There are two constructors: +-- +-- * @StageFor@ — the original, fully general stage. Each agent emits a +-- t'Journal' directly, so the stage body is free to attach /any/ notes +-- (including several different notes from one agent). Built with 'stageFor' +-- or 'stage'. +-- +-- * @StageTagged@ — a /note-tagged/ stage whose note type is fixed to +-- @(tag, t)@ by construction. Each agent emits a bare 'Alg' and the runner +-- attaches the single note @(stTag, t)@ in __one place__ (@runStage@). This +-- removes the write-site note duplication of @alg '.|' (Tag, t)@ and ties +-- the stage's tag to its note type at compile time. Built with 'stageOf'. +-- +-- == Which constructor to use +-- +-- Prefer 'stageOf' for a stage that emits __exactly one note tag__: the tag is +-- written once (as @stTag@), the runner supplies it, and a downstream +-- @projWithNote [(Tag, t)]@ that names the wrong constructor is a type error +-- rather than a silently empty projection. Use 'stageFor'\/'stage' when a single +-- stage must emit __several different notes__ (e.g. a closing stage that posts +-- both @(Closing, t)@ and @(Carryover, t+1)@): such a stage cannot be expressed +-- as a single auto-attached tag, so it keeps returning a t'Journal' itself. +-- +-- The two constructors are observationally interchangeable for a one-note +-- stage: @'stageOf' tag as f@ produces the same messages as +-- @'stageFor' (show tag) as (\\v t g a -> f v t g a '.|' (tag, t))@ (asserted by +-- the @stageOf auto-note@ sentinel). @StageTagged@ only moves the @'.|' (tag, t)@ +-- from the stage body into the runner. +data Stage w t n v b where + StageFor :: { stName :: String + , stAgents :: [a] + , stRun :: w SnapT -> t -> StdGen -> a -> Journal n v b } + -> Stage w t n v b + StageTagged :: (Note tag) + => { stTag :: tag + , stAgentsT :: [a] + , stRunAlg :: w SnapT -> t -> StdGen -> a -> Alg v b } + -> Stage w t (tag, t) v b + +-- | Build a stage that runs once per element of the given agent list, each +-- agent emitting a t'Journal' directly. +stageFor :: String + -> [a] + -> (w SnapT -> t -> StdGen -> a -> Journal n v b) + -> Stage w t n v b +stageFor = StageFor + +-- | Build a singleton stage with no per-agent fan-out and no random draw — +-- handy for aggregate/bookkeeping steps. Equivalent to +-- @'stageFor' name [()] (\\v t _ () -> f v t)@. +stage :: String + -> (w SnapT -> t -> Journal n v b) + -> Stage w t n v b +stage name f = StageFor name [()] (\v t _g () -> f v t) + +-- | Build a __note-tagged__ stage: each agent emits a bare 'Alg' and the runner +-- attaches the single note @(stTag, t)@ once, in @runStage@. The note type is +-- fixed to @(tag, t)@ by the result type, so the write-site tag (the @tag@ +-- argument) and any read-site @projWithNote [(tag, t)]@ are checked against the +-- same constructor by the type-checker — a stringly-typed mismatch becomes a +-- compile error instead of a silently empty projection. +-- +-- Use this for any stage that emits __exactly one note tag__. For a stage that +-- must post __several different notes__ (e.g. @(Closing, t)@ together with +-- @(Carryover, t+1)@), keep using 'stageFor'\/'stage', which let the body return +-- a fully general t'Journal'. +-- +-- Determinism is unaffected: the per-agent 'StdGen' is still derived from +-- @('specSeed', termIx, stageIx, agentIx)@ only (see @runStage@), and the note +-- attachment @'.|' (stTag, t)@ is a pure post-transform of each agent's 'Alg'. +stageOf :: (Note tag) + => tag + -> [a] + -> (w SnapT -> t -> StdGen -> a -> Alg v b) + -> Stage w t (tag, t) v b +stageOf = StageTagged + +-- | The display name of a stage: @stName@ for @StageFor@, @show stTag@ for +-- @StageTagged@ (the tag's 'Show' comes from its 'Note' superclass). Use this +-- instead of @stName@ when a stage may be either constructor. +stageName :: Stage w t n v b -> String +stageName (StageFor nm _ _) = nm +stageName (StageTagged tg _ _) = show tg + +------------------------------------------------------------------ +-- * Simulation specification +------------------------------------------------------------------ + +-- | Parallelism policy for running a stage's agents. The chunk size is fixed +-- (input-size-only), so the partitioning — and therefore the result — does not +-- depend on the runtime scheduler (@DET-1@). +data Par = Sequential -- ^ Run agents left-to-right, no sparks. + | ParChunk !Int -- ^ Evaluate agent messages in fixed-size chunks + -- in parallel ('parListChunk'). + +-- | A complete simulation description. +data SimSpec w t n v b = SimSpec + { specTerms :: (t, t) + -- ^ Inclusive @(from, to)@ term range, a runtime value (no compile-time + -- @lastTerm@ constant required). + , specSeed :: Int + -- ^ Master seed; all per-agent generators derive from it deterministically. + , specLedger :: forall f. w f -> HK f (Journal n v b) + -- ^ The ledger field selector (just the record accessor), used polymorphically + -- across roles to read the snapshot ledger and to write the live one. + -- + -- __Which field is the ledger is a model declaration, not inferred.__ The + -- committed-ledger role is conferred by /this selector alone/: 'runLite' + -- commits every stage's merged messages only to the field it returns, and + -- retention\/spill\/compaction ('runLiteWithPolicy') all act on that same + -- field. The product type only fixes the three roles + -- (@'InitT'@\/@'RefT'@\/@'SnapT'@); it does /not/ mark one field as the + -- ledger and the others as auxiliary — that split is a discipline this + -- selector expresses, not a type-level guarantee. + -- + -- Consequence: if the world has more than one @'Journal' n v b@ field, + -- pointing the selector at the wrong one type-checks and fails __silently__. + -- Commits, eviction and the final projection are then all consistently + -- applied to the wrong ledger, so a test that reads back through the same + -- selector can still pass. Prefer __exactly one__ @'Journal'@ field per + -- world, or name fields so the intended ledger is unmistakable. (A future + -- @newtype Ledger@ wrapper could make this distinction type-level; until + -- then it is a convention.) + , specStages :: [Stage w t n v b] + -- ^ Stages, run in this declared order each term. + , specParallel :: Par + -- ^ Agent-level parallelism policy. + } + +-- | Smart constructor for t'SimSpec' defaulting to 'Sequential'. Prefer this over +-- the raw record so that future, additive t'SimSpec' fields stay non-breaking. +mkSimSpec :: (t, t) + -> Int + -> (forall f. w f -> HK f (Journal n v b)) + -> [Stage w t n v b] + -> SimSpec w t n v b +mkSimSpec terms seed ledger stages = SimSpec + { specTerms = terms + , specSeed = seed + , specLedger = ledger + , specStages = stages + , specParallel = Sequential + } + +------------------------------------------------------------------ +-- * Runner (BSP) +------------------------------------------------------------------ + +-- | Run a t'SimSpec' over the given initial world and project the final +-- snapshot through a continuation. +-- +-- The loop, per term @t@ in @['from'..'to']@ and per stage in declared order: +-- +-- 1. take one snapshot @view@ of the live world ('gFreeze'); +-- 2. run every agent against /that/ snapshot (intra-stage invisibility), +-- producing one message (t'Journal') each — sequentially or in fixed-size +-- parallel chunks per 'specParallel'; +-- 3. /flatten-once commit/: fold all messages into a single journal once +-- with the public 'sigma' (which itself folds into a 'Data.HashMap', +-- skipping zero journals, then rebuilds one journal), and add it to the +-- ledger ref with a single 'modifySTRef''. +-- +-- After all stages of a term, every field's term-boundary 'Field' rule fires +-- ('gCommit'). The final live world is frozen once and handed to the +-- continuation. +runLite :: forall w t n v b r. + ( forall s. LiteWorld w s + , HatVal v, HatBaseClass b, Note n, Enum t, Ord t ) + => SimSpec w t n v b + -> w InitT + -> (w SnapT -> r) + -> r +runLite spec wInit k = runST $ do + wr <- gInitR wInit + let (from0, to0) = specTerms spec + terms = enumFromThenToInclusive from0 to0 + stages = zip [0 ..] (specStages spec) + forM_ (zip [0 ..] terms) $ \(termIx, t) -> do + forM_ stages $ \(stageIx, st) -> do + view <- gFreezeR wr + let msgs = runStage spec view t termIx stageIx st + delta = sigma msgs id :: Journal n v b + modifySTRef' (specLedger spec wr) (\acc -> acc EA..+ delta) + -- term boundary: fire the Field rules exactly once per term, AFTER + -- all stages of the term have committed (BSP semantics, design S3). + gCommitR wInit wr + final <- gFreezeR wr + pure (k final) + where + -- Pin the generic-traversal dictionaries at the @s@ chosen by 'runST'. + gInitR :: forall s. LiteWorld w s => w InitT -> ST s (w (RefT s)) + gInitR = gInit + gFreezeR :: forall s. LiteWorld w s => w (RefT s) -> ST s (w SnapT) + gFreezeR = gFreeze + gCommitR :: forall s. LiteWorld w s => w InitT -> w (RefT s) -> ST s () + gCommitR = gCommit + +-- | Inclusive @[from .. to]@ for an 'Enum'/'Ord' term type. Empty when +-- @from > to@. +enumFromThenToInclusive :: (Enum t, Ord t) => t -> t -> [t] +enumFromThenToInclusive from0 to0 + | from0 > to0 = [] + | otherwise = [from0 .. to0] + +-- | Produce the messages of one stage, applying the parallelism policy. Each +-- agent gets a 'StdGen' derived purely from +-- @('specSeed', termIx, stageIx, agentIx)@, so the result is independent of the +-- evaluation order or the 'Par' policy. +-- +-- Under 'ParChunk' the FIRST message is forced to normal form in the calling +-- thread before the remaining messages are sparked. Every message reaches the +-- shared snapshot @view@ through lazily-built index structures (the Journal's +-- note-axis index, each Alg's base index); if many sparks race to force those +-- shared thunks, the RTS's duplicate-work suspension can re-enter its own +-- blackhole and abort with a spurious @<>@ (observed intermittently at +-- @-N4@; the thunk graph is acyclic — sequential evaluation never loops). +-- Forcing one message first materialises the shared structure in a single +-- thread, so the sparks only evaluate agent-local work. Pure values: the +-- result is unchanged (DET-2 asserts exact equality). +runStage :: forall w t n v b. + (HatVal v, HatBaseClass b, Note n) + => SimSpec w t n v b + -> w SnapT + -> t + -> Int -- ^ term index (0-based) + -> Int -- ^ stage index (0-based) + -> Stage w t n v b + -> [Journal n v b] +runStage spec view t termIx stageIx st = + let seed0 = specSeed spec + -- The per-agent messages, before applying the parallelism policy. Both + -- constructors derive each generator from the same coordinates only, so + -- DET is identical to the StageFor-only runner. 'StageTagged' attaches + -- the single note @(stTag, t)@ here — the ONLY place auto-tagging + -- happens — as a pure post-transform of each agent's bare 'Alg'. + msgs = case st of + StageFor _ agents f -> + [ f view t (deriveGen seed0 termIx stageIx agentIx) a + | (agentIx, a) <- zip [0 ..] agents ] + StageTagged tg agents g -> + [ g view t (deriveGen seed0 termIx stageIx agentIx) a .| (tg, t) + | (agentIx, a) <- zip [0 ..] agents ] + in case specParallel spec of + Sequential -> msgs + ParChunk c -> case msgs of + [] -> [] + (m : ms) -> m `deepseq` + (m : (ms `using` parListChunk (max 1 c) rdeepseq)) + +-- | Deterministically derive an agent's generator from the seed and the +-- @(term, stage, agent)@ coordinates only — never from scheduling. Uses a hash +-- of the tuple so that distinct coordinates almost never collide and the value +-- is stable across runs and 'Par' policies. +deriveGen :: Int -> Int -> Int -> Int -> StdGen +deriveGen seed0 termIx stageIx agentIx = + mkStdGen (hash (seed0, termIx, stageIx, agentIx)) +{-# INLINE deriveGen #-} + +------------------------------------------------------------------ +-- * Policy-driven runner +------------------------------------------------------------------ + +-- | Run a t'SimSpec' under a declarative t'LedgerPolicy', returning in 'IO' +-- (because spill writes a file). The BSP loop is /identical/ to 'runLite' — per +-- term, per stage: snapshot, run agents, flatten-once commit — and the term +-- range, seed, stages, parallelism and per-agent generators are all the same. +-- The only additions happen at each term boundary, /after/ the stages have +-- committed and the 'Field' rules have fired: +-- +-- 1. __compaction__ — if @'compaction' = 'CompressClosedTerms'@, every entry +-- of a /closed/ term (term @<@ the current term @t@) is 'EA.compress'ed. +-- This is norm- and balance-preserving; only the within-term posting +-- sequence is collapsed. The in-progress term is never touched. +-- 2. __retention / spill__ — if @'retain' = 'RetainRecent' w@, terms with +-- @'termOf' n '<=' t - w@ are evicted from the in-memory ledger. If +-- @'spillTo' = 'Just' path@, each newly-closed-and-evicted term is first +-- appended to that binary file (compatible with 'defaultBinarySpillWriter', +-- so 'ExchangeAlgebra.Simulate.Policy.restoreLedger' can read it back). +-- +-- Under 'ExchangeAlgebra.Simulate.Policy.defaultLedgerPolicy' nothing is +-- compacted, evicted or spilled, so the result is observationally equal to +-- @'runLite' spec wInit k@ (see the equivalence test). +-- +-- __Data loss warning.__ @'spillTo' = 'Nothing'@ together with +-- @'RetainRecent' w@ /discards/ evicted terms — they are written nowhere and +-- cannot be restored. Use it only when the older history is genuinely not +-- needed; otherwise set @'spillTo' = 'Just' path@. +runLiteWithPolicy + :: forall w t n v b r. + ( forall s. LiteWorld w s + , HatVal v, HatBaseClass b + , HasTermAxis n, TermOf n ~ t + , StateTime t + , Binary.Binary t, Binary.Binary (Journal n v b) ) + => LedgerPolicy + -> SimSpec w t n v b + -> w InitT + -> (w SnapT -> r) + -> IO r +runLiteWithPolicy pol spec wInit k = do + let (from0, to0) = specTerms spec + terms = zip [0 :: Int ..] (enumFromThenToInclusive from0 to0) + stages = zip [0 :: Int ..] (specStages spec) + window = case retain pol of + RetainAll -> Nothing + RetainRecent w -> Just (max 0 w) + -- High-water mark of the most recent term already spilled (so each closed + -- term is written to disk at most once). 'Nothing' = nothing spilled yet. + spilledRef <- newIORef (Nothing :: Maybe t) + wr <- stToIO (gInitR wInit) + let -- Run one full term (all stages, then Field rules). Mirrors 'runLite'. + runTerm :: Int -> t -> ST RealWorld () + runTerm termIx t = do + forM_ stages $ \(stageIx, st) -> do + view <- gFreezeR wr + let msgs = runStage spec view t termIx stageIx st + delta = sigma msgs id :: Journal n v b + modifySTRef' (specLedger spec wr) (\acc -> acc EA..+ delta) + gCommitR wInit wr + + -- Apply 'CompressClosedTerms' to entries strictly before term @t@. + compactClosed :: t -> ST RealWorld () + compactClosed t = case compaction pol of + FullAudit -> pure () + CompressClosedTerms -> + modifySTRef' (specLedger spec wr) + (compressClosedTerms t) + + withMaybeSpillHandle (spillTo pol) $ \mh -> + forM_ terms $ \(termIx, t) -> do + stToIO (runTerm termIx t) + stToIO (compactClosed t) + -- retention / spill at the term boundary + case window of + Nothing -> pure () + Just w -> do + -- Eviction boundary for a w-term resident window ending at t: + -- evict every term <= t - w. The step-back arithmetic is + -- single-sourced in ExchangeAlgebra.Simulate ('stepBackWith'; + -- design-review C4). When the boundary is below the spec's + -- first term the delete predicate matches nothing — no + -- clamping needed. + let boundary = stepBackWith pred w t -- evict terms <= boundary + spilledHi <- readIORef spilledRef + -- spill newly-closed terms (spilledHi, boundary] before deleting + case mh of + Nothing -> pure () + Just h -> when (firstUnspilled spilledHi <= boundary) $ do + ledger <- stToIO (readSTRef (specLedger spec wr)) + let lo = firstUnspilled spilledHi + chunk = filterWithNote + (\nn _ -> let tt = termOf nn + in tt >= lo && tt <= boundary) + ledger + -- Suppress empty spill chunks: at early term boundaries the + -- eviction window may not yet cover any resident term, so the + -- filtered chunk is empty. Writing it would emit a zero-entry + -- record to the binary file (restored as a no-op, but still a + -- wasted write); skip it. The high-water mark is still advanced + -- below, so a later non-empty term in (lo, boundary] is not lost. + when (not (HM.null (toMap chunk))) $ + defaultBinarySpillWriter h (lo, boundary) chunk + -- delete evicted terms from memory (whether or not spilled) + stToIO $ modifySTRef' (specLedger spec wr) + (filterWithNote (\nn _ -> termOf nn > boundary)) + writeIORef spilledRef (Just boundary) + final <- stToIO (gFreezeR wr) + pure (k final) + where + gInitR :: forall s. LiteWorld w s => w InitT -> ST s (w (RefT s)) + gInitR = gInit + gFreezeR :: forall s. LiteWorld w s => w (RefT s) -> ST s (w SnapT) + gFreezeR = gFreeze + gCommitR :: forall s. LiteWorld w s => w InitT -> w (RefT s) -> ST s () + gCommitR = gCommit + + -- The first term that has not yet been spilled, given the high-water mark. + firstUnspilled :: Maybe t -> t + firstUnspilled Nothing = fst (specTerms spec) + firstUnspilled (Just hi) = succ hi + +-- | Open the spill file in 'WriteMode' if a path is given; otherwise run the +-- continuation with no handle. Truncate on open: one run writes one fresh file; +-- a stale file from an earlier run would otherwise be appended to and fail the +-- range checks in +-- 'ExchangeAlgebra.Simulate.Spill.readBinarySpillFileChecked'. +withMaybeSpillHandle :: Maybe FilePath -> (Maybe Handle -> IO a) -> IO a +withMaybeSpillHandle Nothing act = act Nothing +withMaybeSpillHandle (Just path) act = withFile path WriteMode (act . Just) + +-- | Apply 'EA.compress' to the entry of every Note whose term is strictly +-- before @t@ (a /closed/ term), leaving the in-progress term untouched. Uses +-- 'toMap'\/'fromMap' so the traversal order does not affect the result. +compressClosedTerms + :: (HasTermAxis n, TermOf n ~ t, Ord t, HatVal v, HatBaseClass b) + => t -> Journal n v b -> Journal n v b +compressClosedTerms t j = + fromMap (HM.mapWithKey + (\nn alg -> if termOf nn < t then EA.compress alg else alg) + (toMap j)) diff --git a/src/ExchangeAlgebra/Simulate/Network.hs b/src/ExchangeAlgebra/Simulate/Network.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Simulate/Network.hs @@ -0,0 +1,1229 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | + Module : ExchangeAlgebra.Simulate.Network + Copyright : (c) Kaya Akagi. 2018-2026 + Maintainer : yakagika@icloud.com + + Released under the OWL license + + == What this module is + + A small, additive front-end that separates two concepts that the older + examples conflated into a single dense @N×N@ coefficient matrix: + + 1. the __trade network__ (t'TradeNetwork') — /who may trade with whom/, a + sparse directed relation; and + 2. the __input coefficients__ (t'InputCoefficients') — /the technology/, + a sparse map of per-edge coefficients @a_{ij}@. + + In the dense-matrix style the support (non-zero cells) of the coefficient + matrix /was/ the trade relation, so sparsity was an accident of the data + representation rather than a modelling choice. Splitting them lets a model + pick its market structure (complete, @k@-regular, Erdős–Rényi, scale-free, + sectoral) independently of the coefficients, and lets the summation + + @ + 'sigmaEdges' g f + @ + + run the familiar \"Σ\" notation over the /edges/ of @g@ (cost @O(E)@) instead + of over all ordered pairs (cost @O(N²)@). With 'completeNetwork' the two + coincide, so an existing all-pairs model can be ported without changing the + notation (see 'sigmaEdges'). + + The module also provides 'industrialNetwork' and 'industrialFlows': an + ordered block-triangular, power-law trade graph and its exact-integer, + demand-driven backward substitution. + + == Edge orientation + + An edge @(i, j)@ means \"@i@ is a /supplier/ of @j@\" (equivalently \"@j@ is a + /buyer/ from @i@\"). The coefficient @a_{ij}@ attached to that edge is \"the + amount of @i@ that one unit of @j@'s output requires\". This matches the + long-form table layout @(from, to, coef)@ and the @(supplier, buyer)@ index + order of the example input-coefficient tables. + + == Determinism + + Every generator is a pure function of an explicit 'StdGen' (it does not + return a generator; split one yourself with 'System.Random.split' if you + need an independent stream). The same seed always yields the same network, + and all read-outs ('nodes', 'edges', 'suppliersOf', 'buyersOf', 'inputsOf') + return their results in ascending 'Ord' order, never in hash-table order. + + == Internal representation is private + + t'TradeNetwork', t'InputCoefficients' and 'NetworkError' are abstract: their + constructors are not exported, so the invariants (out\/in adjacency agree, + @supp(A) ⊆ edges(G)@, no self-loops, non-negative coefficients) cannot be + broken from outside. Build values with the smart constructors and the + generators; read them with the accessors. + + == Using a network with the classic "ExchangeAlgebra.Simulate" + + This module deliberately provides /no/ @Updatable@ instance for the network + types (the @Updatable t v a s | a s -> t v@ functional dependency makes it + impossible for the library to fix the user's @(t, v)@). To carry a (read-only) + network in a classic simulation, wrap it in your own @UpdatableSTRef@ cell: + + @ + newtype NetCell s = NetCell (Data.STRef.STRef s (TradeNetwork Int)) + instance UpdatableSTRef NetCell s (TradeNetwork Int) + @ + + and read it inside an event with @readURef@. In the newer + "ExchangeAlgebra.Simulate.Lite" front-end the network is simply a @carry@ + field (it never changes during a run), with no instance at all. +-} + +module ExchangeAlgebra.Simulate.Network + ( -- * Types (abstract) + TradeNetwork + , InputCoefficients + , NetworkError(..) + -- * Smart constructors + , tradeNetwork + , inputCoefficients + -- * Read-outs (deterministic, ascending order) + , nodes + , edges + , suppliersOf + , buyersOf + , edgeCount + , coefficient + , inputsOf + -- * Summation over edges + , sigmaEdges + -- * Network generators (deterministic) + , completeNetwork + , circulant + , kRegular + , erdosRenyi + , scaleFree + , sectorBlock + -- * Ordered industrial networks and flows + , IndustrialEconomy(..) + , IndustrialOptions(..) + , defaultIndustrialOptions + , industrialNetwork + , industrialNetworkWith + , firms + , industrialEdges + , TaxRate(..) + , taxOf + , IndustrialFlows(..) + , FlowOptions(..) + , defaultFlowOptions + , industrialFlows + , industrialFlowsWith + -- * Coefficient generation + , CoefOptions(..) + , defaultCoefOptions + , randomCoefficients + -- * Long-form table / matrix ingestion + , networkFromTable + , coefficientsFromTable + , fromCoefficientMatrix + -- * CSV (fixed schema, minimal self-contained parser) + , parseEdgeCsv + , parseCoefCsv + , readEdgeCsv + , readCoefCsv + ) where + +import Control.DeepSeq (NFData (..)) +import Data.List (sortBy) +import qualified Data.Map.Strict as M +import Data.Map.Strict (Map) +import Data.Maybe (fromMaybe) +import qualified Data.Set as S +import Data.Set (Set) +import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Text.IO as TIO +import qualified Data.Vector as V +-- 'mkStdGen' is referenced only by the Haddock doctest examples (which run in +-- this module's import scope); 'randomR' drives the generators. +import System.Random (StdGen, mkStdGen, randomR) + +import ExchangeAlgebra.Convert.Csv ( splitTrim ) +import ExchangeAlgebra.Journal ( Journal, Note, HatVal, HatBaseClass ) +import qualified ExchangeAlgebra.Journal as EJ + +------------------------------------------------------------------ +-- * Errors +------------------------------------------------------------------ + +-- | Why a smart constructor refused to build a value. All cases are reported +-- rather than silently repaired (in particular a duplicate edge is /not/ merged +-- and a coefficient outside the network is /not/ dropped). +data NetworkError + = SelfLoop -- ^ An edge @(i, i)@ was supplied. + | DuplicateEdge -- ^ The same ordered pair @(i, j)@ appeared twice. + | CoefOutsideNetwork -- ^ A coefficient @(i, j, _)@ has no edge @(i, j)@ in the network. + | NegativeCoefficient -- ^ A coefficient was negative (or a non-finite error value). + | DuplicateCoefficient -- ^ The same @(i, j)@ coefficient appeared twice. + deriving (Eq, Show) + +instance NFData NetworkError where + rnf x = x `seq` () + +------------------------------------------------------------------ +-- * TradeNetwork +------------------------------------------------------------------ + +-- | A sparse directed trade relation over a fixed node set. Holds both the +-- out-adjacency (@supplier ↦ buyers@) and the in-adjacency +-- (@buyer ↦ suppliers@) so that 'suppliersOf' and 'buyersOf' are both +-- @O(log N + deg)@. The two indices are kept mutually consistent by +-- construction. Edges are stored as 'Data.Set.Set' so every read-out is in +-- ascending 'Ord' order. +data TradeNetwork k = TradeNetwork + { tnNodes :: !(Set k) + , tnOut :: !(Map k (Set k)) -- ^ supplier ↦ set of buyers + , tnIn :: !(Map k (Set k)) -- ^ buyer ↦ set of suppliers + } + +instance Eq k => Eq (TradeNetwork k) where + a == b = tnNodes a == tnNodes b && tnOut a == tnOut b && tnIn a == tnIn b + +instance Show k => Show (TradeNetwork k) where + showsPrec d g = showParen (d > 10) + $ showString "TradeNetwork " + . showsPrec 11 (S.toAscList (tnNodes g)) + . showString " " + . showsPrec 11 (edges g) + +instance NFData k => NFData (TradeNetwork k) where + rnf (TradeNetwork ns o i) = rnf ns `seq` rnf o `seq` rnf i + +-- | Build a network from a node list and a directed-edge list. +-- +-- The node set is the union of the given nodes and every endpoint mentioned in +-- the edges (so missing nodes are added rather than rejected). Fails with +-- 'SelfLoop' on any @(i, i)@ edge and with 'DuplicateEdge' if the same ordered +-- pair appears twice (duplicates are never coalesced — that would silently sum +-- relations). +-- +-- >>> let Right g = tradeNetwork [1,2,3] [(1,2),(1,3),(2,3)] :: Either NetworkError (TradeNetwork Int) +-- >>> edges g +-- [(1,2),(1,3),(2,3)] +-- >>> suppliersOf g 3 +-- [1,2] +-- >>> buyersOf g 1 +-- [2,3] +tradeNetwork :: Ord k => [k] -> [(k, k)] -> Either NetworkError (TradeNetwork k) +tradeNetwork ns es = do + seen <- foldM' insertEdge S.empty es + let nodeSet = S.unions + [ S.fromList ns + , S.fromList [ i | (i, _) <- es ] + , S.fromList [ j | (_, j) <- es ] ] + Right (buildNetwork nodeSet (S.toList seen)) + where + insertEdge acc (i, j) + | i == j = Left SelfLoop + | (i, j) `S.member` acc = Left DuplicateEdge + | otherwise = Right (S.insert (i, j) acc) + +-- | Assemble both adjacency indices from a validated edge set. +buildNetwork :: Ord k => Set k -> [(k, k)] -> TradeNetwork k +buildNetwork nodeSet es = TradeNetwork nodeSet outM inM + where + outM = foldl' (\m (i, j) -> M.insertWith S.union i (S.singleton j) m) M.empty es + inM = foldl' (\m (i, j) -> M.insertWith S.union j (S.singleton i) m) M.empty es + +-- | The node set, ascending. +-- +-- >>> let Right g = tradeNetwork [3,1,2] [] :: Either NetworkError (TradeNetwork Int) +-- >>> nodes g +-- [1,2,3] +nodes :: TradeNetwork k -> [k] +nodes = S.toAscList . tnNodes + +-- | The edges @(supplier, buyer)@, ascending. +-- +-- >>> let Right g = tradeNetwork [1,2] [(2,1),(1,2)] :: Either NetworkError (TradeNetwork Int) +-- >>> edges g +-- [(1,2),(2,1)] +edges :: TradeNetwork k -> [(k, k)] +edges g = [ (i, j) | (i, js) <- M.toAscList (tnOut g), j <- S.toAscList js ] + +-- | The suppliers of a given buyer, ascending. +-- +-- >>> let Right g = tradeNetwork [1,2,3] [(1,3),(2,3)] :: Either NetworkError (TradeNetwork Int) +-- >>> suppliersOf g 3 +-- [1,2] +suppliersOf :: Ord k => TradeNetwork k -> k -> [k] +suppliersOf g j = S.toAscList (M.findWithDefault S.empty j (tnIn g)) + +-- | The buyers from a given supplier, ascending. +-- +-- >>> let Right g = tradeNetwork [1,2,3] [(1,2),(1,3)] :: Either NetworkError (TradeNetwork Int) +-- >>> buyersOf g 1 +-- [2,3] +buyersOf :: Ord k => TradeNetwork k -> k -> [k] +buyersOf g i = S.toAscList (M.findWithDefault S.empty i (tnOut g)) + +-- | The number of edges. +-- +-- >>> let Right g = tradeNetwork [1,2,3] [(1,2),(1,3),(2,3)] :: Either NetworkError (TradeNetwork Int) +-- >>> edgeCount g +-- 3 +edgeCount :: TradeNetwork k -> Int +edgeCount = M.foldr' (\s acc -> S.size s + acc) 0 . tnOut + +------------------------------------------------------------------ +-- * InputCoefficients +------------------------------------------------------------------ + +-- | A sparse, buyer-major table of input coefficients: @buyer ↦ (supplier ↦ +-- coefficient)@. The buyer-major layout matches the dominant access pattern +-- (enumerate a fixed buyer's suppliers) and makes the per-buyer column sum (the +-- Hawkins–Simon productivity check) an @O(deg)@ scan. The invariant +-- @supp(A) ⊆ edges(G)@ is enforced by 'inputCoefficients'. +data InputCoefficients k v = InputCoefficients + { icByBuyer :: !(Map k (Map k v)) -- ^ buyer ↦ supplier ↦ coefficient + } + +instance (Eq k, Eq v) => Eq (InputCoefficients k v) where + a == b = icByBuyer a == icByBuyer b + +instance (Show k, Show v) => Show (InputCoefficients k v) where + showsPrec d a = showParen (d > 10) + $ showString "InputCoefficients " + . showsPrec 11 + [ (i, j, v) + | (j, sup) <- M.toAscList (icByBuyer a) + , (i, v) <- M.toAscList sup ] + +instance (NFData k, NFData v) => NFData (InputCoefficients k v) where + rnf (InputCoefficients m) = rnf m + +-- | Build the coefficient table from a network and a long-form list of +-- @(supplier, buyer, coef)@ triples. +-- +-- Fails with 'CoefOutsideNetwork' if a triple has no corresponding edge, +-- 'NegativeCoefficient' if a value is negative or a non-finite error value, and +-- 'DuplicateCoefficient' if the same @(supplier, buyer)@ pair appears twice +-- (duplicates are not summed — the redundant-algebra convention forbids silent +-- aggregation). Zero coefficients are kept as written (they do not create an +-- edge, but if the edge exists they are recorded as @0@). +-- +-- >>> let Right g = tradeNetwork [1,2,3] [(1,3),(2,3)] :: Either NetworkError (TradeNetwork Int) +-- >>> let Right a = inputCoefficients g [(1,3,0.2),(2,3,0.5)] :: Either NetworkError (InputCoefficients Int Double) +-- >>> inputsOf a 3 +-- [(1,0.2),(2,0.5)] +-- >>> coefficient a 1 3 +-- Just 0.2 +inputCoefficients :: (Ord k, HatVal v) + => TradeNetwork k + -> [(k, k, v)] + -> Either NetworkError (InputCoefficients k v) +inputCoefficients g triples = do + m <- foldM' step M.empty triples + Right (InputCoefficients m) + where + edgeSet = S.fromList (edges g) + step acc (i, j, v) + | isBadValue v = Left NegativeCoefficient + | not ((i, j) `S.member` edgeSet) = Left CoefOutsideNetwork + | hasCoef j i acc = Left DuplicateCoefficient + | otherwise = Right (M.insertWith M.union j (M.singleton i v) acc) + hasCoef j i acc = maybe False (M.member i) (M.lookup j acc) + +-- | A value that must not enter a coefficient table: negative, or a non-finite +-- error value (NaN\/Inf). Mirrors the non-negativity invariant enforced by the +-- algebra's @(.\@)@ smart constructor. +isBadValue :: HatVal v => v -> Bool +isBadValue v = v < 0 || EJ.isErrorValue v + +-- | Look up the coefficient on edge @(supplier, buyer)@, if any. +-- +-- >>> let Right g = tradeNetwork [1,2,3] [(1,3)] :: Either NetworkError (TradeNetwork Int) +-- >>> let Right a = inputCoefficients g [(1,3,0.7)] :: Either NetworkError (InputCoefficients Int Double) +-- >>> coefficient a 1 3 +-- Just 0.7 +-- >>> coefficient a 2 3 +-- Nothing +coefficient :: Ord k => InputCoefficients k v -> k -> k -> Maybe v +coefficient a i j = M.lookup j (icByBuyer a) >>= M.lookup i + +-- | The @(supplier, coefficient)@ inputs of a fixed buyer, ascending by +-- supplier. +-- +-- >>> let Right g = tradeNetwork [1,2,3] [(1,3),(2,3)] :: Either NetworkError (TradeNetwork Int) +-- >>> let Right a = inputCoefficients g [(2,3,0.5),(1,3,0.2)] :: Either NetworkError (InputCoefficients Int Double) +-- >>> inputsOf a 3 +-- [(1,0.2),(2,0.5)] +inputsOf :: Ord k => InputCoefficients k v -> k -> [(k, v)] +inputsOf a j = M.toAscList (M.findWithDefault M.empty j (icByBuyer a)) + +------------------------------------------------------------------ +-- * Summation over edges +------------------------------------------------------------------ + +-- | Sum a per-edge journal builder over the edges of a network. This is the +-- network analogue of an all-pairs @Σ@: the notation stays \"Σ over the +-- relation\", but the set it runs over is the @O(E)@ edge list rather than the +-- @O(N²)@ ordered pairs. +-- +-- @f i j@ is the journal contributed by the edge @(i, j)@ (supplier @i@, buyer +-- @j@). Edges are visited in ascending order, so for an exact value type the +-- result is order-independent and for 'Double' it is at least deterministic. +-- +-- With 'completeNetwork' this is exactly the all-pairs sum over distinct +-- ordered pairs, i.e. +-- +-- @'sigmaEdges' ('completeNetwork' ks) f == 'EJ.sigma2When' ks ks (/=) f@ +-- +-- so an all-pairs model ports to a sparse one by swapping the network, leaving +-- the @Σ@ call site unchanged. +-- +-- >>> import ExchangeAlgebra.Journal +-- >>> type J = Journal (Int,Int) Double (HatBase CountUnit) +-- >>> let Right g = tradeNetwork [1,2,3] [(1,2),(1,3)] :: Either NetworkError (TradeNetwork Int) +-- >>> let f i j = (1.0 .@ Not:>> norm (sigmaEdges g f) +-- 2.0 +sigmaEdges :: (Note n, HatVal v, HatBaseClass b) + => TradeNetwork k + -> (k -> k -> Journal n v b) + -> Journal n v b +sigmaEdges g f = EJ.sigma (edges g) (\(i, j) -> f i j) + +------------------------------------------------------------------ +-- * Network generators +------------------------------------------------------------------ + +-- | The complete directed network: every distinct ordered pair @(i, j)@, +-- @i /= j@, is an edge. @O(N²)@ edges — provided so an existing all-pairs model +-- can be expressed without changing its @Σ@ (see 'sigmaEdges'). +-- +-- >>> let g = completeNetwork [1,2,3] :: TradeNetwork Int +-- >>> edgeCount g +-- 6 +-- >>> edges g +-- [(1,2),(1,3),(2,1),(2,3),(3,1),(3,2)] +completeNetwork :: Ord k => [k] -> TradeNetwork k +completeNetwork ks = + buildNetwork nodeSet [ (i, j) | i <- xs, j <- xs, i /= j ] + where + nodeSet = S.fromList ks + xs = S.toAscList nodeSet + +-- | A deterministic circulant (ring-lattice) network: the nodes are taken in +-- ascending order and each buyer draws its @min k (N-1)@ suppliers from the @k@ +-- nodes that follow it cyclically (@j+1, …, j+k@ mod @N@). Unlike 'kRegular' \/ +-- 'erdosRenyi' it needs no 'StdGen' and is built in @O(kN)@ — it never scans the +-- @O(N²)@ ordered pairs — so it stays usable at the @N@ a market-scale run needs. +-- @|E| = min k (N-1) · N@ exactly, with no duplicate and no self edges. +-- +-- >>> let g = circulant [1..6] 2 :: TradeNetwork Int +-- >>> edgeCount g +-- 12 +-- >>> suppliersOf g 1 +-- [2,3] +-- >>> suppliersOf g 6 +-- [1,2] +-- >>> all (\j -> length (suppliersOf g j) == 2) (nodes g) +-- True +circulant :: Ord k => [k] -> Int -> TradeNetwork k +circulant ks k = + buildNetwork nodeSet (concat [ zip (rot d xs) xs | d <- [1 .. deg] ]) + where + nodeSet = S.fromList ks + xs = S.toAscList nodeSet + n = length xs + deg = max 0 (min k (n - 1)) + rot d ys = drop d ys ++ take d ys + +-- | A @k@-regular-in network: each buyer draws @min k (N-1)@ distinct suppliers +-- (sampling without replacement, excluding itself). Deterministic in the given +-- 'StdGen'. +-- +-- >>> let g = kRegular (mkStdGen 1) [1..6] 2 :: TradeNetwork Int +-- >>> all (\j -> length (suppliersOf g j) == 2) (nodes g) +-- True +kRegular :: Ord k => StdGen -> [k] -> Int -> TradeNetwork k +kRegular gen ks k = + buildNetwork nodeSet (concat (snd (foldl' pick (gen, []) xs))) + where + nodeSet = S.fromList ks + xs = S.toAscList nodeSet + deg = max 0 (min k (length xs - 1)) + pick (g0, acc) j = + let candidates = filter (/= j) xs + (chosen, g1) = sampleWithout g0 deg candidates + in (g1, [ (i, j) | i <- chosen ] : acc) + +-- | An Erdős–Rényi @G(n, p)@ directed network: each ordered pair @(i, j)@, +-- @i /= j@, becomes an edge independently with probability @p@. @p <= 0@ yields +-- the empty network, @p >= 1@ yields 'completeNetwork'. Deterministic in the +-- given 'StdGen'. +-- +-- >>> edgeCount (erdosRenyi (mkStdGen 0) [1..5] 1.0 :: TradeNetwork Int) +-- 20 +-- >>> edgeCount (erdosRenyi (mkStdGen 0) [1..5] 0.0 :: TradeNetwork Int) +-- 0 +erdosRenyi :: Ord k => StdGen -> [k] -> Double -> TradeNetwork k +erdosRenyi gen ks p + | p >= 1 = completeNetwork ks + | p <= 0 = buildNetwork nodeSet [] + | otherwise = buildNetwork nodeSet (snd (foldl' step (gen, []) pairs)) + where + nodeSet = S.fromList ks + xs = S.toAscList nodeSet + pairs = [ (i, j) | i <- xs, j <- xs, i /= j ] + step (g0, acc) e = + let (u, g1) = randomR (0, 1) g0 :: (Double, StdGen) + in if u < p then (g1, e : acc) else (g1, acc) + +-- | A scale-free network grown by Barabási–Albert preferential attachment: nodes +-- are added in ascending order; each new node attaches @m@ edges to existing +-- nodes chosen with probability proportional to their current degree (with a +-- uniform fallback while the graph is still empty). Orientation: the new node is +-- the /buyer/, the chosen existing nodes are its /suppliers/. Deterministic in +-- the given 'StdGen'. +-- +-- The first @m@ nodes form a seed clique-ish core (each new seed node attaches +-- to all already-present nodes), so for @N > m@ the edge count is +-- @C(m+1, 2)·1 + (N - m - 1)·m@ counting the directed buyer→supplier edges as +-- one per attachment; the property test checks the exact value. +-- +-- >>> let g = scaleFree (mkStdGen 7) [1..10] 2 :: TradeNetwork Int +-- >>> edgeCount g +-- 17 +scaleFree :: Ord k => StdGen -> [k] -> Int -> TradeNetwork k +scaleFree gen ks m0 = + buildNetwork nodeSet builtEdges + where + nodeSet = S.fromList ks + xs = S.toAscList nodeSet + m = max 1 m0 + -- State threads the generator, the edge accumulator and an incremental + -- degree table (@node ↦ current degree@). The degree table replaces the + -- O(E) rescan that the naive @degree i = length (filter …) acc@ performed + -- for every candidate at every node: each added edge bumps both endpoints' + -- degrees in O(log N), so the per-node weight list is built without ever + -- touching @acc@. The weights produced are bit-for-bit identical to the + -- rescan version, so the generated network is unchanged. + (_, builtEdges0, _) = foldl' addNode (gen, [], M.empty) (zip [0 ..] xs) + builtEdges = reverse builtEdges0 + + -- addNode :: (StdGen, [(k,k)], Map k Int) + -- -> (Int, k) -> (StdGen, [(k,k)], Map k Int) + addNode st@(g0, acc, deg) (ix, j) + | ix == 0 = st -- first node: nothing to attach to + | ix <= m = -- seed phase: attach to all earlier nodes + let suppliers = take ix xs + newEdges = [ (i, j) | i <- suppliers ] + in (g0, newEdges ++ acc, bumpEdges newEdges deg) + | otherwise = -- preferential attachment + let present = take ix xs -- nodes already added + degree i = M.findWithDefault 0 i deg + weighted = [ (i, fromIntegral (1 + degree i) :: Double) | i <- present ] + (chosen, g1) = sampleWeightedWithout g0 m weighted + newEdges = [ (i, j) | i <- chosen ] + in (g1, newEdges ++ acc, bumpEdges newEdges deg) + + -- Increment both endpoints' degree counts for each newly added edge. + bumpEdges es d = foldl' (\d' (i, t) -> bump i (bump t d')) d es + bump k = M.insertWith (+) k 1 + +-- | A stochastic block network: each node carries a sector label, and an +-- ordered pair @(i, j)@ (@i /= j@) becomes an edge with probability +-- @p (sector i, sector j)@. Deterministic in the given 'StdGen'. Generalises +-- 'erdosRenyi' (a single block) and lets intra-\/inter-sector densities differ. +-- +-- >>> let label n = if n <= 2 then 'A' else 'B' +-- >>> let p (a,b) = if a == b then 1.0 else 0.0 +-- >>> let g = sectorBlock (mkStdGen 0) [(n, label n) | n <- [1..4]] p :: TradeNetwork Int +-- >>> edges g +-- [(1,2),(2,1),(3,4),(4,3)] +sectorBlock :: (Ord k, Ord s) + => StdGen -> [(k, s)] -> ((s, s) -> Double) -> TradeNetwork k +sectorBlock gen labelled p = + buildNetwork nodeSet (snd (foldl' step (gen, []) pairs)) + where + secMap = M.fromList labelled + nodeSet = S.fromList (map fst labelled) + xs = S.toAscList nodeSet + pairs = [ (i, j) | i <- xs, j <- xs, i /= j ] + step (g0, acc) (i, j) = + let pr = fromMaybe 0 $ do + si <- M.lookup i secMap + sj <- M.lookup j secMap + pure (p (si, sj)) + (u, g1) = randomR (0, 1) g0 :: (Double, StdGen) + in if pr >= 1 then (g1, (i, j) : acc) + else if pr <= 0 then (g1, acc) + else if u < pr then (g1, (i, j) : acc) else (g1, acc) + +------------------------------------------------------------------ +-- * Ordered industrial networks and demand-driven flows +------------------------------------------------------------------ + +-- | A block-triangular industrial economy. Sector @0@ is the most upstream +-- sector and larger sector numbers are progressively downstream. Every edge is +-- @(supplier, buyer)@; generated edges satisfy @sector supplier <= sector buyer@, +-- and an intra-sector edge additionally satisfies @supplier < buyer@. +data IndustrialEconomy k = IndustrialEconomy + { ieNetwork :: !(TradeNetwork k) + , ieSector :: !(Map k Int) + , ieSize :: !(Map k Double) + } deriving (Eq, Show) + +instance NFData k => NFData (IndustrialEconomy k) where + rnf (IndustrialEconomy g s w) = rnf g `seq` rnf s `seq` rnf w + +-- | Options for 'industrialNetworkWith'. The flow function is consulted only +-- for ordered sector pairs @(upstream, downstream)@. Non-positive and +-- non-finite values make that sector pair ineligible. +data IndustrialOptions = IndustrialOptions + { ioExponent :: !Double + -- ^ Pareto exponent @gamma > 1@. + , ioFlow :: Int -> Int -> Double + -- ^ Sector-flow weight @B[s,s']@. + } + +-- | Pareto exponent @2.5@ and a uniform positive sector-flow matrix. +defaultIndustrialOptions :: IndustrialOptions +defaultIndustrialOptions = IndustrialOptions + { ioExponent = 2.5 + , ioFlow = \_ _ -> 1 + } + +-- | Build the paper's deterministic block-triangular, power-law industrial +-- network from @seed N K m@. Unlike 'sectorBlock', this generator is +-- deterministic from an integer seed, ordered by sector, power-law weighted, +-- and avoids an all-pairs scan: expected construction cost is +-- @O(N*K + |E|*(K + log N))@, or @O(N*K + |E|*log N)@ for fixed @K@. +-- +-- The requested edge count is @m*N@. It is exact whenever the eligible +-- supplier capacity is at least that large; otherwise all eligible pairs are +-- used and @|E| < m*N@. @N <= 0@ produces an empty economy, @m <= 0@ produces +-- no edges, and @K <= 0@ or an exponent not greater than @1@ is an error. +-- +-- >>> let e = industrialNetwork 7 6 2 1 +-- >>> firms e +-- [1,2,3,4,5,6] +-- >>> all (\(i,j) -> let s = ieSector e in s M.! i < s M.! j || (s M.! i == s M.! j && i < j)) (industrialEdges e) +-- True +industrialNetwork :: Int -> Int -> Int -> Int -> IndustrialEconomy Int +industrialNetwork = industrialNetworkWith defaultIndustrialOptions + +-- | Configurable form of 'industrialNetwork'. Supplier selection is weighted +-- by @B[sector i,sector j] * w_i@ without replacement. It first chooses a +-- sector in @O(K)@ and then a firm by binary search over that sector's +-- cumulative-size vector in @O(log N)@. Duplicate draws use bounded rejection; +-- the deterministic fallback fills the remaining eligible candidates in +-- sector/id order. Sector choice is @O(K)@ per draw; @K@ is normally a small +-- fixed model parameter. +industrialNetworkWith + :: IndustrialOptions -> Int -> Int -> Int -> Int -> IndustrialEconomy Int +industrialNetworkWith opts seed n0 k m0 + | k <= 0 = error "industrialNetworkWith: K must be positive" + | not (finitePositive gamma) || gamma <= 1 = + error "industrialNetworkWith: ioExponent must be finite and greater than 1" + | n <= 0 = IndustrialEconomy (buildNetwork S.empty []) M.empty M.empty + | otherwise = IndustrialEconomy network sectors sizes + where + n = max 0 n0 + gamma = ioExponent opts + firmIds = [1 .. n] + (_, sectors, sizes, sectorRev) = foldl' drawFirm (mkStdGen seed, M.empty, M.empty, M.empty) firmIds + sectorLists = M.map reverse sectorRev + pools = M.fromList + [ (s, mkSectorPool (M.findWithDefault [] s sectorLists) sizes) + | s <- [0 .. k - 1] ] + ranks = M.fromList + [ (i, r) + | (_, pool) <- M.toAscList pools + , (r, i) <- zip [0 ..] (V.toList (spFirms pool)) ] + capacities = + [ (j, candidateCapacity opts sectors pools ranks j) + | j <- firmIds ] + capacityTotal = sum (map snd capacities) + requestedInteger = toInteger (max 0 m0) * toInteger n + target = fromInteger (min requestedInteger (toInteger capacityTotal)) + degrees = apportionCapped target + [ (j, cap, M.findWithDefault 1 j sizes) | (j, cap) <- capacities ] + (_, edgeChunks) = foldl' drawBuyer (mkStdGen (seed + 104729), []) firmIds + network = buildNetwork (S.fromList firmIds) (concat (reverse edgeChunks)) + + drawFirm (g0, sm, wm, groups) i = + let (s, g1) = randomR (0, k - 1) g0 + (u0, g2) = randomR (0, 1) g1 :: (Double, StdGen) + -- randomR's interval is closed; cap its upper endpoint so Pareto + -- inversion remains finite while retaining the seed-derived draw. + u = min (1 - 2.220446049250313e-16) (max 0 u0) + logWeight = - log (1 - u) / (gamma - 1) + -- The mathematical Pareto draw can exceed Double's range as gamma + -- approaches 1. Saturate only that unrepresentable tail, keeping + -- ieSize and every sampling table finite and consistent. + w = exp (min (log maxIndustrialSize) logWeight) + in ( g2 + , M.insert i s sm + , M.insert i w wm + , M.insertWith (++) s [i] groups ) + + drawBuyer (g0, acc) j = + let d = M.findWithDefault 0 j degrees + (chosen, g1) = chooseIndustrialSuppliers opts sectors pools ranks j d g0 + in (g1, [ (i, j) | i <- chosen ] : acc) + +-- | Firms in ascending order, equivalent to @nodes . ieNetwork@. +firms :: IndustrialEconomy k -> [k] +firms = nodes . ieNetwork + +-- | Industrial edges in ascending @(supplier,buyer)@ order, equivalent to +-- @edges . ieNetwork@. +industrialEdges :: IndustrialEconomy k -> [(k, k)] +industrialEdges = edges . ieNetwork + +-- | An exact rational tax rate @numerator / denominator@. +data TaxRate = TaxRate + { taxNumerator :: !Integer + , taxDenominator :: !Integer + } deriving (Eq, Show) + +instance NFData TaxRate where + rnf (TaxRate num den) = rnf num `seq` rnf den + +-- | Integer tax on an integer amount. Generated industrial flows are aligned +-- to the denominator, so this division is exact for their amounts. +taxOf :: TaxRate -> Integer -> Integer +taxOf (TaxRate num den) amount + | den <= 0 = error "taxOf: denominator must be positive" + | num < 0 = error "taxOf: numerator must be non-negative" + | amount < 0 = error "taxOf: amount must be non-negative" + | otherwise = amount * num `div` den + +-- | One-period demand-driven monetary flows for an industrial economy. +data IndustrialFlows k = IndustrialFlows + { flowTrade :: !(Map (k, k) Integer) + , flowOutput :: !(Map k Integer) + , flowInput :: !(Map k Integer) + , flowValueAdded :: !(Map k Integer) + , flowFinalDemand :: !(Map k Integer) + } deriving (Eq, Show) + +instance NFData k => NFData (IndustrialFlows k) where + rnf (IndustrialFlows z x inp va f) = + rnf z `seq` rnf x `seq` rnf inp `seq` rnf va `seq` rnf f + +-- | Options for the demand-driven backward substitution. +data FlowOptions = FlowOptions + { foMeanFinalDemand :: !Integer + , foInputShare :: !Double + } deriving (Eq, Show) + +instance NFData FlowOptions where + rnf (FlowOptions f a) = rnf f `seq` rnf a + +-- | Mean final demand @1,000,000@ yen and intermediate-input share @0.5@. +defaultFlowOptions :: FlowOptions +defaultFlowOptions = FlowOptions + { foMeanFinalDemand = 1000000 + , foInputShare = 0.5 + } + +-- | Generate one-period flows with 'defaultFlowOptions'. +industrialFlows :: Ord k + => TaxRate -> IndustrialEconomy k -> IndustrialFlows k +industrialFlows = industrialFlowsWith defaultFlowOptions + +-- | Generate exact integer flows by a single downstream-to-upstream backward +-- substitution. Final demand and every trade amount are positive-denominator +-- multiples. Trade amounts may be zero when a buyer's input units are fewer +-- than its suppliers. For an economy produced by 'industrialNetworkWith', the +-- identities @x_j = sum_i z_ij + v_j = sum_m z_jm + f_j@ and +-- @sum_j v_j = sum_j f_j@ hold exactly. Complexity is +-- @O(N*log N + |E|*log N)@ with ordered 'Map' updates. +industrialFlowsWith + :: Ord k + => FlowOptions -> TaxRate -> IndustrialEconomy k -> IndustrialFlows k +industrialFlowsWith opts (TaxRate num den) economy + | den <= 0 = error "industrialFlowsWith: tax denominator must be positive" + | num < 0 = error "industrialFlowsWith: tax numerator must be non-negative" + | not (a >= 0 && a < 1) || isNaN a || isInfinite a = + error "industrialFlowsWith: foInputShare must be finite and in [0,1)" + | any (not . validOrderedEdge) (industrialEdges economy) = + error "industrialFlowsWith: economy contains an edge outside the ordered sector DAG" + | otherwise = IndustrialFlows zMap xMap inputMap vaMap finalMap + where + a = foInputShare opts + validOrderedEdge (i, j) = + case (M.lookup i (ieSector economy), M.lookup j (ieSector economy)) of + (Just si, Just sj) -> (si, i) < (sj, j) + _ -> False + ks = firms economy + count = length ks + sizeOf j = let w = M.findWithDefault 1 j (ieSize economy) + in if finitePositive w then w else 1 + meanSize = if count == 0 + then 1 + else sum (map sizeOf ks) / fromIntegral count + meanFinal = max 0 (foMeanFinalDemand opts) + finalMap = M.fromList + [ (j, den * max 1 (round (fromIntegral meanFinal * sizeOf j + / meanSize / fromIntegral den))) + | j <- ks ] + order = sortBy downstreamFirst ks + downstreamFirst i j = + compare (M.findWithDefault 0 j (ieSector economy), j) + (M.findWithDefault 0 i (ieSector economy), i) + (_, zMap, xMap, inputMap, vaMap) = + foldl' solveFirm (M.empty, M.empty, M.empty, M.empty, M.empty) order + + solveFirm (orders, zs, xs, ins, vas) j = + let revenue = M.findWithDefault 0 j orders + finalD = M.findWithDefault den j finalMap + output = revenue + finalD + suppliers = suppliersOf (ieNetwork economy) j + input + | null suppliers = 0 + | otherwise = den * floor (a * fromIntegral output / fromIntegral den) + units = input `div` den + allocations = apportionInteger units [ (i, sizeOf i) | i <- suppliers ] + zs' = foldl' (\m i -> M.insert (i, j) (den * M.findWithDefault 0 i allocations) m) + zs suppliers + orders' = foldl' + (\m i -> M.insertWith (+) i (den * M.findWithDefault 0 i allocations) m) + orders suppliers + valueAdded = output - input + in ( orders' + , zs' + , M.insert j output xs + , M.insert j input ins + , M.insert j valueAdded vas ) + +-- | Per-sector cumulative weights used by two-level supplier sampling. +data SectorPool = SectorPool + { spFirms :: !(V.Vector Int) + , spCumulative :: !(V.Vector Double) + } + +mkSectorPool :: [Int] -> Map Int Double -> SectorPool +mkSectorPool ids weights = SectorPool firmVector cumulative + where + firmVector = V.fromList ids + cumulative = V.fromList (drop 1 (scanl (+) 0 [ M.findWithDefault 1 i weights | i <- ids ])) + +candidateCapacity + :: IndustrialOptions + -> Map Int Int + -> Map Int SectorPool + -> Map Int Int + -> Int + -> Int +candidateCapacity opts sectors pools ranks j = + sum [ eligibleCount s | s <- [0 .. buyerSector] ] + where + buyerSector = M.findWithDefault 0 j sectors + buyerRank = M.findWithDefault 0 j ranks + eligibleCount s + | not (finitePositive (ioFlow opts s buyerSector)) = 0 + | s == buyerSector = buyerRank + | otherwise = maybe 0 (V.length . spFirms) (M.lookup s pools) + +chooseIndustrialSuppliers + :: IndustrialOptions + -> Map Int Int + -> Map Int SectorPool + -> Map Int Int + -> Int + -> Int + -> StdGen + -> ([Int], StdGen) +chooseIndustrialSuppliers opts sectors pools ranks buyer wanted g0 = + go g0 S.empty [] 0 + where + buyerSector = M.findWithDefault 0 buyer sectors + buyerRank = M.findWithDefault 0 buyer ranks + attemptLimit = max 64 (wanted * 32) + sectorChoices = + [ ((s, pool, limit), ioFlow opts s buyerSector * prefixWeight pool limit) + | s <- [0 .. buyerSector] + , finitePositive (ioFlow opts s buyerSector) + , Just pool <- [M.lookup s pools] + , let limit = if s == buyerSector then buyerRank else V.length (spFirms pool) + , limit > 0 + , finitePositive (prefixWeight pool limit) ] + + go g selected acc attempts + | S.size selected >= wanted = (reverse acc, g) + | attempts >= attemptLimit = + let remaining = take (wanted - S.size selected) + [ i + | ((_, pool, limit), _) <- sectorChoices + , i <- V.toList (V.take limit (spFirms pool)) + , i `S.notMember` selected ] + in (reverse acc ++ remaining, g) + | otherwise = + let ((_, pool, limit), g1) = weightedChoice g sectorChoices + total = prefixWeight pool limit + (u, g2) = randomR (0, total) g1 :: (Double, StdGen) + ix = cumulativeLowerBound (spCumulative pool) limit u + supplier = spFirms pool V.! ix + in if supplier `S.member` selected + then go g2 selected acc (attempts + 1) + else go g2 (S.insert supplier selected) (supplier : acc) (attempts + 1) + +prefixWeight :: SectorPool -> Int -> Double +prefixWeight _ limit | limit <= 0 = 0 +prefixWeight pool limit = spCumulative pool V.! (limit - 1) + +cumulativeLowerBound :: V.Vector Double -> Int -> Double -> Int +cumulativeLowerBound cumulative limit target = go 0 (limit - 1) + where + go lo hi + | lo >= hi = lo + | cumulative V.! mid >= target = go lo mid + | otherwise = go (mid + 1) hi + where mid = (lo + hi) `div` 2 + +weightedChoice :: StdGen -> [(a, Double)] -> (a, StdGen) +weightedChoice _ [] = error "weightedChoice: empty positive-weight population" +weightedChoice g choices = (pick u choices, g1) + where + total = sum (map snd choices) + (u, g1) = randomR (0, total) g :: (Double, StdGen) + pick _ [(x, _)] = x + pick r ((x, w) : rest) + | r <= w = x + | otherwise = pick (r - w) rest + pick _ [] = error "weightedChoice: unreachable" + +finitePositive :: Double -> Bool +finitePositive x = x > 0 && not (isNaN x) && not (isInfinite x) + +-- | Numerical ceiling for the unrepresentable far tail of a Pareto draw. It is +-- far above any economically meaningful relative size while leaving +-- market-scale sector sums finite. +maxIndustrialSize :: Double +maxIndustrialSize = 1e100 + +-- | Largest-remainder allocation with per-recipient caps. Continuous weighted +-- water-filling finds the cap-saturation threshold in one sorted pass, then a +-- largest-remainder step integerises the result. @O(N log N)@. +apportionCapped :: Int -> [(Int, Int, Double)] -> Map Int Int +apportionCapped requested rows + | target <= 0 = M.fromList [ (key, 0) | (key, _, _) <- rows ] + | remainder > length ranked = + error "apportionCapped: numerical instability in largest-remainder allocation" + | otherwise = foldl' addRemainder bases (take remainder ranked) + where + normalised = + [ (key, max 0 cap, if finitePositive weight then weight else 1) + | (key, cap, weight) <- rows ] + target = min (max 0 requested) (sum [ cap | (_, cap, _) <- normalised ]) + active = sortBy compareThreshold [ row | row@(_, cap, _) <- normalised, cap > 0 ] + lambda = waterLevel target (sum [ weight | (_, _, weight) <- active ]) active + quotas = + [ (key, cap, min (fromIntegral cap) (lambda * weight)) + | (key, cap, weight) <- normalised ] + floors = + [ (key, cap, floor quota, quota - fromIntegral (floor quota :: Int)) + | (key, cap, quota) <- quotas ] + bases = M.fromList [ (key, base) | (key, _, base, _) <- floors ] + remainder = max 0 (target - sum [ base | (_, _, base, _) <- floors ]) + ranked = map (\(key, _, _) -> key) $ sortBy compareRemainder + [ (key, cap, frac) | (key, cap, base, frac) <- floors, base < cap ] + compareThreshold (keyA, capA, weightA) (keyB, capB, weightB) = + compare (fromIntegral capA / weightA) (fromIntegral capB / weightB) + <> compare keyA keyB + compareRemainder (keyA, _, fracA) (keyB, _, fracB) = + compare fracB fracA <> compare keyA keyB + addRemainder m key = M.insertWith (+) key 1 m + waterLevel amount weightTotal candidates = case candidates of + [] -> 0 + (_, cap, weight) : rest + | weightTotal <= 0 -> 0 + | level <= fromIntegral cap / weight -> level + | otherwise -> waterLevel (amount - cap) (weightTotal - weight) rest + where level = fromIntegral amount / weightTotal + +apportionInteger :: Ord k => Integer -> [(k, Double)] -> Map k Integer +apportionInteger amount rows + | amount <= 0 || null rows = M.fromList [ (key, 0) | (key, _) <- rows ] + | otherwise = foldl' addRemainder bases (take (fromInteger remainder) ranked) + where + positiveRows = [ (key, if finitePositive weight then weight else 1) | (key, weight) <- rows ] + total = sum (map snd positiveRows) + quotas = [ (key, fromIntegral amount * weight / total) | (key, weight) <- positiveRows ] + floors = [ (key, floor quota, quota - fromIntegral (floor quota :: Integer)) | (key, quota) <- quotas ] + bases = M.fromList [ (key, base) | (key, base, _) <- floors ] + remainder = max 0 (amount - sum [ base | (_, base, _) <- floors ]) + ranked = map (\(key, _, _) -> key) $ sortBy compareRemainder floors + compareRemainder (keyA, _, fracA) (keyB, _, fracB) = + compare fracB fracA <> compare keyA keyB + addRemainder m key = M.insertWith (+) key 1 m + +------------------------------------------------------------------ +-- * Coefficient generation +------------------------------------------------------------------ + +-- | Options for 'randomCoefficients'. +data CoefOptions = CoefOptions + { coefRange :: !(Double, Double) + -- ^ Inclusive @(lo, hi)@ range each raw coefficient is drawn from. + , hawkinsSimon :: !Bool + -- ^ When 'True', each buyer's column (its suppliers' coefficients) is + -- kept strictly below a column sum of @1@, guaranteeing productivity (a + -- sufficient Hawkins–Simon condition). The rescaling is __shrink-only__: + -- a column whose raw sum is already @< 1@ is left untouched, and only a + -- column whose raw sum is @>= 1@ is scaled down (to @0.95@ of its sum). + -- This preserves the heterogeneity of the raw draws instead of forcing + -- every column to one common sum. When 'False' the raw draws are used + -- as-is. + } deriving (Eq, Show) + +instance NFData CoefOptions where + rnf (CoefOptions r h) = rnf r `seq` rnf h + +-- | @(0, 1)@ range with the Hawkins–Simon rescaling on. +defaultCoefOptions :: CoefOptions +defaultCoefOptions = CoefOptions { coefRange = (0, 1), hawkinsSimon = True } + +-- | Draw a coefficient for every edge of a network, deterministically from the +-- given 'StdGen'. Values are drawn in 'Double' and converted via 'realToFrac' +-- (so the value type @v@ does not need a @Random@ instance). With +-- 'hawkinsSimon' on, the rescaling is __shrink-only__: a column whose raw sum +-- is already strictly below @1@ is kept as drawn, and only a column whose raw +-- sum reaches @1@ is scaled down to @0.95@ of that sum. Either way every column +-- sum ends strictly below @1@, a sufficient condition for the Leontief system +-- to be productive, while the natural spread of the raw draws is preserved +-- (columns are /not/ all forced to one common sum). +-- +-- The result satisfies @supp(A) = edges(G)@ by construction, so it always +-- round-trips back through 'inputCoefficients' without error. +-- +-- >>> let g = completeNetwork [1,2,3] :: TradeNetwork Int +-- >>> let a = randomCoefficients (mkStdGen 5) defaultCoefOptions g :: InputCoefficients Int Double +-- >>> all (\j -> sum (map snd (inputsOf a j)) < 1.0) (nodes g) +-- True +randomCoefficients :: forall k v. (Ord k, HatVal v) + => StdGen -> CoefOptions -> TradeNetwork k -> InputCoefficients k v +randomCoefficients gen opts g = + InputCoefficients (normalise (snd (foldl' drawCol (gen, M.empty) buyers))) + where + (lo, hi) = coefRange opts + buyers = nodes g + -- one column per buyer: draw a raw coefficient per supplier + drawCol (g0, acc) j = + let sup = suppliersOf g j + (row, g1) = foldl' drawOne ([], g0) sup + in (g1, if null row then acc else M.insert j (M.fromList row) acc) + drawOne (row, g0) i = + let (u, g1) = randomR (lo, hi) g0 :: (Double, StdGen) + in ((i, u) : row, g1) + + normalise :: Map k (Map k Double) -> Map k (Map k v) + normalise + | hawkinsSimon opts = M.map rescaleCol + | otherwise = M.map (M.map realToFrac) + -- Shrink-only Hawkins–Simon: leave a productive column (raw sum < 1) + -- untouched, and only scale a column down when its raw sum reaches 1. + rescaleCol col = + let total = sum (M.elems col) + in if total < 1 + then M.map realToFrac col + else M.map (\x -> realToFrac (x / total * target)) col + target = 0.95 :: Double + +------------------------------------------------------------------ +-- * Table / matrix ingestion +------------------------------------------------------------------ + +-- | Build a network from a long-form edge list, deriving the node set from the +-- rows. A thin alias for @'tradeNetwork' []@ (which already unions in every +-- endpoint). +-- +-- >>> let Right g = networkFromTable [(1,2),(2,3)] :: Either NetworkError (TradeNetwork Int) +-- >>> nodes g +-- [1,2,3] +-- >>> edges g +-- [(1,2),(2,3)] +networkFromTable :: Ord k => [(k, k)] -> Either NetworkError (TradeNetwork k) +networkFromTable = tradeNetwork [] + +-- | Build both the network and the coefficient table from a long-form +-- @(supplier, buyer, coef)@ table in one step. The network's edges are exactly +-- the table's @(supplier, buyer)@ pairs, so the @supp(A) ⊆ edges(G)@ invariant +-- holds automatically. +-- +-- >>> let Right (g, a) = coefficientsFromTable [(1,3,0.2),(2,3,0.5)] :: Either NetworkError (TradeNetwork Int, InputCoefficients Int Double) +-- >>> edges g +-- [(1,3),(2,3)] +-- >>> inputsOf a 3 +-- [(1,0.2),(2,0.5)] +coefficientsFromTable :: (Ord k, HatVal v) + => [(k, k, v)] + -> Either NetworkError (TradeNetwork k, InputCoefficients k v) +coefficientsFromTable triples = do + g <- tradeNetwork [] [ (i, j) | (i, j, _) <- triples ] + a <- inputCoefficients g triples + Right (g, a) + +-- | Build a network and coefficient table from a /dense/ matrix presented as a +-- node list plus a lookup function @a i j@ (= the coefficient on edge +-- @(supplier i, buyer j)@). The support is derived by dropping zero (and +-- error-valued) cells, mirroring the older dense-matrix examples in one call. +-- Self-cells @(i, i)@ are skipped. Total, so it returns the pair directly +-- (no 'NetworkError': the support is consistent by construction). +-- +-- >>> let m i j = if i < j then fromIntegral (i + j) else 0 :: Double +-- >>> let (g, a) = fromCoefficientMatrix [1,2,3] m +-- >>> edges g +-- [(1,2),(1,3),(2,3)] +-- >>> coefficient a 1 3 +-- Just 4.0 +fromCoefficientMatrix :: (Ord k, HatVal v) + => [k] -> (k -> k -> v) -> (TradeNetwork k, InputCoefficients k v) +fromCoefficientMatrix ks a = + (buildNetwork nodeSet es, InputCoefficients byBuyer) + where + nodeSet = S.fromList ks + xs = S.toAscList nodeSet + cells = [ (i, j, v) + | i <- xs, j <- xs, i /= j + , let v = a i j + , not (EJ.isZeroValue v), not (EJ.isErrorValue v) ] + es = [ (i, j) | (i, j, _) <- cells ] + byBuyer = foldl' (\m (i, j, v) -> M.insertWith M.union j (M.singleton i v) m) M.empty cells + +------------------------------------------------------------------ +-- * CSV (fixed schema, minimal self-contained parser) +------------------------------------------------------------------ +-- +-- A deliberately tiny CSV reader: comma-separated, no quoting, blank lines and +-- lines whose first non-space character is @#@ are skipped, surrounding +-- whitespace on each field is trimmed. The first non-skipped line must be the +-- header. Avoids a @cassava@ dependency for these fixed schemas. Line splitting +-- is shared with "ExchangeAlgebra.Convert.Csv" through 'splitTrim'. + +-- | Parse an edge CSV with header @from,to@ into @(from, to)@ pairs. +-- +-- >>> parseEdgeCsv (T.pack "from,to\na,b\nb,c\n") +-- Right [("a","b"),("b","c")] +parseEdgeCsv :: Text -> Either String [(Text, Text)] +parseEdgeCsv txt = + case dataRows ["from", "to"] txt of + Left e -> Left e + Right rows -> traverse row rows + where + row [a, b] = Right (a, b) + row r = Left ("edge row expected 2 fields, got " ++ show (length r)) + +-- | Parse a coefficient CSV with header @from,to,coef@ into +-- @(from, to, coef)@ triples (coefficient read as 'Double'). +-- +-- >>> parseCoefCsv (T.pack "from,to,coef\na,b,0.5\n") +-- Right [("a","b",0.5)] +parseCoefCsv :: Text -> Either String [(Text, Text, Double)] +parseCoefCsv txt = + case dataRows ["from", "to", "coef"] txt of + Left e -> Left e + Right rows -> traverse row rows + where + row [a, b, c] = case reads (T.unpack c) of + [(d, "")] -> Right (a, b, d) + _ -> Left ("coef field not a number: " ++ show c) + row r = Left ("coef row expected 3 fields, got " ++ show (length r)) + +-- | Read an edge CSV file into a t'TradeNetwork'. Combines parse and validation +-- errors into the @Left@ string. +readEdgeCsv :: FilePath -> IO (Either String (TradeNetwork Text)) +readEdgeCsv fp = do + txt <- TIO.readFile fp + pure $ case parseEdgeCsv txt of + Left e -> Left e + Right es -> either (Left . show) Right (networkFromTable es) + +-- | Read a coefficient CSV file into a @(t'TradeNetwork', t'InputCoefficients')@ +-- pair. Combines parse and validation errors into the @Left@ string. +readCoefCsv :: FilePath -> IO (Either String (TradeNetwork Text, InputCoefficients Text Double)) +readCoefCsv fp = do + txt <- TIO.readFile fp + pure $ case parseCoefCsv txt of + Left e -> Left e + Right trips -> either (Left . show) Right (coefficientsFromTable trips) + +-- | Split CSV text into trimmed data-field rows, after checking the header. +dataRows :: [Text] -> Text -> Either String [[Text]] +dataRows expectedHeader txt = + case keptLines of + [] -> Left "empty CSV (no header)" + (h : body) + | splitTrim h == expectedHeader -> Right (map splitTrim body) + | otherwise -> Left ("unexpected header: " ++ show (splitTrim h) + ++ ", expected " ++ show expectedHeader) + where + keptLines = filter keep (T.lines txt) + keep l = + let s = T.strip l + in not (T.null s) && not ("#" `T.isPrefixOf` s) + +------------------------------------------------------------------ +-- * Internal sampling helpers +------------------------------------------------------------------ + +-- | Uniform sampling without replacement of @n@ elements from a list, +-- deterministic in the 'StdGen'. Returns the chosen elements (in the order they +-- were drawn) and the advanced generator. If @n >= length xs@ the whole list is +-- returned. +sampleWithout :: StdGen -> Int -> [a] -> ([a], StdGen) +sampleWithout g0 n xs0 = go g0 (max 0 n) xs0 [] + where + go g _ [] acc = (reverse acc, g) + go g k xs acc + | k <= 0 = (reverse acc, g) + | otherwise = + let (ix, g1) = randomR (0, length xs - 1) g + (chosen, rest) = pick ix xs + in go g1 (k - 1) rest (chosen : acc) + pick i ys = case splitAt i ys of + (pre, y : post) -> (y, pre ++ post) + (pre, []) -> (last pre, init pre) -- unreachable (ix in range) + +-- | Weighted sampling without replacement: pick @n@ elements, each draw +-- proportional to its weight, deterministic in the 'StdGen'. +sampleWeightedWithout :: StdGen -> Int -> [(a, Double)] -> ([a], StdGen) +sampleWeightedWithout g0 n xs0 = go g0 (max 0 n) xs0 [] + where + go g _ [] acc = (reverse acc, g) + go g k ws acc + | k <= 0 = (reverse acc, g) + | otherwise = + let total = sum (map snd ws) + (u, g1) = randomR (0, total) g :: (Double, StdGen) + (chosen, rest) = drawAt u ws + in go g1 (k - 1) rest (chosen : acc) + drawAt u ws = walk u ws [] + where + walk _ [] seen = case reverse seen of + ((a, _) : _) -> (a, []) -- exhausted (shouldn't happen) + [] -> error "sampleWeightedWithout: empty" + walk acc ((a, w) : rest) seen + | acc <= w = (a, reverse seen ++ rest) + | otherwise = walk (acc - w) rest ((a, w) : seen) + +------------------------------------------------------------------ +-- * Small utilities +------------------------------------------------------------------ + +-- | Strict left @foldM@ over 'Either', short-circuiting on the first 'Left'. +foldM' :: (b -> a -> Either e b) -> b -> [a] -> Either e b +foldM' f = go + where + go !acc [] = Right acc + go !acc (x : xs) = case f acc x of + Left e -> Left e + Right b' -> go b' xs diff --git a/src/ExchangeAlgebra/Simulate/Policy.hs b/src/ExchangeAlgebra/Simulate/Policy.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Simulate/Policy.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- | + Module : ExchangeAlgebra.Simulate.Policy + Copyright : (c) Kaya Akagi. 2018-2026 + Maintainer : yakagika@icloud.com + + Released under the OWL license + + == What this module is + + @Simulate.Policy@ is a small, /additive/ vocabulary for declaring — once, at + the point a ledger is built — how a long simulation should manage the size of + its audit trail. Instead of hand-wiring + t'ExchangeAlgebra.Simulate.Spill.SpillOptions' + (seven fields plus 'filterWithNote' calls for term extraction and eviction), + the user declares a t'LedgerPolicy' and lets the plumbing be /derived from the + Note's term axis/. + + A policy answers three orthogonal questions: + + * __retention__ ('Retention'): how many recent terms to keep in memory + (@'RetainAll'@ or @'RetainRecent' w@); + * __spill__ ('spillTo'): whether evicted terms are first written to a + binary file (so they can be restored losslessly) or simply discarded; + * __compaction__ ('Compaction'): whether /closed/ terms keep their full + per-entry audit sequence (@'FullAudit'@) or are @compress@ed to one + Hat/Not pair per base (@'CompressClosedTerms'@). + + The three are independent. In particular @'spillTo' = 'Nothing'@ combined + with @'RetainRecent' w@ means __evicted terms are destroyed, not written + anywhere__ — there is no way to recover them. This is deliberate (it makes a + bounded-memory run with no disk cost possible), but it is /lossy/; see + t'LedgerPolicy'. + + == Tuning long simulations + + 'FullAudit' is the default because it preserves the complete posting + sequence: every entry remains available for inspection, replay, and external + audit. In a long simulation that also means already-closed terms keep growing + monotonically with their historical @seq@ data, which can dominate residency. + + 'CompressClosedTerms' is the explicit opt-in for that case. It is applied + only to /closed/ terms, never to the in-progress term, and it preserves + @norm@ and balance while discarding redundant within-term sequence detail. + Because the choice is named in t'LedgerPolicy', it is not an implicit + @bar@\/@compress@ hidden inside another operation. + + A common long-horizon setting is to keep the current and previous closed + terms resident, spill older terms to a restorable binary file, and compress + only the closed terms that remain in memory: + + @ + longRunPolicy :: LedgerPolicy + longRunPolicy = LedgerPolicy + { retain = RetainRecent 2 + , spillTo = Just "ledger.spill" + , compaction = CompressClosedTerms + } + @ + + In local measurements this pattern, used with @'RetainRecent' 2@ and + @'spillTo'@, reduced residency by about 15x compared with retaining the full + uncompressed audit sequence. + + == Relation to the classic engine and to Lite + + This module only carries the /types/ and the two bridge helpers + ('policySpillOptions', 'restoreLedger'). The actual term-boundary application + of a policy in the BSP loop lives in "ExchangeAlgebra.Simulate.Lite" + (@runLiteWithPolicy@), and the classic @runSimulationWithSpill@ can be driven + from a policy via 'policySpillOptions'. Nothing here changes the behaviour or + signatures of the existing spill API; it is a thin declarative front-end over + it. + + == The term axis + + A policy needs to know /which term/ a 'Note' belongs to. Because a tuple + Note carries no intrinsic notion of "which component is the period", the + convention is fixed by the 'HasTermAxis' class: __the last component of the + Note is the term__. The library ships instances for @(e, t)@ and + @(e1, e2, t)@; a bespoke Note needs a one-line instance. +-} + +module ExchangeAlgebra.Simulate.Policy + ( -- * Policy vocabulary + Retention(..) + , Compaction(..) + , LedgerPolicy(..) + , defaultLedgerPolicy + -- * Term axis convention + , HasTermAxis(..) + -- * Bridges to the classic spill engine + , policySpillOptions + , restoreLedger + ) where + +import qualified Data.Binary as Binary + +import ExchangeAlgebra.Journal ( Journal + , Note + , HatVal + , HatBaseClass + , filterWithNote ) +import ExchangeAlgebra.Simulate (StateTime) +import ExchangeAlgebra.Simulate.Spill ( SpillOptions(..) + , SpillDeletePolicy(..) + , defaultBinarySpillWriter + , restoreJournalFromBinarySpill ) +import Control.Monad.ST (ST, RealWorld) + +------------------------------------------------------------------ +-- * Policy vocabulary +------------------------------------------------------------------ + +-- | How much of the ledger's term history is kept resident in memory. +-- +-- 'RetainAll' is the full audit trail (the default, equivalent to the classic +-- engine's behaviour). @'RetainRecent' w@ keeps only the most recent @w@ terms +-- resident; older terms are evicted at the term boundary (and, if 'spillTo' is +-- set, written to disk first — see t'LedgerPolicy'). +data Retention = RetainAll | RetainRecent !Int + deriving (Eq, Show) + +-- | How /closed/ (no-longer-advancing) terms are stored. +-- +-- 'FullAudit' (the default) preserves every posting in its original sequence — +-- the complete audit trail. 'CompressClosedTerms' applies @compress@ to the +-- entries of each closed term, collapsing the redundant per-base posting +-- sequence to a single Hat/Not pair per base. This is /norm-preserving and +-- balance-preserving/ (only the within-term @seq@ redundancy is lost) and is +-- only ever applied to closed terms; the in-progress term always keeps its full +-- audit trail. +-- +-- This is the "closing the books" operation of bookkeeping practice. Per the +-- library's prohibition on /implicit/ @bar@\/@compress@, it is reachable only +-- through this named policy, never silently inside another function. +data Compaction = FullAudit | CompressClosedTerms + deriving (Eq, Show) + +-- | A declarative ledger-management policy, fixed once when the ledger is +-- created. The three fields are orthogonal. +-- +-- __Data loss warning.__ When @'spillTo' = 'Nothing'@ and @'retain'@ is +-- @'RetainRecent' w@, terms older than the window are __deleted with no +-- backup__: they are not written to any file and cannot be recovered. Set +-- @'spillTo' = 'Just' path@ to keep a restorable copy (see 'restoreLedger'). +data LedgerPolicy = LedgerPolicy + { retain :: !Retention -- ^ Resident-history policy (default 'RetainAll'). + , spillTo :: !(Maybe FilePath) -- ^ Optional binary spill file (default 'Nothing'); orthogonal to 'retain'. + , compaction :: !Compaction -- ^ Closed-term storage (default 'FullAudit'). + } deriving (Eq, Show) + +-- | The default policy: keep everything, spill nowhere, never compress. This is +-- exactly the classic full-audit behaviour, so a run under 'defaultLedgerPolicy' +-- is observationally equal to one with no policy at all. +-- +-- >>> defaultLedgerPolicy +-- LedgerPolicy {retain = RetainAll, spillTo = Nothing, compaction = FullAudit} +defaultLedgerPolicy :: LedgerPolicy +defaultLedgerPolicy = LedgerPolicy + { retain = RetainAll + , spillTo = Nothing + , compaction = FullAudit + } + +------------------------------------------------------------------ +-- * Term axis convention +------------------------------------------------------------------ + +-- | The convention that fixes /which/ part of a 'Note' is the simulation term. +-- +-- A policy must map a Note to its term to decide which entries belong to a +-- closed period. Since a tuple Note has no intrinsic "term" component, the rule +-- is fixed here: __the term is the last component of the Note__. The shipped +-- instances follow this rule; a custom Note type provides a one-line instance. +-- +-- >>> termOf ("buy", 7 :: Int) +-- 7 +-- +-- >>> termOf ("buy", "shopA", 3 :: Int) +-- 3 +class (Note n, Ord (TermOf n)) => HasTermAxis n where + -- | The term type extracted from the Note. + type TermOf n + -- | Extract the term (last Note component, by the library convention). + termOf :: n -> TermOf n + +-- | Pair Note: the term is the second (last) component. +instance (Note e, Note t) => HasTermAxis (e, t) where + type TermOf (e, t) = t + termOf = snd + +-- | Triple Note: the term is the third (last) component. +instance (Note e1, Note e2, Note t) => HasTermAxis (e1, e2, t) where + type TermOf (e1, e2, t) = t + termOf (_, _, t) = t + +------------------------------------------------------------------ +-- * Bridges to the classic spill engine +------------------------------------------------------------------ + +-- | Build a binary t'ExchangeAlgebra.Simulate.SpillOptions' for the classic +-- @runSimulationWithSpill@ from +-- a t'LedgerPolicy', deriving the per-chunk extraction and the eviction range +-- from the Note's term axis ('termOf'). This replaces the ~20 lines of +-- hand-written 'filterWithNote' plumbing (cf. @simulateEx2@) with a single call. +-- +-- The caller supplies @spillEvery@ (the chunk size in terms) and two accessors +-- for the world's ledger field: @readLedger@ reads the current ledger, and +-- @modifyLedger@ applies a journal transformation in place. The returned options +-- write each chunk with 'defaultBinarySpillWriter' (so 'restoreLedger' can read +-- them back) and, when @'retain' = 'RetainRecent' w@, evict terms whose term +-- index is at most @chunkEnd - w@. +-- +-- When @'retain' = 'RetainAll'@ no eviction is wired ('NoDelete'); the chunks +-- are still written if you want an external log. The 'compaction' field has no +-- effect on this classic bridge (it is applied only in @runLiteWithPolicy@). +-- The eviction arithmetic itself (step-back and per-chunk delete decision) is +-- single-sourced in "ExchangeAlgebra.Simulate" +-- ('ExchangeAlgebra.Simulate.Spill.stepBackWith' / +-- 'ExchangeAlgebra.Simulate.Spill.spillDeleteDecision'); this bridge only maps +-- the policy vocabulary onto t'SpillOptions' (design-review C4). +policySpillOptions + :: forall n v b t a. + ( HasTermAxis n, TermOf n ~ t, StateTime t + , HatVal v, HatBaseClass b + , Binary.Binary t, Binary.Binary (Journal n v b) ) + => LedgerPolicy + -> Int -- ^ chunk size in terms (@spillEvery@) + -> (a RealWorld -> ST RealWorld (Journal n v b)) -- ^ read the world's ledger + -> ((Journal n v b -> Journal n v b) -> a RealWorld -> ST RealWorld ()) + -- ^ modify the world's ledger in place + -> SpillOptions t a (Journal n v b) +policySpillOptions pol spillEvery readLedger modifyLedger = + SpillOptions + { spillEveryTerms = max 1 spillEvery + , spillFilePath = maybe "" id (spillTo pol) + , spillExtract = readLedger + , spillExtractChunk = Just $ \(chunkStart, chunkEnd) world -> do + ledger <- readLedger world + pure $ filterWithNote + (\n _ -> let t = termOf n + in t >= chunkStart && t <= chunkEnd) + ledger + , spillWriteChunk = defaultBinarySpillWriter + , spillDeletePolicy = case retain pol of + RetainAll -> NoDelete + RetainRecent w -> KeepRecentTerms w + , spillDeleteRange = \(_, deleteEnd) world -> + modifyLedger + (filterWithNote (\n _ -> termOf n > deleteEnd)) + world + } + +-- | Restore a full ledger from a policy-written binary spill file plus the +-- in-memory remainder (the most recent, un-evicted terms). The spilled chunks +-- and the remainder are merged with @('ExchangeAlgebra.Algebra..+')@, the +-- remainder narrowed to terms past the last spilled range so nothing is +-- double-counted. +-- +-- This is the inverse of a @'RetainRecent' w@ + @'spillTo' ('Just' path)@ run: +-- the result is the same ledger a 'FullAudit' run would have produced (exact, +-- with an exact value type such as @MoneyDecimal@). With @'spillTo' = 'Nothing'@ +-- there is nothing to restore — the evicted terms are gone. +restoreLedger + :: ( HasTermAxis n, TermOf n ~ t, Ord t, Enum t, Show t + , HatVal v, HatBaseClass b + , Binary.Binary t, Binary.Binary (Journal n v b) ) + => FilePath -- ^ binary spill file written under the policy + -> Journal n v b -- ^ in-memory remainder (recent terms) + -> IO (Journal n v b) +restoreLedger path remainder = + restoreJournalFromBinarySpill path termOf remainder diff --git a/src/ExchangeAlgebra/Simulate/Spill.hs b/src/ExchangeAlgebra/Simulate/Spill.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Simulate/Spill.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StrictData #-} +{- | + Module : ExchangeAlgebra.Simulate.Spill + Copyright : (c) Kaya Akagi. 2018-2026 + Maintainer : yakagika@icloud.com + Description : Spill-to-disk codec and restore for long simulations: chunk writers, checked readers, and ledger restoration. Shared by the classic engine ("ExchangeAlgebra.Simulate"), the Lite runner and the ledger policy layer; depends only on Algebra and Journal. + + Released under the OWL license +-} + +module ExchangeAlgebra.Simulate.Spill + ( SpillOptions(..) + , SpillDeletePolicy(..) + , stepBackWith + , spillDeleteDecision + , mkSpillOptions + , mkBinarySpillOptions + , defaultSpillWriter + , defaultBinarySpillWriter + , SpillReadError(..) + , SpillRangeIssue(..) + , renderSpillReadError + , readBinarySpillFile + , readBinarySpillFileChecked + , restoreJournalFromBinarySpill + , restoreJournalFromBinarySpillChecked + ) where + +import Control.Monad.ST (RealWorld, ST) +import qualified Data.Binary as Binary +import qualified Data.ByteString.Lazy as BL +import Data.Int (Int64) +import qualified Data.List as L +import System.IO (Handle, hPutStr, hPutStrLn) + +import ExchangeAlgebra.Algebra ((.+), HatBaseClass, HatVal) +import qualified ExchangeAlgebra.Journal as EJ + +-- | Spill configuration for periodic external logging. +-- `spillExtract` selects accounting payload from world. +-- `spillWriteChunk` controls on-disk format. +data SpillOptions t a payload = SpillOptions + { spillEveryTerms :: !Int + , spillFilePath :: FilePath + , spillExtract :: a RealWorld -> ST RealWorld payload + , spillExtractChunk :: Maybe ((t, t) -> a RealWorld -> ST RealWorld payload) + , spillWriteChunk :: Handle -> (t, t) -> payload -> IO () + , spillDeletePolicy :: SpillDeletePolicy t + , spillDeleteRange :: (t, t) -> a RealWorld -> ST RealWorld () + } + +-- | Policy to decide which term range to evict after each spill. +data SpillDeletePolicy t + = NoDelete + | DeleteSpilledChunk + | KeepRecentTerms Int + +-- | Step a term back @n@ times with the supplied step function (the classic +-- engine's previous-term operation, or 'pred' in "ExchangeAlgebra.Simulate.Lite"'s +-- retention loop). This is the __single definition__ of the eviction-window +-- arithmetic that was previously duplicated in both engines (design-review +-- C4). @n <= 0@ returns the term unchanged. +-- +-- Complexity: O(n) +{-# INLINE stepBackWith #-} +stepBackWith :: (t -> t) -> Int -> t -> t +stepBackWith step = go + where + go n x | n <= 0 = x + | otherwise = go (n - 1) (step x) + +-- | The per-chunk delete decision, as a pure function of the +-- 'SpillDeletePolicy' -- the single source of "which term range is evicted +-- after a chunk @(chunkStart, chunkEnd)@ is spilled" (design-review C4): +-- +-- * 'NoDelete' -- evict nothing. +-- * 'DeleteSpilledChunk' -- evict exactly the spilled chunk. +-- * @'KeepRecentTerms' n@ -- evict the chunk except the trailing @n@ terms +-- (the resident window); evict nothing when the window covers the chunk. +-- +-- The step function abstracts the engine's notion of "previous term" +-- (the classic engine's previous-term operation; +-- "ExchangeAlgebra.Simulate.Lite" uses 'pred'). +-- +-- Complexity: O(n) for @'KeepRecentTerms' n@, O(1) otherwise. +spillDeleteDecision :: Ord t => (t -> t) -> SpillDeletePolicy t -> (t, t) -> Maybe (t, t) +spillDeleteDecision step policy (chunkStart, chunkEnd) = case policy of + NoDelete -> Nothing + DeleteSpilledChunk -> Just (chunkStart, chunkEnd) + KeepRecentTerms keepN -> + let deleteEnd = stepBackWith step keepN chunkEnd + in if deleteEnd < chunkStart + then Nothing + else Just (chunkStart, deleteEnd) + +-- | Construct text-format SpillOptions. +-- interval is the spill interval (in terms), path is the output file path. +-- +-- Complexity: O(1) +mkSpillOptions :: Show t + => Int + -> FilePath + -> (a RealWorld -> ST RealWorld String) + -> SpillOptions t a String +mkSpillOptions interval path extractF = + SpillOptions + { spillEveryTerms = max 1 interval + , spillFilePath = path + , spillExtract = extractF + , spillExtractChunk = Nothing + , spillWriteChunk = defaultSpillWriter + , spillDeletePolicy = NoDelete + , spillDeleteRange = \_ _ -> pure () + } + +-- | Construct binary-format SpillOptions. +-- Spills in a format that can be restored with 'readBinarySpillFile'. +-- +-- Complexity: O(1) +mkBinarySpillOptions :: (Binary.Binary t, Binary.Binary payload) + => Int + -> FilePath + -> (a RealWorld -> ST RealWorld payload) + -> SpillOptions t a payload +mkBinarySpillOptions interval path extractF = + SpillOptions + { spillEveryTerms = max 1 interval + , spillFilePath = path + , spillExtract = extractF + , spillExtractChunk = Nothing + , spillWriteChunk = defaultBinarySpillWriter + , spillDeletePolicy = NoDelete + , spillDeleteRange = \_ _ -> pure () + } + +-- | Default text-format spill writer. +-- Writes the chunk range and payload as text to the handle. +defaultSpillWriter :: Show t => Handle -> (t, t) -> String -> IO () +defaultSpillWriter h (tStart, tEnd) payload = do + hPutStrLn h ("# chunk " ++ show tStart ++ " " ++ show tEnd) + hPutStr h payload + hPutStrLn h "\n# end-chunk" + +-- | Default binary-format spill writer. +-- Writes the chunk range and payload to the handle using 'Binary.encode'. +defaultBinarySpillWriter :: (Binary.Binary t, Binary.Binary payload) + => Handle -> (t, t) -> payload -> IO () +defaultBinarySpillWriter h termRange payload = + BL.hPut h $ Binary.encode (termRange, payload) + +-- | Why a binary spill file could not be read back as a well-formed chunk sequence. +data SpillReadError t + = SpillDecodeFailure + { spillErrorOffset :: !Int64 -- ^ Byte offset at which decoding failed. + , spillErrorChunks :: !Int -- ^ Chunks decoded successfully before the failure. + , spillErrorMessage :: String -- ^ Message from 'Binary.decodeOrFail'. + } + | SpillRangeError + { spillRangeIssue :: !SpillRangeIssue + , spillRangePrevious :: (t, t) -- ^ The chunk range decoded just before. + , spillRangeCurrent :: (t, t) -- ^ The offending chunk range. + } + | SpillEmptyRange + { spillRangeCurrent :: (t, t) -- ^ A chunk whose start is after its end. + } + deriving (Eq, Show) + +-- | The relationship by which a chunk range fails to follow its predecessor. +data SpillRangeIssue + = ChunkOutOfOrder + | ChunkOverlap + | ChunkGap + deriving (Eq, Show, Enum, Bounded) + +-- | Render a spill read error for an exception or diagnostic message. +renderSpillReadError :: Show t => SpillReadError t -> String +renderSpillReadError err = case err of + SpillDecodeFailure offset chunks message -> + "binary spill decode failure at byte offset " ++ show offset + ++ " after " ++ show chunks ++ " chunks: " ++ message + SpillRangeError issue previous current -> + "binary spill range error (" ++ show issue ++ "): chunk " + ++ show current ++ " follows " ++ show previous + SpillEmptyRange current -> + "binary spill empty range: " ++ show current + +-- | Read a binary spill file and return it as a list of chunks. +-- Used to restore files written by 'defaultBinarySpillWriter'. +-- Raises an error at the first undecodable chunk; no partial result is returned. +-- +-- Complexity: O(file size) +readBinarySpillFile :: (Binary.Binary t, Binary.Binary payload) + => FilePath + -> IO [((t, t), payload)] +readBinarySpillFile path = do + bytes <- BL.readFile path + case decodeBinarySpillChunks bytes of + Left (offset, chunks, message) -> + let err = SpillDecodeFailure offset chunks message :: SpillReadError () + in error (renderSpillReadError err) + Right chunks -> pure chunks + +-- | Read and validate every chunk in a binary spill file. +-- +-- In addition to decode failures, this rejects empty, overlapping, +-- out-of-order, and gapped ranges. Gaps are errors because restoring around a +-- gap would discard the corresponding terms from the in-memory remainder and +-- silently turn missing spill data into an apparently complete ledger. +-- An empty file is a valid spill containing no chunks. +-- +-- Complexity: O(file size + number of chunks) +readBinarySpillFileChecked + :: (Binary.Binary t, Binary.Binary payload, Ord t, Enum t) + => FilePath + -> IO (Either (SpillReadError t) [((t, t), payload)]) +readBinarySpillFileChecked path = do + bytes <- BL.readFile path + pure $ case decodeBinarySpillChunks bytes of + Left (offset, chunks, message) -> + Left (SpillDecodeFailure offset chunks message) + Right chunks -> validateChunkRanges chunks + +-- Decode once for both public readers. The offset from 'Binary.decodeOrFail' is +-- relative to the current suffix, so add the bytes consumed by prior chunks. +decodeBinarySpillChunks + :: (Binary.Binary t, Binary.Binary payload) + => BL.ByteString + -> Either (Int64, Int, String) [((t, t), payload)] +decodeBinarySpillChunks = go 0 0 + where + go _ _ bs | BL.null bs = Right [] + go offset decoded bs = case Binary.decodeOrFail bs of + Left (_, localOffset, message) -> + Left (offset + localOffset, decoded, message) + Right (rest, consumed, entry) -> + (entry :) <$> go (offset + consumed) (decoded + 1) rest + +validateChunkRanges + :: (Ord t, Enum t) + => [((t, t), payload)] + -> Either (SpillReadError t) [((t, t), payload)] +validateChunkRanges chunks = go Nothing chunks >> Right chunks + where + go _ [] = Right () + go previous (((s, e), _) : rest) + | s > e = Left (SpillEmptyRange (s, e)) + | otherwise = case previous of + Nothing -> go (Just (s, e)) rest + Just prior@(ps, pe) + | s <= pe && e >= ps -> + Left (SpillRangeError ChunkOverlap prior (s, e)) + | e < ps -> + Left (SpillRangeError ChunkOutOfOrder prior (s, e)) + | s /= succ pe -> + Left (SpillRangeError ChunkGap prior (s, e)) + | otherwise -> go (Just (s, e)) rest + +-- | Restore a complete Journal from spilled binary chunks and the current in-memory Journal. +-- The in-memory portion is narrowed to only terms after the last spill range, +-- so duplicate terms are not double-counted. +-- A malformed or stale spill file is not restored: this function raises an +-- error instead. Use 'restoreJournalFromBinarySpillChecked' when the caller +-- needs the failure represented as 'Either'. +-- +-- Complexity: O(file size + number of chunks * union cost) +restoreJournalFromBinarySpill + :: ( Binary.Binary t + , Ord t + , Enum t + , Show t + , Binary.Binary (EJ.Journal n v b) + , EJ.Note n + , HatVal v + , HatBaseClass b + ) + => FilePath + -> (n -> t) + -> EJ.Journal n v b + -> IO (EJ.Journal n v b) +restoreJournalFromBinarySpill spillPath noteToTerm currentLedger = do + restored <- restoreJournalFromBinarySpillChecked + spillPath noteToTerm currentLedger + case restored of + Left err -> error (renderSpillReadError err) + Right ledger -> pure ledger + +-- | Checked form of 'restoreJournalFromBinarySpill'. +-- The current ledger is merged only after the entire spill file has decoded +-- and its chunk ranges have passed the continuity checks. +-- +-- Complexity: O(file size + number of chunks * union cost) +restoreJournalFromBinarySpillChecked + :: ( Binary.Binary t + , Ord t + , Enum t + , Binary.Binary (EJ.Journal n v b) + , EJ.Note n + , HatVal v + , HatBaseClass b + ) + => FilePath + -> (n -> t) + -> EJ.Journal n v b + -> IO (Either (SpillReadError t) (EJ.Journal n v b)) +restoreJournalFromBinarySpillChecked spillPath noteToTerm currentLedger = do + result <- readBinarySpillFileChecked spillPath + pure $ fmap restore result + where + restore chunks = + let spilled = L.foldl' (\acc (_, j) -> acc .+ j) mempty chunks + latestEnd = L.foldl' + (\acc ((_, tEnd), _) -> + case acc of + Nothing -> Just tEnd + Just x -> Just (max x tEnd) + ) + Nothing + chunks + remainder = case latestEnd of + Nothing -> currentLedger + Just tEnd -> + EJ.filterWithNote (\n _ -> noteToTerm n > tEnd) currentLedger + in spilled .+ remainder diff --git a/src/ExchangeAlgebra/Simulate/Visualize.hs b/src/ExchangeAlgebra/Simulate/Visualize.hs --- a/src/ExchangeAlgebra/Simulate/Visualize.hs +++ b/src/ExchangeAlgebra/Simulate/Visualize.hs @@ -42,8 +42,6 @@ import qualified Data.List as L import Graphics.Rendering.Chart.Easy hiding ( (:<),(.~)) import Graphics.Rendering.Chart.Backend.Cairo -import Graphics.Rendering.Chart.Axis -import Graphics.Rendering.Chart.Axis.Int import Graphics.Rendering.Chart.Grid import qualified Control.Monad as CM import Control.Monad.ST @@ -112,13 +110,13 @@ -- | Plot the time series data contained in each column createColumn seriesGroup = layoutToGrid $ execEC $ do - CM.forM_ seriesGroup $ \(label, seriesData) -> - plot $ linePlot label seriesData + CM.forM_ seriesGroup $ \(seriesLabel, seriesData) -> + plot $ linePlot seriesLabel seriesData -- | Render a single time series as a line plot - linePlot label seriesData = liftEC $ do + linePlot seriesLabel seriesData = liftEC $ do plot_lines_values .= [concat seriesData] - plot_lines_title .= label + plot_lines_title .= seriesLabel plot_lines_style . line_color .= opaque blue -- | Set the graph title @@ -232,13 +230,13 @@ -- | Plot multiple time series in each column with color coding createColumn seriesGroup = layoutToGrid $ execEC $ - CM.forM_ (zip [0..] seriesGroup) $ \(index, (label, seriesData)) -> - plot $ linePlot index label seriesData + CM.forM_ (zip [0..] seriesGroup) $ \(seriesIdx, (seriesLabel, seriesData)) -> + plot $ linePlot seriesIdx seriesLabel seriesData -- | Render time series data as a colored line plot - linePlot idx label seriesData = liftEC $ do + linePlot idx seriesLabel seriesData = liftEC $ do plot_lines_values .= [concat seriesData] - plot_lines_title .= label + plot_lines_title .= seriesLabel plot_lines_style . line_color .= colorPalette !! (idx `mod` length colorPalette) -- | Set the graph title @@ -344,13 +342,13 @@ -- | Plot the time series data contained in each column createColumn seriesGroup = layoutToGrid $ execEC $ do - CM.forM_ seriesGroup $ \(label, seriesData) -> - plot $ linePlot label seriesData + CM.forM_ seriesGroup $ \(seriesLabel, seriesData) -> + plot $ linePlot seriesLabel seriesData -- | Render a single time series as a line plot - linePlot label seriesData = liftEC $ do + linePlot seriesLabel seriesData = liftEC $ do plot_lines_values .= [concat seriesData] - plot_lines_title .= label + plot_lines_title .= seriesLabel plot_lines_style . line_color .= opaque blue -- | Set the graph title @@ -452,7 +450,7 @@ where -- flattenIndex iCount iIndex tIndex = tIndex * iCount + iIndex flattenIndex :: Int -> Int -> Int -> Int - flattenIndex width x y = y * width + x + flattenIndex w x y = y * w + x -------------------------------------------------------------------------------- -- 3. Function to draw (i, t) line graphs using a Vector-based approach @@ -491,12 +489,12 @@ -- | Plot multiple TimeSeries contained in one column (TimeSerieses t) createColumn seriesGroup = layoutToGrid $ execEC $ do - CM.forM_ seriesGroup $ \(label, seriesData) -> - plot $ linePlot label seriesData + CM.forM_ seriesGroup $ \(seriesLabel, seriesData) -> + plot $ linePlot seriesLabel seriesData - linePlot label seriesData = liftEC $ do + linePlot seriesLabel seriesData = liftEC $ do plot_lines_values .= [concat seriesData] - plot_lines_title .= label + plot_lines_title .= seriesLabel plot_lines_style . line_color .= opaque blue createTitle name = @@ -552,11 +550,11 @@ -> a RealWorld -> FilePath -> IO () -writeFuncResults funcs range wld path = +writeFuncResults funcs termRange wld path = writeFuncResultsWithContext (\_ t -> return t) (map (\(header, f) -> (header, \t -> f wld t)) funcs) - range + termRange wld path diff --git a/src/ExchangeAlgebra/TrialBalance/Balance.hs b/src/ExchangeAlgebra/TrialBalance/Balance.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/TrialBalance/Balance.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE FlexibleContexts #-} + +{- | +Module : ExchangeAlgebra.TrialBalance.Balance +Description : Shared account-balance representation and netting primitives for trial balances, presentation and consolidation. One type, one pair order (debit, credit), one netting rule. + +Account balances retain their debit or credit direction while keeping scalar +values non-negative. All pair-valued functions in this module use debit first +and credit second. +-} +module ExchangeAlgebra.TrialBalance.Balance + ( AccountBalance(..) + , balancePair + , addPair + , netPair + , combineBalances + , balanceFor + , balanceSide + , balanceAmount + , accountBalances + ) where + +import qualified Data.Map.Strict as M +import Data.Map.Strict (Map) + +import ExchangeAlgebra.Algebra (Alg, HatVal, foldEntries) +import ExchangeAlgebra.Algebra.Base + ( AccountTitles + , ExBaseClass(getAccountTitle, whichSide) + , Side(..) + ) + +-- | Net balance direction remains structural; values stay non-negative. +data AccountBalance v + = NoBalance + | DebitBalance v + | CreditBalance v + deriving (Show, Eq) + +-- | Convert a balance to a pair ordered as debit, then credit. +balancePair :: Num v => AccountBalance v -> (v, v) +balancePair NoBalance = (0, 0) +balancePair (DebitBalance value) = (value, 0) +balancePair (CreditBalance value) = (0, value) + +-- | Add two debit-credit pairs componentwise. +addPair :: Num v => (v, v) -> (v, v) -> (v, v) +addPair (leftDebit, leftCredit) (rightDebit, rightCredit) = + (leftDebit + rightDebit, leftCredit + rightCredit) + +-- | Net a debit-credit pair into one structural balance. +netPair :: (Ord v, Num v) => (v, v) -> AccountBalance v +netPair (debit, credit) + | debit == credit = NoBalance + | debit > credit = DebitBalance (debit - credit) + | otherwise = CreditBalance (credit - debit) + +-- | Combine two balances using the common netting rule. +combineBalances + :: (Ord v, Num v) + => AccountBalance v -> AccountBalance v -> AccountBalance v +combineBalances left right = netPair + (addPair (balancePair left) (balancePair right)) + +-- | Look up an account balance, treating an absent account as balanced. +balanceFor :: AccountTitles -> Map AccountTitles (AccountBalance v) + -> AccountBalance v +balanceFor title = M.findWithDefault NoBalance title + +-- | Recover the structural side of a balance. +balanceSide :: AccountBalance v -> Side +balanceSide NoBalance = Side +balanceSide (DebitBalance _) = Debit +balanceSide (CreditBalance _) = Credit + +-- | Recover the non-negative scalar amount of a balance. +balanceAmount :: Num v => AccountBalance v -> v +balanceAmount NoBalance = 0 +balanceAmount (DebitBalance value) = value +balanceAmount (CreditBalance value) = value + +-- | Aggregate postings by account and net each debit-credit total. +accountBalances + :: (HatVal v, ExBaseClass b) + => Alg v b + -> Map AccountTitles (AccountBalance v) +accountBalances = M.map netPair . foldEntries collect M.empty + where + collect totals value base = + M.insertWith addPair (getAccountTitle base) + (sidePair (whichSide base) value) totals + +sidePair :: Num v => Side -> v -> (v, v) +sidePair Debit value = (value, 0) +sidePair Credit value = (0, value) +sidePair Side _ = (0, 0) diff --git a/src/ExchangeAlgebra/TrialBalance/Validation.hs b/src/ExchangeAlgebra/TrialBalance/Validation.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/TrialBalance/Validation.hs @@ -0,0 +1,432 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wincomplete-patterns -Werror=incomplete-patterns #-} + +{- | +Module : ExchangeAlgebra.TrialBalance.Validation +Description : Explicit findings and policy gate between trial balances and reporting. + +An exactly balanced trial balance can still be unsuitable for financial +statement preparation. This module detects reciprocal-account mismatches, +temporary-account residuals, closing-device residuals, abnormal-side balances, +and missing classification evidence independently of the double-entry balance +check. + +Detection and acceptance are deliberately separate. 'trialBalanceFindings' +always reports the facts it can observe; 'validateTrialBalance' applies a +t'TrialBalancePolicy' and hides the v'ValidatedTrialBalance' constructor. No +finding performs a reclassification automatically. A caller must record and +apply a transfer, then validate the resulting trial balance again. + +Validation uses exact equality. Prefer an exact value type such as +@MoneyDecimal@ for deterministic accounting gates. +-} +module ExchangeAlgebra.TrialBalance.Validation + ( TrialBalanceStage(..) + , ReciprocalPolicy(..) + , TemporaryBalancePolicy(..) + , TrialBalancePolicy(..) + , strictTrialBalancePolicy + , standaloneTrialBalancePolicy + , AccountBalance(..) + , ReclassificationRule(..) + , TrialBalanceInput(..) + , TBFinding(..) + , trialBalanceFindings + , findingBlocksPresentation + , ValidatedTrialBalance + , validateTrialBalance + , validatedTrialBalance + , validatedFindings + , validatedPolicy + , validatedStage + , validatedMaturityRequiredTitles + ) where + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as M +import Data.Map.Strict (Map) +import qualified Data.Set as S +import Data.Set (Set) +import Data.Text (Text) +import qualified Data.Text as T + +import ExchangeAlgebra.Algebra + ( Alg + , Exchange(decL, decR) + , HatVal(..) + , Redundant(norm) + , bases + , foldEntries + ) +import ExchangeAlgebra.Algebra.Base + ( AccountDivision(..) + , AccountRole(..) + , AccountSemantics(asemDivisionSemantics, + asemHomeSideSemantics, asemRoles) + , AccountTitles(..) + , DivisionSemantics(..) + , Hat(..) + , HatBase((:<)) + , HomeSideSemantics(..) + , Side(..) + , accountSemantics + , concreteAccountTitles + ) +import ExchangeAlgebra.TrialBalance.Balance + ( AccountBalance(..) + , accountBalances + , balanceFor + , balanceSide + ) + +-- | Processing point of the supplied trial balance. +data TrialBalanceStage + = BeforeClosing + | AfterClosing + deriving (Show, Eq) + +-- | Whether reciprocal accounts must tie in this validation context. +data ReciprocalPolicy + = RequireReciprocalMatch + | PermitStandaloneReciprocalBalance + deriving (Show, Eq) + +-- | Whether an explained temporary balance may pass the validation gate. +data TemporaryBalancePolicy + = RequireTemporaryAccountsCleared + | PermitExplainedTemporaryBalances + deriving (Show, Eq) + +-- | Policy applied after the complete finding list has been constructed. +data TrialBalancePolicy = TrialBalancePolicy + { _reciprocalPolicy :: ReciprocalPolicy + , _temporaryBalancePolicy :: TemporaryBalancePolicy + } + deriving (Show, Eq) + +-- | Combined/reporting default: reciprocal accounts must tie and temporary +-- accounts must be cleared. +strictTrialBalancePolicy :: TrialBalancePolicy +strictTrialBalancePolicy = TrialBalancePolicy + RequireReciprocalMatch RequireTemporaryAccountsCleared + +-- | Standalone default: a branch or head-office control balance may remain, +-- while an explained temporary balance is retained as an auditable finding. +standaloneTrialBalancePolicy :: TrialBalancePolicy +standaloneTrialBalancePolicy = TrialBalancePolicy + PermitStandaloneReciprocalBalance PermitExplainedTemporaryBalances + +-- | A rule identifies a condition and possible target titles. It supplies an +-- instruction, not an automatic mutation. +data ReclassificationRule + = SideReclassificationRule + AccountTitles + Side + (NonEmpty AccountTitles) + | MaturityEvidenceRequired AccountTitles + deriving (Show, Eq) + +-- | Unvalidated trial-balance input and its external evidence. +data TrialBalanceInput v = TrialBalanceInput + { _trialBalanceElement :: Alg v (HatBase AccountTitles) + , _trialBalanceStage :: TrialBalanceStage + , _temporaryBalanceExplanations :: Map AccountTitles Text + , _reclassificationRules :: [ReclassificationRule] + , _maturityEvidenceTitles :: Set AccountTitles + } + deriving (Show) + +-- | Facts detected before financial-statement presentation. +data TBFinding v + = InvalidTrialBalanceValue v + | WildcardTrialBalanceAccount + | WildcardTrialBalanceSide + | UnbalancedTrialBalance v v + | ReciprocalMismatch + (AccountBalance v) + (AccountBalance v) + | StandaloneReciprocalBalance AccountTitles (AccountBalance v) + | UnresolvedTemporaryBalance AccountTitles (AccountBalance v) + | ExplainedTemporaryBalance AccountTitles (AccountBalance v) Text + | BlankTemporaryExplanation AccountTitles (AccountBalance v) + | ClosingDeviceResidual AccountTitles (AccountBalance v) + | DerivedCoordinateResidual AccountTitles (AccountBalance v) + | UnclosedNominalBalance AccountTitles (AccountBalance v) + | UnexplainedAbnormalBalance + AccountTitles Side (AccountBalance v) + | AbnormalBalanceWithReclassificationRule + AccountTitles (AccountBalance v) AccountTitles + | AmbiguousReclassification + AccountTitles (AccountBalance v) (NonEmpty AccountTitles) + | MissingMaturityEvidence AccountTitles + | InapplicableReclassificationRule ReclassificationRule + deriving (Show, Eq) + +-- | Detect every applicable finding. Structural errors suppress any operation +-- that would call the partial legacy @whichSide@ function on wildcard bases. +trialBalanceFindings :: HatVal v => TrialBalanceInput v -> [TBFinding v] +trialBalanceFindings input + | not (null structuralFindings) = structuralFindings + | otherwise = balanceFindings + ++ reciprocalFindings balances + ++ temporaryFindings input balances + ++ closingFindings input balances + ++ abnormalFindings input balances + ++ maturityFindings input balances + ++ ruleConfigurationFindings input + where + alg = _trialBalanceElement input + structuralFindings = + [ InvalidTrialBalanceValue value + | value <- valuesOf alg + , isErrorValue value + ] + ++ [ WildcardTrialBalanceAccount + | _ :< AccountTitle <- bases alg + ] + ++ [ WildcardTrialBalanceSide + | HatNot :< _ <- bases alg + ] + debit = norm (decL alg) + credit = norm (decR alg) + balanceFindings = + [ UnbalancedTrialBalance debit credit | debit /= credit ] + balances = accountBalances alg + +-- | Decide whether one finding blocks presentation under a chosen policy. +findingBlocksPresentation :: TrialBalancePolicy -> TBFinding v -> Bool +findingBlocksPresentation policy finding = case finding of + ExplainedTemporaryBalance _ _ _ -> + _temporaryBalancePolicy policy == RequireTemporaryAccountsCleared + StandaloneReciprocalBalance _ _ -> + _reciprocalPolicy policy == RequireReciprocalMatch + ReciprocalMismatch _ _ -> True + InvalidTrialBalanceValue _ -> True + WildcardTrialBalanceAccount -> True + WildcardTrialBalanceSide -> True + UnbalancedTrialBalance _ _ -> True + UnresolvedTemporaryBalance _ _ -> True + BlankTemporaryExplanation _ _ -> True + ClosingDeviceResidual _ _ -> True + DerivedCoordinateResidual _ _ -> True + UnclosedNominalBalance _ _ -> True + UnexplainedAbnormalBalance _ _ _ -> True + AbnormalBalanceWithReclassificationRule _ _ _ -> True + AmbiguousReclassification _ _ _ -> True + MissingMaturityEvidence _ -> True + InapplicableReclassificationRule _ -> True + +-- | Trial balance accepted by a stated policy. The constructor is hidden. +data ValidatedTrialBalance v = ValidatedTrialBalance + (Alg v (HatBase AccountTitles)) + [TBFinding v] + TrialBalancePolicy + TrialBalanceStage + (Set AccountTitles) + +-- | Apply a policy to the complete finding list. +validateTrialBalance + :: HatVal v + => TrialBalancePolicy + -> TrialBalanceInput v + -> Either (NonEmpty (TBFinding v)) (ValidatedTrialBalance v) +validateTrialBalance policy input = + case filter (findingBlocksPresentation policy) findings of + [] -> Right (ValidatedTrialBalance + (_trialBalanceElement input) findings policy + (_trialBalanceStage input) (maturityRequiredTitles input)) + blocker : blockers -> Left (blocker :| blockers) + where + findings = trialBalanceFindings input + +-- | Recover the accepted algebra element. +validatedTrialBalance + :: ValidatedTrialBalance v -> Alg v (HatBase AccountTitles) +validatedTrialBalance (ValidatedTrialBalance alg _ _ _ _) = alg + +-- | Recover both blocking-policy-independent facts and permitted warnings. +validatedFindings :: ValidatedTrialBalance v -> [TBFinding v] +validatedFindings (ValidatedTrialBalance _ findings _ _ _) = findings + +-- | Recover the policy that admitted this trial balance. +validatedPolicy :: ValidatedTrialBalance v -> TrialBalancePolicy +validatedPolicy (ValidatedTrialBalance _ _ policy _ _) = policy + +-- | Recover the processing stage at which the trial balance was admitted. +validatedStage :: ValidatedTrialBalance v -> TrialBalanceStage +validatedStage (ValidatedTrialBalance _ _ _ stage _) = stage + +-- | Maturity-allocation obligations that crossed the validation boundary. +validatedMaturityRequiredTitles + :: ValidatedTrialBalance v -> Set AccountTitles +validatedMaturityRequiredTitles (ValidatedTrialBalance _ _ _ _ titles) = titles + +maturityRequiredTitles :: TrialBalanceInput v -> Set AccountTitles +maturityRequiredTitles input = S.fromList + [ title + | MaturityEvidenceRequired title <- _reclassificationRules input + ] + +valuesOf :: HatVal v => Alg v (HatBase AccountTitles) -> [v] +valuesOf = foldEntries (\values value _ -> value : values) [] + +reciprocalFindings + :: (Eq v) + => Map AccountTitles (AccountBalance v) + -> [TBFinding v] +reciprocalFindings balances = + case (branch, headOffice) of + (NoBalance, NoBalance) -> [] + (NoBalance, balance) -> + [StandaloneReciprocalBalance HeadOfficeCurrentAccount balance] + (balance, NoBalance) -> + [StandaloneReciprocalBalance BranchCurrentAccount balance] + _ | reciprocalBalancesMatch branch headOffice -> [] + | otherwise -> [ReciprocalMismatch branch headOffice] + where + branch = balanceFor BranchCurrentAccount balances + headOffice = balanceFor HeadOfficeCurrentAccount balances + +reciprocalBalancesMatch :: Eq v => AccountBalance v -> AccountBalance v -> Bool +reciprocalBalancesMatch NoBalance NoBalance = True +reciprocalBalancesMatch (DebitBalance left) (CreditBalance right) = left == right +reciprocalBalancesMatch (CreditBalance left) (DebitBalance right) = left == right +reciprocalBalancesMatch _ _ = False + +temporaryFindings + :: TrialBalanceInput v + -> Map AccountTitles (AccountBalance v) + -> [TBFinding v] +temporaryFindings input balances = concatMap finding temporaryTitles + where + temporaryTitles = case _trialBalanceStage input of + BeforeClosing -> titlesWithRole SuspenseOrClearingAccount + AfterClosing -> filter (/= CashOverShort) + (titlesWithRole SuspenseOrClearingAccount) + finding title = case balanceFor title balances of + NoBalance -> [] + balance -> case M.lookup title (_temporaryBalanceExplanations input) of + Nothing -> [UnresolvedTemporaryBalance title balance] + Just explanation + | T.null (T.strip explanation) -> + [BlankTemporaryExplanation title balance] + | otherwise -> + [ExplainedTemporaryBalance title balance explanation] + +closingFindings + :: TrialBalanceInput v + -> Map AccountTitles (AccountBalance v) + -> [TBFinding v] +closingFindings input balances = case _trialBalanceStage input of + BeforeClosing -> [] + AfterClosing -> + concatMap residual (CashOverShort : titlesWithRole ClosingDevice) + ++ concatMap derivedResidual + (titlesWithRole PeriodResult ++ titlesWithRole ReportingSubtotal) + ++ [ UnclosedNominalBalance title balance + | (title, balance) <- M.toList balances + , hasBalance balance + , isNominal title + ] + where + residual title = case balanceFor title balances of + NoBalance -> [] + balance -> [ClosingDeviceResidual title balance] + derivedResidual title = case balanceFor title balances of + NoBalance -> [] + balance -> [DerivedCoordinateResidual title balance] + isNominal title = case accountSemantics title of + Just semantics -> case asemDivisionSemantics semantics of + StatementDivision Cost -> True + StatementDivision Revenue -> True + _ -> False + Nothing -> False + hasBalance NoBalance = False + hasBalance _ = True + +abnormalFindings + :: TrialBalanceInput v + -> Map AccountTitles (AccountBalance v) + -> [TBFinding v] +abnormalFindings input balances = concatMap finding (M.toList balances) + where + finding (_, NoBalance) = [] + finding (title, balance) = case expectedSide title of + Nothing -> [] + Just expected + | balanceSide balance == expected -> [] + | otherwise -> classifyRule title expected balance + classifyRule title expected balance = case ruleTargets title (balanceSide balance) + (_reclassificationRules input) of + [] -> [UnexplainedAbnormalBalance + title expected balance] + [target] -> [AbnormalBalanceWithReclassificationRule + title balance target] + target : targets -> [AmbiguousReclassification + title balance (target :| targets)] + +maturityFindings + :: Eq v + => TrialBalanceInput v + -> Map AccountTitles (AccountBalance v) + -> [TBFinding v] +maturityFindings input balances = + [ MissingMaturityEvidence title + | MaturityEvidenceRequired title <- _reclassificationRules input + , balanceFor title balances /= NoBalance + , S.notMember title (_maturityEvidenceTitles input) + ] + +expectedSide :: AccountTitles -> Maybe Side +expectedSide title = do + semantics <- accountSemantics title + if OrdinaryAccount `elem` asemRoles semantics + then case asemHomeSideSemantics semantics of + FixedHomeSide side -> Just side + ContextDependentHomeSide -> Nothing + NoFixedHomeSide -> Nothing + NoPostingSide -> Nothing + else Nothing + +ruleTargets + :: AccountTitles + -> Side + -> [ReclassificationRule] + -> [AccountTitles] +ruleTargets title side = deduplicate S.empty . concatMap targets + where + deduplicate _ [] = [] + deduplicate seen (candidate : candidates) + | candidate `S.member` seen = deduplicate seen candidates + | otherwise = candidate + : deduplicate (S.insert candidate seen) candidates + targets (SideReclassificationRule source trigger candidates) + | source == title && trigger == side = NE.toList candidates + | otherwise = [] + targets (MaturityEvidenceRequired _) = [] + +ruleConfigurationFindings :: TrialBalanceInput v -> [TBFinding v] +ruleConfigurationFindings input = + [ InapplicableReclassificationRule rule + | rule <- _reclassificationRules input + , not (applicable rule) + ] + where + applicable (MaturityEvidenceRequired title) = title /= AccountTitle + applicable (SideReclassificationRule source trigger candidates) = + source /= AccountTitle + && trigger /= Side + && expectedSide source /= Nothing + && expectedSide source /= Just trigger + && all (targetAccepts trigger) (NE.toList candidates) + targetAccepts trigger target = + target /= AccountTitle && expectedSide target == Just trigger + +titlesWithRole :: AccountRole -> [AccountTitles] +titlesWithRole role = + [ title + | title <- concreteAccountTitles + , Just semantics <- [accountSemantics title] + , role `elem` asemRoles semantics + ] diff --git a/src/ExchangeAlgebra/Value.hs b/src/ExchangeAlgebra/Value.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Value.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingStrategies #-} + +{- | + Module : ExchangeAlgebra.Value + Copyright : (c) Kaya Akagi. 2018-2026 + Maintainer : yakagika@icloud.com + + Released under the OWL license + + Exact, non-negative decimal value type (t'MoneyDecimal') for use as the @v@ + parameter of @Alg v b@ / @Journal n v b@. + + == Why this exists (DESIGN, 2026-06-06) + + The accounting value type is selectable: + + * @Double@ — fast IEEE-754; the default. Addition is /non-associative/, + so the order in which same-base postings are summed (which depends on how a + value was /constructed/) can change @norm@ / @bar@ results. In the + agent-based simulations this manifested as a ~3% swing in a stock value when + the construction order changed (see plans/in-progress/LAZY_EVAL_AUDIT.md and + FP_SUMMATION_SURVEY.md). This is acceptable for relative-price ABM work where + speed matters, but it is not deterministic/auditable. + + * @MoneyDecimal@ — exact base-10 fixed-point (a non-negative 'Data.Decimal'). + Addition is /exact and associative/, so results are independent of + construction order: the fromList fold direction, parallel merges, etc. no + longer change the answer. This is the right choice for audited ledgers and + for making the construction-order optimizations (fromList O(N)) safe. + + @Integer@ (minimal-currency-unit) is intentionally NOT offered: ABM simulations + use relative prices with base unit 1 and sub-unit fractional prices, which an + integer cannot represent. + + == Ergonomics + + Numeric literals work without wrapping, because 'Num'/'Fractional' are derived: + + > type Ledger = Journal Term MoneyDecimal (HatBase AccountTitles) + > entry = 10.5 :@ Hat: Decimal +toDecimal (MoneyDecimal d) = d + +-- 'Nearly': for an exact type there is no rounding noise to tolerate, so the +-- tolerance argument is ignored and equality is exact. (Contrast the @Double@ +-- instance, which uses a scale-aware tolerance.) +instance Nearly MoneyDecimal where + {-# INLINE isNearly #-} + isNearly x y _ = x == y + +instance HatVal MoneyDecimal where + {-# INLINE zeroValue #-} + zeroValue = MoneyDecimal 0 + -- Exact decimals have no NaN/Infinity; the only "error value" is a negative + -- amount, which violates the non-negativity invariant of the algebra. + {-# INLINE isErrorValue #-} + isErrorValue (MoneyDecimal x) = x < 0 + -- Render exactly (e.g. "0.3", "12.34"); unlike the Double instance there is no + -- fixed-2-decimal formatting, because the decimal value is already exact. + {-# INLINE showValue #-} + showValue (MoneyDecimal x) = show x + +-- 'Binary'/'Hashable' are defined here (not orphan) because 'Data.Decimal' ships +-- neither, and 'Alg'/t'Journal' serialisation and the binary spill path require +-- @Binary v@. Both go through the (places, mantissa) structure of t'Decimal'. +instance Binary.Binary MoneyDecimal where + {-# INLINE put #-} + put (MoneyDecimal (Decimal places mantissa)) = do + Binary.put (places :: Word8) + Binary.put (mantissa :: Integer) + {-# INLINE get #-} + get = do + places <- Binary.get :: Binary.Get Word8 + mantissa <- Binary.get :: Binary.Get Integer + pure (MoneyDecimal (Decimal places mantissa)) + +instance Hashable MoneyDecimal where + {-# INLINE hashWithSalt #-} + hashWithSalt s (MoneyDecimal (Decimal places mantissa)) = + s `hashWithSalt` places `hashWithSalt` mantissa + +instance NFData MoneyDecimal where + {-# INLINE rnf #-} + rnf (MoneyDecimal (Decimal places mantissa)) = rnf places `seq` rnf mantissa + +------------------------------------------------------------------ +-- * MoneyDouble — fast IEEE-754 value type +------------------------------------------------------------------ + +-- | A fast IEEE-754 money value (wraps 'Prelude.Double'). +-- +-- This is the @newtype@ counterpart of the bare-@Double@ instance: a dedicated, +-- domain-specific money type so a ledger value cannot be silently confused with +-- an ABM coefficient, a random draw, or any other raw 'Double'. Every instance +-- it needs is owned here (via @deriving newtype@), so — exactly like +-- t'MoneyDecimal' — there are no orphan instances. Use t'MoneyDouble' for the same +-- speed as bare 'Double' while keeping the value type distinct in signatures. +-- +-- Trade-off vs t'MoneyDecimal': addition is /non-associative/ (FP), so @norm@ \/ +-- @bar@ can differ in the last ULP depending on construction order. It is fast +-- and runs everywhere bare 'Double' does (subtraction is signed, so the +-- intermediate negatives that arise inside @bar@\/@(.-)@ are fine — unlike +-- @Number.NonNegative.Double@, whose @(-)@ /errors/ on a negative result). +-- +-- Non-negativity is the same /soft/ invariant as for t'MoneyDecimal' and bare +-- 'Double': not enforced by the constructor, but 'isErrorValue' reports +-- @isNaN x || isInfinite x || x < 0@, so the @(.\@)@ smart constructor and +-- @(.*)@ reject negative\/non-finite values. +newtype MoneyDouble = MoneyDouble Double + -- All instances are coerced from the existing bare-'Double' instances + -- ('Nearly'/'HatVal' live in "ExchangeAlgebra.Algebra"; 'Binary'/'Hashable'/ + -- 'NFData' come from the binary/hashable/deepseq packages), so t'MoneyDouble' + -- is a zero-cost wrapper with identical numeric behaviour and 2-decimal + -- 'showValue' formatting. + deriving newtype ( Eq, Ord, Show, Num, Fractional, Real, RealFrac + , Nearly, HatVal, Hashable, NFData, Binary.Binary ) + +-- | Project out the underlying 'Prelude.Double'. +toDouble :: MoneyDouble -> Double +toDouble (MoneyDouble d) = d + +-- | Round a value to @n@ decimal places using /banker's rounding/ +-- (round-half-to-even): the unbiased financial default. Ties go to the nearest +-- even digit (@2.5 -> 2@, @3.5 -> 4@, @0.125 -> 0.12@), so repeated rounding over +-- many transactions does not drift the total upward the way half-up does. This is +-- 'Prelude.round' applied per 'Data.Decimal.roundTo''. +-- +-- Apply at the point a monetary amount is finalised after multiplication/division +-- (tax, proration, scalar product). The core algebra (add/subtract) is exact and +-- needs no rounding. +bankersRound :: Word8 -> MoneyDecimal -> MoneyDecimal +bankersRound places (MoneyDecimal d) = MoneyDecimal (roundTo' round places d) + +-- | Round a value to @n@ decimal places by rounding /up/ (ceiling). This preserves +-- the previous library default (@rounding = ceiling@) and suits jurisdictions whose +-- rules round up. Prefer 'bankersRound' unless a ceiling rule is specifically required. +ceilingRound :: Word8 -> MoneyDecimal -> MoneyDecimal +ceilingRound places (MoneyDecimal d) = MoneyDecimal (roundTo' ceiling places d) diff --git a/src/ExchangeAlgebra/Write.hs b/src/ExchangeAlgebra/Write.hs --- a/src/ExchangeAlgebra/Write.hs +++ b/src/ExchangeAlgebra/Write.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} {- | Module : ExchangeAlgebra.Write Copyright : (c) Kaya Akagi. 2018-2026 @@ -23,16 +24,30 @@ , csvTranspose -- * Balance Sheet / P&L / Journal output , writeBS + , bsRows , writePL + , plRows , writeJournal + , journalRows , writeAccountOf + , writeAccountOfJournal + , accountLedgerRowsJournal , writeCompoundTrialBalance + , compoundTrialBalanceRows + -- * Closing documents (決算書類) + , writeWorksheet + , worksheetRows + , writePostClosingTrialBalance + , postClosingTrialBalanceRows + , accountLedgerRows -- * Simulation output , writeTermIO , writeIOMatrix -- * Spill / Restore , restoreJournalFromBinarySpill + , restoreJournalFromBinarySpillChecked -- * Helpers + , balanceOf , tshow , toSameLength ) where @@ -40,17 +55,22 @@ import qualified ExchangeAlgebra.Algebra as EA import ExchangeAlgebra.Algebra import qualified ExchangeAlgebra.Journal as EJ +import ExchangeAlgebra.Journal ((.|)) import qualified ExchangeAlgebra.Algebra.Transfer as ET +import qualified ExchangeAlgebra.Reporting.Group as RG -import ExchangeAlgebra.Simulate +import ExchangeAlgebra.Simulate.Spill + ( restoreJournalFromBinarySpill + , restoreJournalFromBinarySpillChecked ) import qualified Data.List as L import qualified Data.Text as T -import qualified Data.Binary as Binary import Control.Monad import qualified Data.Set as Set +import qualified Data.HashMap.Strict as Map +import qualified Data.Map.Strict as OMap import Data.Array.IO import Data.Time (Day) import System.IO (openFile, IOMode(WriteMode), hClose) @@ -82,51 +102,250 @@ tshow :: (Show a) => a -> T.Text tshow = T.pack . show --- | Output a Balance Sheet in CSV format. --- Internally applies @finalStockTransfer@, then decomposes into assets, liabilities, and equity for output. +-- | Render one 'RG.RelativeAmount' as a statement cell. The magnitude is +-- always non-negative (see "ExchangeAlgebra.Reporting.Group"); a deduction, or +-- a net that its deductions pushed past zero, is shown with a leading @-@. +-- The minus sign exists only here, in the rendered text — never in a value. -- +-- Complexity: O(show cost) +renderRelative :: (HatVal n) => RG.RelativeAmount n -> T.Text +renderRelative amount + | RG.raBelowZero amount = T.cons '-' magnitude + | otherwise = magnitude + where + magnitude = tshow (RG.raMagnitude amount) + +-- | Flatten presentation blocks into @(label, value)@ statement cells. +-- Gross and deduction rows are labelled by their account title, subtotal and +-- net rows by the group's label. +-- +-- Complexity: O(r) (r = number of rows in the given blocks) +groupCells :: (HatVal n) + => [RG.PresentationGroupDef] + -> [(RG.PresentationGroupDef, [RG.GroupRow n])] + -> [(T.Text, T.Text)] +groupCells defs blocks = + [ (label (RG.grKind row), renderRelative (RG.grAmount row)) + | (_, rows) <- blocks, row <- rows ] + where + label kind = case kind of + RG.GrossRow t -> tshow t + RG.DeductionRow t -> tshow t + RG.SubgroupRow key -> groupLabel key + RG.NetRow key -> groupLabel key + groupLabel key = maybe (tshow key) RG.pgLabel (RG.lookupGroupDef defs key) + +-- | Build the rows of a Balance Sheet, as a pure value (the part 'writeBS' +-- renders to CSV). +-- +-- Internally applies @'ET.finalStockTransfer'@ -- the only netting on the +-- /algebra/ this function does -- which closes every 'Cost'\/'Revenue' +-- account into 'RetainedEarnings' via @('.-')@\/@bar@. The closed algebra is +-- then partitioned by 'whichSide'\/'whatDiv' into assets (debit side) and +-- liability\/equity (credit side, further split by division); +-- 'decL'\/'decR'\/'EA.filter' only select entries, they do not aggregate them. +-- +-- __Contra accounts (Definition 7 amendment, Land 3).__ Contra assets +-- (@whatDiv == Assets && isContra@, e.g. 貸倒引当金\/減価償却累計額) sit on +-- the credit side, so a plain side partition would either drop them from the +-- statement or file them under Liability. They are instead collected into the +-- presentation groups of "ExchangeAlgebra.Reporting.Group" and shown as a +-- real deduction — @gross lines → deduction lines → net line@ — inside the +-- Asset column, replacing Land 2's temporary placement in the Liability +-- column. A +-- group is formed only when one of its contra accounts actually carries gross +-- activity, so a chart that contains no contra posting keeps its ordinary +-- rows. Deduction +-- and negative-net cells carry a leading @-@; values themselves stay in +-- \(\mathbb{R}_0^+\). +-- +-- Column totals use the ordinary cells plus each outermost group's net, so +-- nested subtotal rows are not counted twice. __Known limitation:__ an +-- ungrouped non-contra asset whose net balance is +-- on the credit side (an abnormal balance) is still not displayed, and is now +-- excluded from the totals as well; the side-versus-division placement of +-- abnormal balances is a separate pre-existing issue, not part of the contra +-- amendment. +-- Presentation groups are financial-statement aggregates keyed by account +-- title. With a multi-axis base, grouped titles therefore aggregate across +-- the remaining axes; ungrouped titles retain the legacy per-entry layout. +-- +-- Layout: +-- +-- > Asset | | Total +-- > | | +-- > Liability | | Equity | | Total +-- > | | | | +-- +-- ==== __Examples__ +-- +-- Cash 100 (asset), a loan 60 (liability), capital 40 (equity); no +-- cost\/revenue accounts, so @'ET.finalStockTransfer'@ is a no-op, and no +-- contra account is present, so no presentation group is formed: +-- +-- >>> type T = Alg Double (HatBase AccountTitles) +-- >>> let alg = (100 .@ Not:>> mapM_ print (bsRows alg) +-- ["Asset","","Liability",""] +-- ["Cash","100.0","LoansPayable","60.0"] +-- ["Total","100.0","Equity",""] +-- ["","","CapitalStock","40.0"] +-- ["","","Total","100.0"] +-- +-- Receivables 1000 with an allowance of 100 against them, and capital 900. +-- The allowance is deducted from the receivables and the asset total is the +-- net 900, not the gross 1000: +-- +-- >>> let contra = (1000 .@ Not:>> mapM_ print (bsRows contra) +-- ["Asset","","Liability",""] +-- ["AccountsReceivable","1000.0","Equity",""] +-- ["AllowanceForDoubtfulAccounts","-100.0","CapitalStock","900.0"] +-- ["TradeReceivablesNet","900.0","Total","900.0"] +-- ["Total","900.0","",""] +-- -- Complexity: O(s) (s = total number of scalar entries) -writeBS :: (HatVal n, HatBaseClass b, ExBaseClass b) => FilePath -> Alg n b -> IO () -writeBS path alg = writeCSV path result +bsRows :: (HatVal n, HatBaseClass b, ExBaseClass b) => Alg n b -> [[T.Text]] +bsRows alg = result where transferred = ET.finalStockTransfer alg - debitSide = decR transferred - creditSide = decL transferred - assets = creditSide - liability = EA.filter (\x -> whatDiv (_hatBase x) == Liability) debitSide - equity = EA.filter (\x -> whatDiv (_hatBase x) == Equity) debitSide - debitTotal = tshow (EA.norm debitSide) - creditTotal = tshow (EA.norm creditSide) + grouping = RG.groupingForDivisions [Assets, Liability, Equity] + RG.defaultPresentationGrouping + grouped = RG.presentGroups grouping (accountGrossTotals transferred) + consumed = RG.gpConsumed grouped + ungrouped = EA.filter + (\x -> not (Set.member (getAccountTitle (_hatBase x)) consumed)) transferred + creditSide = decR ungrouped + debitSide = decL ungrouped + assets = debitSide + liability = EA.filter (\x -> whatDiv (_hatBase x) == Liability) creditSide + equity = EA.filter (\x -> whatDiv (_hatBase x) == Equity) creditSide + blocksIn divisions = + [block | block@(def, _) <- RG.gpBlocks grouped + , RG.pgDivision def `elem` divisions] + rootOf division = OMap.findWithDefault (zeroValue, zeroValue) division + (RG.gpRootTotals grouped) + -- Totals are the sum of the displayed cells: the ungrouped entries of the + -- column plus each group's net (counted once, at its outermost block). + assetGross = RG.addGross (EA.norm assets, zeroValue) (rootOf Assets) + creditGross = RG.addGross + (zeroValue, EA.norm liability + EA.norm equity) + (RG.addGross (rootOf Liability) (rootOf Equity)) + assetTotal = renderRelative (RG.relativeTo Debit assetGross) + creditTotal = renderRelative (RG.relativeTo Credit creditGross) + (assetGroupText, assetGroupValue) = + unzip (groupCells grouping (blocksIn [Assets])) + (liabilityGroupText, liabilityGroupValue) = + unzip (groupCells grouping (blocksIn [Liability])) + (equityGroupText, equityGroupValue) = + unzip (groupCells grouping (blocksIn [Equity])) assetsText = L.map (tshow . getAccountTitle . _hatBase) (EA.toList assets) - assetsValue = L.map (tshow . _val) (EA.toList assets) + ++ assetGroupText + assetsValue = L.map (tshow . _val) (EA.toList assets) ++ assetGroupValue liabilityText = L.map (tshow . getAccountTitle . _hatBase) (EA.toList liability) - liabilityValue = L.map (tshow . _val) (EA.toList liability) + ++ liabilityGroupText + liabilityValue = L.map (tshow . _val) (EA.toList liability) ++ liabilityGroupValue equityText = L.map (tshow . getAccountTitle . _hatBase) (EA.toList equity) - equityValue = L.map (tshow . _val) (EA.toList equity) + ++ equityGroupText + equityValue = L.map (tshow . _val) (EA.toList equity) ++ equityGroupValue result = csvTranspose [ [T.pack "Asset"] ++ assetsText ++ [T.pack "Total"] - , [T.empty] ++ assetsValue ++ [creditTotal] + , [T.empty] ++ assetsValue ++ [assetTotal] , [T.pack "Liability"] ++ liabilityText ++ [T.pack "Equity"] ++ equityText ++ [T.pack "Total"] - , [T.empty] ++ liabilityValue ++ [T.empty] ++ equityValue ++ [debitTotal] + , [T.empty] ++ liabilityValue ++ [T.empty] ++ equityValue ++ [creditTotal] ] --- | Output a Profit and Loss Statement in CSV format. --- Decomposes into costs and revenues for output. +-- | Output a Balance Sheet in CSV format. Pure layout is delegated to +-- 'bsRows'; this function only writes the file. See 'bsRows' for the +-- @'ET.finalStockTransfer'@ closing semantics and the column layout. -- +-- Complexity: O(s) (s = total number of scalar entries; see 'bsRows') +writeBS :: (HatVal n, HatBaseClass b, ExBaseClass b) => FilePath -> Alg n b -> IO () +writeBS path alg = writeCSV path (bsRows alg) + +-- | Build the rows of a Profit and Loss Statement, as a pure value (the part +-- 'writePL' renders to CSV). +-- +-- No closing is applied here (contrast 'bsRows', which applies +-- @'ET.finalStockTransfer'@) -- this decomposes the algebra /as given/ into +-- cost and revenue entries by 'whichSide'\/'whatDiv' ('decL'\/'decR'\/'EA.filter' +-- only select, they do not aggregate). +-- +-- __Contra accounts (Definition 7 amendment, Land 3).__ A contra revenue +-- (売上割戻) sits on the debit side and a contra cost (仕入割戻, 還付法人税等) +-- on the credit side, so the side partition above would drop all three from +-- the statement entirely. They are instead collected into the presentation +-- groups of "ExchangeAlgebra.Reporting.Group" and shown as a real deduction +-- (@gross lines → deduction lines → net line@) inside their own column, on +-- the same terms as 'bsRows'. A group is formed only when one of its contra +-- accounts carries gross activity, so a statement containing no contra +-- posting keeps its ordinary rows. The column totals keep their historical cross-placement +-- (the Cost column's total cell states the revenue total and vice versa), but +-- are now the sum of the cells displayed in the other column. +-- +-- Layout: +-- +-- > Cost | | Total +-- > | | +-- > Revenue | | Total +-- > | | +-- +-- ==== __Examples__ +-- +-- A single sale of 500 (revenue) against its cost of 300; no contra account, +-- so no presentation group is formed: +-- +-- >>> type T = Alg Double (HatBase AccountTitles) +-- >>> let alg = (500 .@ Not:>> mapM_ print (plRows alg) +-- ["Cost","","Revenue",""] +-- ["SalesCost","300.0","Sales","500.0"] +-- ["Total","500.0","Total","300.0"] +-- +-- The same sale with a rebate of 50 granted on it. Gross sales stay visible, +-- the rebate is deducted, and net sales carry into the total: +-- +-- >>> let rebated = alg .+ (50 .@ Not:>> mapM_ print (plRows rebated) +-- ["Cost","","Revenue",""] +-- ["SalesCost","300.0","Sales","500.0"] +-- ["","","SalesRebates","-50.0"] +-- ["","","NetSales","450.0"] +-- ["Total","450.0","Total","300.0"] +-- -- Complexity: O(s) (s = total number of scalar entries) -writePL :: (HatVal n, HatBaseClass b, ExBaseClass b) => FilePath -> Alg n b -> IO () -writePL path alg = writeCSV path result +plRows :: (HatVal n, HatBaseClass b, ExBaseClass b) => Alg n b -> [[T.Text]] +plRows alg = result where - debitSide = decR alg - creditSide = decL alg - cost = EA.filter (\x -> whatDiv (_hatBase x) == Cost) creditSide - revenue = EA.filter (\x -> whatDiv (_hatBase x) == Revenue) debitSide - debitTotal = tshow (EA.norm cost) - creditTotal = tshow (EA.norm revenue) + grouping = RG.groupingForDivisions [Cost, Revenue] RG.defaultPresentationGrouping + grouped = RG.presentGroups grouping (accountGrossTotals alg) + consumed = RG.gpConsumed grouped + ungrouped = EA.filter + (\x -> not (Set.member (getAccountTitle (_hatBase x)) consumed)) alg + creditSide = decR ungrouped + debitSide = decL ungrouped + cost = EA.filter (\x -> whatDiv (_hatBase x) == Cost) debitSide + revenue = EA.filter (\x -> whatDiv (_hatBase x) == Revenue) creditSide + blocksIn division = + [block | block@(def, _) <- RG.gpBlocks grouped + , RG.pgDivision def == division] + rootOf division = OMap.findWithDefault (zeroValue, zeroValue) division + (RG.gpRootTotals grouped) + costGross = RG.addGross (EA.norm cost, zeroValue) (rootOf Cost) + revenueGross = RG.addGross (zeroValue, EA.norm revenue) (rootOf Revenue) + -- Historical cross-placement preserved: the Cost column's total cell + -- states the revenue total, and the Revenue column's the cost total. + debitTotal = renderRelative (RG.relativeTo Debit costGross) + creditTotal = renderRelative (RG.relativeTo Credit revenueGross) + (costGroupText, costGroupValue) = unzip (groupCells grouping (blocksIn Cost)) + (revenueGroupText, revenueGroupValue) = + unzip (groupCells grouping (blocksIn Revenue)) costText = L.map (tshow . getAccountTitle . _hatBase) (EA.toList cost) - costValue = L.map (tshow . _val) (EA.toList cost) + ++ costGroupText + costValue = L.map (tshow . _val) (EA.toList cost) ++ costGroupValue revenueText = L.map (tshow . getAccountTitle . _hatBase) (EA.toList revenue) - revenueValue = L.map (tshow . _val) (EA.toList revenue) + ++ revenueGroupText + revenueValue = L.map (tshow . _val) (EA.toList revenue) ++ revenueGroupValue (ct, rt) = toSameLength costText revenueText (cv, rv) = toSameLength costValue revenueValue result = csvTranspose @@ -136,6 +355,13 @@ , [T.empty] ++ rv ++ [debitTotal] ] +-- | Output a Profit and Loss Statement in CSV format. Pure layout is +-- delegated to 'plRows'; this function only writes the file. +-- +-- Complexity: O(s) (s = total number of scalar entries; see 'plRows') +writePL :: (HatVal n, HatBaseClass b, ExBaseClass b) => FilePath -> Alg n b -> IO () +writePL path alg = writeCSV path (plRows alg) + -- | Pad two lists to the same length. Appends empty text to the shorter list. -- -- Complexity: O(max(|xs|, |ys|)) @@ -149,85 +375,339 @@ lx = Prelude.length xs ly = Prelude.length ys +-- | Build the rows of a journal (仕訳帳), as a pure value (the part +-- 'writeJournal' renders to CSV). +-- +-- Entries are grouped by date (via @f@) into a deterministic, deduplicated, +-- ascending day sequence; within a day the debit and credit postings are +-- listed by 'decL'\/'decR' and padded to equal length with 'toSameLength' -- +-- no aggregation\/@bar@ is applied, so a day with more debit than credit +-- postings (or vice versa) simply gets blank cells on the shorter side. +-- +-- ==== __Examples__ +-- +-- Three days: a capital contribution, a cash sale, and a day with two debit +-- postings against one credit posting (the debit column is one line longer, +-- and the credit/date cells of that extra line are padded blank): +-- +-- >>> import Data.Time (fromGregorian) +-- >>> type T = Alg Double (HatBase (AccountTitles, Day)) +-- >>> let d1 = fromGregorian 2024 4 1 +-- >>> let d2 = fromGregorian 2024 4 2 +-- >>> let d3 = fromGregorian 2024 4 3 +-- >>> let getDay (_ :< (_, d)) = d +-- >>> let alg = (100 .@ Not:<(Cash,d1)) .+ (100 .@ Not:<(CapitalStock,d1)) .+ (50 .@ Not:<(Cash,d2)) .+ (50 .@ Not:<(Sales,d2)) .+ (30 .@ Not:<(Cash,d3)) .+ (10 .@ Not:<(AccountsReceivable,d3)) .+ (40 .@ Not:<(Sales,d3)) :: T +-- >>> mapM_ print (journalRows alg getDay) +-- ["Day","Debit","Amount","Credit","Amount"] +-- ["2024-04-01","Cash","100.0","CapitalStock","100.0"] +-- ["2024-04-02","Cash","50.0","Sales","50.0"] +-- ["2024-04-03","AccountsReceivable","10.0","Sales","40.0"] +-- ["","Cash","30.0","",""] +-- +-- Complexity: O(s * log d) (s = number of entries, d = number of distinct dates) +journalRows :: (HatVal n, HatBaseClass b, ExBaseClass b) + => Alg n b + -> (b -> Day) + -> [[T.Text]] +journalRows alg f = csvTranspose [ds, dt, dv, ct, cv] + where + days = L.sort $ Set.toList . Set.fromList $ L.map (f . _hatBase) $ EA.toList alg + rows = L.map perDay days + perDay d = + let da = EA.filter (\y -> (f . _hatBase) y == d) alg + dl = decL da + dr = decR da + dlTexts = L.map (tshow . getAccountTitle . _hatBase) (EA.toList dl) + drTexts = L.map (tshow . getAccountTitle . _hatBase) (EA.toList dr) + dlValues = L.map (tshow . _val) (EA.toList dl) + drValues = L.map (tshow . _val) (EA.toList dr) + (dt', ct') = toSameLength dlTexts drTexts + (dv', cv') = toSameLength dlValues drValues + (ds', _) = toSameLength [tshow d] cv' + in (ds', dt', dv', ct', cv') + ds = [T.pack "Day"] ++ concatMap (\(a,_,_,_,_) -> a) rows + dt = [T.pack "Debit"] ++ concatMap (\(_,a,_,_,_) -> a) rows + dv = [T.pack "Amount"] ++ concatMap (\(_,_,a,_,_) -> a) rows + ct = [T.pack "Credit"] ++ concatMap (\(_,_,_,a,_) -> a) rows + cv = [T.pack "Amount"] ++ concatMap (\(_,_,_,_,a) -> a) rows + -- | Output journal entries in CSV format. -- Groups by date and records the debit/credit account titles and amounts for each day. +-- Pure layout is delegated to 'journalRows'; this function only writes the file. -- --- Complexity: O(s * log d) (s = number of entries, d = number of distinct dates) +-- Complexity: O(s * log d) (s = number of entries, d = number of distinct dates; see 'journalRows') writeJournal :: (HatVal n, HatBaseClass b, ExBaseClass b) => FilePath -> Alg n b -> (b -> Day) -> IO () -writeJournal path alg f = do - let days = L.sort $ Set.toList . Set.fromList $ L.map (f . _hatBase) $ EA.toList alg - rows <- forM days $ \d -> do - let da = EA.filter (\y -> (f . _hatBase) y == d) alg - let dl = decL da - let dr = decR da - let dlTexts = L.map (tshow . getAccountTitle . _hatBase) (EA.toList dl) - let drTexts = L.map (tshow . getAccountTitle . _hatBase) (EA.toList dr) - let dlValues = L.map (tshow . _val) (EA.toList dl) - let drValues = L.map (tshow . _val) (EA.toList dr) - let (dt', ct') = toSameLength dlTexts drTexts - let (dv', cv') = toSameLength dlValues drValues - let (ds', _) = toSameLength [tshow d] cv' - pure (ds', dt', dv', ct', cv') - let ds = [T.pack "Day"] ++ concatMap (\(a,_,_,_,_) -> a) rows - let dt = [T.pack "Debit"] ++ concatMap (\(_,a,_,_,_) -> a) rows - let dv = [T.pack "Amount"] ++ concatMap (\(_,_,a,_,_) -> a) rows - let ct = [T.pack "Credit"] ++ concatMap (\(_,_,_,a,_) -> a) rows - let cv = [T.pack "Amount"] ++ concatMap (\(_,_,_,_,a) -> a) rows - writeCSV path (csvTranspose [ds, dt, dv, ct, cv]) +writeJournal path alg f = writeCSV path (journalRows alg f) --- | Output account ledgers in CSV format. +-- | Build the rows of a general ledger (総勘定元帳 / T-account) for the given +-- account titles, as a pure value (the part 'writeAccountOf' renders to CSV). -- --- __Note__: Not yet implemented. Calling this will raise an exception. +-- The ledger is the audit-trail view of an algebra: for each requested account +-- title, every posting touching that title is listed __individually in date +-- order, with no aggregation__ — the redundant sequence (seq) of the algebra is +-- preserved verbatim. (Contrast with 'writeCompoundTrialBalance', which is the +-- aggregated, @bar@\/@norm@-netted view.) This is the showcase of the algebra's +-- redundancy: each historical posting is kept as a separate ledger line. +-- +-- For each title the layout is a two-sided T-account: +-- +-- > +-- > Date | Debit | Date | Credit +-- +-- Debit-side postings (@'whichSide' == 'Debit'@) go on the left, credit-side +-- postings on the right; the two columns are padded to equal length. Within a +-- side, postings are sorted by date and otherwise keep their original order +-- (so the line count equals the number of postings — no netting). +-- +-- ==== __Examples__ +-- +-- Two separate debit postings to Cash are kept as two ledger lines (the seq is +-- /not/ aggregated into a single 30; the count of postings is preserved): +-- +-- >>> import Data.Time (fromGregorian) +-- >>> type T = Alg Double (HatBase AccountTitles) +-- >>> let led = (10 .@ Not:<Cash) .+ (20 .@ Not:<Cash) .+ (5 .@ Hat:<Cash) :: T +-- >>> let d = fromGregorian 2024 4 1 +-- >>> mapM_ print (accountLedgerRows [Cash] led (const d)) +-- ["Cash","","",""] +-- ["Date","Debit","Date","Credit"] +-- ["2024-04-01","20.0","2024-04-01","5.0"] +-- ["2024-04-01","10.0","",""] +-- +-- Complexity: O(t * s) (t = number of titles, s = number of entries). +accountLedgerRows :: (HatVal n, HatBaseClass b, ExBaseClass b) + => [AccountTitles] + -> Alg n b + -> (b -> Day) + -> [[T.Text]] +accountLedgerRows titles alg f = + concatMap titleBlock titles + where + titleBlock t = + let xs = projByAccountTitle t alg + debits = sortByDay (EA.toList (decL xs)) + credits = sortByDay (EA.toList (decR xs)) + dDates = L.map (tshow . f . _hatBase) debits + dVals = L.map (tshow . _val) debits + cDates = L.map (tshow . f . _hatBase) credits + cVals = L.map (tshow . _val) credits + (dDates', cDates') = toSameLength dDates cDates + (dVals', cVals') = toSameLength dVals cVals + header = [tshow t, T.empty, T.empty, T.empty] + sub = [T.pack "Date", T.pack "Debit", T.pack "Date", T.pack "Credit"] + body = L.zipWith4 (\a b c d -> [a,b,c,d]) dDates' dVals' cDates' cVals' + in header : sub : body + sortByDay = L.sortBy (\x y -> compare ((f . _hatBase) x) ((f . _hatBase) y)) + +-- | Output general ledgers (総勘定元帳) for the given account titles in CSV +-- format. Pure layout is delegated to 'accountLedgerRows'; this function only +-- performs the file write. +-- +-- Each requested title is rendered as a two-sided T-account whose postings are +-- listed __individually, without aggregation__ (the seq redundancy is the audit +-- trail — see 'accountLedgerRows'). +-- +-- Complexity: O(t * s) (t = number of titles, s = number of entries). writeAccountOf :: (HatVal n, HatBaseClass b, ExBaseClass b) => [AccountTitles] -> FilePath -> Alg n b -> (b -> Day) -> IO () -writeAccountOf _ _ _ _ = undefined +writeAccountOf titles path alg f = writeCSV path (accountLedgerRows titles alg f) +-- | Build the rows of general ledgers (総勘定元帳) from a 'EJ.Journal', as a +-- pure value (the part 'writeAccountOfJournal' renders to CSV), carrying the +-- per-posting note (摘要) as an extra column. +-- +-- As with 'accountLedgerRows', postings are listed __individually, without +-- aggregation__ — the redundant sequence is the audit trail. Because each +-- posting carries its own note, this version uses a flat detail layout rather +-- than the two-sided T-account: +-- +-- > <Title> +-- > Note | Debit | Credit +-- > <note> | <amount> | -- debit-side posting +-- > <note> | | <amount> -- credit-side posting +-- +-- The note is rendered with 'show'. Postings are emitted in note order +-- (the 'EJ.Journal' is keyed by note); within a note the algebra's own seq +-- order is preserved. No 'EA.bar' \/ aggregation is applied. +-- +-- ==== __Examples__ +-- +-- Two Cash postings under different notes; note order ("pay" < "sale") +-- determines the row order, not posting order: +-- +-- >>> let jrn = ((100 .@ Not:<Cash) .| "sale") .+ ((40 .@ Hat:<Cash) .| "pay") :: EJ.Journal String Double (HatBase AccountTitles) +-- >>> mapM_ print (accountLedgerRowsJournal [Cash] jrn) +-- ["Cash","",""] +-- ["Note","Debit","Credit"] +-- ["\"pay\"","","40.0"] +-- ["\"sale\"","100.0",""] +-- +-- Complexity: O(t * s) (t = number of titles, s = number of postings). +accountLedgerRowsJournal :: (HatVal n, HatBaseClass b, ExBaseClass b, EJ.Note note) + => [AccountTitles] + -> EJ.Journal note n b + -> [[T.Text]] +accountLedgerRowsJournal titles j = + concatMap titleBlock titles + where + pairs = L.sortBy (\(a,_) (b,_) -> compare a b) (Map.toList (EJ.toMap j)) + titleBlock t = + let header = [tshow t, T.empty, T.empty] + sub = [T.pack "Note", T.pack "Debit", T.pack "Credit"] + body = concatMap (noteRows t) pairs + in header : sub : body + noteRows t (note, alg) = + let xs = projByAccountTitle t alg + mkRow x = + let amt = tshow (_val x) + in if (whichSide . _hatBase) x == Debit + then [tshow note, amt, T.empty] + else [tshow note, T.empty, amt] + in L.map mkRow (EA.toList (EA.filter (\x -> x /= EA.Zero) xs)) --- | Output a Compound Trial Balance in CSV format. --- Calculates the debit total, credit total, and balance for each account title and outputs as a table. +-- | Output general ledgers (総勘定元帳) from a 'EJ.Journal' in CSV format, +-- carrying the per-posting note (摘要) as an extra column. Pure layout is +-- delegated to 'accountLedgerRowsJournal'; this function only writes the +-- file. See 'accountLedgerRowsJournal' for the flat note-detail layout. -- --- Complexity: O(s * a) (s = number of entries, a = number of distinct account titles) -writeCompoundTrialBalance :: (HatVal n, HatBaseClass b, ExBaseClass b) - => FilePath - -> Alg n b - -> IO () -writeCompoundTrialBalance path alg = do - let header = [T.pack "Debit Balance" - ,T.pack "Debit Total" - ,T.pack "Account Title" - ,T.pack "Credit Total" - ,T.pack "Credit Balance"] - let accounts = L.sort - $ Set.toList . Set.fromList - $ L.map (getAccountTitle . _hatBase) - $ EA.toList alg - let (lines', debitBalanceTotal, debitTotal, creditBalanceTotal, creditTotal) = - L.foldl' step ([], zeroValue, zeroValue, zeroValue, zeroValue) accounts - let totalLine = [ tshow debitBalanceTotal - , tshow creditTotal - , T.pack "Total" - , tshow debitTotal - , tshow creditBalanceTotal - ] - writeCSV path (header : lines' ++ [totalLine]) +-- Complexity: O(t * s) (t = number of titles, s = number of postings; see +-- 'accountLedgerRowsJournal'). +writeAccountOfJournal :: (HatVal n, HatBaseClass b, ExBaseClass b, EJ.Note note) + => [AccountTitles] + -> FilePath + -> EJ.Journal note n b + -> IO () +writeAccountOfJournal titles path j = + writeCSV path (accountLedgerRowsJournal titles j) + + +------------------------------------------------------------------ +-- Trial-balance aggregation (non-negative single-pass) +------------------------------------------------------------------ + +-- | Per-account gross debit/credit totals, accumulated in a __single pass__ over +-- the algebra's scalar entries (O(s)), keyed by 'AccountTitles' in 'Ord' order. +-- +-- Each entry contributes its (non-negative) value to either the debit or the +-- credit total of its account title, classified by 'whichSide' (which already +-- folds in the Hat\/Not reversal) — exactly the @Debit@\/@Credit@ partition that +-- 'decL'\/'decR' produce. Summing per side reproduces @'norm' . 'decL'@ (debit +-- gross) and @'norm' . 'decR'@ (credit gross) without any signed netting, so the +-- value-domain invariant ($\\mathbb{R}_0^+$) is preserved: only non-negative +-- magnitudes are stored. +-- +-- 'foldEntries' already skips zero values, matching the @x /= 'Zero'@ guard in +-- 'decL'\/'decR'. The resulting 'OMap.Map' iterates titles in ascending order, +-- matching the previous @L.sort . Set.toList . Set.fromList@ title enumeration. +-- +-- Complexity: O(s) (s = number of scalar entries). +accountGrossTotals :: (HatVal n, HatBaseClass b, ExBaseClass b) + => Alg n b -> OMap.Map AccountTitles (n, n) +accountGrossTotals = EA.foldEntries step OMap.empty where - step (accLines, dbt, dt, cbt, ct) a = - let xs = projByAccountTitle a alg - xr = norm (decR xs) - xl = norm (decL xs) - (dc, diff) = diffRL xs + -- (debit gross, credit gross) + step acc v b = + let !t = getAccountTitle b + !pair = case whichSide b of + Debit -> (v, zeroValue) + Credit -> (zeroValue, v) + Side -> (zeroValue, zeroValue) + in OMap.insertWith addPair t pair acc + addPair (d1, c1) (d2, c2) = (d1 + d2, c1 + c2) + +-- | Net a @(debit gross, credit gross)@ pair into a @(Side, magnitude)@ balance, +-- reproducing 'diffRL' exactly. 'diffRL' compares @r = 'norm' . 'decR'@ (credit) +-- against @l = 'norm' . 'decL'@ (debit) with the scale-aware tolerance, so the +-- same comparison is applied here: near-equal sides report @(v'Side', 0)@, +-- otherwise the larger side wins with the non-negative difference. +-- +-- Complexity: O(1). +netGross :: (HatVal n) => (n, n) -> (Side, n) +netGross (l, r) -- l = debit gross, r = credit gross + | nearlyEqScaled r l = (Side, zeroValue) + | r > l = (Credit, r - l) + | otherwise = (Debit, l - r) + +-- | Build the rows of a Compound Trial Balance (合計残高試算表), as a pure +-- value (the part 'writeCompoundTrialBalance' renders to CSV). Calculates the +-- debit total, credit total, and balance for each account title, aggregated +-- via the single-pass @accountGrossTotals@\/@netGross@ (the same +-- @diffRL@-equivalent netting as 'balanceOf'; no implicit @bar@). Layout: +-- +-- > Debit Balance | Debit Total | Account Title | Credit Total | Credit Balance +-- +-- __Legacy column-placement quirk (preserved verbatim):__ unlike +-- 'worksheetRows'\/'postClosingTrialBalanceRows' (which route a @(side,mag)@ +-- balance through @sideCells@, putting a Debit balance in the Debit cell and +-- a Credit balance in the Credit cell), this layout places the balance +-- figure in the column pair /opposite/ the netted side: a debit-heavy +-- account's balance lands in the __Credit Balance__ (rightmost) column, and a +-- credit-heavy account's balance lands in the __Debit Balance__ (leftmost) +-- column — see the example below. Reusing @sideCells@ here would require +-- flipping 'Debit'\/'Credit' first, which is no clearer than the explicit +-- case analysis in @step@ below, so this was kept as-is rather than +-- consolidated (design-review C7) to guarantee output is unchanged. +-- +-- ==== __Examples__ +-- +-- Cash is debit-heavy (gross debit 100, credit 0); CapitalStock and +-- LoansPayable are credit-heavy. Note where each balance figure lands: +-- +-- >>> type T = Alg Double (HatBase AccountTitles) +-- >>> let alg = (100 .@ Not:<Cash) .+ (60 .@ Not:<LoansPayable) .+ (40 .@ Not:<CapitalStock) :: T +-- >>> mapM_ print (compoundTrialBalanceRows alg) +-- ["Debit Balance","Debit Total","Account Title","Credit Total","Credit Balance"] +-- ["","100.0","Cash","0.0","100.0"] +-- ["40.0","0.0","CapitalStock","40.0",""] +-- ["60.0","0.0","LoansPayable","60.0",""] +-- ["100.0","100.0","Total","100.0","100.0"] +-- +-- Complexity: O(s) (single pass over s scalar entries; see @accountGrossTotals@) +compoundTrialBalanceRows :: (HatVal n, HatBaseClass b, ExBaseClass b) + => Alg n b -> [[T.Text]] +compoundTrialBalanceRows alg = + header : lines' ++ [totalLine] + where + header = [T.pack "Debit Balance" + ,T.pack "Debit Total" + ,T.pack "Account Title" + ,T.pack "Credit Total" + ,T.pack "Credit Balance"] + -- Single pass (O(s)): gross debit/credit totals per title, in Ord order. + accounts = OMap.toList (accountGrossTotals alg) + (lines', debitBalanceTotal, debitTotal, creditBalanceTotal, creditTotal) = + L.foldl' step ([], zeroValue, zeroValue, zeroValue, zeroValue) accounts + totalLine = [ tshow debitBalanceTotal + , tshow creditTotal + , T.pack "Total" + , tshow debitTotal + , tshow creditBalanceTotal + ] + step (accLines, dbt, dt, cbt, ct) (a, gross) = + let xl = fst gross -- norm (decL xs) : debit gross + xr = snd gross -- norm (decR xs) : credit gross + (dc, diff) = netGross gross + -- 'netGross'/'diffRL' returns the wildcard v'Side' with a zero + -- difference when an account nets to zero (e.g. a fully-cleared + -- suspense account). Treat that as no balance on either side + -- (cf. 'sideCells'). (dbt', cbt') = case dc of Credit -> (dbt + diff, cbt) Debit -> (dbt, cbt + diff) + Side -> (dbt, cbt) + -- See the Haddock above: the Credit case places 'diff' in the + -- *Debit Balance* column (position 0) and the Debit case places + -- it in the *Credit Balance* column (position 4) -- opposite of + -- 'sideCells' -- a legacy layout kept verbatim. line = case dc of Credit -> [ tshow diff , tshow xl @@ -241,10 +721,290 @@ , tshow xr , tshow diff ] + Side -> [ T.empty + , tshow xl + , tshow a + , tshow xr + , T.empty + ] in (accLines ++ [line], dbt', dt + xr, cbt', ct + xl) +-- | Output a Compound Trial Balance in CSV format. +-- Calculates the debit total, credit total, and balance for each account +-- title and outputs as a table. Pure layout is delegated to +-- 'compoundTrialBalanceRows'; this function only writes the file. See +-- 'compoundTrialBalanceRows' for the column layout (including the legacy +-- Debit\/Credit Balance placement quirk). +-- +-- Complexity: O(s) (single pass over s scalar entries; see +-- 'compoundTrialBalanceRows') +writeCompoundTrialBalance :: (HatVal n, HatBaseClass b, ExBaseClass b) + => FilePath + -> Alg n b + -> IO () +writeCompoundTrialBalance path alg = + writeCSV path (compoundTrialBalanceRows alg) + ------------------------------------------------------------------ +-- Closing documents (決算書類): worksheet & post-closing trial balance +------------------------------------------------------------------ + +-- | Per-account net balance: @('diffRL' . 'projByAccountTitle' title)@ on a +-- single-title restriction returns @(side, magnitude)@ where @side@ is the +-- balance side (Debit or Credit) after netting and @magnitude@ is the +-- (non-negative) amount. This is the explicit aggregation used by both the +-- worksheet trial-balance column and the post-closing trial balance (the +-- analogous netting that 'writeCompoundTrialBalance' performs). +balanceOf :: (HatVal n, HatBaseClass b, ExBaseClass b) + => AccountTitles -> Alg n b -> (Side, n) +balanceOf t = diffRL . projByAccountTitle t + +-- | Place a @(side, magnitude)@ balance into a (debit, credit) text column pair. +-- A zero magnitude produces two empty cells. +sideCells :: (HatVal n) => (Side, n) -> (T.Text, T.Text) +sideCells (side, mag) + | mag == zeroValue = (T.empty, T.empty) + -- 'diffRL' returns the wildcard v'Side' only when the net magnitude is zero, + -- which the guard above has already handled; a non-zero balance is always + -- 'Debit' or 'Credit'. The non-exhaustive @case@ is by design (audited). + | otherwise = case side of + Debit -> (tshow mag, T.empty) + Credit -> (T.empty, tshow mag) + +-- | Build the rows of an 8-column worksheet (8 桁精算表), as a pure value +-- (the part 'writeWorksheet' renders to CSV). +-- +-- Columns (matching the lecture's 精算表): per account title there are four +-- debit\/credit column pairs — +-- +-- > Account Title +-- > | Trial Balance (Debit, Credit) -- 残高試算表 +-- > | Adjustments (Debit, Credit) -- 整理記入 +-- > | Profit & Loss (Debit, Credit) -- 損益計算書 +-- > | Balance Sheet (Debit, Credit) -- 貸借対照表 +-- +-- For each account title: +-- +-- * the __Trial Balance__ pair is the net balance of the +-- /pre-adjustment ledger/ (@'balanceOf' title pre@ — an explicit +-- @diffRL@ netting, no implicit @bar@); +-- * the __Adjustments__ pair is the net balance of the /adjustment entries/ +-- (@'balanceOf' title adj@); +-- * the __final balance__ is the net balance of @pre '.+' adj@, routed by +-- 'whatDiv': 'Cost'\/'Revenue' titles go to the __Profit & Loss__ columns, +-- 'Assets'\/'Liability'\/'Equity' titles go to the __Balance Sheet__ +-- columns. +-- +-- The penultimate row is the column totals of the trial-balance, P\/L and B\/S +-- column pairs. The final row is the profit\/loss balancing figure +-- (当期純利益\/純損失): it is the amount that makes each of the P\/L and B\/S +-- column pairs balance. By construction (the homomorphism @norm@) the P\/L +-- imbalance equals the B\/S imbalance — that equality is the worksheet's own +-- self-check (精算表の貸借差額の一致). __This function does not enforce the +-- equality__; if the inputs are inconsistent it still emits both figures so the +-- discrepancy is visible (rather than raising an error). +-- +-- Account titles are listed in 'Ord' order so the output is deterministic. +-- +-- ==== __Examples__ +-- +-- Opening capital 100 + a cash sale of 50, with no adjustments. Cash (150) and +-- CapitalStock (100) go to the Balance Sheet; Sales (50) goes to Profit & Loss. +-- The net income of 50 appears on the P\/L debit and B\/S credit, making both +-- statement column pairs balance at 50 and 150 respectively: +-- +-- >>> type T = Alg Double (HatBase AccountTitles) +-- >>> let pre = (150 .@ Not:<Cash) .+ (100 .@ Not:<CapitalStock) .+ (50 .@ Not:<Sales) :: T +-- >>> mapM_ print (worksheetRows pre (zeroValue .@ Not:<Cash)) +-- ["Account Title","Trial Balance","","Adjustments","","Profit & Loss","","Balance Sheet",""] +-- ["","Debit","Credit","Debit","Credit","Debit","Credit","Debit","Credit"] +-- ["Cash","150.0","","","","","","150.0",""] +-- ["CapitalStock","","100.0","","","","","","100.0"] +-- ["Sales","","50.0","","","","50.0","",""] +-- ["Subtotal","150.0","150.0","","","0.0","50.0","150.0","100.0"] +-- ["Net Income","","","","","50.0","","","50.0"] +-- ["Total","","","","","50.0","50.0","150.0","150.0"] +-- +-- Complexity: O(s) (single pass per algebra over s scalar entries; +-- see @accountGrossTotals@). +worksheetRows :: (HatVal n, HatBaseClass b, ExBaseClass b) + => Alg n b -- ^ pre-adjustment ledger (決算整理前残高) + -> Alg n b -- ^ adjustment entries (決算整理仕訳) + -> [[T.Text]] +worksheetRows pre adj = + header : sub : bodyRows ++ [tbTotalRow, netRow, grandTotalRow] + where + header = + [ T.pack "Account Title" + , T.pack "Trial Balance", T.empty + , T.pack "Adjustments", T.empty + , T.pack "Profit & Loss", T.empty + , T.pack "Balance Sheet", T.empty ] + sub = + [ T.empty + , T.pack "Debit", T.pack "Credit" + , T.pack "Debit", T.pack "Credit" + , T.pack "Debit", T.pack "Credit" + , T.pack "Debit", T.pack "Credit" ] + combined = pre .+ adj + -- Single pass per algebra (O(s)): gross debit/credit totals per title. + -- 'balanceOf t alg' = 'diffRL (projByAccountTitle t alg)' is reproduced as + -- 'netGross' of the per-title gross pair; a title absent from a map (e.g. + -- only in 'adj', not 'pre') yields '(0,0)', i.e. 'diffRL Zero = (Side, 0)'. + preTotals = accountGrossTotals pre + adjTotals = accountGrossTotals adj + combTotals = accountGrossTotals combined + grossOf m t = OMap.findWithDefault (zeroValue, zeroValue) t m + -- Title enumeration: the keys of 'combined' in Ord order (= the previous + -- 'L.sort . Set.toList . Set.fromList' over 'EA.toList combined'). + titles = OMap.keys combTotals + -- per-title row + accumulate the four debit/credit column totals + (bodyRows, tbD, tbC, plD, plC, bsD, bsC) = + L.foldl' step ([], zeroValue, zeroValue, zeroValue, zeroValue, zeroValue, zeroValue) titles + step (rows, tbd, tbc, pld, plc, bsd, bsc) t = + let tb = netGross (grossOf preTotals t) + (tbDc, tbCc) = sideCells tb + adjPair = netGross (grossOf adjTotals t) + (adjDc, adjCc) = sideCells adjPair + finalPair@(finalSide, finalMag) = netGross (grossOf combTotals t) + div' = classifyAccountDivision t + isPL = div' == Cost || div' == Revenue + (plDc, plCc, bsDc, bsCc) + | isPL = let (d,c) = sideCells finalPair in (d, c, T.empty, T.empty) + | otherwise = let (d,c) = sideCells finalPair in (T.empty, T.empty, d, c) + row = [ tshow t, tbDc, tbCc, adjDc, adjCc, plDc, plCc, bsDc, bsCc ] + -- column totals + addCol side mag d c = case side of + Debit -> (d + mag, c) + Credit -> (d, c + mag) + _ -> (d, c) -- wildcard v'Side' (balanced to zero): adds nothing + (ntbd, ntbc) = let (s,m) = tb in addCol s m tbd tbc + (npld, nplc) | isPL = addCol finalSide finalMag pld plc + | otherwise = (pld, plc) + (nbsd, nbsc) | not isPL = addCol finalSide finalMag bsd bsc + | otherwise = (bsd, bsc) + in (rows ++ [row], ntbd, ntbc, npld, nplc, nbsd, nbsc) + -- trial-balance totals row (整理記入 totals are intentionally omitted: the + -- adjustment column does not have a meaningful single grand total in the + -- lecture's layout; the self-check is on P/L and B/S). + tbTotalRow = + [ T.pack "Subtotal" + , tshow tbD, tshow tbC + , T.empty, T.empty + , tshow plD, tshow plC + , tshow bsD, tshow bsC ] + -- profit/loss balancing figure (当期純利益 / 純損失). + -- P/L imbalance: if credit (revenue) side exceeds debit (cost) side, the + -- difference is net income, recorded on the P/L debit side and the B/S + -- credit side (it increases equity). The reverse is a net loss. + plDiff = absDiff plD plC + bsDiff = absDiff bsD bsC + netProfit = plC > plD -- revenue side larger => profit + (netLabel, netPlD, netPlC, netBsD, netBsC) + | plC == plD = (T.pack "Net Income/Loss", T.empty, T.empty, T.empty, T.empty) + | netProfit = (T.pack "Net Income", tshow plDiff, T.empty, T.empty, tshow bsDiff) + | otherwise = (T.pack "Net Loss", T.empty, tshow plDiff, tshow bsDiff, T.empty) + netRow = + [ netLabel + , T.empty, T.empty + , T.empty, T.empty + , netPlD, netPlC + , netBsD, netBsC ] + -- grand totals after adding the balancing figure (both sides now equal). + plTotal = max plD plC + bsTotal = max bsD bsC + grandTotalRow = + [ T.pack "Total" + , T.empty, T.empty + , T.empty, T.empty + , tshow plTotal, tshow plTotal + , tshow bsTotal, tshow bsTotal ] + absDiff a b = if a >= b then a - b else b - a + +-- | Output an 8-column worksheet (8 桁精算表) in CSV format. +-- Pure layout is delegated to 'worksheetRows'; this function only writes the +-- file. See 'worksheetRows' for the column structure and the self-check +-- (P\/L vs B\/S balancing figure) semantics. +-- +-- Complexity: O(s) (single pass per algebra; see 'worksheetRows'). +writeWorksheet :: (HatVal n, HatBaseClass b, ExBaseClass b) + => FilePath + -> Alg n b -- ^ pre-adjustment ledger + -> Alg n b -- ^ adjustment entries + -> IO () +writeWorksheet path pre adj = writeCSV path (worksheetRows pre adj) + +-- | Build the rows of a post-closing trial balance (繰越試算表), as a pure +-- value (the part 'writePostClosingTrialBalance' renders to CSV). +-- +-- After the closing transfers, only the /real/ (permanent) accounts remain on +-- the ledger. This lists the net balance of every 'Assets'\/'Liability'\/ +-- 'Equity' account (the carried-forward balances, 次期繰越); 'Cost'\/'Revenue' +-- (nominal) accounts are __excluded by construction__, since they have been +-- closed out to the income summary. Layout: +-- +-- > Debit | Account Title | Credit +-- +-- The net balance per title is computed with an explicit @diffRL@ netting +-- (the same aggregation as 'writeCompoundTrialBalance'); no implicit @bar@. +-- The final row gives the debit and credit totals (which must agree). +-- +-- Titles are listed in 'Ord' order for deterministic output. +-- +-- ==== __Examples__ +-- +-- A ledger with cash, a loan (liability) and a sale (revenue). Only the real +-- accounts (Cash, LoansPayable) survive; the nominal Sales account is dropped. +-- +-- >>> type T = Alg Double (HatBase AccountTitles) +-- >>> let led = (100 .@ Not:<Cash) .+ (40 .@ Hat:<Cash) .+ (60 .@ Not:<LoansPayable) .+ (100 .@ Not:<Sales) :: T +-- >>> mapM_ print (postClosingTrialBalanceRows led) +-- ["Debit","Account Title","Credit"] +-- ["60.0","Cash",""] +-- ["","LoansPayable","60.0"] +-- ["60.0","Total","60.0"] +-- +-- Complexity: O(s) (single pass over s scalar entries; see @accountGrossTotals@). +postClosingTrialBalanceRows :: (HatVal n, HatBaseClass b, ExBaseClass b) + => Alg n b -> [[T.Text]] +postClosingTrialBalanceRows alg = + header : bodyRows ++ [totalRow] + where + header = [T.pack "Debit", T.pack "Account Title", T.pack "Credit"] + -- Single pass (O(s)): gross debit/credit totals per title, in Ord order; + -- keep only real (Assets/Liability/Equity) titles. + totals = accountGrossTotals alg + titles = L.filter isReal (OMap.keys totals) + isReal t = let d = classifyAccountDivision t + in d == Assets || d == Liability || d == Equity + (bodyRows, debitTotal, creditTotal) = + L.foldl' step ([], zeroValue, zeroValue) titles + step (rows, dt, ct) t = + let (side, mag) = netGross (OMap.findWithDefault (zeroValue, zeroValue) t totals) + (dCell, cCell) = sideCells (side, mag) + (dt', ct') = case side of + Debit | mag /= zeroValue -> (dt + mag, ct) + Credit | mag /= zeroValue -> (dt, ct + mag) + _ -> (dt, ct) + row = [dCell, tshow t, cCell] + in (rows ++ [row], dt', ct') + totalRow = [tshow debitTotal, T.pack "Total", tshow creditTotal] + +-- | Output a post-closing trial balance (繰越試算表) in CSV format. +-- Pure layout is delegated to 'postClosingTrialBalanceRows'; this function only +-- writes the file. Only 'Assets'\/'Liability'\/'Equity' (real) accounts appear; +-- 'Cost'\/'Revenue' accounts are excluded — see 'postClosingTrialBalanceRows'. +-- +-- Complexity: O(s) (single pass; see 'postClosingTrialBalanceRows'). +writePostClosingTrialBalance :: (HatVal n, HatBaseClass b, ExBaseClass b) + => FilePath + -> Alg n b + -> IO () +writePostClosingTrialBalance path alg = + writeCSV path (postClosingTrialBalanceRows alg) + +------------------------------------------------------------------ -- Write Functions for Simulation ------------------------------------------------------------------ @@ -252,15 +1012,15 @@ -- Outputs a slice of the specified term from a 3D array (term, row industry, column industry). -- -- Complexity: O(r * c) (r = number of rows, c = number of columns) -writeTermIO :: (HatVal n,BaseClass b, StateTime t, Ix b, Ix t, Enum b) +writeTermIO :: (HatVal n,BaseClass b, Ix t, Ix b, Enum b) => FilePath -> t -> IOArray (t, b, b) n -> IO () writeTermIO path t arr = do ((_, c1Min, c2Min), (_, c1Max, c2Max)) <- getBounds arr let rows = [c1Min .. c1Max] let cols = [c2Min .. c2Max] body <- forM rows $ \r -> do - vals <- forM cols $ \c -> tshow <$> readArray arr (t, r, c) - pure (tshow r : vals) + cells <- forM cols $ \c -> tshow <$> readArray arr (t, r, c) + pure (tshow r : cells) writeCSV path ((T.pack "" : L.map tshow cols) : body) -- | Output a 2D IOArray (Input-Output Table or ripple effect matrix) in CSV format. @@ -272,46 +1032,6 @@ let rows = [r1 .. r2] let cols = [c1 .. c2] body <- forM rows $ \r -> do - vals <- forM cols $ \c -> tshow <$> readArray arr (r, c) - pure (tshow r : vals) + cells <- forM cols $ \c -> tshow <$> readArray arr (r, c) + pure (tshow r : cells) writeCSV path ((T.pack "" : L.map tshow cols) : body) - ------------------------------------------------------------------- --- Spill Restore Utilities ------------------------------------------------------------------- - --- | Restore a complete Journal from spilled binary chunks and the current in-memory Journal. --- The in-memory portion is narrowed to only terms after the last spill range, --- so duplicate terms are not double-counted. --- --- Complexity: O(file size + number of chunks * union cost) -restoreJournalFromBinarySpill - :: ( Binary.Binary t - , Ord t - , Binary.Binary (EJ.Journal n v b) - , EJ.Note n - , HatVal v - , HatBaseClass b - ) - => FilePath - -> (n -> t) - -> EJ.Journal n v b - -> IO (EJ.Journal n v b) -restoreJournalFromBinarySpill spillPath noteToTerm currentLedger = do - chunks <- readBinarySpillFile spillPath - let spilled = L.foldl' (\acc (_, j) -> acc .+ j) mempty chunks - latestEnd = L.foldl' - (\acc ((_, tEnd), _) -> - case acc of - Nothing -> Just tEnd - Just x -> Just (max x tEnd) - ) - Nothing - chunks - remainder = case latestEnd of - Nothing -> currentLedger - Just tEnd -> - EJ.filterWithNote (\n _ -> noteToTerm n > tEnd) currentLedger - pure (spilled .+ remainder) - ------------------------------------------------------------------- diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -7,836 +7,6816 @@ module Main (main) where import ExchangeAlgebra.Journal -import qualified ExchangeAlgebra.Algebra as EA -import qualified ExchangeAlgebra.Algebra.Transfer as EAT -import qualified ExchangeAlgebra.Journal as EJ -import qualified ExchangeAlgebra.Journal.Transfer as EJT -import qualified ExchangeAlgebra.Simulate as ES -import ExchangeAlgebra.Simulate -import qualified ExchangeAlgebra.Write as EW -import ExchangeAlgebra.Write - -import qualified Data.HashMap.Strict as HM -import qualified Data.Map.Strict as M -import qualified Data.List as L -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import Control.Monad (forM_) -import Control.Monad.ST -import Data.Array.ST -import Data.STRef -import System.Exit (exitFailure) -import System.IO (IOMode(WriteMode), withFile) -import System.Directory (removeFile) -import System.Random (StdGen, mkStdGen, randomR) -import Control.Monad (replicateM) -import Control.Monad.State (runState, state) - --- ================================================================ --- Unit test helpers --- ================================================================ - -eps :: Double -eps = 1e-9 - -assertEqual :: (Eq a, Show a) => String -> a -> a -> IO () -assertEqual label expected actual - | expected == actual = putStrLn ("[PASS] " ++ label) - | otherwise = do - putStrLn ("[FAIL] " ++ label) - putStrLn (" expected: " ++ show expected) - putStrLn (" actual : " ++ show actual) - exitFailure - -assertNear :: String -> Double -> Double -> IO () -assertNear label expected actual - | abs (expected - actual) <= eps = putStrLn ("[PASS] " ++ label) - | otherwise = do - putStrLn ("[FAIL] " ++ label) - putStrLn (" expected: " ++ show expected) - putStrLn (" actual : " ++ show actual) - exitFailure - --- ================================================================ --- Existing pure algebra tests --- ================================================================ - -type TestAlg = EA.Alg Double (HatBase CountUnit) -type TestJournal = EJ.Journal String Double (HatBase CountUnit) -type AxisJournal = EJ.Journal (String, Int) Double (HatBase CountUnit) - -algSample :: TestAlg -algSample = - (1 :@ (Hat :< Yen)) - .+ (1 :@ (Not :< Amount)) - .+ (2 :@ (Not :< Yen)) - .+ (2 :@ (Hat :< Amount)) - .+ (3 :@ (Hat :< Yen)) - -journalSample :: TestJournal -journalSample = EJ.fromList [x, y, z] - where - x = ((1 :@ (Hat :< Yen)) .+ (1 :@ (Not :< Amount))) .| "cat" :: TestJournal - y = ((2 :@ (Not :< Yen)) .+ (2 :@ (Hat :< Amount))) .| "dog" :: TestJournal - z = ((3 :@ (Hat :< Yen)) .+ (3 :@ (Not :< Amount))) .| "fish" :: TestJournal - -testProjMultiPatternOnePass :: IO () -testProjMultiPatternOnePass = do - let qs :: [HatBase CountUnit] - qs = [Hat :< Yen, HatNot :< Amount, Hat :< Yen] - expected = L.foldl' (\acc q -> acc .+ EA.proj [q] algSample) EA.Zero qs - actual = EA.proj qs algSample - assertEqual "Alg.proj multi-pattern preserves behavior" expected actual - -testProjNormFastPath :: IO () -testProjNormFastPath = do - let qs :: [HatBase CountUnit] - qs = [Hat :< Yen, HatNot :< Amount, Hat :< Yen] - expected = norm $ (.-) $ EA.proj qs algSample - actual = EA.projNorm qs algSample - assertNear "Alg.projNorm fast path matches existing semantics" expected actual - -testProjWithBaseNorm :: IO () -testProjWithBaseNorm = do - let bs :: [HatBase CountUnit] - bs = [Not :< Amount] - expected = norm $ EJ.projWithBase bs journalSample - actual = EJ.projWithBaseNorm bs journalSample - assertNear "Journal.projWithBaseNorm matches norm . projWithBase" expected actual - -testProjWithNoteNorm :: IO () -testProjWithNoteNorm = do - let bs :: [HatBase CountUnit] - bs = [HatNot :< Amount, Hat :< Yen] - ns1 = ["dog", "cat"] - ns2 = [plank] - expected1 = norm $ EJ.projWithNoteBase ns1 bs journalSample - actual1 = EJ.projWithNoteNorm ns1 bs journalSample - expected2 = norm $ EJ.projWithNoteBase ns2 bs journalSample - actual2 = EJ.projWithNoteNorm ns2 bs journalSample - assertNear "Journal.projWithNoteNorm (selected notes)" expected1 actual1 - assertNear "Journal.projWithNoteNorm (plank wildcard)" expected2 actual2 - --- | Regression test for the `bases` typo bug. --- --- Before the fix at Algebra.hs:868, `bases` ignored the `_notSide` Seq and --- iterated `_hatSide` twice (with `Hat` and `Not` labels). As a result, --- `length (bases x) != length (vals x)` whenever Hat/Not Seq lengths differed. --- --- This test constructs an Alg where the Hat Seq for `Yen` has length 1 and --- the Not Seq has length 2, plus a separate basis whose Hat Seq is empty. --- That makes the divergence detectable in both directions. -testBasesNotSideRegression :: IO () -testBasesNotSideRegression = do - let alg :: TestAlg - alg = (100 :@ (Hat :< Yen)) -- Yen: hatSide = [100] - .+ (50 :@ (Not :< Yen)) -- Yen: notSide = [50] - .+ (30 :@ (Not :< Yen)) -- Yen: notSide = [50, 30] - .+ (20 :@ (Not :< Amount)) -- Amount: notSide = [20], hatSide = [] - vs = EA.vals alg - bs = EA.bases alg - hatCount = length (L.filter isHat bs) - notCount = length (L.filter (not . isHat) bs) - -- vals and bases must agree on total count (one label per scalar entry) - assertEqual "bases/vals same length (regression for hs/ns typo)" - (length vs) (length bs) - -- Expected: 1 Hat label (Hat:<Yen) and 3 Not labels (50:<Yen, 30:<Yen, 20:<Amount) - assertEqual "bases Hat label count" 1 hatCount - assertEqual "bases Not label count" 3 notCount - --- | Regression test for the @union@ zero-singleton base-relabel bug --- (Algebra.hs). When one operand of @(.+)@ is a /zero-valued/ singleton on base --- @b1@ and the other a /real/ singleton on a different base @b2@, the result must --- keep the real value on its OWN base (@v2:@b2@), not relabel it onto the zero --- posting's base. The old code returned @v2:@b1@ / @v1:@b2@, which silently moved --- a value to the wrong base — preserving @norm@ but corrupting per-base projection. -testUnionZeroSingletonBase :: IO () -testUnionZeroSingletonBase = do - let zb = 0 :@ (Hat :< Yen) :: TestAlg -- zero value, base Yen - rb = 5 :@ (Hat :< Amount) :: TestAlg -- real value, base Amount - assertEqual "union zero(.+)real keeps real value on its own base" - rb (EA.proj [Hat :< Amount] (zb .+ rb)) - assertEqual "union real(.+)zero keeps real value on its own base" - rb (EA.proj [Hat :< Amount] (rb .+ zb)) - assertEqual "union zero(.+)real: nothing relabeled onto the zero's base" - (EA.Zero :: TestAlg) (EA.proj [Hat :< Yen] (zb .+ rb)) - assertEqual "union real(.+)zero: nothing relabeled onto the zero's base" - (EA.Zero :: TestAlg) (EA.proj [Hat :< Yen] (rb .+ zb)) - -testSigmaMergePath :: IO () -testSigmaMergePath = do - let xs = [1 .. 5 :: Int] - f :: Int -> TestAlg - f i - | i == 3 = EA.Zero - | odd i = fromIntegral i :@ (Hat :< Yen) - | otherwise = fromIntegral i :@ (Not :< Amount) - expected :: TestAlg - expected = EA.unionsMerge (L.map f xs) - actual :: TestAlg - actual = EA.sigma xs f - assertEqual "Alg.sigma bulk-merge path matches unionsMerge" expected actual - -testSigma2When :: IO () -testSigma2When = do - let xs = [1 .. 3 :: Int] - ys = [1 .. 4 :: Int] - cond i j = i /= j && even (i + j) - f :: Int -> Int -> TestAlg - f i j = - let v = fromIntegral (i * 10 + j) - in if odd i - then v :@ (Hat :< Yen) - else v :@ (Not :< Amount) - expected :: TestAlg - expected = - EA.unionsMerge - [ f i j - | i <- xs - , j <- ys - , cond i j - ] - actual :: TestAlg - actual = EA.sigma2When xs ys cond f - assertEqual "Alg.sigma2When matches list-comprehension sum" expected actual - -testSigmaFromMap :: IO () -testSigmaFromMap = do - let kvs = M.fromList - [ ((1, 2), 5.0) - , ((2, 3), 0.0) - , ((3, 1), 7.0) - ] :: M.Map (Int, Int) Double - f :: (Int, Int) -> Double -> TestAlg - f (i, j) v - | i < j = v :@ (Hat :< Yen) - | otherwise = v :@ (Not :< Amount) - expected :: TestAlg - expected = EA.unionsMerge - [ f (1, 2) 5.0 - , f (3, 1) 7.0 - ] - actual :: TestAlg - actual = EA.sigmaFromMap kvs f - assertEqual "Alg.sigmaFromMap iterates non-zero map entries only" expected actual - -testJournalSigmaMergePath :: IO () -testJournalSigmaMergePath = do - let xs = [1 .. 4 :: Int] - f :: Int -> TestJournal - f i = case i of - 1 -> (1 :@ (Hat :< Yen)) .| "A" - 2 -> EJ.Zero - 3 -> (EA.Zero :: TestAlg) .| "A" - _ -> (2 :@ (Not :< Amount)) .| "B" - expected :: TestJournal - expected = EJ.fromMap $ HM.fromList - [ ("A", 1 :@ (Hat :< Yen)) - , ("B", 2 :@ (Not :< Amount)) - ] - actual = EJ.sigma xs f - assertEqual "Journal.sigma bulk-merge path skips zero postings" (EJ.toMap expected) (EJ.toMap actual) - -testJournalSigma2When :: IO () -testJournalSigma2When = do - let xs = [1 .. 3 :: Int] - ys = [1 .. 3 :: Int] - cond i j = i < j - f :: Int -> Int -> TestJournal - f i j - | i == 1 && j == 2 = (EA.Zero :: TestAlg) .| "N" - | odd (i + j) = (fromIntegral (i + j) :@ (Hat :< Yen)) .| "N" - | otherwise = EJ.Zero - expected :: TestJournal - expected = EJ.fromMap $ HM.fromList [("N", 5 :@ (Hat :< Yen))] - actual = EJ.sigma2When xs ys cond f - assertEqual "Journal.sigma2When matches filtered pair sum" (EJ.toMap expected) (EJ.toMap actual) - -testJournalSigmaOn :: IO () -testJournalSigmaOn = do - let xs = [1 .. 4 :: Int] - f :: Int -> TestAlg - f i - | i <= 2 = EA.Zero - | otherwise = fromIntegral i :@ (Hat :< Yen) - expected :: TestJournal - expected = (EA.sigma xs f) .| "SalesPurchase" - actual :: TestJournal - actual = EJ.sigmaOn "SalesPurchase" xs f - zeroExpected = EJ.Zero :: TestJournal - zeroActual = EJ.sigmaOn "SalesPurchase" xs (\_ -> EA.Zero :: TestAlg) - assertEqual "Journal.sigmaOn attaches note after EA.sigma" (EJ.toMap expected) (EJ.toMap actual) - assertEqual "Journal.sigmaOn returns Zero when EA.sigma is Zero" (EJ.toMap zeroExpected) (EJ.toMap zeroActual) - -testJournalSigmaOnFromMap :: IO () -testJournalSigmaOnFromMap = do - let kvs = M.fromList - [ ((1, 2), 4.0) - , ((2, 3), 0.0) - , ((2, 1), 6.0) - ] :: M.Map (Int, Int) Double - f :: (Int, Int) -> Double -> TestAlg - f (i, j) v - | i < j = v :@ (Hat :< Yen) - | otherwise = v :@ (Not :< Amount) - expected :: TestJournal - expected = (EA.sigmaFromMap kvs f) .| "SalesPurchase" - actual :: TestJournal - actual = EJ.sigmaOnFromMap "SalesPurchase" kvs f - zeroActual :: TestJournal - zeroActual = EJ.sigmaOnFromMap "SalesPurchase" (M.singleton (1, 1) 0.0) f - assertEqual "Journal.sigmaOnFromMap matches EA.sigmaFromMap + note" (EJ.toMap expected) (EJ.toMap actual) - assertEqual "Journal.sigmaOnFromMap returns Zero for empty-effective map" (EJ.toMap (EJ.Zero :: TestJournal)) (EJ.toMap zeroActual) - -testFilterByAxisEquivalent :: IO () -testFilterByAxisEquivalent = do - let ledger :: AxisJournal - ledger = EJ.fromList - [ (10 :@ (Hat :< Yen)) .| ("A", 1) - , (20 :@ (Not :< Amount)) .| ("B", 1) - , (30 :@ (Hat :< Yen)) .| ("A", 2) - ] - expected = EJ.filterWithNote (\(_, t') _ -> t' == 1) ledger - actual = EJ.filterByAxis 1 (EJ.NoteAxisKey (1 :: Int)) ledger - mismatch = EJ.filterByAxis 1 (EJ.NoteAxisKey ("1" :: String)) ledger - assertEqual "Journal.filterByAxis matches filterWithNote on axis=1" - (EJ.toMap expected) - (EJ.toMap actual) - assertEqual "Journal.filterByAxis type mismatch returns empty" - (EJ.toMap (EJ.Zero :: AxisJournal)) - (EJ.toMap mismatch) - -testFilterByAxisWithDeltaUpdates :: IO () -testFilterByAxisWithDeltaUpdates = do - let base :: AxisJournal - base = EJ.fromMap $ HM.fromList - [ (("A", 1), 10 :@ (Hat :< Yen)) - , (("C", 2), 5 :@ (Not :< Amount)) - ] - rhs :: AxisJournal - rhs = EJ.fromMap $ HM.fromList - [ (("A", 1), 3 :@ (Not :< Amount)) - , (("B", 1), 7 :@ (Hat :< Yen)) - ] - ledger = base .+ rhs - expected = EJ.filterWithNote (\(_, t') _ -> t' == 1) ledger - actual = EJ.filterByAxis 1 (EJ.NoteAxisKey (1 :: Int)) ledger - assertEqual "Journal.filterByAxis works after append updates" - (EJ.toMap expected) - (EJ.toMap actual) - --- ================================================================ --- Transfer regression tests --- ================================================================ - -type TransferAlg = EA.Alg Double SimHatBase2 -type TransferJournal = EJ.Journal String Double SimHatBase2 - -transferAlgSample :: TransferAlg -transferAlgSample = EA.fromList - [ 7 :@ Not :<(WageExpenditure, 1, 1, Yen) - , 3 :@ Hat :<(Depreciation, 2, 2, Yen) - , 11 :@ Not :<(Purchases, 3, 3, Yen) - , 13 :@ Not :<(ValueAdded, 1, 2, Yen) - , 17 :@ Hat :<(Sales, 2, 1, Yen) - , 19 :@ Not :<(InterestEarned, 4, 4, Yen) - , 23 :@ Hat :<(InterestExpense, 5, 5, Yen) - , 29 :@ Not :<(TaxesRevenue, 2, 2, Yen) - , 31 :@ Hat :<(TaxesExpense, 3, 3, Yen) - , 37 :@ Not :<(WageEarned, 6, 6, Yen) - , 41 :@ Hat :<(ConsumptionExpenditure, 6, 6, Yen) - , 43 :@ Not :<(CentralBankPaymentIncome, 1, 1, Yen) - , 47 :@ Hat :<(CentralBankPaymentExpense, 1, 1, Yen) - , 53 :@ Not :<(GrossProfit, 7, 7, Yen) - , 59 :@ Hat :<(OrdinaryProfit, 8, 8, Yen) - , 61 :@ Not :<(Cash, 1, 1, Yen) - ] - -transferJournalSample :: TransferJournal -transferJournalSample = EJ.fromList - [ transferAlgSample .| "A" - , ((5 :@ Not :<(Sales, 2, 1, Yen)) .+ (2 :@ Hat :<(WageExpenditure, 1, 1, Yen))) .| "B" - , ((3 :@ Hat :<(TaxesExpense, 3, 3, Yen)) .+ (4 :@ Not :<(InterestEarned, 4, 4, Yen))) .| "C" - ] - -testFinalStockTransferAlgEquivalence :: IO () -testFinalStockTransferAlgEquivalence = do - let ref = - (.-) - . EAT.retainedEarningTransfer - . EAT.ordinaryProfitTransfer - . EAT.grossProfitTransfer - $ transferAlgSample - actual = EAT.finalStockTransfer transferAlgSample - assertEqual "Algebra.finalStockTransfer matches composed transfer" ref actual - -testFinalStockTransferJournalEquivalence :: IO () -testFinalStockTransferJournalEquivalence = do - let ref = - (.-) - . EJT.retainedEarningTransfer - . EJT.ordinaryProfitTransfer - . EJT.grossProfitTransfer - $ transferJournalSample - actual = EJT.finalStockTransfer transferJournalSample - assertEqual "Journal.finalStockTransfer matches composed transfer" (EJ.toMap ref) (EJ.toMap actual) - --- A ledger whose Debit and Credit sides are equal (net income is zero). --- @diffRL@ reports the wildcard 'Side' here, which used to crash --- @incomeSummaryAccount@ with "Non-exhaustive patterns" (regression for 0.4.1.2). -balancedTransferAlg :: TransferAlg -balancedTransferAlg = EA.fromList - [ 5 :@ Not :<(Cash, 1, 1, Yen) -- Assets -> Debit side - , 5 :@ Not :<(Sales, 2, 1, Yen) -- Revenue -> Credit side - ] - -balancedTransferJournal :: TransferJournal -balancedTransferJournal = balancedTransferAlg .| "balanced" - --- | Regression: a balanced ledger (credit == debit) must not crash --- @incomeSummaryAccount@; it returns the input unchanged. -testIncomeSummaryBalancedAlg :: IO () -testIncomeSummaryBalancedAlg = do - let actual = EAT.incomeSummaryAccount balancedTransferAlg - assertEqual - "Algebra.incomeSummaryAccount on balanced ledger returns input unchanged" - (EA.toList balancedTransferAlg) - (EA.toList actual) - -testIncomeSummaryBalancedJournal :: IO () -testIncomeSummaryBalancedJournal = do - let actual = EJT.incomeSummaryAccount balancedTransferJournal - assertEqual - "Journal.incomeSummaryAccount on balanced ledger returns input unchanged" - (EJ.toMap balancedTransferJournal) - (EJ.toMap actual) - -type SpillRestoreJournal = EJ.Journal (String, Int) Double (HatBase CountUnit) - -testRestoreJournalFromBinarySpill :: IO () -testRestoreJournalFromBinarySpill = do - let spillPath = "/tmp/exchangealgebra_spill_restore_test.bin" - chunk1 :: SpillRestoreJournal - chunk1 = EJ.fromList - [ (1 :@ (Hat :< Yen)) .| ("A", 1) - , (2 :@ (Not :< Amount)) .| ("B", 2) - ] - chunk2 :: SpillRestoreJournal - chunk2 = (3 :@ (Hat :< Yen)) .| ("C", 3) - currentLedger :: SpillRestoreJournal - currentLedger = EJ.fromList - [ (4 :@ (Not :< Amount)) .| ("Tail", 4) - , (8 :@ (Hat :< Yen)) .| ("AlreadySpilled", 2) - ] - expected :: SpillRestoreJournal - expected = chunk1 .+ chunk2 .+ ((4 :@ (Not :< Amount)) .| ("Tail", 4)) - - withFile spillPath WriteMode $ \h -> do - ES.defaultBinarySpillWriter h (1 :: Int, 2 :: Int) chunk1 - ES.defaultBinarySpillWriter h (3 :: Int, 3 :: Int) chunk2 - - actual <- restoreJournalFromBinarySpill spillPath snd currentLedger - assertEqual "Write.restoreJournalFromBinarySpill merges spill + tail remainder" - (EJ.toMap expected) - (EJ.toMap actual) - --- ================================================================ --- SimulateEx1 reproduction (default scenario only, no parallelism) --- ================================================================ - -type SimTerm = Int - -instance StateTime SimTerm where - initTerm = 1 - lastTerm = 100 -data SimInitVar = SimInitVar - { _simInitStock :: Double - , _simSteadyProduction :: Double - , _simInhouseRatio :: Double - } deriving (Eq, Show) - -instance InitVariables SimInitVar where - -data SimEvent - = SimSalesPurchase - | SimProduction - | SimPlank - deriving (Ord, Show, Enum, Eq, Bounded, Generic) - -instance Hashable SimEvent where - -instance Note SimEvent where - plank = SimPlank - -instance Event SimEvent where - -type SimCompany = Int - -instance Element SimCompany where - wiledcard = -1 - -instance BaseClass SimCompany where - -simFstC, simLastC :: SimCompany -simFstC = 1 -simLastC = 6 - -simCompanies :: [SimCompany] -simCompanies = [simFstC .. simLastC] - -type SimHatBase2 = HatBase (AccountTitles, SimCompany, SimCompany, CountUnit) - -instance ExBaseClass SimHatBase2 where - getAccountTitle (h :< (a, _, _, _)) = a - setAccountTitle (h :< (_, c, e, u)) b = h :< (b, c, e, u) - -type SimTransaction = EJ.Journal (SimEvent, SimTerm) Double SimHatBase2 - -simCompressPreviousTerm :: SimTerm -> SimTransaction -> SimTransaction -simCompressPreviousTerm t le = - EJ.fromMap $ - L.foldl' (\acc ev -> HM.adjust compress (ev, t) acc) - (EJ.toMap le) - [fstEvent .. lastEvent] - -newtype SimLedger s = SimLedger (STRef s SimTransaction) - -instance UpdatableSTRef SimLedger s SimTransaction where - _unwrapURef (SimLedger x) = x - _wrapURef x = SimLedger x - -simInitLedger :: Double -> ST s (SimLedger s) -simInitLedger d = newURef $ EJ.fromList - [ d :@ Not :<(Products, e, e, Amount) .| (plank, initTerm) - | e <- simCompanies - ] - -instance Updatable SimTerm SimInitVar SimLedger s where - type Inner SimLedger s = STRef s SimTransaction - unwrap = _unwrapURef - initialize _ _ e = simInitLedger (_simInitStock e) - updatePattern _ = return Modify - modify _ t _ x = do - le <- readURef x - let added = EJ.gather (plank, t) - $ EJT.finalStockTransfer - $ (.-) $ simTermJournal (t - 1) le - next = simCompressPreviousTerm (t - 1) (le .+ added) - writeURef x next - -type SimInputCoefficient = Double - -newtype SimICTable s = SimICTable (STArray s (SimCompany, SimCompany) SimInputCoefficient) - -instance UpdatableSTArray SimICTable s (SimCompany, SimCompany) SimInputCoefficient where - _unwrapUArray (SimICTable arr) = arr - _wrapUArray arr = SimICTable arr - -simGenerateRandomList :: StdGen -> Int -> ([Double], StdGen) -simGenerateRandomList g n = - let (xs, g') = runState (replicateM n (state (randomR (0, 1.0)))) - (updateGen g 1000) - ys = L.map (\v -> if v < 0.1 then 0 else v) xs - in (ys, g') - -simInitTermCoefficients :: StdGen -> Double -> M.Map SimCompany [SimInputCoefficient] -simInitTermCoefficients g inhouseRatio = - fst $ L.foldl' buildRow (M.empty, g) simCompanies - where - buildRow (acc, g0) c2 = - let (row, g1) = generateRow g0 - in (M.insert c2 row acc, g1) - generateRow g0 = - let (vals, g1) = simGenerateRandomList g0 simLastC - total = sum vals - normalized = L.map (\v -> (v / total) * inhouseRatio) vals - in (normalized, g1) - -simInitICTables :: StdGen -> Double -> ST s (SimICTable s) -simInitICTables g inhouseRatio = do - arr <- newUArray ((simFstC, simFstC), (simLastC, simLastC)) 0 - let termCoefficients = simInitTermCoefficients g inhouseRatio - forM_ simCompanies $ \c2 -> do - let row = termCoefficients M.! c2 - forM_ (zip simCompanies row) $ \(c1, coef) -> - writeUArray arr (c1, c2) coef - return arr - -instance Updatable SimTerm SimInitVar SimICTable s where - type Inner SimICTable s = STArray s (SimCompany, SimCompany) SimInputCoefficient - unwrap (SimICTable a) = a - initialize g _ e = simInitICTables g (_simInhouseRatio e) - updatePattern _ = return DoNothing - -type SimSteadyProd = Double - -newtype SimSP s = SimSP (STRef s SimSteadyProd) - -instance UpdatableSTRef SimSP s SimSteadyProd where - _unwrapURef (SimSP x) = x - _wrapURef x = SimSP x - -instance Updatable SimTerm SimInitVar SimSP s where - type Inner SimSP s = STRef s SimSteadyProd - unwrap = _unwrapURef - initialize _ _ e = newURef (_simSteadyProduction e) - updatePattern _ = return DoNothing - -data SimWorld s = SimWorld - { _simLedger :: SimLedger s - , _simIcs :: SimICTable s - , _simSp :: SimSP s - } deriving (Generic) - --- helper functions - -simTermJournal :: SimTerm -> SimTransaction -> SimTransaction -simTermJournal t = EJ.filterWithNote (\(_, t') _ -> t' == t) - -simGetOneProduction :: SimWorld s -> SimTerm -> SimCompany -> ST s SimTransaction -simGetOneProduction wld t c = do - let arr = _simIcs wld - inputs <- mapM (\c2 -> do - coef <- readUArray arr (c2, c) - return $ coef :@ Hat :<(Products, c2, c, Amount) .| (SimProduction, t) - ) simCompanies - let totalInput = EJ.fromList inputs - result = (1 :@ Not :<(Products, c, c, Amount) .| (SimProduction, t)) .+ totalInput - return result - -simJournal :: SimWorld s -> SimTransaction -> ST s () -simJournal _ Zero = return () -simJournal wld js = modifyURef (_simLedger wld) (\x -> x .+ js) - -simBuildShortageMap :: SimTerm -> SimTransaction -> M.Map (SimCompany, SimCompany) Double -simBuildShortageMap t le = - let termAlg = EJ.toAlg $ (.-) $ simTermJournal t le - in L.foldl' go M.empty (EA.toList termAlg) - where - go acc (v :@ (Hat :< (Products, j, i, Amount))) = M.insertWith (+) (i, j) v acc - go acc _ = acc - -simPurchases :: SimTerm -> SimWorld s -> ST s SimTransaction -simPurchases t wld = do - le <- readURef (_simLedger wld) - let shortageMap = simBuildShortageMap t le - o i j = M.findWithDefault 0 (i, j) shortageMap - return $ sigma simCompanies $ \i - -> sigma (simCompanies L.\\ [i]) $ \j - -> (o i j) :@ Not :<(Products, j, i, Amount) - .+ (o i j) :@ Hat :<(Cash, (.#), i, Yen) - .+ (o i j) :@ Not :<(Purchases, (.#), i, Yen) - .+ (o i j) :@ Not :<(Cash, (.#), j, Yen) - .+ (o i j) :@ Not :<(Sales, (.#), j, Yen) - .+ (o i j) :@ Hat :<(Products, j, j, Amount) - .| (SimSalesPurchase, t) - -instance StateSpace SimTerm SimInitVar SimEvent SimWorld s where - event = simEvent - -simEvent :: SimWorld s -> SimTerm -> SimEvent -> ST s () - -simEvent wld t SimSalesPurchase = do - toAdd <- simPurchases t wld - simJournal wld toAdd - -simEvent wld t SimProduction = do - sp <- readURef (_simSp wld) - forM_ simCompanies $ \e1 -> do - op <- simGetOneProduction wld t e1 - simJournal wld (sp .* op) - -simEvent _ _ SimPlank = return () - -simGetTermStock :: SimWorld s -> SimTerm -> SimCompany -> ST s Double -simGetTermStock wld t e = do - le <- readURef (_simLedger wld) - let tj = (.-) $ simTermJournal t le - plusStock = norm $ EJ.projWithBase [Not :<(Products, e, e, Amount)] tj - minusStock = norm $ EJ.projWithBase [Hat :<(Products, e, e, Amount)] tj - return $ plusStock - minusStock - -simGetTermGrossProfit :: SimWorld s -> SimTerm -> SimCompany -> ST s Double -simGetTermGrossProfit wld t e = do - le <- readURef (_simLedger wld) - let termTr = simTermJournal t le - tr = EJT.grossProfitTransfer termTr - plus = norm $ EJ.projWithBase [Not :<(GrossProfit, (.#), e, Yen)] tr - minus = norm $ EJ.projWithBase [Hat :<(GrossProfit, (.#), e, Yen)] tr - return (plus - minus) - --- ================================================================ --- Simulation integration test --- ================================================================ - -simEps :: Double -simEps = 1e-6 - -assertSimNear :: String -> Double -> Double -> IO () -assertSimNear label expected actual - | abs (expected - actual) <= simEps = putStrLn ("[PASS] " ++ label) - | otherwise = do - putStrLn ("[FAIL] " ++ label) - putStrLn (" expected: " ++ show expected) - putStrLn (" actual : " ++ show actual) - exitFailure - -testSimulateEx1Default :: IO () -testSimulateEx1Default = do - let gen = mkStdGen 2025 - defaultEnv = SimInitVar - { _simInitStock = 20 - , _simInhouseRatio = 0.4 - , _simSteadyProduction = 10 - } - - wld <- ES.runSimulation gen defaultEnv - - -- Stock at term 1 for each company - stocks1 <- stToIO $ mapM (simGetTermStock wld 1) simCompanies - -- Stock at term 50 for each company - stocks50 <- stToIO $ mapM (simGetTermStock wld 50) simCompanies - -- Stock at term 100 for each company - stocks100 <- stToIO $ mapM (simGetTermStock wld 100) simCompanies - -- Gross profit at term 50 for each company - profits50 <- stToIO $ mapM (simGetTermGrossProfit wld 50) simCompanies - - -- Stock at t=1 - assertSimNear "sim1 stock(t=1,c=1)" 28.487224703666264 (stocks1 !! 0) - assertSimNear "sim1 stock(t=1,c=3)" 30.0 (stocks1 !! 2) - assertSimNear "sim1 stock(t=1,c=6)" 30.0 (stocks1 !! 5) -- re-baselined: union zero-base fix removed a phantom self-input - -- Stock at t=50 - assertSimNear "sim1 stock(t=50,c=1)" 304.9028131162567 (stocks50 !! 0) - assertSimNear "sim1 stock(t=50,c=4)" 292.4764622201871 (stocks50 !! 3) - -- Stock at t=100 - assertSimNear "sim1 stock(t=100,c=1)" 586.9595359862476 (stocks100 !! 0) - assertSimNear "sim1 stock(t=100,c=6)" 767.960563480499 (stocks100 !! 5) -- re-baselined: union zero-base fix (bug compounded over terms) - -- Gross profit at t=50 - assertSimNear "sim1 profit(t=50,c=1)" 0.35886554260018855 (profits50 !! 0) - assertSimNear "sim1 profit(t=50,c=2)" 1.572544209772035 (profits50 !! 1) - --- ================================================================ --- CSV Write tests --- ================================================================ - -testCsvTranspose :: IO () -testCsvTranspose = do - -- Square matrix - let input1 = [ [T.pack "a", T.pack "b"] - , [T.pack "c", T.pack "d"] ] - expected1 = [ [T.pack "a", T.pack "c"] - , [T.pack "b", T.pack "d"] ] - assertEqual "CSV.transpose square matrix" expected1 (EW.csvTranspose input1) - - -- Ragged matrix (shorter rows padded with empty) - let input2 = [ [T.pack "a", T.pack "b", T.pack "c"] - , [T.pack "d"] ] - expected2 = [ [T.pack "a", T.pack "d"] - , [T.pack "b", T.empty] - , [T.pack "c", T.empty] ] - assertEqual "CSV.transpose ragged matrix" expected2 (EW.csvTranspose input2) - - -- Single row - let input3 = [[T.pack "x", T.pack "y", T.pack "z"]] - expected3 = [[T.pack "x"], [T.pack "y"], [T.pack "z"]] - assertEqual "CSV.transpose single row" expected3 (EW.csvTranspose input3) - - -- Empty - assertEqual "CSV.transpose empty" ([] :: [[T.Text]]) (EW.csvTranspose []) - -testCsvWriteCSV :: IO () -testCsvWriteCSV = do - let path = "/tmp/exchangealgebra_csv_test.csv" - input = [ [T.pack "Name", T.pack "Value"] - , [T.pack "Alice", T.pack "100"] - , [T.pack "Bob", T.pack "200"] ] - EW.writeCSV path input - raw <- readFileStrict path - -- Each cell should be quoted - let lns = lines raw - assertEqual "CSV writeCSV line count" 3 (length lns) - assertEqual "CSV writeCSV header" "\"Name\",\"Value\"" (lns !! 0) - assertEqual "CSV writeCSV row 1" "\"Alice\",\"100\"" (lns !! 1) - assertEqual "CSV writeCSV row 2" "\"Bob\",\"200\"" (lns !! 2) - removeFile path - -testCsvWriteCSVWithQuotes :: IO () -testCsvWriteCSVWithQuotes = do - let path = "/tmp/exchangealgebra_csv_quote_test.csv" - input = [[T.pack "say \"hello\"", T.pack "a,b"]] - EW.writeCSV path input - raw <- readFileStrict path - let lns = lines raw - -- Internal quotes should be escaped as "" - assertEqual "CSV writeCSV escapes quotes" "\"say \"\"hello\"\"\",\"a,b\"" (lns !! 0) - removeFile path - -testCsvWriteCSVEmpty :: IO () -testCsvWriteCSVEmpty = do - let path = "/tmp/exchangealgebra_csv_empty_test.csv" - input = [[T.pack "", T.pack "x"]] - EW.writeCSV path input - raw <- readFileStrict path - let lns = lines raw - assertEqual "CSV writeCSV empty cell" "\"\",\"x\"" (lns !! 0) - removeFile path - --- | Regression tests for scale-aware numeric tolerance (WI-11/12/14). --- These exercise large magnitudes that the previous fixed @1e-13@ absolute --- tolerance handled incorrectly (retaining pure rounding noise as a residual); --- small-scale behavior is unchanged. See plans LAZY_EVAL_AUDIT.md s4.6. -testNumericToleranceScaleAware :: IO () -testNumericToleranceScaleAware = do - assertEqual "nearlyEqScaled: large-scale rounding treated as equal" - True (EA.nearlyEqScaled (1e10 + 0.1 + 0.2) (1e10 + 0.3 :: Double)) - assertEqual "isNearlyNum 1e-13: large-scale rounding rejected (documents old flaw)" - False (EA.isNearlyNum (1e10 + 0.1 + 0.2) (1e10 + 0.3) (1e-13 :: Double)) - assertEqual "nearlyEqScaled: small-scale noise treated as equal" - True (EA.nearlyEqScaled (0.1 + 0.2) (0.3 :: Double)) - assertEqual "nearlyEqScaled: genuine residual kept (not swallowed)" - False (EA.nearlyEqScaled (1e10 + 5.0) (1e10 :: Double)) - assertEqual "nearlyEqScaled: NaN guarded (no crash, not equal)" - False (EA.nearlyEqScaled (0/0) (1.0 :: Double)) - let big = (1e10 :@ (Hat :< Yen)) .+ (0.1 :@ (Hat :< Yen)) .+ (0.2 :@ (Hat :< Yen)) - .+ (1e10 :@ (Not :< Yen)) .+ (0.3 :@ (Not :< Yen)) :: TestAlg - assertEqual "bar cancels balanced large-scale element to Zero" - True (EA.isZero ((.-) big)) - --- | Strict file read helper for tests -readFileStrict :: FilePath -> IO String -readFileStrict p = do - bs <- TIO.readFile p - return (T.unpack bs) - --- ================================================================ --- Main --- ================================================================ - -main :: IO () -main = do - testProjMultiPatternOnePass - testProjNormFastPath - testProjWithBaseNorm - testProjWithNoteNorm - testBasesNotSideRegression - testNumericToleranceScaleAware - testUnionZeroSingletonBase - testSigmaMergePath - testSigma2When - testSigmaFromMap - testJournalSigmaMergePath - testJournalSigma2When - testJournalSigmaOn - testJournalSigmaOnFromMap - testFilterByAxisEquivalent - testFilterByAxisWithDeltaUpdates - testFinalStockTransferAlgEquivalence - testFinalStockTransferJournalEquivalence - testIncomeSummaryBalancedAlg - testIncomeSummaryBalancedJournal - testRestoreJournalFromBinarySpill - testSimulateEx1Default - testCsvTranspose - testCsvWriteCSV - testCsvWriteCSVWithQuotes - testCsvWriteCSVEmpty +import qualified ExchangeAlgebra.Convert as EC +import qualified ExchangeAlgebra.Convert.Checked as ECC +import qualified ExchangeAlgebra.Accounting.PostingPolicy as PP +import qualified ExchangeAlgebra.Consolidation.Worksheet as CW +import qualified ExchangeAlgebra.TrialBalance.Balance as TBB +import qualified ExchangeAlgebra.TrialBalance.Validation as TB +import qualified ExchangeAlgebra.Reporting.Presentation as RP +import qualified ExchangeAlgebra.Reporting.Metric as RM +import qualified ExchangeAlgebra.Reporting.Group as RG +import qualified ExchangeAlgebra.Convert.Csv as ECsv +import qualified ExchangeAlgebra.Assist as Assist +import qualified ExchangeAlgebra.Assist.Descriptions as AssistDesc +import qualified ExchangeAlgebra.Algebra.Base.Account.Registry as Registry +import qualified ExchangeAlgebra.Algebra as EA +import qualified ExchangeAlgebra.Algebra.Internal as EAI +import qualified ExchangeAlgebra.Algebra.Transfer as EAT +import qualified ExchangeAlgebra.Journal as EJ +import qualified ExchangeAlgebra.Journal.Transfer as EJT +import qualified ExchangeAlgebra.Bookkeeping as EB +import ExchangeAlgebra.Value (MoneyDecimal, bankersRound) +import qualified ExchangeAlgebra.Simulate as ES +import ExchangeAlgebra.Simulate +import qualified ExchangeAlgebra.Simulate.Lite as Lite +import ExchangeAlgebra.Simulate.Network + ( TradeNetwork, InputCoefficients, NetworkError(..) + , tradeNetwork, inputCoefficients + , nodes, edges, suppliersOf, buyersOf, edgeCount + , coefficient, inputsOf, sigmaEdges + , completeNetwork, kRegular, erdosRenyi, scaleFree, sectorBlock + , IndustrialEconomy(..), IndustrialOptions(..) + , defaultIndustrialOptions, industrialNetwork, industrialNetworkWith + , firms, industrialEdges + , TaxRate(..), taxOf, IndustrialFlows(..) + , FlowOptions(..), industrialFlows, industrialFlowsWith + , CoefOptions(..), defaultCoefOptions, randomCoefficients + , networkFromTable, coefficientsFromTable, fromCoefficientMatrix + , parseEdgeCsv, parseCoefCsv ) +import ExchangeAlgebra.Simulate.Lite + ( InitT, RefT, SnapT, HK + , Field(..), carry, resetEach, updateEach + , Stage, stage, stageFor, stageOf + , Par(..), SimSpec, mkSimSpec, runLite, runLiteWithPolicy ) +import qualified ExchangeAlgebra.Simulate.Policy as Policy +import ExchangeAlgebra.Value (MoneyDouble) +import qualified ExchangeAlgebra.Write as EW +import ExchangeAlgebra.Write +import qualified ExchangeAlgebra.Optimize as O +import qualified ExchangeAlgebra.Optimize.Annealing as OA +import qualified ExchangeAlgebra.Optimize.GA as OG +import qualified Data.Vector.Unboxed as UV + +import qualified Data.HashMap.Strict as HM +import qualified Data.Map.Strict as M +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set +import Data.Char (isAlpha, isAlphaNum, isAscii, isSpace) +import qualified Data.Binary as Binary +import qualified Data.Binary.Put as BinaryPut +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Numeric (showHex) +import Control.Monad (forM_) +import Control.Monad.ST +import Data.Array.ST +import Data.STRef +import System.Exit (exitFailure) +import System.IO (IOMode(WriteMode), withFile) +import Data.Time (Day, TimeOfDay(..), fromGregorian) +import System.Directory (removeFile) +import System.Random (StdGen, mkStdGen, randomR, split) +import Control.Monad (replicateM) +import Control.Monad.State (runState, state) +import Control.Exception (try, evaluate, ErrorCall, SomeException) +import Control.DeepSeq (force) +import Test.QuickCheck hiding (Fixed) +import GHC.Generics (Generic) +import System.Random (randomR) + +-- ================================================================ +-- Unit test helpers +-- ================================================================ + +eps :: Double +eps = 1e-9 + +assertEqual :: (Eq a, Show a) => String -> a -> a -> IO () +assertEqual label expected actual + | expected == actual = putStrLn ("[PASS] " ++ label) + | otherwise = do + putStrLn ("[FAIL] " ++ label) + putStrLn (" expected: " ++ show expected) + putStrLn (" actual : " ++ show actual) + exitFailure + +assertNear :: String -> Double -> Double -> IO () +assertNear label expected actual + | abs (expected - actual) <= eps = putStrLn ("[PASS] " ++ label) + | otherwise = do + putStrLn ("[FAIL] " ++ label) + putStrLn (" expected: " ++ show expected) + putStrLn (" actual : " ++ show actual) + exitFailure + +decodeAccountTitleOrFail :: BL.ByteString -> Either String AccountTitles +decodeAccountTitleOrFail bytes = case Binary.decodeOrFail bytes of + Left (_, _, message) -> Left message + Right (_, _, title) -> Right title + +testAccountTitlesBinary :: IO () +testAccountTitlesBinary = do + let titles = [minBound .. maxBound] :: [AccountTitles] + roundTripped = L.map (Binary.decode . Binary.encode) titles + invalidTag = fromIntegral (fromEnum (maxBound :: AccountTitles) + 1) + invalidBytes = BinaryPut.runPut (BinaryPut.putWord16be invalidTag) + assertEqual "AccountTitles Binary covers all 236 constructors" + 236 (L.length titles) + assertEqual "AccountTitles Binary Word16be roundtrip" + titles roundTripped + assertEqual "AccountTitles Binary rejects out-of-range Word16" + True (case decodeAccountTitleOrFail invalidBytes of + Left _ -> True + Right _ -> False) + +-- ================================================================ +-- AccountTitles classification exhaustiveness (Phase A) +-- ================================================================ +-- +-- Pins the (whatDiv, whichSide, fixedCurrent) classification of every +-- AccountTitles constructor against an explicit expected table that encodes +-- the Phase A design table. Any new constructor that is not added here makes +-- the test fail (the [minBound .. maxBound] traversal will hit a title absent +-- from the table), forcing the table to be kept in sync and guarding against +-- classifyAccountDivision's wildcard silently classifying a title as Assets. +-- +-- whichSide is evaluated on the @Not :< title@ base (no Hat reversal), so it +-- equals the "home side" implied by whatDiv: Debit for Assets/Cost, +-- Credit for Liability/Equity/Revenue. + +-- | Expected classification for every non-wildcard AccountTitles constructor. +-- (title, expected whatDiv, expected whichSide on Not-base, expected fixedCurrent) +accountTitleClassTable :: [(AccountTitles, AccountDivision, Side, FixedCurrent)] +accountTitleClassTable = + -- Pre-existing titles + [ (Cash, Assets, Debit, Current) + , (Deposits, Assets, Debit, Current) + , (CurrentDeposits, Assets, Debit, Current) + , (Securities, Assets, Debit, Current) + , (InvestmentSecurities, Assets, Debit, Fixed) + , (LongTermNationalBonds, Assets, Debit, Fixed) + , (ShortTermNationalBonds, Assets, Debit, Current) + , (Products, Assets, Debit, Current) + , (Machinery, Assets, Debit, Fixed) + , (Building, Assets, Debit, Fixed) + , (Vehicle, Assets, Debit, Fixed) + , (StockInvestment, Assets, Debit, Other) + , (EquipmentInvestment, Assets, Debit, Fixed) + , (LongTermLoansReceivable, Assets, Debit, Fixed) + , (AccountsReceivable, Assets, Debit, Current) + , (ShortTermLoansReceivable, Assets, Debit, Current) + , (ReserveDepositReceivable, Assets, Debit, Current) + , (Gold, Assets, Debit, Fixed) + , (GovernmentService, Assets, Debit, Current) + , (CapitalStock, Equity, Credit, Other) + , (RetainedEarnings, Equity, Credit, Other) + , (LongTermLoansPayable, Liability, Credit, Fixed) + , (ShortTermLoansPayable, Liability, Credit, Current) + , (LoansPayable, Liability, Credit, Current) + , (ReserveForDepreciation, Liability, Credit, Current) + , (DepositPayable, Liability, Credit, Current) + , (LongTermNationalBondsPayable, Liability, Credit, Fixed) + , (ShortTermNationalBondsPayable, Liability, Credit, Current) + , (ReserveDepositPayable, Liability, Credit, Current) + , (CentralBankNotePayable, Liability, Credit, Current) + , (Depreciation, Cost, Debit, Other) + , (AmortizationExpense, Cost, Debit, Other) + , (SalesCost, Cost, Debit, Other) + , (BusinessTrip, Cost, Debit, Other) + , (Commutation, Cost, Debit, Other) + , (UtilitiesExpense, Cost, Debit, Other) + , (RentExpense, Cost, Debit, Other) + , (AdvertisingExpense, Cost, Debit, Other) + , (DeliveryExpenses, Cost, Debit, Other) + , (SuppliesExpenses, Cost, Debit, Other) + , (MiscellaneousExpenses, Cost, Debit, Other) + , (WageExpenditure, Cost, Debit, Other) + , (InterestExpense, Cost, Debit, Other) + , (TaxesExpense, Cost, Debit, Other) + , (ConsumptionExpenditure, Cost, Debit, Other) + , (SubsidyExpense, Cost, Debit, Other) + , (CentralBankPaymentExpense, Cost, Debit, Other) + , (Purchases, Cost, Debit, Other) + , (NetIncome, Cost, Debit, Other) + , (ValueAdded, Revenue, Credit, Other) + , (SubsidyIncome, Revenue, Credit, Other) + , (NationalBondInterestEarned, Revenue, Credit, Other) + , (DepositInterestEarned, Revenue, Credit, Other) + , (GrossProfit, Revenue, Credit, Other) + , (OrdinaryProfit, Revenue, Credit, Other) + , (InterestEarned, Revenue, Credit, Other) + , (ReceiptFee, Revenue, Credit, Other) + , (RentalIncome, Revenue, Credit, Other) + , (WageEarned, Revenue, Credit, Other) + , (TaxesRevenue, Revenue, Credit, Other) + , (CentralBankPaymentIncome, Revenue, Credit, Other) + , (Sales, Revenue, Credit, Other) + , (NetLoss, Revenue, Credit, Other) + -- Phase A additions: Assets (資産) + , (PettyCash, Assets, Debit, Current) + , (NotesReceivable, Assets, Debit, Current) + , (ElectronicallyRecordedReceivable, Assets, Debit, Current) + , (CreditCardReceivable, Assets, Debit, Current) + , (NotesLoansReceivable, Assets, Debit, Current) + , (MerchandiseInventory, Assets, Debit, Current) + , (AdvancesPaid, Assets, Debit, Current) + , (PrepaidExpenses, Assets, Debit, Current) + , (AccruedRevenue, Assets, Debit, Current) + , (OtherReceivables, Assets, Debit, Current) + , (PaymentsOnBehalf, Assets, Debit, Current) + , (SuspensePayments, Assets, Debit, Current) + , (ConsumptionTaxPaid, Assets, Debit, Current) + , (PrepaidCorporateIncomeTaxes, Assets, Debit, Current) + , (Land, Assets, Debit, Fixed) + , (Fixtures, Assets, Debit, Fixed) + , (Patent, Assets, Debit, Fixed) + , (Trademark, Assets, Debit, Fixed) + , (Software, Assets, Debit, Fixed) + , (CashOverShort, Assets, Debit, Other) + -- Phase A additions: Liability (負債) + , (AccountsPayable, Liability, Credit, Current) + , (NotesPayable, Liability, Credit, Current) + , (ElectronicallyRecordedObligations, Liability, Credit, Current) + , (NotesLoansPayable, Liability, Credit, Current) + , (BankOverdraft, Liability, Credit, Current) + , (AdvancesReceived, Liability, Credit, Current) + , (UnearnedRevenue, Liability, Credit, Current) + , (AccruedExpenses, Liability, Credit, Current) + , (OtherPayables, Liability, Credit, Current) + , (DepositsReceived, Liability, Credit, Current) + , (SuspenseReceipts, Liability, Credit, Current) + , (ConsumptionTaxReceived, Liability, Credit, Current) + , (AccruedConsumptionTax, Liability, Credit, Current) + , (AccruedCorporateIncomeTaxes, Liability, Credit, Current) + , (UnpaidDividends, Liability, Credit, Current) + , (AllowanceForDoubtfulAccounts, Assets, Credit, Current) -- contra asset (isContra) + , (AccumulatedDepreciation, Assets, Credit, Fixed) -- contra asset (isContra) + -- Phase A additions: Equity (資本) + , (LegalRetainedEarnings, Equity, Credit, Other) + -- Phase A additions: Cost (費用) + , (ProvisionForDoubtfulAccounts, Cost, Debit, Other) + , (BadDebtLoss, Cost, Debit, Other) + , (LossOnSalesOfFixedAssets, Cost, Debit, Other) + , (LossOnSalesOfNotesReceivable, Cost, Debit, Other) + , (PaymentFees, Cost, Debit, Other) + , (MiscellaneousLoss, Cost, Debit, Other) + , (CorporateIncomeTaxes, Cost, Debit, Other) + , (CommunicationExpenses, Cost, Debit, Other) + -- Phase A additions: Revenue (収益) + , (GainOnSalesOfFixedAssets, Revenue, Credit, Other) + , (RecoveryOfBadDebts, Revenue, Credit, Other) + , (MiscellaneousIncome, Revenue, Credit, Other) + -- Phase B addition: Revenue (収益) + , (ReversalOfAllowanceForDoubtfulAccounts, Revenue, Credit, Other) + -- T4b additions: equity-method accounts + , (InvestmentInAssociate, Assets, Debit, Fixed) + , (EquityInEarningsOfInvestee, Revenue, Credit, Other) + -- FX library additions: OCI/capital accounts + , (CumulativeTranslationAdjustment, Equity, Credit, Other) + -- V-Land 2 additions + , (TimeDeposits, Assets, Debit, Current) + , (LoansReceivable, Assets, Debit, Current) + , (GiftCertificatesReceived, Assets, Debit, Current) + , (SecurityDepositsPaid, Assets, Debit, Fixed) + , (SuppliesOnHand, Assets, Debit, Current) + , (ContractAssets, Assets, Debit, Current) + , (IncomeTaxesRefundReceivable, Assets, Debit, Current) + , (WorkInProcess, Assets, Debit, Current) + , (DeferredTaxAssets, Assets, Debit, Fixed) + , (LeasedAssets, Assets, Debit, Fixed) + , (ToolsAndInstruments, Assets, Debit, Fixed) + , (ConstructionInProgress, Assets, Debit, Fixed) + , (Goodwill, Assets, Debit, Fixed) + , (SoftwareInProgress, Assets, Debit, Fixed) + , (LongTermPrepaidExpenses, Assets, Debit, Fixed) + , (DishonoredNotesReceivable, Assets, Debit, Current) + , (PrepaidPensionCost, Assets, Debit, Fixed) + , (NetDefinedBenefitAsset, Assets, Debit, Fixed) + , (DepositsInSpecialAccounts, Assets, Debit, Current) + , (Structures, Assets, Debit, Fixed) + , (LeaseholdRights, Assets, Debit, Fixed) + , (NonOperatingNotesReceivable, Assets, Debit, Current) + , (NonOperatingElectronicallyRecordedReceivable, Assets, Debit, Current) + , (RefundLiabilities, Liability, Credit, Current) + , (NonOperatingNotesPayable, Liability, Credit, Current) + , (NonOperatingElectronicallyRecordedObligations, Liability, Credit, Current) + , (BonusesPayable, Liability, Credit, Current) + , (AllowanceForRepairs, Liability, Credit, Current) + , (AllowanceForProductWarranties, Liability, Credit, Current) + , (AllowanceForBonuses, Liability, Credit, Current) + , (DeferredTaxLiabilities, Liability, Credit, Fixed) + , (LeaseObligations, Liability, Credit, Fixed) + , (GuaranteeDepositsReceived, Liability, Credit, Fixed) + , (AllowanceForRetirementBenefits, Liability, Credit, Fixed) + , (LongTermOtherPayables, Liability, Credit, Fixed) + , (NetDefinedBenefitLiability, Liability, Credit, Fixed) + , (StockSubscriptionDeposits, Equity, Credit, Other) + , (LegalCapitalSurplus, Equity, Credit, Other) + , (OtherCapitalSurplus, Equity, Credit, Other) + , (DividendEqualizationReserve, Equity, Credit, Other) + , (RepairFundReserve, Equity, Credit, Other) + , (ConstructionFundReserve, Equity, Credit, Other) + , (GeneralReserve, Equity, Credit, Other) + , (ValuationDifferenceOnOtherSecurities, Equity, Credit, Other) + , (NonControllingInterests, Equity, Credit, Other) + , (CapitalSurplus, Equity, Credit, Other) + , (EarnedSurplus, Equity, Credit, Other) + , (ServiceRevenue, Revenue, Credit, Other) + , (OperatingRevenue, Revenue, Credit, Other) + , (GainOnSalesOfSecurities, Revenue, Credit, Other) + , (GainOnValuationOfSecurities, Revenue, Credit, Other) + , (DividendsReceived, Revenue, Credit, Other) + , (InterestOnSecurities, Revenue, Credit, Other) + , (GainOnSalesOfInvestmentSecurities, Revenue, Credit, Other) + , (InsuranceGain, Revenue, Credit, Other) + , (GainOnBargainPurchase, Revenue, Credit, Other) + , (ReversalOfAllowanceForRepairs, Revenue, Credit, Other) + , (ReversalOfAllowanceForProductWarranties, Revenue, Credit, Other) + , (GainOnDonationOfFixedAssets, Revenue, Credit, Other) + , (GainOnNationalSubsidies, Revenue, Credit, Other) + , (GainOnConstructionGrants, Revenue, Credit, Other) + , (LandRentReceived, Revenue, Credit, Other) + , (SalesRebates, Revenue, Debit, Other) + , (CostOfServices, Cost, Debit, Other) + , (OperatingExpenses, Cost, Debit, Other) + , (InventoryShrinkageLoss, Cost, Debit, Other) + , (LossOnValuationOfMerchandise, Cost, Debit, Other) + , (Bonuses, Cost, Debit, Other) + , (RetirementBenefitExpenses, Cost, Debit, Other) + , (ProvisionForRepairs, Cost, Debit, Other) + , (ProvisionForBonuses, Cost, Debit, Other) + , (ProvisionForProductWarranties, Cost, Debit, Other) + , (ResearchAndDevelopmentExpenses, Cost, Debit, Other) + , (AmortizationOfGoodwill, Cost, Debit, Other) + , (AmortizationOfSoftware, Cost, Debit, Other) + , (AmortizationOfPatents, Cost, Debit, Other) + , (LeaseExpenses, Cost, Debit, Other) + , (IncorporationExpenses, Cost, Debit, Other) + , (StockIssuanceCosts, Cost, Debit, Other) + , (BusinessCommencementExpenses, Cost, Debit, Other) + , (DevelopmentExpenses, Cost, Debit, Other) + , (LossOnSalesOfElectronicallyRecordedReceivables, Cost, Debit, Other) + , (LossOnSalesOfReceivables, Cost, Debit, Other) + , (LossOnSalesOfSecurities, Cost, Debit, Other) + , (LossOnValuationOfSecurities, Cost, Debit, Other) + , (LossOnSalesOfInvestmentSecurities, Cost, Debit, Other) + , (LossOnFire, Cost, Debit, Other) + , (LossOnRetirementOfFixedAssets, Cost, Debit, Other) + , (LossOnReductionOfFixedAssets, Cost, Debit, Other) + , (AdditionalIncomeTaxesForPriorPeriods, Cost, Debit, Other) + , (RefundOfIncomeTaxes, Cost, Credit, Other) + , (PurchaseRebates, Cost, Credit, Other) + , (WelfareExpenses, Cost, Debit, Other) + , (MaintenanceExpenses, Cost, Debit, Other) + , (StatutoryWelfareExpenses, Cost, Debit, Other) + , (LandRentPaid, Cost, Debit, Other) + , (InsuranceExpense, Cost, Debit, Other) + , (RepairsExpense, Cost, Debit, Other) + , (StorageExpenses, Cost, Debit, Other) + , (MembershipFees, Cost, Debit, Other) + , (IncomeSummary, Assets, Debit, Other) + , (SuspenseAccount, Assets, Debit, Current) + , (ForeignExchangeGains, Revenue, Credit, Other) + , (ForeignExchangeLosses, Cost, Debit, Other) + , (ContraAccountForGuaranteeObligations, Assets, Debit, Other) + , (GuaranteeObligations, Liability, Credit, Other) + , (IncomeTaxesAdjustment, Cost, Debit, Other) + , (BranchCurrentAccount, Assets, Debit, Other) + , (HeadOfficeCurrentAccount, Liability, Credit, Other) + , (NetIncomeAttributableToNCI, Cost, Debit, Other) + , (NetLossAttributableToNCI, Revenue, Credit, Other) + , (TradingSecurities, Assets, Debit, Current) + , (HeldToMaturityBonds, Assets, Debit, Fixed) + , (SubsidiaryStocks, Assets, Debit, Fixed) + , (AffiliateStocks, Assets, Debit, Fixed) + , (AvailableForSaleSecurities, Assets, Debit, Fixed) + , (ConsumptionTaxRefundReceivable, Assets, Debit, Current) + , (PropertyTaxPayable, Liability, Credit, Current) + , (DepositsReceivedFromOfficers, Liability, Credit, Current) + ] + +testAccountTitleClassification :: IO () +testAccountTitleClassification = do + -- All non-wildcard constructors, derived from Bounded/Enum. + let allTitles = [ t | t <- [minBound .. maxBound], t /= AccountTitle ] + tableMap = M.fromList [ (t, (d, s, fc)) | (t, d, s, fc) <- accountTitleClassTable ] + -- A title is "covered" iff it appears in the expected table. + missing = [ t | t <- allTitles, not (M.member t tableMap) ] + extra = [ t | (t, _, _, _) <- accountTitleClassTable, t `notElem` allTitles ] + -- Guard: the table must list exactly the non-wildcard constructors. + assertEqual "AccountTitles class table covers every constructor (no missing)" + ([] :: [AccountTitles]) missing + assertEqual "AccountTitles class table has no stale entry (no extra)" + ([] :: [AccountTitles]) extra + -- Per-title classification must match the expected table. + forM_ allTitles $ \t -> do + let base = Not :< t :: HatBase AccountTitles + actual = (whatDiv base, whichSide base, fixedCurrent base) + case M.lookup t tableMap of + Just expected -> + assertEqual ("classification of " ++ show t) expected actual + Nothing -> return () -- already reported by the "missing" guard + +type TestAlg = EA.Alg Double (HatBase CountUnit) +type TestJournal = EJ.Journal String Double (HatBase CountUnit) +type AxisJournal = EJ.Journal (String, Int) Double (HatBase CountUnit) + +algSample :: TestAlg +algSample = + (1 :@ (Hat :< Yen)) + .+ (1 :@ (Not :< Amount)) + .+ (2 :@ (Not :< Yen)) + .+ (2 :@ (Hat :< Amount)) + .+ (3 :@ (Hat :< Yen)) + +journalSample :: TestJournal +journalSample = EJ.fromList [x, y, z] + where + x = ((1 :@ (Hat :< Yen)) .+ (1 :@ (Not :< Amount))) .| "cat" :: TestJournal + y = ((2 :@ (Not :< Yen)) .+ (2 :@ (Hat :< Amount))) .| "dog" :: TestJournal + z = ((3 :@ (Hat :< Yen)) .+ (3 :@ (Not :< Amount))) .| "fish" :: TestJournal + +testReplaceNotesMatchesInsert :: IO () +testReplaceNotesMatchesInsert = do + let x = (10.00 .@ (Not :< Cash)) .| "A" + :: EJ.Journal String Double (HatBase AccountTitles) + y = (20.00 .@ (Not :< Cash)) .| "B" + :: EJ.Journal String Double (HatBase AccountTitles) + z = (30.00 .@ (Hat :< Cash)) .| "A" + :: EJ.Journal String Double (HatBase AccountTitles) + source = x .+ y + expected = z .+ y + assertEqual "Journal.replaceNotes replaces the complete matching Note" + (EJ.toMap expected) + (EJ.toMap (EJ.replaceNotes z source)) + assertEqual "Journal.replaceNotes matches insert" + (EJ.toMap (EJ.insert z source)) + (EJ.toMap (EJ.replaceNotes z source)) + +testMapPosting :: IO () +testMapPosting = do + let source = (1 .@ (Hat :< Yen)) + .+ (2 .@ (Hat :< Yen)) + .+ (3 .@ (Not :< Amount)) + .+ (4 .@ (Hat :< Amount)) + :: TestAlg + actual = EA.mapPosting (\v b -> (2 * v, b)) source + assertNear "Algebra.mapPosting doubles norm" + (2 * norm source) (norm actual) + assertEqual "Algebra.mapPosting preserves posting count" + (length (EA.toList source)) (length (EA.toList actual)) + assertEqual "Algebra.mapPosting preserves posting order" + (EA.toList (2 .* source)) (EA.toList actual) + +testMapMaybePosting :: IO () +testMapMaybePosting = do + let droppedBase = Not :< Amount :: HatBase CountUnit + zeroedBase = Hat :< Yen :: HatBase CountUnit + source = (1 .@ (Hat :< Yen)) + .+ (2 .@ (Hat :< Yen)) + .+ (3 .@ droppedBase) + .+ (4 .@ (Hat :< Amount)) + :: TestAlg + dropped = EA.mapMaybePosting + (\v b -> if b == droppedBase then Nothing else Just (v, b)) + source + zeroed = EA.mapMaybePosting + (\v b -> Just (if b == zeroedBase then 0 else v, b)) + source + without b = L.filter (\posting -> case posting of + _ :@ b' -> b' /= b + _ -> False) + assertNear "Algebra.mapMaybePosting drop decreases norm" + (norm source - 3) (norm dropped) + assertEqual "Algebra.mapMaybePosting drop preserves remaining order" + (without droppedBase (EA.toList source)) (EA.toList dropped) + assertEqual "Algebra.mapMaybePosting normalises zero values away" + (without zeroedBase (EA.toList source)) (EA.toList zeroed) + +-- | Multi-pattern 'proj' uses __set__ semantics: a duplicated query selects the +-- same posting only once (no double counting). The de-duplicated query list and +-- its de-duplicated counterpart must give identical results. +testProjMultiPatternOnePass :: IO () +testProjMultiPatternOnePass = do + let qs, qsDedup :: [HatBase CountUnit] + qs = [Hat :< Yen, HatNot :< Amount, Hat :< Yen] -- Hat:<Yen duplicated + qsDedup = [Hat :< Yen, HatNot :< Amount] + -- duplicate query does not change the projection (set semantics) + assertEqual "Alg.proj treats query list as a set (duplicate exact)" + (EA.proj qsDedup algSample) (EA.proj qs algSample) + -- and the duplicated Hat:<Yen is counted once, not twice + assertEqual "Alg.proj no double counting (single Hat:<Yen)" + (EA.proj [Hat :< Yen] algSample) + (EA.proj [Hat :< Yen, Hat :< Yen] algSample) + +-- | 'projNetNorm' returns a bar-netted norm; the identity is +-- @projNetNorm bs x == norm (bar (proj bs x))@ (not @norm (proj bs x)@), and the +-- query list is a set (duplicates do not double count). +testProjNormFastPath :: IO () +testProjNormFastPath = do + let qs :: [HatBase CountUnit] + qs = [Hat :< Yen, HatNot :< Amount, Hat :< Yen] + expected = norm $ EA.bar $ EA.proj qs algSample + actual = EA.projNetNorm qs algSample + assertNear "Alg.projNetNorm == norm . bar . proj (set semantics)" expected actual + +-- | R7 sentinel (a): a duplicated exact base must project the same as a single +-- copy (MoneyDecimal exact: no floating tolerance needed). +testProjDuplicateExact :: IO () +testProjDuplicateExact = do + let alg :: EA.Alg MoneyDecimal (HatBase CountUnit) + alg = (10 :@ (Hat :< Yen)) + .+ (3 :@ (Not :< Amount)) + b = Hat :< Yen :: HatBase CountUnit + assertEqual "proj [b,b] == proj [b] (duplicate exact, MoneyDecimal)" + (EA.proj [b] alg) (EA.proj [b, b] alg) + assertEqual "projNetNorm [b,b] == projNetNorm [b] (duplicate exact)" + (EA.projNetNorm [b] alg) (EA.projNetNorm [b, b] alg) + +-- | R7 sentinel (b): an exact base together with a wildcard query that subsumes +-- it must not double count the overlapping posting. +testProjExactWildcardOverlap :: IO () +testProjExactWildcardOverlap = do + let alg :: EA.Alg MoneyDecimal (HatBase CountUnit) + alg = (10 :@ (Hat :< Yen)) + .+ (5 :@ (Not :< Amount)) + exact = Hat :< Yen :: HatBase CountUnit + wild = Hat :< (.#) :: HatBase CountUnit -- subsumes Hat:<Yen + -- the wildcard already selects everything the exact base does, so the union + -- equals the wildcard alone (overlap counted once) + assertEqual "proj [exact,wild] == proj [wild] (overlap, no double count)" + (EA.proj [wild] alg) (EA.proj [exact, wild] alg) + assertEqual "projNetNorm [exact,wild] == projNetNorm [wild] (overlap)" + (EA.projNetNorm [wild] alg) (EA.projNetNorm [exact, wild] alg) + +-- | R7 sentinel (c): the bar-netted identity @projNetNorm bs x == norm (bar (proj +-- bs x))@ holds on a base carrying both hat and not sides (where it differs from +-- @norm (proj bs x)@). +testProjNormBarIdentity :: IO () +testProjNormBarIdentity = do + let alg :: EA.Alg MoneyDecimal (HatBase CountUnit) + alg = (10 :@ (Hat :< Yen)) -- Yen carries both sides + .+ (4 :@ (Not :< Yen)) + .+ (7 :@ (Not :< Amount)) + bs = [HatNot :< Yen, HatNot :< Amount] :: [HatBase CountUnit] + assertEqual "projNetNorm == norm . bar . proj (both-sided base, MoneyDecimal)" + (norm (EA.bar (EA.proj bs alg))) (EA.projNetNorm bs alg) + +testProjWithBaseNorm :: IO () +testProjWithBaseNorm = do + let bs :: [HatBase CountUnit] + bs = [Not :< Amount] + expected = norm $ EJ.projWithBase bs journalSample + actual = EJ.projWithBaseNetNorm bs journalSample + assertNear "Journal.projWithBaseNetNorm matches norm . projWithBase" expected actual + +testProjWithNoteNorm :: IO () +testProjWithNoteNorm = do + let bs :: [HatBase CountUnit] + bs = [HatNot :< Amount, Hat :< Yen] + ns1 = ["dog", "cat"] + ns2 = [plank] + expected1 = norm $ EJ.projWithNoteBase ns1 bs journalSample + actual1 = EJ.projWithNoteBaseNetNorm ns1 bs journalSample + expected2 = norm $ EJ.projWithNoteBase ns2 bs journalSample + actual2 = EJ.projWithNoteBaseNetNorm ns2 bs journalSample + assertNear "Journal.projWithNoteBaseNetNorm (selected notes)" expected1 actual1 + assertNear "Journal.projWithNoteBaseNetNorm (plank wildcard)" expected2 actual2 + +-- | Sentinel for the REMOVED RULES rewrite +-- @norm (projWithBase bs js) = projWithBaseNetNorm bs js@ (and the note-base +-- analogue): the equation is false when a query selects both sides of one +-- base. 'EJ.projWithBaseNetNorm' \/ 'EJ.projWithNoteBaseNetNorm' are the /bar-netted/ +-- read-outs (per base @|not - hat|@), while @norm . projWithBase@ is the +-- gross norm (sums both sides). Both values are pinned here so a future +-- \"optimization\" that silently nets the gross path fails loudly. +testProjWithBaseNormBothSided :: IO () +testProjWithBaseNormBothSided = do + let alg :: EA.Alg MoneyDecimal (HatBase CountUnit) + alg = (10 :@ (Hat :< Yen)) -- Yen carries both sides + .+ (4 :@ (Not :< Yen)) + .+ (7 :@ (Not :< Amount)) + js = alg .| "n" :: EJ.Journal String MoneyDecimal (HatBase CountUnit) + bs = [HatNot :< Yen] :: [HatBase CountUnit] + assertEqual "projWithBaseNetNorm nets both sides (HatNot query): |10-4|" + 6 (EJ.projWithBaseNetNorm bs js) + assertEqual "norm . projWithBase stays gross (no RULES rewrite): 10+4" + 14 (norm (EJ.projWithBase bs js)) + assertEqual "projWithBaseNetNorm == norm . map bar . projWithBase" + (norm (EJ.map EA.bar (EJ.projWithBase bs js))) + (EJ.projWithBaseNetNorm bs js) + assertEqual "projWithNoteBaseNetNorm nets both sides (HatNot query): |10-4|" + 6 (EJ.projWithNoteBaseNetNorm ["n"] bs js) + assertEqual "norm . projWithNoteBase stays gross (no RULES rewrite): 10+4" + 14 (norm (EJ.projWithNoteBase ["n"] bs js)) + +-- | Regression test for the `bases` typo bug. +-- +-- Before the fix at Algebra.hs:868, `bases` ignored the `_notSide` Seq and +-- iterated `_hatSide` twice (with `Hat` and `Not` labels). As a result, +-- `length (bases x) != length (vals x)` whenever Hat/Not Seq lengths differed. +-- +-- This test constructs an Alg where the Hat Seq for `Yen` has length 1 and +-- the Not Seq has length 2, plus a separate basis whose Hat Seq is empty. +-- That makes the divergence detectable in both directions. +testBasesNotSideRegression :: IO () +testBasesNotSideRegression = do + let alg :: TestAlg + alg = (100 :@ (Hat :< Yen)) -- Yen: hatSide = [100] + .+ (50 :@ (Not :< Yen)) -- Yen: notSide = [50] + .+ (30 :@ (Not :< Yen)) -- Yen: notSide = [50, 30] + .+ (20 :@ (Not :< Amount)) -- Amount: notSide = [20], hatSide = [] + vs = EA.vals alg + bs = EA.bases alg + hatCount = length (L.filter isHat bs) + notCount = length (L.filter (not . isHat) bs) + -- vals and bases must agree on total count (one label per scalar entry) + assertEqual "bases/vals same length (regression for hs/ns typo)" + (length vs) (length bs) + -- Expected: 1 Hat label (Hat:<Yen) and 3 Not labels (50:<Yen, 30:<Yen, 20:<Amount) + assertEqual "bases Hat label count" 1 hatCount + assertEqual "bases Not label count" 3 notCount + +testSigmaMergePath :: IO () +testSigmaMergePath = do + let xs = [1 .. 5 :: Int] + f :: Int -> TestAlg + f i + | i == 3 = EA.Zero + | odd i = fromIntegral i :@ (Hat :< Yen) + | otherwise = fromIntegral i :@ (Not :< Amount) + expected :: TestAlg + expected = EA.unionsMerge (L.map f xs) + actual :: TestAlg + actual = EA.sigma xs f + assertEqual "Alg.sigma bulk-merge path matches unionsMerge" expected actual + +-- | Characterization: the same-base 'Seq' order is __construction-path +-- dependent__. The pairwise-union path ('EA.fromList' = 'mconcat') and the +-- bulk-merge path ('EA.sigma' \/ 'EA.unionsMerge') produce the same /multiset/ +-- of postings but in different sequence orders, which 'Eq' \/ @Binary@ observe +-- (and 'Double' observes through the last ULP of 'norm'\/'bar' association). +-- This test pins the current orders so any change to either path is a +-- conscious decision; unifying the paths is tracked in the 0.5.0.0 cleanup +-- plan. For order-independent comparison use `MoneyDecimal` (exact) or compare +-- after 'EA.compress'\/'EA.bar'. +testSameBaseSeqOrderPathDependence :: IO () +testSameBaseSeqOrderPathDependence = do + let f :: Int -> TestAlg + f i = fromIntegral i :@ (Hat :< Yen) + xs = L.map f [1, 2, 3] + viaFromList = EA.fromList xs + viaSigma = EA.sigma [1, 2, 3] f + viaMerge = EA.unionsMerge xs + assertEqual "fromList same-base seq order (pairwise-union path)" + [3, 1, 2] (EA.vals viaFromList) + assertEqual "sigma same-base seq order (bulk-merge path)" + [3, 2, 1] (EA.vals viaSigma) + assertEqual "unionsMerge order matches sigma (same merge path)" + (EA.vals viaSigma) (EA.vals viaMerge) + -- same multiset, different order: Eq observes the redundancy order + assertEqual "fromList /= sigma under Eq (order is observable)" + False (viaFromList == viaSigma) + -- the algebraic content is nevertheless identical + assertNear "norm agrees across construction paths" + (norm viaFromList) (norm viaSigma) + assertEqual "bar agrees across construction paths" + (EA.bar viaFromList) (EA.bar viaSigma) + +testSigma2When :: IO () +testSigma2When = do + let xs = [1 .. 3 :: Int] + ys = [1 .. 4 :: Int] + cond i j = i /= j && even (i + j) + f :: Int -> Int -> TestAlg + f i j = + let v = fromIntegral (i * 10 + j) + in if odd i + then v :@ (Hat :< Yen) + else v :@ (Not :< Amount) + expected :: TestAlg + expected = + EA.unionsMerge + [ f i j + | i <- xs + , j <- ys + , cond i j + ] + actual :: TestAlg + actual = EA.sigma2When xs ys cond f + assertEqual "Alg.sigma2When matches list-comprehension sum" expected actual + +testSigmaFromMap :: IO () +testSigmaFromMap = do + let kvs = M.fromList + [ ((1, 2), 5.0) + , ((2, 3), 0.0) + , ((3, 1), 7.0) + ] :: M.Map (Int, Int) Double + f :: (Int, Int) -> Double -> TestAlg + f (i, j) v + | i < j = v :@ (Hat :< Yen) + | otherwise = v :@ (Not :< Amount) + expected :: TestAlg + expected = EA.unionsMerge + [ f (1, 2) 5.0 + , f (3, 1) 7.0 + ] + actual :: TestAlg + actual = EA.sigmaFromMap kvs f + assertEqual "Alg.sigmaFromMap iterates non-zero map entries only" expected actual + +testJournalFromListStrict :: IO () +testJournalFromListStrict = do + -- fromList is now a strict left fold (L.foldl' (.+) mempty). Verify it still + -- preserves the posting multiset by matching the old lazy right-fold reference + -- (foldr (.+) mempty). Colliding note keys (i `mod` 30) force same-note/same-base + -- postings into one Alg sequence, where the two folds accumulate in opposite + -- order; with MoneyDecimal (exact, associative) the aggregate (norm) is identical. + let mk i = ((fromIntegral (i `mod` 7 + 1) :: MoneyDecimal) + :@ ((if even i then Hat else Not) :< ([Yen, Amount] !! (i `mod` 2)))) + .| show (i `mod` 30) + xs :: [Journal String MoneyDecimal (HatBase CountUnit)] + xs = [ mk i | i <- [1 .. 400 :: Int] ] + strict = EJ.fromList xs + lazyRef = foldr (.+) mempty xs + -- exact value type ⇒ norm identical regardless of seq order (multiset preserved) + assertEqual "Journal.fromList (strict): norm matches lazy foldr reference (MoneyDecimal exact)" + (norm strict) (norm lazyRef) + -- distinct note keys ⇒ no seq collision ⇒ exact structural equality with foldr + let ys :: [Journal String MoneyDecimal (HatBase CountUnit)] + ys = [ ((fromIntegral i :: MoneyDecimal) :@ (Not :< Yen)) .| show i + | i <- [1 .. 20 :: Int] ] + assertEqual "Journal.fromList (strict): structurally equal to foldr for distinct notes" + (EJ.toMap (EJ.fromList ys)) (EJ.toMap (foldr (.+) mempty ys)) + +-- | Regression test for the @union@ zero-singleton base-relabel bug +-- (Algebra.hs). When one operand of @(.+)@ is a /zero-valued/ singleton on base +-- @b1@ and the other a /real/ singleton on a different base @b2@, the result must +-- keep the real value on its OWN base (@v2:@b2@), not relabel it onto the zero +-- posting's base. The old code returned @v2:@b1@ / @v1:@b2@, which silently moved +-- a value to the wrong base. It preserved @norm@ (total unchanged) but corrupted +-- per-base projection, and surfaced as construction-order-dependent simulation +-- results (sparsified coefficients build explicit @0:@base@ singletons via raw +-- @(:@)@). See plans/in-progress/SELECTABLE_VALUE_TYPE_PLAN.md (Stage D). +testUnionZeroSingletonBase :: IO () +testUnionZeroSingletonBase = do + let zb = 0 :@ (Hat :< Yen) :: TestAlg -- zero value, base Yen + rb = 5 :@ (Hat :< Amount) :: TestAlg -- real value, base Amount + -- both fold directions of the singleton/singleton union + assertEqual "union zero(.+)real keeps real value on its own base" + rb (EA.proj [Hat :< Amount] (zb .+ rb)) + assertEqual "union real(.+)zero keeps real value on its own base" + rb (EA.proj [Hat :< Amount] (rb .+ zb)) + -- the real value must NOT appear on the zero posting's base + assertEqual "union zero(.+)real: nothing relabeled onto the zero's base" + (EA.Zero :: TestAlg) (EA.proj [Hat :< Yen] (zb .+ rb)) + assertEqual "union real(.+)zero: nothing relabeled onto the zero's base" + (EA.Zero :: TestAlg) (EA.proj [Hat :< Yen] (rb .+ zb)) + +-- | Regression for audit divergence C: scalar product (.*) must reject a +-- negative / non-finite scalar instead of silently producing negative +-- (out-of-domain) postings. (Pre-fix, (.*) used raw (:@) and bypassed the +-- isErrorValue check that (.@) performs.) +testScalarRejectsNegative :: IO () +testScalarRejectsNegative = do + let xD = 10 :@ (Not :< Yen) :: TestAlg + rD <- try (evaluate (norm ((-1) .* xD))) :: IO (Either SomeException Double) + case rD of + Left _ -> putStrLn "[PASS] (.*) rejects negative scalar (Double)" + Right v -> do putStrLn ("[FAIL] (.*) negative scalar leaked (Double): " ++ show v); exitFailure + let xN = 10 :@ (Not :< Yen) :: EA.Alg MoneyDecimal (HatBase CountUnit) + rN <- try (evaluate (norm ((-1) .* xN))) :: IO (Either SomeException MoneyDecimal) + case rN of + Left _ -> putStrLn "[PASS] (.*) rejects negative scalar (MoneyDecimal)" + Right v -> do putStrLn ("[FAIL] (.*) negative scalar leaked (MoneyDecimal): " ++ show v); exitFailure + -- non-negative scalar still works + assertNear "(.*) non-negative scalar works" 20.0 (norm (2 .* xD)) + +-- Step 1 (concrete projection keeps the axis index lazy): the module is compiled +-- @Strict@, so a concrete (non-wildcard) 'projNetNorm' must NOT force the lazy +-- @_axisPosting@ index (it should be a plain 'Map.lookup'); a wildcard 'projNetNorm' +-- must use (force) it. We poison the index fields with 'error' and check which +-- projection crashes. Guards the projExactMap/projWildMap split. +testProjConcreteNoIndexForce :: IO () +testProjConcreteNoIndexForce = do + let alg :: EA.Alg Double SimHatBase2 + alg = EA.fromList [ 10 :@ Not :< (Cash, 1, 1, Yen) + , 20 :@ Not :< (Products, 2, 2, Amount) + , 30 :@ Hat :< (Cash, 3, 3, Yen) ] + case alg of + EAI.Liner m _ _ _ _ _ -> do + let poison = EAI.Liner m (error "POISON") (error "POISON") + (error "POISON") (error "POISON") (error "POISON") + rc <- try (evaluate (EA.projNetNorm [Not :< (Cash, 1, 1, Yen)] poison)) + :: IO (Either SomeException Double) + case rc of + Right v | v == 10.0 -> putStrLn "[PASS] concrete projNetNorm does not force the axis index" + Right v -> do putStrLn ("[FAIL] concrete projNetNorm wrong value: " ++ show v); exitFailure + Left _ -> do putStrLn "[FAIL] concrete projNetNorm forced the (poisoned) axis index"; exitFailure + rw <- try (evaluate (EA.projNetNorm [Not :< (Cash, (.#), 1, Yen)] poison)) + :: IO (Either SomeException Double) + case rw of + Left _ -> putStrLn "[PASS] wildcard projNetNorm uses the axis index (forced, as required)" + Right v -> do putStrLn ("[FAIL] wildcard projNetNorm did not use the index: " ++ show v); exitFailure + _ -> do putStrLn "[FAIL] expected a Liner"; exitFailure + +-- The Liner @_bpToId@ and @_nextBpId@ fields are reserved for the dormant P1a +-- incremental-id scheme and are not maintained by 'linerFromMap' (it leaves them +-- as lazy 'error' poison). This guards two invariants: (1) normal projection +-- (concrete + wildcard) never forces those poisoned fields, so 'projWildMap' +-- stays green; (2) forcing the unused fields fails loudly (as designed) rather +-- than returning a stale/empty value. +testLinerReservedFieldsPoisoned :: IO () +testLinerReservedFieldsPoisoned = do + let alg :: EA.Alg Double SimHatBase2 + alg = EA.fromList [ 10 :@ Not :< (Cash, 1, 1, Yen) + , 20 :@ Not :< (Products, 2, 2, Amount) + , 30 :@ Hat :< (Cash, 3, 3, Yen) ] + -- projWildMap path (and concrete path) must stay green without forcing the + -- reserved fields. + assertNear "wildcard projNetNorm green with reserved fields unmaintained" + 10.0 (EA.projNetNorm [Not :< (Cash, (.#), 1, Yen)] alg) + assertNear "concrete projNetNorm green with reserved fields unmaintained" + 10.0 (EA.projNetNorm [Not :< (Cash, 1, 1, Yen)] alg) + -- Forcing _bpToId / _nextBpId must error (poison), proving they are not + -- silently maintained. + case alg of + EAI.Liner _ _ bpToId _ nextBpId _ -> do + rb <- (try (evaluate (HM.size bpToId)) :: IO (Either SomeException Int)) + case rb of + Left _ -> putStrLn "[PASS] _bpToId is poisoned (forcing it errors as designed)" + Right _ -> do putStrLn "[FAIL] _bpToId was forced without error (unexpectedly maintained)"; exitFailure + rn <- (try (evaluate nextBpId) :: IO (Either SomeException Int)) + case rn of + Left _ -> putStrLn "[PASS] _nextBpId is poisoned (forcing it errors as designed)" + Right _ -> do putStrLn "[FAIL] _nextBpId was forced without error (unexpectedly maintained)"; exitFailure + _ -> do putStrLn "[FAIL] expected a Liner"; exitFailure + +testJournalSigmaMergePath :: IO () +testJournalSigmaMergePath = do + let xs = [1 .. 4 :: Int] + f :: Int -> TestJournal + f i = case i of + 1 -> (1 :@ (Hat :< Yen)) .| "A" + 2 -> EJ.Zero + 3 -> (EA.Zero :: TestAlg) .| "A" + _ -> (2 :@ (Not :< Amount)) .| "B" + expected :: TestJournal + expected = EJ.fromMap $ HM.fromList + [ ("A", 1 :@ (Hat :< Yen)) + , ("B", 2 :@ (Not :< Amount)) + ] + actual = EJ.sigma xs f + assertEqual "Journal.sigma bulk-merge path skips zero postings" (EJ.toMap expected) (EJ.toMap actual) + +testJournalSigma2When :: IO () +testJournalSigma2When = do + let xs = [1 .. 3 :: Int] + ys = [1 .. 3 :: Int] + cond i j = i < j + f :: Int -> Int -> TestJournal + f i j + | i == 1 && j == 2 = (EA.Zero :: TestAlg) .| "N" + | odd (i + j) = (fromIntegral (i + j) :@ (Hat :< Yen)) .| "N" + | otherwise = EJ.Zero + expected :: TestJournal + expected = EJ.fromMap $ HM.fromList [("N", 5 :@ (Hat :< Yen))] + actual = EJ.sigma2When xs ys cond f + assertEqual "Journal.sigma2When matches filtered pair sum" (EJ.toMap expected) (EJ.toMap actual) + +testJournalSigmaOn :: IO () +testJournalSigmaOn = do + let xs = [1 .. 4 :: Int] + f :: Int -> TestAlg + f i + | i <= 2 = EA.Zero + | otherwise = fromIntegral i :@ (Hat :< Yen) + expected :: TestJournal + expected = (EA.sigma xs f) .| "SalesPurchase" + actual :: TestJournal + actual = EJ.sigmaOn "SalesPurchase" xs f + zeroExpected = EJ.Zero :: TestJournal + zeroActual = EJ.sigmaOn "SalesPurchase" xs (\_ -> EA.Zero :: TestAlg) + assertEqual "Journal.sigmaOn attaches note after EA.sigma" (EJ.toMap expected) (EJ.toMap actual) + assertEqual "Journal.sigmaOn returns Zero when EA.sigma is Zero" (EJ.toMap zeroExpected) (EJ.toMap zeroActual) + +testJournalSigmaOnFromMap :: IO () +testJournalSigmaOnFromMap = do + let kvs = M.fromList + [ ((1, 2), 4.0) + , ((2, 3), 0.0) + , ((2, 1), 6.0) + ] :: M.Map (Int, Int) Double + f :: (Int, Int) -> Double -> TestAlg + f (i, j) v + | i < j = v :@ (Hat :< Yen) + | otherwise = v :@ (Not :< Amount) + expected :: TestJournal + expected = (EA.sigmaFromMap kvs f) .| "SalesPurchase" + actual :: TestJournal + actual = EJ.sigmaOnFromMap "SalesPurchase" kvs f + zeroActual :: TestJournal + zeroActual = EJ.sigmaOnFromMap "SalesPurchase" (M.singleton (1, 1) 0.0) f + assertEqual "Journal.sigmaOnFromMap matches EA.sigmaFromMap + note" (EJ.toMap expected) (EJ.toMap actual) + assertEqual "Journal.sigmaOnFromMap returns Zero for empty-effective map" (EJ.toMap (EJ.Zero :: TestJournal)) (EJ.toMap zeroActual) + +testFilterByAxisEquivalent :: IO () +testFilterByAxisEquivalent = do + let ledger :: AxisJournal + ledger = EJ.fromList + [ (10 :@ (Hat :< Yen)) .| ("A", 1) + , (20 :@ (Not :< Amount)) .| ("B", 1) + , (30 :@ (Hat :< Yen)) .| ("A", 2) + ] + expected = EJ.filterWithNote (\(_, t') _ -> t' == 1) ledger + actual = EJ.filterByAxis 1 (EJ.NoteAxisKey (1 :: Int)) ledger + mismatch = EJ.filterByAxis 1 (EJ.NoteAxisKey ("1" :: String)) ledger + assertEqual "Journal.filterByAxis matches filterWithNote on axis=1" + (EJ.toMap expected) + (EJ.toMap actual) + assertEqual "Journal.filterByAxis type mismatch returns empty" + (EJ.toMap (EJ.Zero :: AxisJournal)) + (EJ.toMap mismatch) + +testFilterByAxisWithDeltaUpdates :: IO () +testFilterByAxisWithDeltaUpdates = do + let base :: AxisJournal + base = EJ.fromMap $ HM.fromList + [ (("A", 1), 10 :@ (Hat :< Yen)) + , (("C", 2), 5 :@ (Not :< Amount)) + ] + rhs :: AxisJournal + rhs = EJ.fromMap $ HM.fromList + [ (("A", 1), 3 :@ (Not :< Amount)) + , (("B", 1), 7 :@ (Hat :< Yen)) + ] + ledger = base .+ rhs + expected = EJ.filterWithNote (\(_, t') _ -> t' == 1) ledger + actual = EJ.filterByAxis 1 (EJ.NoteAxisKey (1 :: Int)) ledger + assertEqual "Journal.filterByAxis works after append updates" + (EJ.toMap expected) + (EJ.toMap actual) + +-- ================================================================ +-- Transfer regression tests +-- ================================================================ + +type TransferAlg = EA.Alg Double SimHatBase2 +type TransferJournal = EJ.Journal String Double SimHatBase2 + +transferAlgSample :: TransferAlg +transferAlgSample = EA.fromList + [ 7 :@ Not :<(WageExpenditure, 1, 1, Yen) + , 3 :@ Hat :<(Depreciation, 2, 2, Yen) + , 11 :@ Not :<(Purchases, 3, 3, Yen) + , 13 :@ Not :<(ValueAdded, 1, 2, Yen) + , 17 :@ Hat :<(Sales, 2, 1, Yen) + , 19 :@ Not :<(InterestEarned, 4, 4, Yen) + , 23 :@ Hat :<(InterestExpense, 5, 5, Yen) + , 29 :@ Not :<(TaxesRevenue, 2, 2, Yen) + , 31 :@ Hat :<(TaxesExpense, 3, 3, Yen) + , 37 :@ Not :<(WageEarned, 6, 6, Yen) + , 41 :@ Hat :<(ConsumptionExpenditure, 6, 6, Yen) + , 43 :@ Not :<(CentralBankPaymentIncome, 1, 1, Yen) + , 47 :@ Hat :<(CentralBankPaymentExpense, 1, 1, Yen) + , 53 :@ Not :<(GrossProfit, 7, 7, Yen) + , 59 :@ Hat :<(OrdinaryProfit, 8, 8, Yen) + , 61 :@ Not :<(Cash, 1, 1, Yen) + ] + +transferJournalSample :: TransferJournal +transferJournalSample = EJ.fromList + [ transferAlgSample .| "A" + , ((5 :@ Not :<(Sales, 2, 1, Yen)) .+ (2 :@ Hat :<(WageExpenditure, 1, 1, Yen))) .| "B" + , ((3 :@ Hat :<(TaxesExpense, 3, 3, Yen)) .+ (4 :@ Not :<(InterestEarned, 4, 4, Yen))) .| "C" + ] + +testFinalStockTransferAlgEquivalence :: IO () +testFinalStockTransferAlgEquivalence = do + let ref = + (.-) + . EAT.retainedEarningTransfer + . EAT.ordinaryProfitTransfer + . EAT.grossProfitTransfer + $ transferAlgSample + actual = EAT.finalStockTransfer transferAlgSample + assertEqual "Algebra.finalStockTransfer matches composed transfer" ref actual + +testFinalStockTransferJournalEquivalence :: IO () +testFinalStockTransferJournalEquivalence = do + let ref = + (.-) + . EJT.retainedEarningTransfer + . EJT.ordinaryProfitTransfer + . EJT.grossProfitTransfer + $ transferJournalSample + actual = EJT.finalStockTransfer transferJournalSample + assertEqual "Journal.finalStockTransfer matches composed transfer" (EJ.toMap ref) (EJ.toMap actual) + +testFinalStockTransferAggregatedAlias :: IO () +testFinalStockTransferAggregatedAlias = do + let twoNotes = EJ.fromList + [ ((5 .@ (Not :< (Sales, 2, 1, Yen))) + .+ (2 .@ (Hat :< (WageExpenditure, 1, 1, Yen)))) .| "A" + , ((7 .@ (Hat :< (InterestExpense, 5, 5, Yen))) + .+ (3 .@ (Not :< (InterestEarned, 4, 4, Yen)))) .| "B" + ] :: TransferJournal + assertEqual "Journal.finalStockTransferAggregated matches finalStockTransfer" + (EJ.toMap (EJT.finalStockTransfer twoNotes)) + (EJ.toMap (EJT.finalStockTransferAggregated twoNotes)) + +type FinalStockProbe = EA.Alg Double (HatBase AccountTitles) + +-- | Classify the observable image of the same one-posting probe used to +-- generate @test/fixtures/pre-vocab/finalstock.tsv@. +-- +-- Complexity: O(1) +finalStockProbeRule :: AccountTitles -> String +finalStockProbeRule RetainedEarnings = "SELF" +finalStockProbeRule title + | actual == show probe = "Nothing" + | actual == show (1 .@ Not :< RetainedEarnings :: FinalStockProbe) = "Keep" + | actual == show (1 .@ Hat :< RetainedEarnings :: FinalStockProbe) = "Flip" + | otherwise = "UNEXPECTED:" ++ actual + where + probe = 1 .@ Not :< title :: FinalStockProbe + actual = show (EAT.finalStockTransfer probe) + +-- | The pre-vocabulary fixture is frozen. The only permitted behavioural +-- changes are the concrete Cost/Revenue accounts that the former SNA-era +-- title case split omitted. Aggregate NetIncome/NetLoss remain explicit +-- registry overrides and therefore do not occur in this list. +finalStockExpectedClosedDiff :: [AccountTitles] +finalStockExpectedClosedDiff = + [ AmortizationExpense + , SalesCost + , BusinessTrip + , Commutation + , UtilitiesExpense + , RentExpense + , AdvertisingExpense + , DeliveryExpenses + , SuppliesExpenses + , MiscellaneousExpenses + , NationalBondInterestEarned + , DepositInterestEarned + , ReceiptFee + , RentalIncome + , EquityInEarningsOfInvestee + , ProvisionForDoubtfulAccounts + , BadDebtLoss + , LossOnSalesOfFixedAssets + , LossOnSalesOfNotesReceivable + , PaymentFees + , MiscellaneousLoss + , CorporateIncomeTaxes + , CommunicationExpenses + , GainOnSalesOfFixedAssets + , RecoveryOfBadDebts + , MiscellaneousIncome + , ReversalOfAllowanceForDoubtfulAccounts + ] + +-- V-Land 1: finalStockRule の全域を独立参照式 (division + contra を明示分岐) +-- と突き合わせ, 方向 (Keep/Flip) まで固定する。contra P/L (将来の売上割戻等) +-- では division 基準と逆になることをこの式が明文化する。 +testFinalStockRuleReference :: IO () +testFinalStockRuleReference = mapM_ check Registry.concreteAccountTitles + where + check RetainedEarnings = pure () + check t = assertEqual ("finalStockRule reference: " ++ show t) + (expected t) (finalStockProbeRule t) + expected t + | t `L.elem` + [ NetIncome + , NetLoss + , IncomeSummary + , NetIncomeAttributableToNCI + , NetLossAttributableToNCI + ] = "Nothing" + | contra && div_ == Revenue = "Flip" + | contra && div_ == Cost = "Keep" + | div_ == Revenue = "Keep" + | div_ == Cost = "Flip" + | otherwise = "Nothing" + where + div_ = classifyAccountDivision t + contra = Registry.classifyAccountContra t + +testFinalStockRegistryClosedDiff :: IO () +testFinalStockRegistryClosedDiff = do + fixture <- TIO.readFile "test/fixtures/pre-vocab/finalstock.tsv" + let fixtureLines = + [ line + | line <- T.lines fixture + , not (T.null line) + , not (T.isPrefixOf (T.pack "#") line) + ] + parseFixtureLine line = case T.splitOn (T.pack "\t") line of + [titleText, oldRule, _division] -> case EC.parseAccountTitle titleText of + Right title -> (title, T.unpack oldRule) + Left err -> error ("invalid final-stock fixture title: " ++ show err) + fields -> error ("invalid final-stock fixture row: " ++ show fields) + fixtureRows = L.map parseFixtureLine fixtureLines + actualDiff = + [ title + | (title, oldRule) <- fixtureRows + , title /= RetainedEarnings + , finalStockProbeRule title /= oldRule + ] + assertEqual "final-stock fixture covers all 116 concrete account titles" + 116 (L.length fixtureRows) + assertEqual "final-stock registry closed diff = 27 formerly omitted accounts" + finalStockExpectedClosedDiff actualDiff + assertEqual "final-stock aggregate overrides remain open" + ["Nothing", "Nothing", "Nothing", "Nothing", "Nothing"] + [ finalStockProbeRule NetIncome + , finalStockProbeRule NetLoss + , finalStockProbeRule IncomeSummary + , finalStockProbeRule NetIncomeAttributableToNCI + , finalStockProbeRule NetLossAttributableToNCI + ] + +-- ================================================================ +-- V-Land 2 scaffolding (語彙拡張の受理条件, レビュー非依存): +-- pre-vland2 fixture (tools/DumpVocabGolden.hs で生成, commit 85d6a7f に pin) +-- に対する Enum 挿入規律 pin と意味関数 closed-diff。 +-- ================================================================ + +-- | V-Land 2 で既存意味が変わってよい科目の閉リスト。 +-- scaffold 時点 (constructor 追加前) は空。外部レビュー裁定で既存科目の分類が +-- 変わる場合 (例: 有価証券 4 分類分解に伴う 'Securities' の再定義) は +-- ここに列挙して閉じる — 列挙外の意味変化は fail する。 +vocabSemanticsExpectedClosedDiff :: [AccountTitles] +vocabSemanticsExpectedClosedDiff = [] + +-- | 挿入規律 pin: 語彙拡張は「既存 concrete constructor の Enum 序数を 1 つも +-- 動かさず, 新規は最大既存 concrete 序数と wildcard の間にのみ挿入し, +-- wildcard ('AccountTitle') は maxBound のまま」でなければならない +-- (Binary Word16 直列化互換と既存 fixture 世代の解釈可能性の要)。 +testVocabOrdinalPin :: IO () +testVocabOrdinalPin = do + fixture <- TIO.readFile "test/fixtures/pre-vland2/ordinals.tsv" + let parseOrd line = case T.splitOn (T.pack "\t") line of + [name, ordText] -> (name, read (T.unpack ordText) :: Int) + fields -> error ("invalid pre-vland2 ordinals row: " ++ show fields) + rows = + [ parseOrd line + | line <- T.lines fixture + , not (T.null line) + , not (T.isPrefixOf (T.pack "#") line) + ] + current = M.fromList + [ (T.pack (show t), fromEnum t) + | t <- [minBound .. maxBound] :: [AccountTitles] ] + wildcardName = T.pack (show (AccountTitle :: AccountTitles)) + pinnedConcrete = [ r | r@(n, _) <- rows, n /= wildcardName ] + moved = + [ (n, o, M.lookup n current) + | (n, o) <- pinnedConcrete + , M.lookup n current /= Just o ] + assertEqual "vocab ordinal pin: fixture rows = 117 (116 concrete + wildcard)" + 117 (L.length rows) + assertEqual "vocab ordinal pin: no pinned concrete ordinal moved" [] moved + assertEqual "vocab ordinal pin: wildcard is maxBound" + (fromEnum (maxBound :: AccountTitles)) + (fromEnum (AccountTitle :: AccountTitles)) + let maxPinned = L.maximum [ o | (_, o) <- pinnedConcrete ] + pinnedNames = M.fromList [ (n, ()) | (n, _) <- rows ] + misplaced = + [ (n, o) + | (n, o) <- M.toList current + , not (M.member n pinnedNames) + , not (o > maxPinned && o < fromEnum (maxBound :: AccountTitles)) ] + assertEqual "vocab ordinal pin: new constructors sit between max pinned and wildcard" + [] misplaced + assertEqual "vocab ordinal pin: Land 4a constructor ordinals and wildcard" + [232, 233, 234, 235] + (L.map fromEnum + [ ConsumptionTaxRefundReceivable + , PropertyTaxPayable + , DepositsReceivedFromOfficers + , AccountTitle + ]) + -- concreteAccountTitles は wildcard 以外の全 constructor を被覆すること。 + -- 現行の hardcoded 上限 ([Cash .. ReversalOfAllowanceForDoubtfulAccounts]) は + -- 挿入後に新規科目が漏れるため, この assert が V-Land 2 に + -- filter (/= wildcard) [minBound ..] への導出化を強制する。 + assertEqual "vocab ordinal pin: concreteAccountTitles covers all non-wildcard constructors" + (L.filter (/= (AccountTitle :: AccountTitles)) [minBound .. maxBound]) + Registry.concreteAccountTitles + +-- | 意味関数 closed-diff: 既存 116 科目の (division / isContra / whichSide +-- Not\/Hat / whatPIMO / fixedCurrent / finalStock probe) は, +-- 'vocabSemanticsExpectedClosedDiff' に列挙された科目を除き +-- pre-vland2 fixture と行単位で一致しなければならない。 +testPreVland2SemanticsClosedDiff :: IO () +testPreVland2SemanticsClosedDiff = do + fixture <- TIO.readFile "test/fixtures/pre-vland2/semantics.tsv" + let byName = M.fromList + [ (T.pack (show t), t) + | t <- [minBound .. maxBound] :: [AccountTitles] ] + currentRow t = + let nb = Not :< t :: HatBase AccountTitles + hb = Hat :< t :: HatBase AccountTitles + in T.intercalate (T.pack "\t") + [ T.pack (show t) + , T.pack (show (whatDiv nb)) + , T.pack (show (Registry.classifyAccountContra t)) + , T.pack (show (whichSide nb)) + , T.pack (show (whichSide hb)) + , T.pack (show (whatPIMO nb)) + , T.pack (show (fixedCurrent nb)) + , T.pack (finalStockProbeRule t) + ] + rows = + [ line + | line <- T.lines fixture + , not (T.null line) + , not (T.isPrefixOf (T.pack "#") line) ] + titleOf line = case T.splitOn (T.pack "\t") line of + (name:_) -> case M.lookup name byName of + Just t -> t + Nothing -> error ("pre-vland2 semantics: unknown title " ++ T.unpack name) + [] -> error "pre-vland2 semantics: empty row" + actualDiff = + [ titleOf line | line <- rows, currentRow (titleOf line) /= line ] + assertEqual "pre-vland2 semantics fixture covers all 116 concrete account titles" + 116 (L.length rows) + assertEqual "pre-vland2 semantics closed diff" + vocabSemanticsExpectedClosedDiff actualDiff + +-- | R1 sentinel: a /balanced/ ledger (credit total == debit total, net income +-- zero) makes 'diffRL' report the wildcard 'Side'. Before the fix, +-- 'incomeSummaryAccount' matched only Credit/Debit and crashed with +-- "Non-exhaustive patterns". Run every closing-transfer function (Alg and +-- Journal) over a balanced ledger and force the result; none may throw. +-- +-- The ledger pairs equal Sales (Revenue/Credit) and WageExpenditure +-- (Cost/Debit) amounts so @decR == decL@ (balanced). +balancedAlgSample :: TransferAlg +balancedAlgSample = EA.fromList + [ 50 :@ Not :<(Sales, 1, 1, Yen) -- credit (revenue) + , 50 :@ Not :<(WageExpenditure, 1, 1, Yen) -- debit (cost) + , 20 :@ Not :<(Purchases, 2, 2, Yen) -- debit (cost) + , 20 :@ Not :<(InterestEarned, 2, 2, Yen) -- credit (revenue) + ] + +balancedJournalSample :: TransferJournal +balancedJournalSample = EJ.fromList + [ balancedAlgSample .| "A" + , ((10 :@ Not :<(Sales, 3, 3, Yen)) .+ (10 :@ Not :<(Purchases, 3, 3, Yen))) .| "B" + ] + +testIncomeSummaryBalancedNoCrash :: IO () +testIncomeSummaryBalancedNoCrash = do + -- confirm the ledger really is balanced (triggers the wildcard Side) + case EA.diffRL balancedAlgSample of + (Side, _) -> return () + other -> do putStrLn ("[FAIL] balanced sample not balanced: " ++ show (fst other)) + exitFailure + let algFns = + [ ("incomeSummaryAccount", EAT.incomeSummaryAccount) + , ("netIncomeTransfer", EAT.netIncomeTransfer) + , ("grossProfitTransfer", EAT.grossProfitTransfer) + , ("ordinaryProfitTransfer",EAT.ordinaryProfitTransfer) + , ("retainedEarningTransfer",EAT.retainedEarningTransfer) + , ("finalStockTransfer", EAT.finalStockTransfer) + ] + jFns = + [ ("incomeSummaryAccount", EJT.incomeSummaryAccount) + , ("netIncomeTransfer", EJT.netIncomeTransfer) + , ("grossProfitTransfer", EJT.grossProfitTransfer) + , ("ordinaryProfitTransfer",EJT.ordinaryProfitTransfer) + , ("retainedEarningTransfer",EJT.retainedEarningTransfer) + , ("finalStockTransfer", EJT.finalStockTransfer) + ] + forM_ algFns $ \(nm, f) -> do + r <- try (evaluate (EA.norm (f balancedAlgSample))) + :: IO (Either SomeException Double) + case r of + Right _ -> return () + Left e -> do putStrLn ("[FAIL] Alg." ++ nm ++ " threw on balanced ledger: " ++ show e) + exitFailure + forM_ jFns $ \(nm, f) -> do + r <- try (evaluate (EA.norm (EJ.toAlg (f balancedJournalSample)))) + :: IO (Either SomeException Double) + case r of + Right _ -> return () + Left e -> do putStrLn ("[FAIL] Journal." ++ nm ++ " threw on balanced ledger: " ++ show e) + exitFailure + putStrLn "[PASS] all closing transfers identity-safe on balanced ledger (R1)" + +type SpillRestoreJournal = EJ.Journal (String, Int) Double (HatBase CountUnit) + +-- | Design-review C4: the spill/eviction decision logic is single-sourced in +-- 'ES.stepBackWith' / 'ES.spillDeleteDecision' (previously duplicated inline +-- in the classic spill loop and in Lite's retention loop). Pin the decision +-- table and the equivalence with Lite's former @backByTerms@. +testSpillDecisionSingleSource :: IO () +testSpillDecisionSingleSource = do + assertEqual "stepBackWith pred 3 10" (7 :: Int) (ES.stepBackWith pred 3 10) + assertEqual "stepBackWith is id for n <= 0" (10 :: Int) (ES.stepBackWith pred 0 10) + assertEqual "stepBackWith is id for negative n" (10 :: Int) (ES.stepBackWith pred (-1) 10) + assertEqual "NoDelete evicts nothing" + Nothing (ES.spillDeleteDecision pred (ES.NoDelete :: ES.SpillDeletePolicy Int) (1, 10)) + assertEqual "DeleteSpilledChunk evicts exactly the chunk" + (Just (1, 10)) (ES.spillDeleteDecision pred ES.DeleteSpilledChunk (1 :: Int, 10)) + assertEqual "KeepRecentTerms 3 keeps the trailing window" + (Just (1, 7)) (ES.spillDeleteDecision pred (ES.KeepRecentTerms 3) (1 :: Int, 10)) + assertEqual "KeepRecentTerms covering the chunk evicts nothing" + Nothing (ES.spillDeleteDecision pred (ES.KeepRecentTerms 12) (1 :: Int, 10)) + -- Lite boundary equivalence: former backByTerms w t == stepBackWith pred w t + let backByTermsRef w t = let go n x | n <= (0 :: Int) = x + | otherwise = go (n - 1) (pred x) + in go w t + forM_ [(0, 5), (1, 5), (3, 5), (7, 5)] $ \(w, t) -> + assertEqual ("Lite boundary equivalence w=" ++ show w) + (backByTermsRef w t) (ES.stepBackWith pred w (t :: Int)) + +testRestoreJournalFromBinarySpill :: IO () +testRestoreJournalFromBinarySpill = do + let spillPath = "/tmp/exchangealgebra_spill_restore_test.bin" + chunk1 :: SpillRestoreJournal + chunk1 = EJ.fromList + [ (1 .@ (Hat :< Yen)) .| ("A", 1) + , (2 .@ (Not :< Amount)) .| ("B", 2) + ] + chunk2 :: SpillRestoreJournal + chunk2 = (3 .@ (Hat :< Yen)) .| ("C", 3) + currentLedger :: SpillRestoreJournal + currentLedger = EJ.fromList + [ (4 .@ (Not :< Amount)) .| ("Tail", 4) + , (8 .@ (Hat :< Yen)) .| ("AlreadySpilled", 2) + ] + expected :: SpillRestoreJournal + expected = chunk1 .+ chunk2 .+ ((4 .@ (Not :< Amount)) .| ("Tail", 4)) + + removeSpillTestFile spillPath + withFile spillPath WriteMode $ \h -> do + ES.defaultBinarySpillWriter h (1 :: Int, 2 :: Int) chunk1 + ES.defaultBinarySpillWriter h (3 :: Int, 3 :: Int) chunk2 + + actual <- restoreJournalFromBinarySpill spillPath snd currentLedger + assertEqual "Write.restoreJournalFromBinarySpill merges spill + tail remainder" + (EJ.toMap expected) + (EJ.toMap actual) + removeSpillTestFile spillPath + +removeSpillTestFile :: FilePath -> IO () +removeSpillTestFile path = do + _ <- try (removeFile path) :: IO (Either SomeException ()) + pure () + +writeSpillTestChunks + :: FilePath + -> [((Int, Int), SpillRestoreJournal)] + -> IO () +writeSpillTestChunks path chunks = do + removeSpillTestFile path + withFile path WriteMode $ \h -> + forM_ chunks $ \(termRange, chunk) -> + ES.defaultBinarySpillWriter h termRange chunk + +spillCheckedChunk1 :: SpillRestoreJournal +spillCheckedChunk1 = EJ.fromList + [ (1 .@ (Hat :< Yen)) .| ("A", 1) + , (2 .@ (Not :< Amount)) .| ("B", 2) + ] + +spillCheckedChunk2 :: SpillRestoreJournal +spillCheckedChunk2 = (3 .@ (Hat :< Yen)) .| ("C", 3) + +spillCheckedCurrent :: SpillRestoreJournal +spillCheckedCurrent = EJ.fromList + [ (4 .@ (Not :< Amount)) .| ("Tail", 4) + , (8 .@ (Hat :< Yen)) .| ("AlreadySpilled", 2) + ] + +spillCheckedExpected :: SpillRestoreJournal +spillCheckedExpected = + spillCheckedChunk1 .+ spillCheckedChunk2 + .+ ((4 .@ (Not :< Amount)) .| ("Tail", 4)) + +testSpillCheckedReaderWellFormed :: IO () +testSpillCheckedReaderWellFormed = do + let path = "/tmp/exchangealgebra_spill_checked_well_formed.bin" + chunks = [((1, 2), spillCheckedChunk1), ((3, 3), spillCheckedChunk2)] + writeSpillTestChunks path chunks + readResult <- ES.readBinarySpillFileChecked path + :: IO (Either (ES.SpillReadError Int) [((Int, Int), SpillRestoreJournal)]) + case readResult of + Left err -> assertEqual "checked spill reader accepts well-formed chunks" + "Right with two chunks" (ES.renderSpillReadError err) + Right decoded -> assertEqual "checked spill reader returns both chunks" + 2 (L.length decoded) + restored <- restoreJournalFromBinarySpillChecked path snd spillCheckedCurrent + case restored of + Left err -> assertEqual "checked spill restore accepts well-formed chunks" + "Right restored ledger" (ES.renderSpillReadError err) + Right actual -> assertEqual "checked spill restore merges spill + tail remainder" + (EJ.toMap spillCheckedExpected) (EJ.toMap actual) + removeSpillTestFile path + +testSpillCheckedReaderTruncated :: IO () +testSpillCheckedReaderTruncated = do + let path = "/tmp/exchangealgebra_spill_checked_truncated.bin" + encodedChunk2 = Binary.encode + ((3 :: Int, 3 :: Int), spillCheckedChunk2) + truncatedChunk2 = BL.take (BL.length encodedChunk2 `div` 2) encodedChunk2 + removeSpillTestFile path + withFile path WriteMode $ \h -> do + ES.defaultBinarySpillWriter h (1 :: Int, 2 :: Int) spillCheckedChunk1 + BL.hPut h truncatedChunk2 + result <- ES.readBinarySpillFileChecked path + :: IO (Either (ES.SpillReadError Int) [((Int, Int), SpillRestoreJournal)]) + case result of + Left (ES.SpillDecodeFailure offset chunks _) -> do + assertEqual "truncated spill failure follows first chunk" True (offset > 0) + assertEqual "truncated spill reports decoded chunk count" 1 chunks + other -> assertEqual "truncated spill is a decode failure" + "SpillDecodeFailure" (show other) + caught <- try + (restoreJournalFromBinarySpill path snd (mempty :: SpillRestoreJournal)) + :: IO (Either ErrorCall SpillRestoreJournal) + case caught of + Left _ -> putStrLn "[PASS] unchecked spill restore raises ErrorCall" + Right _ -> assertEqual "unchecked spill restore raises ErrorCall" True False + removeSpillTestFile path + +testSpillCheckedReaderStaleAppend :: IO () +testSpillCheckedReaderStaleAppend = do + let path = "/tmp/exchangealgebra_spill_checked_stale_append.bin" + writeSpillTestChunks path + [ ((1, 2), spillCheckedChunk1) + , ((3, 3), spillCheckedChunk2) + , ((1, 2), spillCheckedChunk1) + ] + result <- ES.readBinarySpillFileChecked path + :: IO (Either (ES.SpillReadError Int) [((Int, Int), SpillRestoreJournal)]) + assertEqual "checked spill reader rejects stale append" + (Left (ES.SpillRangeError ES.ChunkOutOfOrder (3, 3) (1, 2))) (fmap (fmap fst) result) + removeSpillTestFile path + +testSpillCheckedReaderOverlap :: IO () +testSpillCheckedReaderOverlap = do + let path = "/tmp/exchangealgebra_spill_checked_overlap.bin" + writeSpillTestChunks path + [((1, 3), spillCheckedChunk1), ((2, 4), spillCheckedChunk2)] + result <- ES.readBinarySpillFileChecked path + :: IO (Either (ES.SpillReadError Int) [((Int, Int), SpillRestoreJournal)]) + assertEqual "checked spill reader rejects overlap" + (Left (ES.SpillRangeError ES.ChunkOverlap (1, 3) (2, 4))) (fmap (fmap fst) result) + removeSpillTestFile path + +testSpillCheckedReaderGap :: IO () +testSpillCheckedReaderGap = do + let path = "/tmp/exchangealgebra_spill_checked_gap.bin" + writeSpillTestChunks path + [((1, 2), spillCheckedChunk1), ((4, 4), spillCheckedChunk2)] + result <- ES.readBinarySpillFileChecked path + :: IO (Either (ES.SpillReadError Int) [((Int, Int), SpillRestoreJournal)]) + assertEqual "checked spill reader rejects gap" + (Left (ES.SpillRangeError ES.ChunkGap (1, 2) (4, 4))) (fmap (fmap fst) result) + removeSpillTestFile path + +testSpillCheckedReaderEmptyRange :: IO () +testSpillCheckedReaderEmptyRange = do + let path = "/tmp/exchangealgebra_spill_checked_empty_range.bin" + writeSpillTestChunks path [((3, 1), spillCheckedChunk1)] + result <- ES.readBinarySpillFileChecked path + :: IO (Either (ES.SpillReadError Int) [((Int, Int), SpillRestoreJournal)]) + assertEqual "checked spill reader rejects empty range" + (Left (ES.SpillEmptyRange (3, 1))) (fmap (fmap fst) result) + removeSpillTestFile path + +testSpillCheckedReaderEmptyFile :: IO () +testSpillCheckedReaderEmptyFile = do + let path = "/tmp/exchangealgebra_spill_checked_empty_file.bin" + removeSpillTestFile path + withFile path WriteMode $ \_ -> pure () + result <- ES.readBinarySpillFileChecked path + :: IO (Either (ES.SpillReadError Int) [((Int, Int), SpillRestoreJournal)]) + assertEqual "checked spill reader accepts empty file" (Right []) (fmap (fmap fst) result) + removeSpillTestFile path + +-- ================================================================ +-- SimulateEx1 reproduction (default scenario only, no parallelism) +-- ================================================================ + +type SimTerm = Int + +instance StateTime SimTerm where + initTerm = 1 + lastTerm = 100 +data SimInitVar = SimInitVar + { _simInitStock :: Double + , _simSteadyProduction :: Double + , _simInhouseRatio :: Double + } deriving (Eq, Show) + +instance InitVariables SimInitVar where + +data SimEvent + = SimSalesPurchase + | SimProduction + | SimPlank + deriving (Ord, Show, Enum, Eq, Bounded, Generic) + +instance Hashable SimEvent where + +instance Note SimEvent where + plank = SimPlank + +instance Event SimEvent where + +type SimCompany = Int + +instance Element SimCompany where + wildcard = -1 + +instance BaseClass SimCompany where + +simFstC, simLastC :: SimCompany +simFstC = 1 +simLastC = 6 + +simCompanies :: [SimCompany] +simCompanies = [simFstC .. simLastC] + +type SimHatBase2 = HatBase (AccountTitles, SimCompany, SimCompany, CountUnit) + +instance ExBaseClass SimHatBase2 where + getAccountTitle (h :< (a, _, _, _)) = a + setAccountTitle (h :< (_, c, e, u)) b = h :< (b, c, e, u) + +-- Accounting value type is MoneyDecimal (exact): ledger arithmetic is exact and +-- construction-order-independent. ABM parameters / input coefficients / random +-- draws remain Double and are converted (realToFrac) at the boundary where they +-- enter the ledger; reported stock/profit convert back to Double. +type SimTransaction = EJ.Journal (SimEvent, SimTerm) MoneyDecimal SimHatBase2 + +simCompressPreviousTerm :: SimTerm -> SimTransaction -> SimTransaction +simCompressPreviousTerm t le = + EJ.fromMap $ + L.foldl' (\acc ev -> HM.adjust compress (ev, t) acc) + (EJ.toMap le) + [fstEvent .. lastEvent] + +newtype SimLedger s = SimLedger (STRef s SimTransaction) + +instance UpdatableSTRef SimLedger s SimTransaction where + _unwrapURef (SimLedger x) = x + _wrapURef x = SimLedger x + +simInitLedger :: Double -> ST s (SimLedger s) +simInitLedger d = newURef $ EJ.fromList + [ realToFrac d :@ Not :<(Products, e, e, Amount) .| (plank, initTerm) -- Double param -> MoneyDecimal + | e <- simCompanies + ] + +instance Updatable SimTerm SimInitVar SimLedger s where + type Inner SimLedger s = STRef s SimTransaction + unwrap = _unwrapURef + initialize _ _ e = simInitLedger (_simInitStock e) + updatePattern _ = return Modify + modify _ t _ x = do + le <- readURef x + let added = EJ.gather (plank, t) + $ EJT.finalStockTransfer + $ (.-) $ simTermJournal (t - 1) le + next = simCompressPreviousTerm (t - 1) (le .+ added) + writeURef x next + +type SimInputCoefficient = Double + +newtype SimICTable s = SimICTable (STArray s (SimCompany, SimCompany) SimInputCoefficient) + +instance UpdatableSTArray SimICTable s (SimCompany, SimCompany) SimInputCoefficient where + _unwrapUArray (SimICTable arr) = arr + _wrapUArray arr = SimICTable arr + +simGenerateRandomList :: StdGen -> Int -> ([Double], StdGen) +simGenerateRandomList g n = + let (xs, g') = runState (replicateM n (state (randomR (0, 1.0)))) + (updateGen g 1000) + ys = L.map (\v -> if v < 0.1 then 0 else v) xs + in (ys, g') + +simInitTermCoefficients :: StdGen -> Double -> M.Map SimCompany [SimInputCoefficient] +simInitTermCoefficients g inhouseRatio = + fst $ L.foldl' buildRow (M.empty, g) simCompanies + where + buildRow (acc, g0) c2 = + let (row, g1) = generateRow g0 + in (M.insert c2 row acc, g1) + generateRow g0 = + let (vals, g1) = simGenerateRandomList g0 simLastC + total = sum vals + normalized = L.map (\v -> (v / total) * inhouseRatio) vals + in (normalized, g1) + +simInitICTables :: StdGen -> Double -> ST s (SimICTable s) +simInitICTables g inhouseRatio = do + arr <- newUArray ((simFstC, simFstC), (simLastC, simLastC)) 0 + let termCoefficients = simInitTermCoefficients g inhouseRatio + forM_ simCompanies $ \c2 -> do + let row = termCoefficients M.! c2 + forM_ (zip simCompanies row) $ \(c1, coef) -> + writeUArray arr (c1, c2) coef + return arr + +instance Updatable SimTerm SimInitVar SimICTable s where + type Inner SimICTable s = STArray s (SimCompany, SimCompany) SimInputCoefficient + unwrap (SimICTable a) = a + initialize g _ e = simInitICTables g (_simInhouseRatio e) + updatePattern _ = return DoNothing + +type SimSteadyProd = Double + +newtype SimSP s = SimSP (STRef s SimSteadyProd) + +instance UpdatableSTRef SimSP s SimSteadyProd where + _unwrapURef (SimSP x) = x + _wrapURef x = SimSP x + +instance Updatable SimTerm SimInitVar SimSP s where + type Inner SimSP s = STRef s SimSteadyProd + unwrap = _unwrapURef + initialize _ _ e = newURef (_simSteadyProduction e) + updatePattern _ = return DoNothing + +data SimWorld s = SimWorld + { _simLedger :: SimLedger s + , _simIcs :: SimICTable s + , _simSp :: SimSP s + } deriving (Generic) + +-- helper functions + +simTermJournal :: SimTerm -> SimTransaction -> SimTransaction +simTermJournal t = EJ.filterWithNote (\(_, t') _ -> t' == t) + +simGetOneProduction :: SimWorld s -> SimTerm -> SimCompany -> ST s SimTransaction +simGetOneProduction wld t c = do + let arr = _simIcs wld + inputs <- mapM (\c2 -> do + coef <- readUArray arr (c2, c) + return $ realToFrac coef :@ Hat :<(Products, c2, c, Amount) .| (SimProduction, t) -- Double coef -> MoneyDecimal + ) simCompanies + let totalInput = EJ.fromList inputs + result = (1 :@ Not :<(Products, c, c, Amount) .| (SimProduction, t)) .+ totalInput + return result + +simJournal :: SimWorld s -> SimTransaction -> ST s () +simJournal _ Zero = return () +simJournal wld js = modifyURef (_simLedger wld) (\x -> x .+ js) + +-- Values come from the MoneyDecimal ledger (via EA.toList), so the shortage map is +-- MoneyDecimal-valued; no conversion is needed and the amounts re-enter the ledger exactly. +simBuildShortageMap :: SimTerm -> SimTransaction -> M.Map (SimCompany, SimCompany) MoneyDecimal +simBuildShortageMap t le = + let termAlg = EJ.toAlg $ (.-) $ simTermJournal t le + in L.foldl' go M.empty (EA.toList termAlg) + where + go acc (v :@ (Hat :< (Products, j, i, Amount))) = M.insertWith (+) (i, j) v acc + go acc _ = acc + +simPurchases :: SimTerm -> SimWorld s -> ST s SimTransaction +simPurchases t wld = do + le <- readURef (_simLedger wld) + let shortageMap = simBuildShortageMap t le + o i j = M.findWithDefault 0 (i, j) shortageMap + return $ sigma simCompanies $ \i + -> sigma (simCompanies L.\\ [i]) $ \j + -> (o i j) :@ Not :<(Products, j, i, Amount) + .+ (o i j) :@ Hat :<(Cash, (.#), i, Yen) + .+ (o i j) :@ Not :<(Purchases, (.#), i, Yen) + .+ (o i j) :@ Not :<(Cash, (.#), j, Yen) + .+ (o i j) :@ Not :<(Sales, (.#), j, Yen) + .+ (o i j) :@ Hat :<(Products, j, j, Amount) + .| (SimSalesPurchase, t) + +instance StateSpace SimTerm SimInitVar SimEvent SimWorld s where + event = simEvent + +simEvent :: SimWorld s -> SimTerm -> SimEvent -> ST s () + +simEvent wld t SimSalesPurchase = do + toAdd <- simPurchases t wld + simJournal wld toAdd + +simEvent wld t SimProduction = do + sp <- readURef (_simSp wld) + forM_ simCompanies $ \e1 -> do + op <- simGetOneProduction wld t e1 + simJournal wld (realToFrac sp .* op) -- Double steady-production multiplier -> MoneyDecimal scalar + +simEvent _ _ SimPlank = return () + +simGetTermStock :: SimWorld s -> SimTerm -> SimCompany -> ST s Double +simGetTermStock wld t e = do + le <- readURef (_simLedger wld) + let tj = (.-) $ simTermJournal t le + plusStock = norm $ EJ.projWithBase [Not :<(Products, e, e, Amount)] tj + minusStock = norm $ EJ.projWithBase [Hat :<(Products, e, e, Amount)] tj + return $ realToFrac (plusStock - minusStock) -- exact MoneyDecimal stock -> Double for reporting + +simGetTermGrossProfit :: SimWorld s -> SimTerm -> SimCompany -> ST s Double +simGetTermGrossProfit wld t e = do + le <- readURef (_simLedger wld) + let termTr = simTermJournal t le + tr = EJT.grossProfitTransfer termTr + plus = norm $ EJ.projWithBase [Not :<(GrossProfit, (.#), e, Yen)] tr + minus = norm $ EJ.projWithBase [Hat :<(GrossProfit, (.#), e, Yen)] tr + return $ realToFrac (plus - minus) -- exact MoneyDecimal -> Double for reporting + +-- ================================================================ +-- Simulation integration test +-- ================================================================ + +simEps :: Double +simEps = 1e-6 + +assertSimNear :: String -> Double -> Double -> IO () +assertSimNear label expected actual + | abs (expected - actual) <= simEps = putStrLn ("[PASS] " ++ label) + | otherwise = do + putStrLn ("[FAIL] " ++ label) + putStrLn (" expected: " ++ show expected) + putStrLn (" actual : " ++ show actual) + exitFailure + +testSimulateEx1Default :: IO () +testSimulateEx1Default = do + let gen = mkStdGen 2025 + defaultEnv = SimInitVar + { _simInitStock = 20 + , _simInhouseRatio = 0.4 + , _simSteadyProduction = 10 + } + + wld <- ES.runSimulation gen defaultEnv + + -- Stock at term 1 for each company + stocks1 <- stToIO $ mapM (simGetTermStock wld 1) simCompanies + -- Stock at term 50 for each company + stocks50 <- stToIO $ mapM (simGetTermStock wld 50) simCompanies + -- Stock at term 100 for each company + stocks100 <- stToIO $ mapM (simGetTermStock wld 100) simCompanies + -- Gross profit at term 50 for each company + profits50 <- stToIO $ mapM (simGetTermGrossProfit wld 50) simCompanies + + -- Stock at t=1 + assertSimNear "sim1 stock(t=1,c=1)" 28.487224703666264 (stocks1 !! 0) + assertSimNear "sim1 stock(t=1,c=3)" 30.0 (stocks1 !! 2) + assertSimNear "sim1 stock(t=1,c=6)" 30.0 (stocks1 !! 5) -- re-baselined: union zero-base fix removed a phantom self-input + -- Stock at t=50 + assertSimNear "sim1 stock(t=50,c=1)" 304.9028131162567 (stocks50 !! 0) + assertSimNear "sim1 stock(t=50,c=4)" 292.4764622201871 (stocks50 !! 3) + -- Stock at t=100 + assertSimNear "sim1 stock(t=100,c=1)" 586.9595359862476 (stocks100 !! 0) + assertSimNear "sim1 stock(t=100,c=6)" 767.9605634804993 (stocks100 !! 5) -- re-baselined: union zero-base fix (bug compounded over terms) + -- Gross profit at t=50 + assertSimNear "sim1 profit(t=50,c=1)" 0.35886554260018855 (profits50 !! 0) + assertSimNear "sim1 profit(t=50,c=2)" 1.572544209772035 (profits50 !! 1) + +-- ================================================================ +-- CSV Write tests +-- ================================================================ + +testCsvTranspose :: IO () +testCsvTranspose = do + -- Square matrix + let input1 = [ [T.pack "a", T.pack "b"] + , [T.pack "c", T.pack "d"] ] + expected1 = [ [T.pack "a", T.pack "c"] + , [T.pack "b", T.pack "d"] ] + assertEqual "CSV.transpose square matrix" expected1 (EW.csvTranspose input1) + + -- Ragged matrix (shorter rows padded with empty) + let input2 = [ [T.pack "a", T.pack "b", T.pack "c"] + , [T.pack "d"] ] + expected2 = [ [T.pack "a", T.pack "d"] + , [T.pack "b", T.empty] + , [T.pack "c", T.empty] ] + assertEqual "CSV.transpose ragged matrix" expected2 (EW.csvTranspose input2) + + -- Single row + let input3 = [[T.pack "x", T.pack "y", T.pack "z"]] + expected3 = [[T.pack "x"], [T.pack "y"], [T.pack "z"]] + assertEqual "CSV.transpose single row" expected3 (EW.csvTranspose input3) + + -- Empty + assertEqual "CSV.transpose empty" ([] :: [[T.Text]]) (EW.csvTranspose []) + +testCsvWriteCSV :: IO () +testCsvWriteCSV = do + let path = "/tmp/exchangealgebra_csv_test.csv" + input = [ [T.pack "Name", T.pack "Value"] + , [T.pack "Alice", T.pack "100"] + , [T.pack "Bob", T.pack "200"] ] + EW.writeCSV path input + raw <- readFileStrict path + -- Each cell should be quoted + let lns = lines raw + assertEqual "CSV writeCSV line count" 3 (length lns) + assertEqual "CSV writeCSV header" "\"Name\",\"Value\"" (lns !! 0) + assertEqual "CSV writeCSV row 1" "\"Alice\",\"100\"" (lns !! 1) + assertEqual "CSV writeCSV row 2" "\"Bob\",\"200\"" (lns !! 2) + removeFile path + +testCsvWriteCSVWithQuotes :: IO () +testCsvWriteCSVWithQuotes = do + let path = "/tmp/exchangealgebra_csv_quote_test.csv" + input = [[T.pack "say \"hello\"", T.pack "a,b"]] + EW.writeCSV path input + raw <- readFileStrict path + let lns = lines raw + -- Internal quotes should be escaped as "" + assertEqual "CSV writeCSV escapes quotes" "\"say \"\"hello\"\"\",\"a,b\"" (lns !! 0) + removeFile path + +testCsvWriteCSVEmpty :: IO () +testCsvWriteCSVEmpty = do + let path = "/tmp/exchangealgebra_csv_empty_test.csv" + input = [[T.pack "", T.pack "x"]] + EW.writeCSV path input + raw <- readFileStrict path + let lns = lines raw + assertEqual "CSV writeCSV empty cell" "\"\",\"x\"" (lns !! 0) + removeFile path + +-- ================================================================ +-- Legacy-generation writer output-pinning tests (design-review C7) +-- +-- These pin the exact CSV bytes produced, for small fixed inputs, by the +-- "legacy generation" writers (writeBS / writePL / writeJournal / +-- writeCompoundTrialBalance / writeAccountOfJournal) as computed by the +-- pre-refactor implementation. Their purpose is to let the "generation +-- unification" refactor (pure *Rows builder + thin IO wrapper, matching the +-- worksheetRows/postClosingTrialBalanceRows/accountLedgerRows style) be +-- verified to leave output bit-for-bit unchanged: these must stay green, +-- unmodified, across the refactor. +-- ================================================================ + +testWriteBSPinned :: IO () +testWriteBSPinned = do + let path = "/tmp/exchangealgebra_write_bs_pinned_test.csv" + alg = (100 .@ Not :< Cash) + .+ (60 .@ Not :< LoansPayable) + .+ (40 .@ Not :< CapitalStock) + :: EA.Alg Double (HatBase AccountTitles) + EW.writeBS path alg + raw <- readFileStrict path + removeFile path + let lns = lines raw + assertEqual "writeBS pinned: line count" 5 (length lns) + assertEqual "writeBS pinned: row0 (Asset/Liability headers)" + "\"Asset\",\"\",\"Liability\",\"\"" (lns !! 0) + assertEqual "writeBS pinned: row1 (Cash/LoansPayable)" + "\"Cash\",\"100.0\",\"LoansPayable\",\"60.0\"" (lns !! 1) + assertEqual "writeBS pinned: row2 (Total/Equity header)" + "\"Total\",\"100.0\",\"Equity\",\"\"" (lns !! 2) + assertEqual "writeBS pinned: row3 (CapitalStock)" + "\"\",\"\",\"CapitalStock\",\"40.0\"" (lns !! 3) + assertEqual "writeBS pinned: row4 (grand total)" + "\"\",\"\",\"Total\",\"100.0\"" (lns !! 4) + +testWritePLPinned :: IO () +testWritePLPinned = do + let path = "/tmp/exchangealgebra_write_pl_pinned_test.csv" + alg = (500 .@ Not :< Sales) + .+ (300 .@ Not :< SalesCost) + :: EA.Alg Double (HatBase AccountTitles) + EW.writePL path alg + raw <- readFileStrict path + removeFile path + let lns = lines raw + assertEqual "writePL pinned: line count" 3 (length lns) + assertEqual "writePL pinned: row0 (Cost/Revenue headers)" + "\"Cost\",\"\",\"Revenue\",\"\"" (lns !! 0) + assertEqual "writePL pinned: row1 (SalesCost/Sales)" + "\"SalesCost\",\"300.0\",\"Sales\",\"500.0\"" (lns !! 1) + assertEqual "writePL pinned: row2 (totals)" + "\"Total\",\"500.0\",\"Total\",\"300.0\"" (lns !! 2) + +testWriteJournalPinned :: IO () +testWriteJournalPinned = do + let path = "/tmp/exchangealgebra_write_journal_pinned_test.csv" + d1 = fromGregorian 2024 4 1 + d2 = fromGregorian 2024 4 2 + d3 = fromGregorian 2024 4 3 + getDay' :: HatBase (AccountTitles, Day) -> Day + getDay' (_ :< (_, d)) = d + alg = (100 .@ Not :< (Cash, d1)) + .+ (100 .@ Not :< (CapitalStock, d1)) + .+ (50 .@ Not :< (Cash, d2)) + .+ (50 .@ Not :< (Sales, d2)) + .+ (30 .@ Not :< (Cash, d3)) + .+ (10 .@ Not :< (AccountsReceivable, d3)) + .+ (40 .@ Not :< (Sales, d3)) + :: EA.Alg Double (HatBase (AccountTitles, Day)) + EW.writeJournal path alg getDay' + raw <- readFileStrict path + removeFile path + let lns = lines raw + assertEqual "writeJournal pinned: line count" 5 (length lns) + assertEqual "writeJournal pinned: header" + "\"Day\",\"Debit\",\"Amount\",\"Credit\",\"Amount\"" (lns !! 0) + assertEqual "writeJournal pinned: day1" + "\"2024-04-01\",\"Cash\",\"100.0\",\"CapitalStock\",\"100.0\"" (lns !! 1) + assertEqual "writeJournal pinned: day2" + "\"2024-04-02\",\"Cash\",\"50.0\",\"Sales\",\"50.0\"" (lns !! 2) + assertEqual "writeJournal pinned: day3 line1 (2 debits vs 1 credit -> toSameLength padding)" + "\"2024-04-03\",\"AccountsReceivable\",\"10.0\",\"Sales\",\"40.0\"" (lns !! 3) + assertEqual "writeJournal pinned: day3 line2 (padded Day/Credit cells empty)" + "\"\",\"Cash\",\"30.0\",\"\",\"\"" (lns !! 4) + +testWriteCompoundTrialBalancePinned :: IO () +testWriteCompoundTrialBalancePinned = do + let path = "/tmp/exchangealgebra_write_ctb_pinned_test.csv" + alg = (100 .@ Not :< Cash) + .+ (60 .@ Not :< LoansPayable) + .+ (40 .@ Not :< CapitalStock) + :: EA.Alg Double (HatBase AccountTitles) + EW.writeCompoundTrialBalance path alg + raw <- readFileStrict path + removeFile path + let lns = lines raw + assertEqual "writeCompoundTrialBalance pinned: line count" 5 (length lns) + assertEqual "writeCompoundTrialBalance pinned: header" + "\"Debit Balance\",\"Debit Total\",\"Account Title\",\"Credit Total\",\"Credit Balance\"" + (lns !! 0) + -- NOTE (legacy layout quirk, preserved verbatim): a debit-balance account + -- (Cash: gross debit 100 / credit 0) places its balance figure in the + -- *Credit Balance* column (rightmost), not the *Debit Balance* column, + -- and a credit-balance account (CapitalStock/LoansPayable) places it in + -- *Debit Balance* (leftmost) -- the opposite of the (side,mag) -> + -- (debitCell,creditCell) convention 'sideCells' uses elsewhere + -- (worksheetRows / postClosingTrialBalanceRows). See the Haddock on + -- 'compoundTrialBalanceRows' for why this was kept as explicit case + -- analysis instead of being consolidated onto 'sideCells'. + assertEqual "writeCompoundTrialBalance pinned: Cash (debit-heavy -> Credit Balance col)" + "\"\",\"100.0\",\"Cash\",\"0.0\",\"100.0\"" (lns !! 1) + assertEqual "writeCompoundTrialBalance pinned: CapitalStock (credit-heavy -> Debit Balance col)" + "\"40.0\",\"0.0\",\"CapitalStock\",\"40.0\",\"\"" (lns !! 2) + assertEqual "writeCompoundTrialBalance pinned: LoansPayable (credit-heavy -> Debit Balance col)" + "\"60.0\",\"0.0\",\"LoansPayable\",\"60.0\",\"\"" (lns !! 3) + assertEqual "writeCompoundTrialBalance pinned: totals" + "\"100.0\",\"100.0\",\"Total\",\"100.0\",\"100.0\"" (lns !! 4) + +testWriteAccountOfJournalPinned :: IO () +testWriteAccountOfJournalPinned = do + let path = "/tmp/exchangealgebra_write_aoj_pinned_test.csv" + jrn = ((100 .@ Not :< Cash) .| "sale") + .+ ((40 .@ Hat :< Cash) .| "pay") + :: Journal String Double (HatBase AccountTitles) + EW.writeAccountOfJournal [Cash] path jrn + raw <- readFileStrict path + removeFile path + let lns = lines raw + assertEqual "writeAccountOfJournal pinned: line count" 4 (length lns) + assertEqual "writeAccountOfJournal pinned: title header" + "\"Cash\",\"\",\"\"" (lns !! 0) + assertEqual "writeAccountOfJournal pinned: sub header" + "\"Note\",\"Debit\",\"Credit\"" (lns !! 1) + assertEqual "writeAccountOfJournal pinned: note order (\"pay\" < \"sale\")" + "\"\"\"pay\"\"\",\"\",\"40.0\"" (lns !! 2) + assertEqual "writeAccountOfJournal pinned: sale posting" + "\"\"\"sale\"\"\",\"100.0\",\"\"" (lns !! 3) + +-- | Regression tests for scale-aware numeric tolerance (WI-11/12/14). +-- These exercise large magnitudes that the previous fixed @1e-13@ absolute +-- tolerance handled incorrectly (retaining pure rounding noise as a residual); +-- small-scale behavior is unchanged. See plans LAZY_EVAL_AUDIT.md s4.6. +testNumericToleranceScaleAware :: IO () +testNumericToleranceScaleAware = do + assertEqual "nearlyEqScaled: large-scale rounding treated as equal" + True (EA.nearlyEqScaled (1e10 + 0.1 + 0.2) (1e10 + 0.3 :: Double)) + assertEqual "isNearlyNum 1e-13: large-scale rounding rejected (documents old flaw)" + False (EA.isNearlyNum (1e10 + 0.1 + 0.2) (1e10 + 0.3) (1e-13 :: Double)) + assertEqual "nearlyEqScaled: small-scale noise treated as equal" + True (EA.nearlyEqScaled (0.1 + 0.2) (0.3 :: Double)) + assertEqual "nearlyEqScaled: genuine residual kept (not swallowed)" + False (EA.nearlyEqScaled (1e10 + 5.0) (1e10 :: Double)) + assertEqual "nearlyEqScaled: NaN guarded (no crash, not equal)" + False (EA.nearlyEqScaled (0/0) (1.0 :: Double)) + let big = (1e10 :@ (Hat :< Yen)) .+ (0.1 :@ (Hat :< Yen)) .+ (0.2 :@ (Hat :< Yen)) + .+ (1e10 :@ (Not :< Yen)) .+ (0.3 :@ (Not :< Yen)) :: TestAlg + assertEqual "bar cancels balanced large-scale element to Zero" + True (EA.isZero ((.-) big)) + +-- | Smoke test for the exact non-negative decimal value type 'MoneyDecimal' (Stage B). +-- The point of an exact value type is that summation is associative, so @norm@ is +-- *independent of construction order* — the property that makes the fromList O(N) +-- optimization safe (Stage D). Note the raw @Seq@ order (and hence @toMap@/@Eq@) +-- still depends on construction; only the numeric results are order-independent. +testMoneyDecimalExactOrderIndependent :: IO () +testMoneyDecimalExactOrderIndependent = do + assertEqual "MoneyDecimal: 0.1 + 0.2 == 0.3 exactly" + True (0.1 + 0.2 == (0.3 :: MoneyDecimal)) + let mk i = ((fromIntegral (i `mod` 7 + 1) :: MoneyDecimal) + :@ ((if even i then Hat else Not) :< ([Yen, Amount] !! (i `mod` 2)))) + .| show (i `mod` 150) + xs :: [Journal String MoneyDecimal (HatBase CountUnit)] + xs = [ mk i | i <- [1 .. 400 :: Int] ] + viaFoldr = foldr (.+) mempty xs + viaFoldl = L.foldl' (.+) mempty xs + -- exact ⇒ norm is identical for the two construction orders + assertEqual "MoneyDecimal Journal: norm is construction-order-independent" + (norm viaFoldr) (norm viaFoldl) + -- banker's rounding (round half to even) + assertEqual "bankersRound 0 2.5 = 2 (half to even)" (2 :: MoneyDecimal) (bankersRound 0 2.5) + assertEqual "bankersRound 0 3.5 = 4 (half to even)" (4 :: MoneyDecimal) (bankersRound 0 3.5) + assertEqual "bankersRound 2 0.125 = 0.12 (half to even)" (0.12 :: MoneyDecimal) (bankersRound 2 0.125) + +-- | Strict file read helper for tests +readFileStrict :: FilePath -> IO String +readFileStrict p = do + bs <- TIO.readFile p + return (T.unpack bs) + +-- ================================================================ +-- Main +-- ================================================================ + +-- ================================================================ +-- Redundant-algebra axiom property tests (QuickCheck) +-- +-- Encodes the Definition 6 axioms (paper Appendix A) + derived lemmas as +-- QuickCheck properties, plus regression generalizations for the union +-- zero-base bug and construction-order independence. Property suite, additive. +-- ================================================================ + +type NNAlg = EA.Alg MoneyDecimal (HatBase CountUnit) + +-- run a QuickCheck property in the existing IO-style harness +quickProp :: Testable p => String -> p -> IO () +quickProp label p = do + r <- quickCheckWithResult stdArgs { maxSuccess = 200, chatty = False } p + if isSuccess r + then putStrLn ("[PASS] " ++ label) + else do putStrLn ("[FAIL] " ++ label); putStr (output r); exitFailure + +-- generators: concrete (non-wildcard) bases, intentional collisions +genUnit :: Gen CountUnit +genUnit = elements [Yen, Dollar, Amount] + +genSide :: Gen Hat +genSide = elements [Hat, Not] + +genBase :: Gen (HatBase CountUnit) +genBase = (:<) <$> genSide <*> genUnit + +genNNDouble :: Gen Double -- non-negative, finite +genNNDouble = do + NonNegative x <- arbitrary + if isNaN x || isInfinite x then genNNDouble else pure x + +genAlgD :: Gen TestAlg +genAlgD = sized $ \n -> do + k <- choose (0, min 40 n) + ps <- vectorOf k ((,) <$> genNNDouble <*> genBase) + pure (EA.fromList [ v .@ b | (v, b) <- ps ]) + +genAlgN :: Gen NNAlg +genAlgN = sized $ \n -> do + k <- choose (0, min 40 n) + ps <- vectorOf k ((,) <$> (realToFrac <$> genNNDouble) <*> genBase) + pure (EA.fromList [ v .@ b | (v, b) <- ps ]) + +-- exact per-base signed net (Not +, Hat -) via Rational; the observable +-- accounting content. Robust to seq order; catches base misassociation. +netByBase :: (HatVal v, Real v) => EA.Alg v (HatBase CountUnit) -> M.Map CountUnit Rational +netByBase = EA.foldEntries step M.empty + where + step m v b = M.insertWith (+) (part b) (signed v b) m + part (_ :< u) = u + signed v b = if isHat b then negate (toRational v) else toRational v + +-- ℘ observation: retain each full Hat/Not base and its value multiset, while +-- forgetting the representation-level order of the per-side Seq. +observe :: (Ord b, Ord v, HatVal v, HatBaseClass b) + => EA.Alg v b -> M.Map b [v] +observe = fmap L.sort . EA.foldEntries step M.empty + where + step m v b = M.insertWith (++) b [v] m + +epsEq :: Double -> Double -> Bool +epsEq a b = abs (a - b) <= 1e-9 * (1 + max (abs a) (abs b)) + +-- ================================================================ +-- ExchangeAlgebra.Convert.Csv: generic journal CSV reader. +-- Read-only round-trip property: a generated list of postings rendered to a +-- fixed-schema CSV string parses back to exactly the term built directly by +-- journalFromSides (MoneyDecimal = exact, so strict equality, no tolerance). +-- ================================================================ + +-- concrete account titles only (no wildcard); use canonical Show names so the +-- CSV round-trip does not exercise the ambiguous-alias path. +genAccountTitle :: Gen AccountTitles +genAccountTitle = elements EC.concreteAccountTitles + +genSideCsv :: Gen Side +genSideCsv = elements [Debit, Credit] + +-- non-negative MoneyDecimal with up to 2 decimal places, written exactly as a +-- decimal literal (terminating) so scientificAmount parses it back exactly. +genAmountMD :: Gen (MoneyDecimal, T.Text) +genAmountMD = do + whole <- choose (0, 99999) :: Gen Integer + cents <- choose (0, 99) :: Gen Integer + let txt = T.pack (show whole) <> T.pack "." <> + T.pack (let s = show cents in if length s == 1 then '0':s else s) + val = fromRational (toRational whole + toRational cents / 100) :: MoneyDecimal + pure (val, txt) + +genPostingCsv :: Gen (Side, AccountTitles, MoneyDecimal, T.Text) +genPostingCsv = do + s <- genSideCsv + a <- genAccountTitle + (v, vtx) <- genAmountMD + pure (s, a, v, vtx) + +renderCsv :: [(Side, AccountTitles, MoneyDecimal, T.Text)] -> T.Text +renderCsv rows = + T.unlines (header : L.map line rows) + where + header = T.pack "side,account,amount" + line (s, a, _, vtx) = + T.intercalate (T.pack ",") + [ sideText s, T.pack (show a), vtx ] + sideText Debit = T.pack "debit" + sideText Credit = T.pack "credit" + sideText Side = T.pack "debit" -- unused (generator never yields wildcard) + +testConvertCsvRoundTrip :: IO () +testConvertCsvRoundTrip = do + quickProp "convert-csv: render -> parse is exact (MoneyDecimal)" $ + forAll (resize 30 (listOf genPostingCsv)) $ \rows -> + let csv = renderCsv rows + expected = EC.journalFromSides + [ (s, a, v) | (s, a, v, _) <- rows ] + :: EA.Alg MoneyDecimal (HatBase AccountTitles) + parsed = ECsv.parseJournalCsv csv + :: Either EC.ConvError + (EA.Alg MoneyDecimal (HatBase AccountTitles)) + in parsed == Right expected + + -- structural guards: bad header, unknown account, negative amount, bad arity. + let badHeader = T.pack "s,a,amt\ndebit,Cash,1\n" + badAcct = T.pack "side,account,amount\ndebit,Goodwill_X,1\n" + badAmt = T.pack "side,account,amount\ndebit,Cash,-1\n" + badArity = T.pack "side,account,amount\ndebit,Cash\n" + run t = ECsv.parseJournalCsv t + :: Either EC.ConvError + (EA.Alg MoneyDecimal (HatBase AccountTitles)) + expectLeft label pat t = case run t of + Left e | pat e -> putStrLn ("[PASS] " ++ label) + | otherwise -> do putStrLn ("[FAIL] " ++ label ++ ": wrong error " ++ show e); exitFailure + Right _ -> do putStrLn ("[FAIL] " ++ label ++ ": accepted bad input"); exitFailure + expectLeft "convert-csv: rejects bad header" + (\e -> case e of EC.MalformedCsv _ -> True; _ -> False) badHeader + expectLeft "convert-csv: rejects unknown account" + (\e -> case e of EC.UnknownAccount _ -> True; _ -> False) badAcct + expectLeft "convert-csv: rejects negative amount" + (\e -> case e of EC.BadAmount _ -> True; _ -> False) badAmt + expectLeft "convert-csv: rejects wrong field count" + (\e -> case e of EC.MalformedCsv _ -> True; _ -> False) badArity + +-- ================================================================ +-- ExchangeAlgebra.Assist: account descriptions and LLM feedback helpers. +-- ================================================================ + +testAssistDescriptionsDrift :: IO () +testAssistDescriptionsDrift = + assertEqual "Assist descriptions are the registry projection" + registryProjection AssistDesc.accountDescriptions + where + registryProjection = + [ (title, Registry.asNameEn spec, Registry.asNameJa spec, Registry.asDescription spec) + | title <- Registry.concreteAccountTitles + , Just spec <- [Registry.accountSpec title] + ] + +testAssistDescribeAccount :: IO () +testAssistDescribeAccount = do + let missing = + [ title + | title <- EC.concreteAccountTitles + , Assist.describeAccount title == Nothing + ] + assertEqual "Assist.describeAccount covers every concrete account" + ([] :: [AccountTitles]) missing + assertEqual "Assist.describeAccount rejects wildcard AccountTitle" + Nothing (Assist.describeAccount AccountTitle) + +testAssistAllAccountInfos :: IO () +testAssistAllAccountInfos = do + assertEqual "Assist.allAccountInfos length" 235 (length Assist.allAccountInfos) + assertEqual "Assist.allAccountInfos follows concreteAccountTitles order" + EC.concreteAccountTitles (L.map Assist.aiTitle Assist.allAccountInfos) + forM_ Assist.allAccountInfos $ \info -> do + let title = Assist.aiTitle info + case Registry.accountSemantics title of + Nothing -> do + putStrLn ("[FAIL] missing account semantics: " ++ show title) + exitFailure + Just semantics -> do + assertEqual ("Assist.aiRoles " ++ show title) + (Registry.asemRoles semantics) (Assist.aiRoles info) + assertEqual ("Assist.aiPostingCapability " ++ show title) + (Registry.asemPostingCapability semantics) + (Assist.aiPostingCapability info) + assertEqual ("Assist.aiDivisionSemantics " ++ show title) + (Registry.asemDivisionSemantics semantics) + (Assist.aiDivisionSemantics info) + assertEqual ("Assist.aiHomeSideSemantics " ++ show title) + (Registry.asemHomeSideSemantics semantics) + (Assist.aiHomeSideSemantics info) + assertEqual ("Assist.aiReportingEligibility " ++ show title) + (Registry.asemReportingEligibility semantics) + (Assist.aiReportingEligibility info) + +testAccountMetadataLand1 :: IO () +testAccountMetadataLand1 = do + let semantics = + [ (title, value) + | title <- Registry.concreteAccountTitles + , Just value <- [Registry.accountSemantics title] + ] + exceptional = + [ NetIncome, NetLoss, GrossProfit, OrdinaryProfit, IncomeSummary + , SuspensePayments, SuspenseReceipts, CashOverShort, SuspenseAccount + , BranchCurrentAccount, HeadOfficeCurrentAccount + , NetIncomeAttributableToNCI, NetLossAttributableToNCI + ] + lookupSem title = Registry.accountSemantics title + lookupInfo title = Assist.describeAccount title + nonStatementTitles = + [ title + | (title, value) <- semantics + , case Registry.asemDivisionSemantics value of + StatementDivision _ -> False + _ -> True + ] + assertEqual "Land 1 metadata covers all 235 concrete titles" + 235 (L.length semantics) + assertEqual "Land 1 metadata rejects wildcard AccountTitle" + Nothing (Registry.accountSemantics AccountTitle) + assertEqual "Land 1 non-statement metadata is exactly the reviewed exception set" + (L.sort exceptional) (L.sort nonStatementTitles) + forM_ semantics $ \(title, value) -> do + assertEqual ("Land 1 roles are non-empty: " ++ show title) + True (not (L.null (Registry.asemRoles value))) + -- Land 4a: rolesFor no longer consults asIsContra (explicit + -- enumeration), so pin the contra role to the registry flag. + assertEqual ("Land 4a contra role matches registry isContra: " ++ show title) + (Registry.classifyAccountContra title) + (ContraAccount `elem` Registry.asemRoles value) + case Registry.asemDivisionSemantics value of + StatementDivision division -> do + assertEqual ("Land 1 statement division preserves legacy value: " ++ show title) + (classifyAccountDivision title) division + _ -> assertEqual ("Land 1 exceptional title is closed-listed: " ++ show title) + True (title `L.elem` exceptional) + case Registry.asemHomeSideSemantics value of + FixedHomeSide side -> + assertEqual ("Land 1 fixed home side preserves legacy value: " ++ show title) + (whichSide (Not :< title)) side + _ -> pure () + assertEqual "Land 1 Cash semantics" + (Just ( [OrdinaryAccount], OrdinaryPosting + , StatementDivision Assets, FixedHomeSide Debit, StatementEligible )) + (fmap semanticsTuple (lookupSem Cash)) + assertEqual "Land 1 IncomeSummary semantics" + (Just ( [ClosingDevice], ClosingOnly + , DirectionEncoding Assets, ContextDependentHomeSide, NotPresented )) + (fmap semanticsTuple (lookupSem IncomeSummary)) + assertEqual "Land 1 NetIncome semantics" + (Just ( [PeriodResult], EngineGeneratedOnly + , DirectionEncoding Cost, FixedHomeSide Debit, DerivedPresentation )) + (fmap semanticsTuple (lookupSem NetIncome)) + assertEqual "Land 1 GrossProfit is an engine-generated coordinate" + (Just ( [ReportingSubtotal], EngineGeneratedOnly + , DirectionEncoding Revenue, FixedHomeSide Credit + , DerivedPresentation )) + (fmap semanticsTuple (lookupSem GrossProfit)) + assertEqual "Land 1 NCI profit is distinct from bare net income" + (Just ( [AttributionAccount, PeriodResult], ConsolidationOnly + , DirectionEncoding Cost, FixedHomeSide Debit + , ContextualPresentation )) + (fmap semanticsTuple (lookupSem NetIncomeAttributableToNCI)) + assertEqual "Land 1a NCI equity is consolidation-only" + (Just ( [AttributionAccount], ConsolidationOnly + , StatementDivision Equity, FixedHomeSide Credit + , ContextualPresentation )) + (fmap semanticsTuple (lookupSem NonControllingInterests)) + assertEqual "Land 1 branch account semantics" + (Just ( [ReciprocalAccount], OrdinaryPosting + , BookkeepingControlClass Assets, FixedHomeSide Debit + , ContextualPresentation )) + (fmap semanticsTuple (lookupSem BranchCurrentAccount)) + assertEqual "Land 1 IncomeSummary LLM description does not classify it as an asset" + True (case lookupInfo IncomeSummary of + Just info -> not (T.isPrefixOf (T.pack "Asset") (Assist.aiDesc info)) + && T.isInfixOf (T.pack "not a balance-sheet classification") + (Assist.aiDesc info) + Nothing -> False) + assertEqual "Land 1 NetIncome LLM name drops legacy Expense wording" + (Just (T.pack "当期純利益")) (fmap Assist.aiNameJa (lookupInfo NetIncome)) + where + semanticsTuple value = + ( Registry.asemRoles value + , Registry.asemPostingCapability value + , Registry.asemDivisionSemantics value + , Registry.asemHomeSideSemantics value + , Registry.asemReportingEligibility value + ) + +accountMetadataLand1Header :: T.Text -> T.Text +accountMetadataLand1Header what = + T.pack "# account-semantics-050 Land 1 " <> what + <> T.pack "; schema 1; base 09c8a60c0bfb1a7fedb01689ceee789b8b4e6084\n" + +accountMetadataLand1Row :: AccountTitles -> T.Text +accountMetadataLand1Row title = case Registry.accountSemantics title of + Nothing -> error ("missing AccountSemantics for " ++ show title) + Just semantics -> T.intercalate (T.pack "\t") + [ goldenShow title + , goldenShow (Registry.asemRoles semantics) + , goldenShow (Registry.asemPostingCapability semantics) + , goldenShow (Registry.asemDivisionSemantics semantics) + , goldenShow (Registry.asemHomeSideSemantics semantics) + , goldenShow (Registry.asemReportingEligibility semantics) + ] + +accountMetadataLand1InfoRow :: Assist.AccountInfo -> T.Text +accountMetadataLand1InfoRow info = T.intercalate (T.pack "\t") + [ goldenShow (Assist.aiTitle info) + , goldenShow (Assist.aiRoles info) + , goldenShow (Assist.aiPostingCapability info) + , goldenShow (Assist.aiDivisionSemantics info) + , goldenShow (Assist.aiHomeSideSemantics info) + , goldenShow (Assist.aiReportingEligibility info) + , goldenEsc (Assist.aiNameEn info) + , goldenEsc (Assist.aiNameJa info) + , goldenEsc (Assist.aiDesc info) + ] + +accountMetadataLand1Suggestions :: T.Text +accountMetadataLand1Suggestions = + accountMetadataLand1Header + (T.pack "LLM suggestAccounts (query, total matches, top-10 titles)") + <> T.unlines (L.map row corpus) + where + infos = Assist.allAccountInfos + fields = L.concat + [ [goldenShow (Assist.aiTitle info), Assist.aiNameEn info, Assist.aiNameJa info] + | info <- infos + ] + descTokens = L.concatMap (T.words . Assist.aiDesc) infos + corpus = goldenDedupSort + (L.concatMap (\value -> [value, T.toLower value]) fields <> descTokens) + row query = + let matches = L.map Assist.aiTitle (Assist.suggestAccounts query) + in goldenEsc query <> T.pack "\t" <> goldenShow (L.length matches) + <> T.pack "\t" + <> T.intercalate (T.pack ",") (L.map goldenShow (L.take 10 matches)) + +testAccountMetadataLand1Golden :: IO () +testAccountMetadataLand1Golden = do + metadata <- TIO.readFile "test/fixtures/account-semantics-050/metadata.tsv" + info <- TIO.readFile "test/fixtures/account-semantics-050/account-info.tsv" + suggest <- TIO.readFile "test/fixtures/account-semantics-050/suggest.tsv" + let expectedMetadata = + accountMetadataLand1Header + (T.pack "registry (title, roles, posting, divisionSemantics, homeSideSemantics, reportingEligibility)") + <> T.unlines (L.map accountMetadataLand1Row Registry.concreteAccountTitles) + expectedInfo = + accountMetadataLand1Header + (T.pack "LLM AccountInfo (title, roles, posting, divisionSemantics, homeSideSemantics, reportingEligibility, nameEn, nameJa, description)") + <> T.unlines (L.map accountMetadataLand1InfoRow Assist.allAccountInfos) + assertEqual "Land 1 metadata fixture has 235 rows" + 235 (L.length (L.drop 1 (T.lines metadata))) + assertEqual "Land 1 metadata fixture" metadata expectedMetadata + assertEqual "Land 1 LLM AccountInfo fixture" info expectedInfo + assertEqual "Land 1 LLM suggestion fixture" + suggest accountMetadataLand1Suggestions + +testAccountInfoLand1Migration :: IO () +testAccountInfoLand1Migration = do + legacy <- TIO.readFile "test/fixtures/pre-account-semantics-050/account-info.tsv" + let titleMap = M.fromList + [ (goldenShow title, title) | title <- Registry.concreteAccountTitles ] + rows = L.filter (not . T.null) (L.drop 1 (T.lines legacy)) + assertEqual "Land 1 AccountInfo migration covers 232 legacy rows" + 232 (L.length rows) + forM_ rows $ \line -> case T.splitOn (T.pack "\t") line of + [titleText, oldDivision, oldSide, oldNameEn, oldNameJa, oldDesc] -> + case M.lookup titleText titleMap of + Nothing -> assertEqual "Land 1 migration unknown legacy title" + (T.pack "") titleText + Just title -> case (Registry.accountSemantics title, Assist.describeAccount title) of + (Just semantics, Just info) -> do + assertEqual ("Land 1 legacy division is recoverable: " ++ show title) + oldDivision + (legacyDivisionText (Registry.asemDivisionSemantics semantics)) + assertEqual ("Land 1 legacy home side is recoverable: " ++ show title) + oldSide (goldenShow (whichSide (Not :< title))) + case Registry.asemDivisionSemantics semantics of + StatementDivision _ -> do + assertEqual ("Land 1 ordinary nameEn unchanged: " ++ show title) + oldNameEn (goldenEsc (Assist.aiNameEn info)) + -- Land 4a: the Assist projection (aiNameJa) now + -- returns the annotation-free asLabelJa and is + -- pinned by account-semantics-050/account-info.tsv; + -- the pre-golden pins the registry fields. + assertEqual ("Land 1 registry nameJa unchanged: " ++ show title) + oldNameJa (maybe T.empty + (goldenEsc . Registry.asNameJa) + (Registry.accountSpec title)) + assertEqual ("Land 1 registry description unchanged: " ++ show title) + oldDesc (maybe T.empty + (goldenEsc . Registry.asDescription) + (Registry.accountSpec title)) + _ -> pure () + _ -> do + putStrLn ("[FAIL] missing Land 1 migration metadata: " ++ show title) + exitFailure + _ -> assertEqual "Land 1 migration malformed legacy row" (T.pack "") line + where + legacyDivisionText semantics = goldenShow $ case semantics of + StatementDivision division -> division + BookkeepingControlClass division -> division + DirectionEncoding division -> division + NoStatementDivision -> error "legacy division is unavailable" + +testAssistSuggestAccounts :: IO () +testAssistSuggestAccounts = do + assertEqual "Assist.suggestAccounts cash contains Cash" + True (Cash `elem` L.map Assist.aiTitle (Assist.suggestAccounts (T.pack "cash"))) + assertEqual "Assist.suggestAccounts 現金 contains Cash" + True (Cash `elem` L.map Assist.aiTitle (Assist.suggestAccounts (T.pack "現金"))) + assertEqual "Assist.suggestAccounts empty query" + [] (Assist.suggestAccounts T.empty) + assertEqual "Assist.suggestAccounts no match" + [] (Assist.suggestAccounts (T.pack "zzzznomatch")) + +-- ================================================================ +-- Land 1 registry: frozen pre-registry behaviour. +-- ================================================================ + +goldenCommit :: T.Text +goldenCommit = T.pack "2d9164642f2862725c653e496976770f6e2c7d6f" + +goldenHeader :: T.Text -> T.Text +goldenHeader what = + T.pack "# pre-land1 " <> what <> T.pack "; commit " <> goldenCommit <> T.pack "\n" + +goldenShow :: Show a => a -> T.Text +goldenShow = T.pack . show + +goldenEsc :: T.Text -> T.Text +goldenEsc = T.replace (T.pack "\t") (T.pack "\\t") + . T.replace (T.pack "\n") (T.pack "\\n") + +goldenDedupSort :: [T.Text] -> [T.Text] +goldenDedupSort = L.map L.head . L.group . L.sort + +legacySuggestAccounts :: [Assist.AccountInfo] -> T.Text -> [Assist.AccountInfo] +legacySuggestAccounts infos query + | L.null tokens = [] + | otherwise = L.map snd + . L.sortOn (\(rank, info) -> (negate rank, fromEnum (Assist.aiTitle info))) + . L.filter ((> 0) . fst) + $ [ (matchRank info, info) | info <- infos ] + where + tokens = L.map T.toCaseFold (T.words query) + matchRank info = L.length + [ token + | token <- tokens + , L.any (T.isInfixOf token) (legacySearchFields info) + ] + legacySearchFields info = L.map T.toCaseFold $ case Registry.accountSpec (Assist.aiTitle info) of + Just spec -> + [ goldenShow (Assist.aiTitle info) + , Registry.asNameEn spec + , Registry.asNameJa spec + , Registry.asDescription spec + ] + Nothing -> [] + +goldenInfoRow :: Assist.AccountInfo -> T.Text +-- Historical schema reconstruction. The live Land 1 AccountInfo projection is +-- pinned separately by accountMetadataLand1InfoRow. +goldenInfoRow info = case Registry.accountSpec (Assist.aiTitle info) of + Nothing -> error "goldenInfoRow: wildcard AccountTitle" + Just spec -> T.intercalate (T.pack "\t") + [ goldenShow (Assist.aiTitle info) + , goldenShow (Registry.asDivision spec) + , goldenShow (whichSide (Not :< Assist.aiTitle info)) + , goldenEsc (Registry.asNameEn spec) + , goldenEsc (Registry.asNameJa spec) + , goldenEsc (Registry.asDescription spec) + ] + +goldenAliasResolution :: T.Text -> T.Text +goldenAliasResolution fixture = + goldenHeader (T.pack "parseAccountTitle over corpus (query, show(Either ConvError AccountTitles))") + <> T.unlines (L.map row queries) + where + queries = L.map (T.takeWhile (/= '\t')) (L.drop 1 (T.lines fixture)) + row query = goldenEsc query <> T.pack "\t" + <> goldenEsc (goldenShow (EC.parseAccountTitle query)) + +goldenSuggestions :: T.Text +goldenSuggestions = + goldenHeader (T.pack "suggestAccounts over corpus (query, total matches, top-10 titles)") + <> T.unlines (L.map row corpus) + where + -- The post-Land2 fixture is a closed diff over the pre-vocabulary 116 + -- titles. V-Land 2 appends new titles, which are tested separately and + -- must not retroactively change this historical fuzzy-suggestion oracle. + infos = L.take 116 Assist.allAccountInfos + historicalTitles = L.map Assist.aiTitle infos + nameFields = L.concatMap legacyNameFields infos + descTokens = L.concatMap legacyDescTokens infos + corpus = goldenDedupSort + (L.concatMap (\q -> [q, T.toLower q]) nameFields <> descTokens) + row query = + let matches = L.filter (`L.elem` historicalTitles) + (L.map Assist.aiTitle (legacySuggestAccounts infos query)) + in goldenEsc query <> T.pack "\t" + <> goldenShow (L.length matches) <> T.pack "\t" + <> T.intercalate (T.pack ",") (L.map goldenShow (L.take 10 matches)) + legacyNameFields info = case Registry.accountSpec (Assist.aiTitle info) of + Just spec -> + [ goldenShow (Assist.aiTitle info) + , Registry.asNameEn spec + , Registry.asNameJa spec + ] + Nothing -> [] + legacyDescTokens info = case Registry.accountSpec (Assist.aiTitle info) of + Just spec -> T.words (Registry.asDescription spec) + Nothing -> [] + +postVocabHeader :: T.Text -> T.Text +postVocabHeader what = T.pack "# post-vocab " <> what <> T.pack "; schema 1\n" + +postVocabInfoGolden :: T.Text +postVocabInfoGolden = + postVocabHeader (T.pack "AccountInfo (title, division, homeSide, nameEn, nameJa, description)") + <> T.unlines (L.map goldenInfoRow Assist.allAccountInfos) + +postVocabSuggestionsGolden :: T.Text +postVocabSuggestionsGolden = + postVocabHeader (T.pack "suggestAccounts (query, total matches, top-10 titles)") + <> T.unlines (L.map row corpus) + where + infos = Assist.allAccountInfos + nameFields = L.concatMap legacyNameFields infos + descTokens = L.concatMap legacyDescTokens infos + corpus = goldenDedupSort + (L.concatMap (\q -> [q, T.toLower q]) nameFields <> descTokens) + row query = + let matches = L.map Assist.aiTitle (legacySuggestAccounts infos query) + in goldenEsc query <> T.pack "\t" + <> goldenShow (L.length matches) <> T.pack "\t" + <> T.intercalate (T.pack ",") (L.map goldenShow (L.take 10 matches)) + legacyNameFields info = case Registry.accountSpec (Assist.aiTitle info) of + Just spec -> + [ goldenShow (Assist.aiTitle info) + , Registry.asNameEn spec + , Registry.asNameJa spec + ] + Nothing -> [] + legacyDescTokens info = case Registry.accountSpec (Assist.aiTitle info) of + Just spec -> T.words (Registry.asDescription spec) + Nothing -> [] + +postVocabOrdinalsGolden :: T.Text +postVocabOrdinalsGolden = + postVocabHeader (T.pack "Enum ordinals (constructor, fromEnum)") + <> T.unlines + [ goldenShow title <> T.pack "\t" <> goldenShow (fromEnum title) + | title <- [minBound .. maxBound] :: [AccountTitles] + ] + +postVocabSemanticsGolden :: T.Text +postVocabSemanticsGolden = + postVocabHeader (T.pack "semantics (title, whatDiv, isContra, whichSide Not, whichSide Hat, whatPIMO, fixedCurrent, finalStockProbe)") + <> T.unlines (L.map row Registry.concreteAccountTitles) + where + row title = + let nb = Not :< title :: HatBase AccountTitles + hb = Hat :< title :: HatBase AccountTitles + in T.intercalate (T.pack "\t") + [ goldenShow title + , goldenShow (whatDiv nb) + , goldenShow (Registry.classifyAccountContra title) + , goldenShow (whichSide nb) + , goldenShow (whichSide hb) + , goldenShow (whatPIMO nb) + , goldenShow (fixedCurrent nb) + , T.pack (finalStockProbeRule title) + ] + +testPostVocabGolden :: IO () +testPostVocabGolden = do + ordinals <- TIO.readFile "test/fixtures/post-vocab/ordinals.tsv" + semantics <- TIO.readFile "test/fixtures/post-vocab/semantics.tsv" + info <- TIO.readFile "test/fixtures/post-vocab/account-info.tsv" + suggestions <- TIO.readFile "test/fixtures/post-vocab/suggest.tsv" + assertEqual "post-vocab ordinal fixture" ordinals postVocabOrdinalsGolden + assertEqual "post-vocab semantics fixture" semantics postVocabSemanticsGolden + assertEqual "post-vocab account-info fixture" info postVocabInfoGolden + assertEqual "post-vocab suggest fixture" suggestions postVocabSuggestionsGolden + +-- ================================================================ +-- 0.5.0.0 account-semantics pipeline: pre-change compatibility baseline. +-- ================================================================ + +accountSemanticsBaselineCommit :: T.Text +accountSemanticsBaselineCommit = T.pack "0d8e2791429145f2a48c79adbe62563328ee5c0b" + +accountSemanticsHeader :: T.Text -> T.Text +accountSemanticsHeader what = + T.pack "# pre-account-semantics-050 " <> what + <> T.pack "; schema 1; commit " <> accountSemanticsBaselineCommit <> T.pack "\n" + +accountSemanticsBinaryHex :: AccountTitles -> T.Text +accountSemanticsBinaryHex = T.pack . concatMap hexByte . BL.unpack . Binary.encode + where + hexByte byte = case showHex byte "" of + [digit] -> ['0', digit] + digits -> digits + +-- The pre-account-semantics fixture is immutable and predates the three +-- Land 4a constructors appended after ordinal 231. +accountSemanticsBaselineTitles :: [AccountTitles] +accountSemanticsBaselineTitles = L.take 232 Registry.concreteAccountTitles + +accountSemanticsSemanticsGolden :: T.Text +accountSemanticsSemanticsGolden = + accountSemanticsHeader (T.pack "semantics (title, enum, binaryHex, division, closing, isContra, whichSide Not, whichSide Hat, whatPIMO, fixedCurrent, finalStockProbe)") + <> T.unlines (L.map row accountSemanticsBaselineTitles) + where + row title = + let nb = Not :< title :: HatBase AccountTitles + hb = Hat :< title :: HatBase AccountTitles + spec = case Registry.accountSpec title of + Just value -> value + Nothing -> error ("missing AccountSpec for " ++ show title) + in T.intercalate (T.pack "\t") + [ goldenShow title + , goldenShow (fromEnum title) + , accountSemanticsBinaryHex title + , goldenShow (Registry.asDivision spec) + , goldenShow (Registry.asClosing spec) + , goldenShow (Registry.asIsContra spec) + , goldenShow (whichSide nb) + , goldenShow (whichSide hb) + , goldenShow (whatPIMO nb) + , goldenShow (fixedCurrent nb) + , T.pack (finalStockProbeRule title) + ] + +accountSemanticsInfoGolden :: T.Text +accountSemanticsInfoGolden = + accountSemanticsHeader (T.pack "AccountInfo (title, division, homeSide, nameEn, nameJa, description)") + <> T.unlines (L.map goldenInfoRow (L.take 232 Assist.allAccountInfos)) + +accountSemanticsProjectionGolden :: T.Text +accountSemanticsProjectionGolden = + accountSemanticsHeader (T.pack "projection flags for Not then Hat (currentAssets, fixedAssets, deferredAssets, currentLiability, fixedLiability, capitalStock, contraAssets, contra)") + <> T.unlines (L.map row accountSemanticsBaselineTitles) + where + kept :: (EA.Alg Double (HatBase AccountTitles) + -> EA.Alg Double (HatBase AccountTitles)) + -> EA.Alg Double (HatBase AccountTitles) + -> T.Text + kept projection value = if norm (projection value) == (1 :: Double) + then T.pack "1" else T.pack "0" + row title = T.intercalate (T.pack "\t") + (goldenShow title : L.concatMap (probe title) [Not, Hat]) + probe title hat = + let value = 1 .@ hat :< title :: EA.Alg Double (HatBase AccountTitles) + in [ kept EA.projCurrentAssets value + , kept EA.projFixedAssets value + , kept EA.projDeferredAssets value + , kept EA.projCurrentLiability value + , kept EA.projFixedLiability value + , kept EA.projCapitalStock value + , kept EA.projContraAssets value + , kept EA.projContra value + ] + +accountSemanticsPresentationGolden :: T.Text +accountSemanticsPresentationGolden = + accountSemanticsHeader (T.pack "legacy presentation probe (title, bsRows of 1@Not, plRows of 1@Not)") + <> T.unlines (L.map row accountSemanticsBaselineTitles) + where + row title = + let value = 1 .@ Not :< title :: EA.Alg Double (HatBase AccountTitles) + in T.intercalate (T.pack "\t") + [ goldenShow title + , goldenEsc (goldenShow (EW.bsRows value)) + , goldenEsc (goldenShow (EW.plRows value)) + ] + +testAccountSemanticsPrechangeGolden :: IO () +testAccountSemanticsPrechangeGolden = do + semantics <- TIO.readFile "test/fixtures/pre-account-semantics-050/semantics.tsv" + info <- TIO.readFile "test/fixtures/pre-account-semantics-050/account-info.tsv" + projections <- TIO.readFile "test/fixtures/pre-account-semantics-050/projection-membership.tsv" + presentation <- TIO.readFile "test/fixtures/pre-account-semantics-050/presentation.tsv" + assertEqual "pre-account-semantics semantics fixture has 232 rows" + 232 (L.length (L.drop 1 (T.lines semantics))) + assertEqual "pre-account-semantics semantics fixture" + semantics accountSemanticsSemanticsGolden + assertEqual "pre-account-semantics legacy AccountInfo fixture" + info accountSemanticsInfoGolden + assertEqual "pre-account-semantics projection fixture" + projections accountSemanticsProjectionGolden + let oldPresentation = L.drop 1 (T.lines presentation) + newPresentation = L.drop 1 (T.lines accountSemanticsPresentationGolden) + changedTitles = + [ T.takeWhile (/= '\t') new + | (old, new) <- L.zip oldPresentation newPresentation + , old /= new + ] + assertEqual "pre-account-semantics presentation row count" + (L.length oldPresentation) (L.length newPresentation) + assertEqual "Land 3 presentation closed diff = contra rows plus two formerly phantom totals" + [ T.pack "NetLoss" + , T.pack "AllowanceForDoubtfulAccounts" + , T.pack "AccumulatedDepreciation" + , T.pack "SalesRebates" + , T.pack "RefundOfIncomeTaxes" + , T.pack "PurchaseRebates" + , T.pack "NetLossAttributableToNCI" + ] + changedTitles + +-- Land 2 (Definition 7 contra amendment) 以降: alias 解決だけが byte 一致 +-- (parseAccountTitle は division 非依存)。semantics / info / suggest は +-- 意図的差分を持つため, closed-diff test (testLand2*ClosedDiff) が引き継ぐ。 +testRegistryGolden :: IO () +testRegistryGolden = do + aliases <- TIO.readFile "test/fixtures/pre-land1/alias-resolution.tsv" + jcci <- TIO.readFile "test/fixtures/jcci-2022/queries.tsv" + let oldRows = L.filter (not . T.null) (L.drop 1 (T.lines aliases)) + currentRows = L.filter (not . T.null) + (L.drop 1 (T.lines (goldenAliasResolution aliases))) + changedQueries = + [ T.takeWhile (/= '\t') old + | (old, current) <- L.zip oldRows currentRows + , old /= current + ] + expectedChangedQueries = L.sort (L.map T.pack + [ "未払金", "借入金", "仮払金", "仮受金" + , "有価証券", "投資有価証券" + , " 未払金 ", " 借入金 ", " 仮払金 ", " 仮受金 " + , " 有価証券 ", " 投資有価証券 " + ]) + officialQueries = + [ EC.normalizeTitle (fields L.!! 3) + | line <- L.filter (not . T.null) (L.drop 1 (T.lines jcci)) + , let fields = T.splitOn (T.pack "\t") line + , L.length fields == 7 + ] + assertEqual "registry golden: historical row count" + (L.length oldRows) (L.length currentRows) + assertEqual "registry golden: every changed historical alias is JCCI-scoped" + ([] :: [T.Text]) + [q | q <- changedQueries, EC.normalizeTitle q `L.notElem` officialQueries] + -- The pre-land fixture freezes each old result; testJcciAccountNameCoverage + -- freezes each new result. Freezing this exact query set closes the diff. + assertEqual "registry golden: exact adjudicated historical alias diff" + expectedChangedQueries (L.sort changedQueries) + +-- | JCCI 2022 A欄/B欄の全 distinct query は, 一意のRightかfixtureで候補を +-- 閉じたAmbiguousのどちらかでなければならない. Unknown/first-matchは不可. +testJcciAccountNameCoverage :: IO () +testJcciAccountNameCoverage = do + source <- TIO.readFile "test/fixtures/jcci-2022/source.tsv" + fixture <- TIO.readFile "test/fixtures/jcci-2022/queries.tsv" + let sourceRows = L.filter (not . T.null) (L.drop 1 (T.lines source)) + rows = L.filter (not . T.null) (L.drop 1 (T.lines fixture)) + outcomes = [field L.!! 4 | row <- rows, let field = T.splitOn (T.pack "\t") row] + sourceFields = + [ fields + | row <- sourceRows + , let fields = T.splitOn (T.pack "\t") row + , L.length fields == 6 + ] + sourceEntries = + [ (EC.normalizeTitle label, standardName) + | fields <- sourceFields + , let standardName = fields L.!! 2 + , label <- standardName : T.splitOn (T.pack "|") (fields L.!! 3) + , not (T.null (T.strip label)) + ] + sourceLabels = goldenDedupSort (L.map fst sourceEntries) + fixtureLabels = goldenDedupSort + [ EC.normalizeTitle (fields L.!! 3) + | row <- rows + , let fields = T.splitOn (T.pack "\t") row + , L.length fields == 7 + ] + assertEqual "JCCI source A-row count" 215 (L.length sourceRows) + assertEqual "JCCI source rows have six columns" + (L.length sourceRows) (L.length sourceFields) + assertEqual "JCCI distinct normalized A/B query count" 316 (L.length rows) + assertEqual "JCCI fixture covers exactly the source A/B labels" + sourceLabels fixtureLabels + assertEqual "JCCI unique resolutions" 295 (L.length (L.filter (== T.pack "right") outcomes)) + assertEqual "JCCI policy ambiguities" 21 (L.length (L.filter (== T.pack "ambiguous") outcomes)) + forM_ rows $ \row -> case T.splitOn (T.pack "\t") row of + [_, _, _, query, _, _, standardNames] -> + assertEqual ("JCCI source provenance: " ++ T.unpack query) + (goldenDedupSort + [ standardName + | (label, standardName) <- sourceEntries + , label == EC.normalizeTitle query + ]) + (goldenDedupSort (T.splitOn (T.pack "|") standardNames)) + fields -> assertEqual "JCCI fixture provenance row has seven columns" + (7 :: Int) (L.length fields) + mapM_ check rows + where + check row = case T.splitOn (T.pack "\t") row of + [_, _, _, query, outcome, candidateText, _] -> + let names = T.splitOn (T.pack "|") candidateText + in case traverse (`M.lookup` land2TitleMap) names of + Nothing -> assertEqual "JCCI fixture names only real constructors" + (T.pack "known constructors") candidateText + Just candidates -> case candidates of + [candidate] | outcome == T.pack "right" -> + assertEqual ("JCCI Right: " ++ T.unpack query) + (Right candidate) (EC.parseAccountTitle query) + _ : _ : _ | outcome == T.pack "ambiguous" -> + assertEqual ("JCCI Ambiguous: " ++ T.unpack query) + (Left (EC.AmbiguousAccount query candidates)) + (EC.parseAccountTitle query) + _ -> assertEqual "JCCI fixture outcome/candidate arity" + (T.pack "right=1 or ambiguous>=2") + (outcome <> T.pack ":" <> candidateText) + _ -> assertEqual "JCCI fixture row has seven columns" (7 :: Int) + (L.length (T.splitOn (T.pack "\t") row)) + +-- | Every cleaned Japanese label is a bare account name, and every level-2 +-- JCCI A-column name that resolves uniquely is the profile display label. +testAccountLabelsLand4a :: IO () +testAccountLabelsLand4a = do + let labels = + [ (title, Registry.asLabelJa spec) + | title <- Registry.concreteAccountTitles + , Just spec <- [Registry.accountSpec title] + ] + forbidden = L.map T.pack ["。", "—", "\\/", "'"] + invalid = + [ (title, label) + | (title, label) <- labels + , any (`T.isInfixOf` label) forbidden + || T.any (\c -> isAscii c && isAlpha c) label + ] + assertEqual "Land 4a asLabelJa covers all 235 concrete titles" + 235 (L.length labels) + assertEqual "Land 4a asLabelJa contains only cleaned Japanese account names" + ([] :: [(AccountTitles, T.Text)]) invalid + + source <- TIO.readFile "test/fixtures/jcci-2022/source.tsv" + let rows = + [ fields + | row <- L.drop 1 (T.lines source) + , not (T.null row) + , let fields = T.splitOn (T.pack "\t") row + , L.length fields == 6 + , T.pack "2" `T.isInfixOf` (fields L.!! 0) + ] + aNames = L.map (L.!! 2) rows + resolved = + [ (name, title, RP.presentationLabel RP.JcciSecondGradeReport title) + | name <- aNames + , Right title <- [EC.parseAccountTitle name] + ] + skipped = + [ name + | name <- aNames + , Left (EC.AmbiguousAccount _ _) <- [EC.parseAccountTitle name] + ] + unexpected = + [ (name, show err) + | name <- aNames + , Left err <- [EC.parseAccountTitle name] + , case err of EC.AmbiguousAccount _ _ -> False; _ -> True + ] + mismatches = + [ (name, title, label) + | (name, title, label) <- resolved + , label /= name + ] + assertEqual "Land 4a JCCI level-2 A-column rows" 117 (L.length aNames) + assertEqual "Land 4a JCCI A-column MATCH count" 113 (L.length resolved) + assertEqual "Land 4a JCCI A-column skip set" + (L.sort (L.map T.pack + ["営業収益", "営業費用", "為替差損益", "有価証券評価損益"])) + (L.sort skipped) + assertEqual "Land 4a JCCI A-column has no unexpected parse failures" + ([] :: [(T.Text, String)]) unexpected + assertEqual "Land 4a JCCI A-column labels MATCH 113/113" + ([] :: [(T.Text, AccountTitles, T.Text)]) mismatches + +testRegistryWildcards :: IO () +testRegistryWildcards = do + divisionResult <- try (evaluate (classifyAccountDivision AccountTitle)) + :: IO (Either SomeException AccountDivision) + assertEqual "registry wildcard: classifyAccountDivision errors" + True (case divisionResult of Left _ -> True; Right _ -> False) + assertEqual "registry wildcard: fixedCurrent is Other" + Other (fixedCurrent (Not :< AccountTitle)) + assertEqual "registry wildcard: describeAccount is Nothing" + Nothing (Assist.describeAccount AccountTitle) + +testRegistryContraLand2 :: IO () +testRegistryContraLand2 = + assertEqual "registry contra True set = valuation accounts plus V-Land 2 P/L contra accounts" + allContra + (L.filter Registry.classifyAccountContra Registry.concreteAccountTitles) + +-- ================================================================ +-- Land 2 (Definition 7 contra amendment): closed-diff vs pre-land1 +-- golden, contract / relation properties, presentation invariance. +-- pre-land1 fixtures stay frozen as the pre-amendment reference. +-- ================================================================ + +land2Contra :: [AccountTitles] +land2Contra = [AllowanceForDoubtfulAccounts, AccumulatedDepreciation] + +allContra :: [AccountTitles] +allContra = land2Contra <> [SalesRebates, RefundOfIncomeTaxes, PurchaseRebates] + +land2TitleMap :: M.Map T.Text AccountTitles +land2TitleMap = M.fromList + [ (T.pack (show t), t) | t <- Registry.concreteAccountTitles ] + +-- registry から生成しない literal 期待値 (循環 oracle 回避) +land2ExpectedDesc :: AccountTitles -> T.Text +land2ExpectedDesc AllowanceForDoubtfulAccounts = T.pack + "Asset (contra): Allowance for doubtful accounts (貸倒引当金), a credit-balance valuation account (評価勘定) deducted from receivables. Home side is Credit because it is a contra asset (isContra); values stay non-negative and the Hat\\/Not structure is intact. B\\/S deduction (net) presentation is the Write side's job." +land2ExpectedDesc AccumulatedDepreciation = T.pack + "Asset (contra): Accumulated depreciation (減価償却累計額), a credit-balance valuation account (評価勘定) under the indirect method (間接法), deducted from the related depreciable assets. Home side is Credit because it is a contra asset (isContra). This is the canonical bookkeeping account for accumulated depreciation; the existing 'ReserveForDepreciation' is retained as the legacy SNA\\/macro-accounting name." +land2ExpectedDesc t = T.pack ("land2ExpectedDesc: not a contra account: " ++ show t) + +-- T1: 全域機械比較 — whichSide/whatPIMO/fixedCurrent は全一致, +-- whatDiv は当該 2 件 (Liability→Assets) ちょうど。 +testLand2SemanticsClosedDiff :: IO () +testLand2SemanticsClosedDiff = do + fixture <- TIO.readFile "test/fixtures/pre-land1/account-semantics.tsv" + let rows = L.filter (not . T.null) (L.drop 1 (T.lines fixture)) + assertEqual "land2 semantics: fixture row count" 116 (L.length rows) + mapM_ checkRow rows + where + checkRow line = case T.splitOn (T.pack "\t") line of + [name, oldDiv, oldPimo, oldSideN, oldSideH, oldFc] -> + case M.lookup name land2TitleMap of + Nothing -> assertEqual "land2 semantics: unknown fixture title" (T.pack "") name + Just t -> do + let nb = Not :< t :: HatBase AccountTitles + hb = Hat :< t :: HatBase AccountTitles + assertEqual ("land2 whatPIMO invariant: " ++ show t) + oldPimo (goldenShow (whatPIMO nb)) + assertEqual ("land2 whichSide Not invariant: " ++ show t) + oldSideN (goldenShow (whichSide nb)) + assertEqual ("land2 whichSide Hat invariant: " ++ show t) + oldSideH (goldenShow (whichSide hb)) + assertEqual ("land2 fixedCurrent invariant: " ++ show t) + oldFc (goldenShow (fixedCurrent nb)) + if t `L.elem` land2Contra + then do + assertEqual ("land2 whatDiv old was Liability: " ++ show t) + (T.pack "Liability") oldDiv + assertEqual ("land2 whatDiv new is Assets: " ++ show t) + Assets (whatDiv nb) + else assertEqual ("land2 whatDiv invariant: " ++ show t) + oldDiv (goldenShow (whatDiv nb)) + _ -> assertEqual "land2 semantics: malformed fixture row" (T.pack "") line + +-- T8 込み: allAccountInfos の閉じた差分 — 当該 2 行だけ aiDivision と +-- aiDesc が変わり (desc は "Asset (contra):" で始まる), 他は byte 一致。 +testLand2InfoClosedDiff :: IO () +testLand2InfoClosedDiff = do + fixture <- TIO.readFile "test/fixtures/pre-land1/account-info.tsv" + let oldRows = L.filter (not . T.null) (L.drop 1 (T.lines fixture)) + -- V-Land 2 appends new constructors after every pre-vland2 concrete + -- title. This closed-diff compares only the pinned historical prefix. + newRows = L.take (L.length oldRows) + [ (Assist.aiTitle i, goldenInfoRow i) | i <- Assist.allAccountInfos ] + assertEqual "land2 info: row count" (L.length oldRows) (L.length newRows) + mapM_ check (L.zip oldRows newRows) + where + check (oldLine, (t, newLine)) + | t `L.elem` land2Contra = do + let oldF = T.splitOn (T.pack "\t") oldLine + newF = T.splitOn (T.pack "\t") newLine + assertEqual ("land2 info title invariant: " ++ show t) + (oldF L.!! 0) (newF L.!! 0) + assertEqual ("land2 info old division was Liability: " ++ show t) + (T.pack "Liability") (oldF L.!! 1) + assertEqual ("land2 info new division is Assets: " ++ show t) + (T.pack "Assets") (newF L.!! 1) + assertEqual ("land2 info home side invariant: " ++ show t) + (oldF L.!! 2) (newF L.!! 2) + assertEqual ("land2 info nameEn invariant: " ++ show t) + (oldF L.!! 3) (newF L.!! 3) + assertEqual ("land2 info nameJa invariant: " ++ show t) + (oldF L.!! 4) (newF L.!! 4) + assertEqual ("land2 info desc updated to contra wording: " ++ show t) + True (oldF L.!! 5 /= newF L.!! 5) + assertEqual ("land2 info new desc literal: " ++ show t) + (land2ExpectedDesc t) (newF L.!! 5) + | otherwise = + assertEqual ("land2 info invariant: " ++ show t) oldLine newLine + +-- suggest の閉じた差分: 変化した (追加/削除/変更) query は全て, 当該 2 科目の +-- 旧/新 desc に対する token match rank の変化で説明できる。 +testLand2SuggestClosedDiff :: IO () +testLand2SuggestClosedDiff = do + fixture <- TIO.readFile "test/fixtures/pre-land1/suggest.tsv" + infoFixture <- TIO.readFile "test/fixtures/pre-land1/account-info.tsv" + let toMap txt = M.fromList + [ (T.takeWhile (/= '\t') line, line) + | line <- L.filter (not . T.null) (L.drop 1 (T.lines txt)) ] + oldMap = toMap fixture + newMap = toMap goldenSuggestions + oldFieldsOf t = L.concat + [ [ fs L.!! 0, fs L.!! 3, fs L.!! 4, fs L.!! 5 ] + | line <- L.filter (not . T.null) (L.drop 1 (T.lines infoFixture)) + , let fs = T.splitOn (T.pack "\t") line + , fs L.!! 0 == T.pack (show t) + ] + newFieldsOf t = case Assist.describeAccount t of + Just i -> [ T.pack (show t), Assist.aiNameEn i, Assist.aiNameJa i, Assist.aiDesc i ] + Nothing -> [] + rank fields q = L.length + [ tok + | tok <- L.map T.toCaseFold (T.words q) + , L.any (T.isInfixOf tok) (L.map T.toCaseFold fields) ] + -- corpus 帰属の変化 (query が旧/新 desc の token 集合の片方にだけある) + -- も desc 変更の帰結として許容する (行の追加/削除がこれで起きる)。 + descTokensOf fields = case fields of + [_, _, _, desc] -> T.words desc + _ -> [] + tokenMembershipChange q = L.or + [ (q `L.elem` descTokensOf (oldFieldsOf t)) + /= (q `L.elem` descTokensOf (newFieldsOf t)) + | t <- land2Contra ] + affected q = tokenMembershipChange q || L.or + [ rank (oldFieldsOf t) q /= rank (newFieldsOf t) q | t <- land2Contra ] + diffQueries = L.nub + ( [ q | (q, old) <- M.toList oldMap, maybe True (/= old) (M.lookup q newMap) ] + ++ [ q | q <- M.keys newMap, not (M.member q oldMap) ] ) + postFixture <- TIO.readFile "test/fixtures/post-land2/suggest.tsv" + assertEqual "land2 suggest: post fixture byte-identical (expected output itself)" + postFixture goldenSuggestions + assertEqual "land2 suggest: some diff exists (descs changed)" + True (not (L.null diffQueries)) + mapM_ (\q -> assertEqual + ("land2 suggest diff explained by contra desc change: " ++ T.unpack q) + True (affected q)) + diffQueries + +-- T2: 契約 isContra(b) ⇔ homeSide(b) ≠ defaultSide(whatDiv b) +testLand2Contract :: IO () +testLand2Contract = mapM_ check Registry.concreteAccountTitles + where + check t = + let nb = Not :< t :: HatBase AccountTitles + in assertEqual ("land2 contract (isContra = reversed home side): " ++ show t) + (isContra nb) (whichSide nb /= defaultSide (whatDiv nb)) + +-- T3: pimoFlip は自己逆で, 原典の交換関係を保つ +testLand2PimoFlip :: IO () +testLand2PimoFlip = do + let pimoAll = [PS, IN, MS, OUT] + mapM_ (\x -> assertEqual ("land2 pimoFlip involution: " ++ show x) + x (pimoFlip (pimoFlip x))) pimoAll + mapM_ (\(x, y) -> assertEqual ("land2 pimoFlip preserves (<=>): " ++ show (x, y)) + (x <=> y) (pimoFlip x <=> pimoFlip y)) + [ (x, y) | x <- pimoAll, y <- pimoAll ] + +-- T4: (<=>) — PIMO instance = 原典 Prop 5.3.8, Division instance = +-- pimoFromDivision 経由の外延, 旧 instance との差分 = ordered 4 case ちょうど。 +testLand2ExchangeRelation :: IO () +testLand2ExchangeRelation = do + let pimoAll = [PS, IN, MS, OUT] + divAll = [Assets, Equity, Liability, Cost, Revenue] + assertEqual "land2 (<=>) PIMO instance = Prop 5.3.8 pairs" + [ (PS,IN), (PS,MS), (IN,PS), (IN,OUT), (MS,PS), (MS,OUT), (OUT,IN), (OUT,MS) ] + [ (x, y) | x <- pimoAll, y <- pimoAll, x <=> y ] + mapM_ (\(a, b) -> assertEqual ("land2 (<=>) division = via pimoFromDivision: " ++ show (a, b)) + (pimoFromDivision a <=> pimoFromDivision b) (a <=> b)) + [ (a, b) | a <- divAll, b <- divAll ] + let oldRel (Assets, Liability) = True + oldRel (Liability, Assets) = True + oldRel (Assets, Equity) = True + oldRel (Equity, Assets) = True + oldRel (Cost, Liability) = True + oldRel (Liability, Cost) = True + oldRel (Cost, Equity) = True + oldRel (Equity, Cost) = True + oldRel _ = False + assertEqual "land2 (<=>) division migration = exactly 4 ordered cases" + [ (Assets, Revenue), (Cost, Revenue), (Revenue, Assets), (Revenue, Cost) ] + [ (a, b) | a <- divAll, b <- divAll, oldRel (a, b) /= (a <=> b) ] + +-- T9: 8 組込み instance + custom instance (SimHatBase2) の全科目 sweepで +-- isContra のTrue集合が既存評価勘定2件 + V-Land 2 P/L控除3件になること。 +testLand2IsContraInstances :: IO () +testLand2IsContraInstances = do + let day0 = fromGregorian 2026 1 1 + tod0 = TimeOfDay 0 0 0 + nm = T.pack "spec" + sweep :: ExBaseClass b => String -> (AccountTitles -> b) -> IO () + sweep label mk = assertEqual ("land2 isContra sweep: " ++ label) + allContra + [ t | t <- Registry.concreteAccountTitles, isContra (mk t) ] + sweep "HatBase AccountTitles" (\t -> Not :< t :: HatBase AccountTitles) + sweep "HatBase (AccountTitles, Day)" (\t -> Not :< (t, day0)) + sweep "HatBase (AccountTitles, Name)" (\t -> Not :< (t, nm)) + sweep "HatBase (CountUnit, AccountTitles)" (\t -> Not :< (Yen, t)) + sweep "HatBase (AccountTitles, Name, CountUnit)" (\t -> Not :< (t, nm, Yen)) + sweep "HatBase (AccountTitles, Name, CountUnit, Subject)" + (\t -> Not :< (t, nm, Yen, nm)) + sweep "HatBase (AccountTitles, Name, CountUnit, Subject, Day)" + (\t -> Not :< (t, nm, Yen, nm, day0)) + sweep "HatBase (AccountTitles, Name, CountUnit, Subject, Day, TimeOfDay)" + (\t -> Not :< (t, nm, Yen, nm, day0, tod0)) + sweep "SimHatBase2 (custom instance)" (\t -> Not :< (t, 1, 2, Yen) :: SimHatBase2) + +-- T8: LLM-facing メタデータの literal 期待値 (registry から生成しない) +testLand2AiDivision :: IO () +testLand2AiDivision = do + assertEqual "land2 statement metadata literal: AllowanceForDoubtfulAccounts" + (Just (StatementDivision Assets, FixedHomeSide Credit)) + (fmap (\i -> (Assist.aiDivisionSemantics i, Assist.aiHomeSideSemantics i)) + (Assist.describeAccount AllowanceForDoubtfulAccounts)) + assertEqual "land2 statement metadata literal: AccumulatedDepreciation" + (Just (StatementDivision Assets, FixedHomeSide Credit)) + (fmap (\i -> (Assist.aiDivisionSemantics i, Assist.aiHomeSideSemantics i)) + (Assist.describeAccount AccumulatedDepreciation)) + +-- T5/T6: presentation battery。bsRows/plRows の literal は, 以下で明記する +-- vocabulary closing 差分を除き, Land 1 出力 (pre-land2 golden, commit +-- 1c1f3f2) と byte 一致 = 表示互換 shim の証明。 +-- division projection は contra を含まず, contra は projContraAssets のみが選ぶ +-- (意図的差分: projCurrentLiability/projFixedLiability から当該 2 件が消えた)。 +land2B1, land2B2, land2B3, land2B4, land2B5 :: BAlg +land2B1 = 100 .@ Not:<Cash .+ 60 .@ Not:<LoansPayable .+ 40 .@ Not:<CapitalStock +land2B2 = 500 .@ Not:<Sales .+ 300 .@ Not:<SalesCost +land2B3 = 1000 .@ Not:<AccountsReceivable .+ 900 .@ Not:<Cash .+ 800 .@ Not:<Building + .+ 100 .@ Not:<AllowanceForDoubtfulAccounts .+ 200 .@ Not:<AccumulatedDepreciation + .+ 2000 .@ Not:<CapitalStock .+ 400 .@ Not:<LoansPayable +land2B4 = 30 .@ Not:<Cash .+ 80 .@ Hat:<Cash + .+ 100 .@ Not:<AllowanceForDoubtfulAccounts .+ 120 .@ Hat:<AllowanceForDoubtfulAccounts + .+ 500 .@ Not:<Building .+ 200 .@ Not:<LoansPayable .+ 300 .@ Hat:<LoansPayable + .+ 250 .@ Not:<AccumulatedDepreciation .+ 50 .@ Hat:<AccumulatedDepreciation +land2B5 = land2B3 .+ 300 .@ Not:<SalesCost .+ 500 .@ Not:<Sales .+ 200 .@ Not:<Cash + +testLand3PresentationGroups :: IO () +testLand3PresentationGroups = do + let defaultDefs = RG.defaultPresentationGrouping + tradeDef = maybe (error "missing TradeReceivablesGroup") id + (RG.lookupGroupDef defaultDefs RG.TradeReceivablesGroup) + amount below magnitude = RG.RelativeAmount below (magnitude :: Double) + present defs entries = RG.presentGroups defs (M.fromList entries) + contraTitles = + [ title + | title <- Registry.concreteAccountTitles + , maybe False Registry.asIsContra (Registry.accountSpec title) + ] + deductionTitles = L.concatMap RG.pgDeductions defaultDefs + allMembers def = RG.pgGross def ++ RG.pgDeductions def + assertEqual "Land 3 default groups cover each registry contra exactly once" + (L.sort contraTitles) (L.sort deductionTitles) + assertEqual "Land 3 default group memberships are disjoint" + (L.length (L.concatMap allMembers defaultDefs)) + (Set.size (Set.fromList (L.concatMap allMembers defaultDefs))) + forM_ defaultDefs $ \def -> + forM_ (allMembers def) $ \title -> + assertEqual ("Land 3 default title lookup: " ++ show title) + (Just (RG.pgKey def)) (RG.presentationGroupOf title) + forM_ defaultDefs $ \def -> do + forM_ (RG.pgGross def) $ \title -> + assertEqual ("Land 3 gross member is non-contra: " ++ show title) + (Just (RG.pgDivision def, False)) + ((\spec -> (Registry.asDivision spec, Registry.asIsContra spec)) + <$> Registry.accountSpec title) + forM_ (RG.pgDeductions def) $ \title -> + assertEqual ("Land 3 deduction member is same-division contra: " ++ show title) + (Just (RG.pgDivision def, True)) + ((\spec -> (Registry.asDivision spec, Registry.asIsContra spec)) + <$> Registry.accountSpec title) + + let exceeded = present [tradeDef] + [ (AccountsReceivable, (100, 0)) + , (AllowanceForDoubtfulAccounts, (0, 150)) + ] + assertEqual "Land 3 edge: contra exceeding gross yields a negative net" + [(tradeDef, + [ RG.GroupRow (RG.GrossRow AccountsReceivable) (amount False 100) + , RG.GroupRow (RG.DeductionRow AllowanceForDoubtfulAccounts) (amount True 150) + , RG.GroupRow (RG.NetRow RG.TradeReceivablesGroup) (amount True 50) + ])] + (RG.gpBlocks exceeded) + + let parentAbsent = present [tradeDef] + [(AllowanceForDoubtfulAccounts, (0, 30))] + assertEqual "Land 3 edge: parent absent still renders deduction and net" + [(tradeDef, + [ RG.GroupRow (RG.DeductionRow AllowanceForDoubtfulAccounts) (amount True 30) + , RG.GroupRow (RG.NetRow RG.TradeReceivablesGroup) (amount True 30) + ])] + (RG.gpBlocks parentAbsent) + + let multiContraDef = tradeDef + { RG.pgGross = [AccountsReceivable] + , RG.pgDeductions = + [AllowanceForDoubtfulAccounts, AccumulatedDepreciation] + } + multipleContra = present [multiContraDef] + [ (AccountsReceivable, (1000, 0)) + , (AllowanceForDoubtfulAccounts, (0, 100)) + , (AccumulatedDepreciation, (0, 200)) + ] + assertEqual "Land 3 edge: multiple contra rows deduct exactly once" + [(multiContraDef, + [ RG.GroupRow (RG.GrossRow AccountsReceivable) (amount False 1000) + , RG.GroupRow (RG.DeductionRow AllowanceForDoubtfulAccounts) (amount True 100) + , RG.GroupRow (RG.DeductionRow AccumulatedDepreciation) (amount True 200) + , RG.GroupRow (RG.NetRow RG.TradeReceivablesGroup) (amount False 700) + ])] + (RG.gpBlocks multipleContra) + + let child = tradeDef { RG.pgParent = Just RG.DepreciableAssetsGroup } + parent = maybe (error "missing DepreciableAssetsGroup") id + (RG.lookupGroupDef defaultDefs RG.DepreciableAssetsGroup) + nested = present [parent, child] + [ (AccountsReceivable, (1000, 0)) + , (AllowanceForDoubtfulAccounts, (0, 100)) + , (Building, (800, 0)) + , (AccumulatedDepreciation, (0, 200)) + ] + assertEqual "Land 3 edge: nested child precedes and rolls into parent" + [ (child, + [ RG.GroupRow (RG.GrossRow AccountsReceivable) (amount False 1000) + , RG.GroupRow (RG.DeductionRow AllowanceForDoubtfulAccounts) (amount True 100) + , RG.GroupRow (RG.NetRow RG.TradeReceivablesGroup) (amount False 900) + ]) + , (parent, + [ RG.GroupRow (RG.GrossRow Building) (amount False 800) + , RG.GroupRow (RG.SubgroupRow RG.TradeReceivablesGroup) (amount False 900) + , RG.GroupRow (RG.DeductionRow AccumulatedDepreciation) (amount True 200) + , RG.GroupRow (RG.NetRow RG.DepreciableAssetsGroup) (amount False 1500) + ]) + ] + (RG.gpBlocks nested) + assertEqual "Land 3 edge: only the nested root contributes to totals" + (M.singleton Assets (1800, 300)) (RG.gpRootTotals nested) + assertEqual "Land 3 edge: all nested definition members are consumed" + (Set.fromList (L.concatMap allMembers [parent, child])) + (RG.gpConsumed nested) + + let inactiveChild = present [parent, child] + [ (AccountsReceivable, (1000, 0)) + , (Building, (800, 0)) + , (AccumulatedDepreciation, (0, 200)) + ] + assertEqual "Land 3 edge: inactive child gross is not rolled into its parent" + [(parent, + [ RG.GroupRow (RG.GrossRow Building) (amount False 800) + , RG.GroupRow (RG.DeductionRow AccumulatedDepreciation) (amount True 200) + , RG.GroupRow (RG.NetRow RG.DepreciableAssetsGroup) (amount False 600) + ])] + (RG.gpBlocks inactiveChild) + assertEqual "Land 3 edge: inactive child gross remains unconsumed" + (Set.fromList (allMembers parent)) (RG.gpConsumed inactiveChild) + assertEqual "Land 3 edge: inactive child cannot inflate the parent total" + (M.singleton Assets (800, 200)) (RG.gpRootTotals inactiveChild) + + let salesDef = maybe (error "missing NetSalesGroup") id + (RG.lookupGroupDef defaultDefs RG.NetSalesGroup) + offsetContra = present [salesDef] + [ (Sales, (0, 500)) + , (SalesRebates, (50, 50)) + ] + assertEqual "Land 3 edge: fully offset contra activity still activates its group" + [(salesDef, + [ RG.GroupRow (RG.GrossRow Sales) (amount False 500) + , RG.GroupRow (RG.NetRow RG.NetSalesGroup) (amount False 500) + ])] + (RG.gpBlocks offsetContra) + assertEqual "Land 3 edge: fully offset contra title cannot leak to ordinary rows" + (Set.fromList [Sales, SalesRebates]) (RG.gpConsumed offsetContra) + + let rows f b = L.map (L.map T.unpack) (f b) + excessiveChart = (100 .@ Not:<AccountsReceivable + .+ 150 .@ Not:<AllowanceForDoubtfulAccounts + :: EA.Alg Double (HatBase AccountTitles)) + purchasesAndTaxes = (500 .@ Not:<Purchases + .+ 50 .@ Not:<PurchaseRebates + .+ 300 .@ Not:<CorporateIncomeTaxes + .+ 40 .@ Not:<RefundOfIncomeTaxes + :: EA.Alg Double (HatBase AccountTitles)) + excessiveRows = rows bsRows excessiveChart + purchasesAndTaxesRows = rows plRows purchasesAndTaxes + assertEqual "Land 3 rendering: contra excess signs both net and asset total" + True + (["TradeReceivablesNet","-50.0","",""] `elem` excessiveRows + && ["Total","-50.0","",""] `elem` excessiveRows) + assertEqual "Land 3 rendering: purchase rebate and net label are pinned" + True + (["PurchaseRebates","-50.0","",""] `elem` purchasesAndTaxesRows + && ["NetPurchases","450.0","",""] `elem` purchasesAndTaxesRows) + assertEqual "Land 3 rendering: tax refund and net label are pinned" + True + (["RefundOfIncomeTaxes","-40.0","",""] `elem` purchasesAndTaxesRows + && ["IncomeTaxesNet","260.0","",""] `elem` purchasesAndTaxesRows) + +testLand2Presentation :: IO () +testLand2Presentation = do + let rows f b = L.map (L.map T.unpack) (f b) + -- Non-contra statements remain byte-identical. Contra statements use + -- Land 3 gross -> deduction -> net presentation. + assertEqual "land2 bsRows b1 (= Land 1)" + [ ["Asset","","Liability",""] + , ["Cash","100.0","LoansPayable","60.0"] + , ["Total","100.0","Equity",""] + , ["","","CapitalStock","40.0"] + , ["","","Total","100.0"] ] + (rows bsRows land2B1) + assertEqual "land3 bsRows b3 contra groups" + [ ["Asset","","Liability",""] + , ["Cash","900.0","LoansPayable","400.0"] + , ["AccountsReceivable","1000.0","Equity",""] + , ["AllowanceForDoubtfulAccounts","-100.0","CapitalStock","2000.0"] + , ["TradeReceivablesNet","900.0","Total","2400.0"] + , ["Building","800.0","",""] + , ["AccumulatedDepreciation","-200.0","",""] + , ["DepreciableAssetsNet","600.0","",""] + , ["Total","2400.0","",""] ] + (rows bsRows land2B3) + assertEqual "land3 bsRows b4 abnormal balances" + [ ["Asset","","Liability",""] + , ["LoansPayable","100.0","Equity",""] + , ["AllowanceForDoubtfulAccounts","20.0","Total","0.0"] + , ["TradeReceivablesNet","20.0","",""] + , ["Building","500.0","",""] + , ["AccumulatedDepreciation","-200.0","",""] + , ["DepreciableAssetsNet","300.0","",""] + , ["Total","420.0","",""] ] + (rows bsRows land2B4) + -- Pre-vocab difference: SalesCost is now closed by the registry-derived + -- Cost rule, so Sales 500 - SalesCost 300 becomes RetainedEarnings 200. + assertEqual "land3 bsRows b5 closing and contra groups" + [ ["Asset","","Liability",""] + , ["Cash","1100.0","LoansPayable","400.0"] + , ["AccountsReceivable","1000.0","Equity",""] + , ["AllowanceForDoubtfulAccounts","-100.0","CapitalStock","2000.0"] + , ["TradeReceivablesNet","900.0","RetainedEarnings","200.0"] + , ["Building","800.0","Total","2600.0"] + , ["AccumulatedDepreciation","-200.0","",""] + , ["DepreciableAssetsNet","600.0","",""] + , ["Total","2600.0","",""] ] + (rows bsRows land2B5) + assertEqual "land2 plRows b2 (= Land 1)" + [ ["Cost","","Revenue",""] + , ["SalesCost","300.0","Sales","500.0"] + , ["Total","500.0","Total","300.0"] ] + (rows plRows land2B2) + -- projections: 資産系は Land 1 と一致, liability 系は contra が消える (意図的差分), + -- contra は projContraAssets のみが Hat/Not 双方を保持して選ぶ。 + assertEqual "land2 projCurrentAssets b3 (= Land 1)" + "900.00:@Not:<Cash .+ 1000.00:@Not:<AccountsReceivable" + (show (EA.projCurrentAssets land2B3)) + assertEqual "land2 projCurrentLiability b3 (intentional: contra dropped)" + "400.00:@Not:<LoansPayable" + (show (EA.projCurrentLiability land2B3)) + assertEqual "land2 projFixedLiability b3 (intentional: contra dropped)" + "0" + (show (EA.projFixedLiability land2B3)) + assertEqual "land2 projContraAssets b3" + "100.00:@Not:<AllowanceForDoubtfulAccounts .+ 200.00:@Not:<AccumulatedDepreciation" + (show (EA.projContraAssets land2B3)) + assertEqual "land2 projCurrentAssets b4 (= Land 1; no contra Hat leakage)" + "30.00:@Not:<Cash" + (show (EA.projCurrentAssets land2B4)) + assertEqual "land2 projFixedAssets b4 (= Land 1; no contra Hat leakage)" + "500.00:@Not:<Building" + (show (EA.projFixedAssets land2B4)) + assertEqual "land2 projCurrentLiability b4 (intentional: contra dropped)" + "200.00:@Not:<LoansPayable" + (show (EA.projCurrentLiability land2B4)) + assertEqual "land2 projContraAssets b4 keeps Hat and Not, excludes Cash" + "120.00:@Hat:<AllowanceForDoubtfulAccounts .+ 100.00:@Not:<AllowanceForDoubtfulAccounts .+ 50.00:@Hat:<AccumulatedDepreciation .+ 250.00:@Not:<AccumulatedDepreciation" + (show (EA.projContraAssets land2B4)) + assertEqual "land2 projContraAssets b5" + "100.00:@Not:<AllowanceForDoubtfulAccounts .+ 200.00:@Not:<AccumulatedDepreciation" + (show (EA.projContraAssets land2B5)) + +-- Current presentation battery. Exact Land 3 rows are pinned above; this dump +-- is also compared structurally with the pre-Land 2 fixture below. +land2PresentationLines :: [T.Text] +land2PresentationLines = L.concatMap sect + [ ("b1-basic", land2B1), ("b2-pl", land2B2), ("b3-contra", land2B3) + , ("b4-abnormal", land2B4), ("b5-closing", land2B5) ] + where + sect (n, a) = + (T.pack ("## " ++ n)) + : T.pack "-- bsRows" + : L.map (T.pack . show . L.map T.unpack) (bsRows a) + ++ T.pack "-- plRows" + : L.map (T.pack . show . L.map T.unpack) (plRows a) + ++ L.concat [ [T.pack ("-- " ++ pn), T.pack (show (pf a))] | (pn, pf) <- projList ] + projList = + [ ("projCurrentAssets", EA.projCurrentAssets) + , ("projFixedAssets", EA.projFixedAssets) + , ("projDeferredAssets", EA.projDeferredAssets) + , ("projCurrentLiability", EA.projCurrentLiability) + , ("projFixedLiability", EA.projFixedLiability) + , ("projCapitalStock", EA.projCapitalStock) + ] + +testLand2PresentationClosedDiff :: IO () +testLand2PresentationClosedDiff = do + fixture <- TIO.readFile "test/fixtures/pre-land2/presentation.txt" + let oldLines = L.filter (not . T.null) (L.drop 1 (T.lines fixture)) + newLines = land2PresentationLines + names = L.map T.pack ["b1-basic", "b2-pl", "b3-contra", "b4-abnormal", "b5-closing"] + markers = L.map T.pack + [ "-- bsRows", "-- plRows", "-- projCurrentAssets" + , "-- projFixedAssets", "-- projDeferredAssets" + , "-- projCurrentLiability", "-- projFixedLiability" + , "-- projCapitalStock" + ] + section name xs = takeWhile (not . T.isPrefixOf (T.pack "## ")) + (drop 1 (dropWhile (/= (T.pack "## " <> name)) xs)) + block marker xs = marker + : takeWhile (not . T.isPrefixOf (T.pack "-- ")) + (drop 1 (dropWhile (/= marker) xs)) + changedBlocks = + [ (name, marker) + | name <- names + , marker <- markers + , block marker (section name oldLines) /= block marker (section name newLines) + ] + assertEqual "Land 3 closed diff: only adjudicated battery blocks changed" + [ (T.pack "b2-pl", T.pack "-- bsRows") + , (T.pack "b3-contra", T.pack "-- bsRows") + , (T.pack "b3-contra", T.pack "-- projCurrentLiability") + , (T.pack "b3-contra", T.pack "-- projFixedLiability") + , (T.pack "b4-abnormal", T.pack "-- bsRows") + , (T.pack "b4-abnormal", T.pack "-- projCurrentLiability") + , (T.pack "b4-abnormal", T.pack "-- projFixedLiability") + , (T.pack "b5-closing", T.pack "-- bsRows") + , (T.pack "b5-closing", T.pack "-- projCurrentLiability") + , (T.pack "b5-closing", T.pack "-- projFixedLiability") + ] + changedBlocks + +-- HatNot は whichSide で明示 error (規約の regression 固定) +testLand2HatNotPolicy :: IO () +testLand2HatNotPolicy = do + r <- try (evaluate (whichSide (HatNot :< Cash :: HatBase AccountTitles))) + :: IO (Either SomeException Side) + assertEqual "land2 whichSide HatNot policy: explicit error" + True (case r of Left _ -> True; Right _ -> False) + +-- ================================================================ +-- ExchangeAlgebra.Convert.Checked: checked construction for generated entries. +-- ================================================================ + +type CheckedAlgM = EA.Alg MoneyDecimal (HatBase AccountTitles) +type CheckedJournalM = EJ.Journal Int MoneyDecimal (HatBase AccountTitles) + +checkedEntryM :: [(Side, AccountTitles, MoneyDecimal)] + -> Either (NE.NonEmpty (ECC.EntryError MoneyDecimal)) CheckedAlgM +checkedEntryM = ECC.checkedEntry + +checkedJournalM :: [(Int, [(Side, AccountTitles, MoneyDecimal)])] + -> Either (NE.NonEmpty (ECC.JournalError Int MoneyDecimal)) CheckedJournalM +checkedJournalM = ECC.checkedJournal + +genPositiveAmountMD :: Gen MoneyDecimal +genPositiveAmountMD = fromInteger <$> choose (1, 9999) + +genCheckedAmountMD :: Gen MoneyDecimal +genCheckedAmountMD = fromInteger <$> choose (-5, 20) + +genCheckedSide :: Gen Side +genCheckedSide = frequency + [ (8, elements [Debit, Credit]) + , (1, pure Side) + ] + +genCheckedAccountTitle :: Gen AccountTitles +genCheckedAccountTitle = frequency + [ (12, genAccountTitle) + , (1, pure AccountTitle) + ] + +genCheckedPosting :: Gen (Side, AccountTitles, MoneyDecimal) +genCheckedPosting = + (,,) <$> genCheckedSide <*> genCheckedAccountTitle <*> genCheckedAmountMD + +genAcceptedEntryRows :: Gen [(Side, AccountTitles, MoneyDecimal)] +genAcceptedEntryRows = do + amount <- genPositiveAmountMD + debitAccount <- genOrdinaryPostingTitle + creditAccount <- genOrdinaryPostingTitle + pure [ (Debit, debitAccount, amount) + , (Credit, creditAccount, amount) + ] + +genOrdinaryPostingTitle :: Gen AccountTitles +genOrdinaryPostingTitle = elements + [ title + | title <- Registry.concreteAccountTitles + , Just semantics <- [Registry.accountSemantics title] + , Registry.asemPostingCapability semantics == OrdinaryPosting + ] + +genCheckedEntryRows :: Gen [(Side, AccountTitles, MoneyDecimal)] +genCheckedEntryRows = frequency + [ (5, resize 8 (listOf genCheckedPosting)) + , (3, genAcceptedEntryRows) + , (1, pure []) + ] + +genKnownCertPosting :: Gen (Side, AccountTitles, MoneyDecimal) +genKnownCertPosting = + (,,) <$> elements [Debit, Credit] <*> genAccountTitle <*> genCheckedAmountMD + +genKnownCertJournal :: Gen [(Int, [(Side, AccountTitles, MoneyDecimal)])] +genKnownCertJournal = do + rows <- resize 6 (listOf (resize 6 (listOf genKnownCertPosting))) + pure (zip [1..] rows) + +sideTextForCert :: Side -> T.Text +sideTextForCert Debit = T.pack "debit" +sideTextForCert Credit = T.pack "credit" +sideTextForCert Side = T.pack "Side" + +textJournalForCert + :: [(Int, [(Side, AccountTitles, MoneyDecimal)])] + -> [(Int, [(T.Text, T.Text, MoneyDecimal)])] +textJournalForCert = L.map renderEntry + where + renderEntry (txid, rows) = (txid, L.map renderPosting rows) + renderPosting (side, account, amount) = + (sideTextForCert side, T.pack (show account), amount) + +checkedJournalTextReference + :: [(Int, [(T.Text, T.Text, MoneyDecimal)])] + -> Either (NE.NonEmpty (ECC.JournalError Int MoneyDecimal)) CheckedJournalM +checkedJournalTextReference entries = + case errors of + [] -> Right (L.foldl' (.+) mempty journals) + e : es -> Left (e NE.:| es) + where + checked = + [ (txid, ECC.checkedEntryText rows) + | (txid, rows) <- entries + ] + errors = + [ ECC.EntryErrors txid errs + | (txid, Left errs) <- checked + ] + journals = + [ alg .| txid + | (txid, Right alg) <- checked + ] + +prop_certifyKnownAccountsMatchesCheckedJournal :: Property +prop_certifyKnownAccountsMatchesCheckedJournal = + forAll genKnownCertJournal $ \entries -> + let textEntries = textJournalForCert entries + in case ( ECC.certifyJournalText textEntries + , checkedJournalTextReference textEntries + , checkedJournalM entries + ) of + (ECC.FullyResolved actual, Right textExpected, Right expected) -> + EJ.toMap actual == EJ.toMap textExpected + && EJ.toMap actual == EJ.toMap expected + (ECC.Rejected _, Left _, Left _) -> True + _ -> False + +prop_certifyUnknownAccountPreservesBalance :: Property +prop_certifyUnknownAccountPreservesBalance = + forAll genAcceptedEntryRows $ \rows -> + let replaceAccount (side, _, amount) = + (sideTextForCert side, T.pack "NoSuchAccount_XYZ", amount) + in case ECC.certifyJournalText [(1 :: Int, L.map replaceAccount rows)] of + ECC.BalancedUnresolved {} -> True + _ -> False + +prop_certifyImbalancePrecedesUnknownAccount :: Property +prop_certifyImbalancePrecedesUnknownAccount = + forAll genPositiveAmountMD $ \amount -> + let input = + [ (1 :: Int, + [ (T.pack "debit", T.pack "NoSuchAccount_XYZ", amount) + , (T.pack "credit", T.pack "Cash", amount + 1) + ]) + ] + in case ECC.certifyJournalText input of + ECC.Rejected errs -> any journalHasImbalance (NE.toList errs) + _ -> False + where + journalHasImbalance (ECC.EntryErrors _ errs) = + any isImbalanced (NE.toList errs) + journalHasImbalance _ = False + + isImbalanced ECC.Imbalanced {} = True + isImbalanced _ = False + +prop_certifyDuplicateTxIdAlwaysRejected :: Property +prop_certifyDuplicateTxIdAlwaysRejected = + forAll genAcceptedEntryRows $ \rows -> + let input = textJournalForCert [(1, rows), (1, rows)] + in case ECC.certifyJournalText input of + ECC.Rejected errs -> ECC.DuplicateTxId 1 `elem` NE.toList errs + _ -> False + +prop_certifyBalancedUnresolvedTotals :: Property +prop_certifyBalancedUnresolvedTotals = + forAll genPositiveAmountMD $ \amount -> + let input = + [ (1 :: Int, + [ (T.pack "debit", T.pack "NoSuchAccount_XYZ", amount) + , (T.pack "credit", T.pack "Sales", amount) + ]) + ] + in case ECC.certifyJournalText input of + ECC.BalancedUnresolved + { ECC._certDebitTotal = debitTotal + , ECC._certCreditTotal = creditTotal + } -> debitTotal == creditTotal + && debitTotal == amount + && creditTotal == amount + _ -> False + +checkedEntryAcceptsSpec :: [(Side, AccountTitles, MoneyDecimal)] -> Bool +checkedEntryAcceptsSpec rows = + not (null rows) + && all validPosting rows + && ECC.exactBalanced (EC.journalFromSides rows :: CheckedAlgM) + where + validPosting (side, account, amount) = + side /= Side + && account /= AccountTitle + && maybe False + (ECC.postingAllowedIn ECC.OrdinaryJournal + . Registry.asemPostingCapability) + (Registry.accountSemantics account) + && amount > 0 + && not (EA.isErrorValue amount) + +data ConsolidationFixtureRow + = FixturePosting String String [String] + AccountTitles AccountTitles MoneyDecimal + | FixtureLink String String MoneyDecimal + deriving (Show, Eq) + +parseConsolidationFixtureRow :: T.Text -> Either String ConsolidationFixtureRow +parseConsolidationFixtureRow line = case T.splitOn (T.pack "\t") line of + [kind, rowId, sourceIdsText, debitText, creditText, amountText] + | kind == T.pack "source" || kind == T.pack "adjustment" -> do + debitAccount <- firstShow (EC.parseAccountTitle debitText) + creditAccount <- firstShow (EC.parseAccountTitle creditText) + amount <- parseAmount amountText + let sourceIds + | sourceIdsText == T.pack "-" = [] + | otherwise = L.map T.unpack + (T.splitOn (T.pack "|") sourceIdsText) + Right (FixturePosting (T.unpack kind) (T.unpack rowId) sourceIds + debitAccount creditAccount amount) + | kind == T.pack "link" -> do + amount <- parseAmount amountText + Right (FixtureLink (T.unpack rowId) (T.unpack sourceIdsText) amount) + fields -> Left ("invalid consolidation fixture row: " ++ show fields) + where + firstShow (Left err) = Left (show err) + firstShow (Right value) = Right value + parseAmount amountText = case reads (T.unpack amountText) of + [(amount, "")] -> Right (fromInteger amount) + _ -> Left ("invalid fixture amount: " ++ T.unpack amountText) + +loadMinimalConsolidationFixture + :: IO (CW.WorksheetInput String String MoneyDecimal) +loadMinimalConsolidationFixture = do + contents <- TIO.readFile + "test/fixtures/consolidation-worksheet-050/minimal.tsv" + rows <- case traverse parseConsolidationFixtureRow + (filter (not . T.null) (drop 1 (T.lines contents))) of + Left err -> fail err + Right parsed -> pure parsed + let postings = + [ (kind, rowId, sourceIds, debitAccount, creditAccount, amount) + | FixturePosting kind rowId sourceIds debitAccount creditAccount amount + <- rows + ] + sources = + [ CW.TrialBalanceSource rowId + (EC.journalFromSides + [ (Debit, debitAccount, amount) + , (Credit, creditAccount, amount) + ] :: CheckedAlgM) + | (kind, rowId, _, debitAccount, creditAccount, amount) <- postings + , kind == "source" + ] + adjustments = + [ CW.WorksheetAdjustment rowId (sourceId NE.:| sourceIdsTail) + (EC.journalFromSides + [ (Debit, debitAccount, amount) + , (Credit, creditAccount, amount) + ] :: CheckedAlgM) + | (kind, rowId, sourceId : sourceIdsTail, + debitAccount, creditAccount, amount) <- postings + , kind == "adjustment" + ] + links = M.fromList + [ (rowId, (direction, amount)) + | FixtureLink rowId direction amount <- rows + ] + sourceList <- case NE.nonEmpty sources of + Nothing -> fail "minimal consolidation fixture has no sources" + Just nonEmptySources -> pure nonEmptySources + plResult <- fixtureResult links "pl-net-income" + ownersPlResult <- fixtureResult links "pl-parent-net-income" + ownersSsResult <- fixtureResult links "ss-parent-net-income" + nciResult <- fixtureResult links "nci-period-share" + openingRetained <- fixtureBalance links "opening-retained-earnings" + retainedDividends <- fixtureAmount links "retained-earnings-dividends" + ssClosingRetained <- fixtureBalance links "ss-closing-retained-earnings" + bsRetained <- fixtureBalance links "bs-retained-earnings" + openingNci <- fixtureBalance links "opening-nci" + nciDividends <- fixtureAmount links "nci-dividends" + closingNci <- fixtureBalance links "closing-nci" + bsNci <- fixtureBalance links "bs-nci" + pure (CW.WorksheetInput sourceList adjustments + (CW.WorksheetLinkage + { CW._profitOrLossNetIncome = plResult + , CW._profitOrLossNetIncomeAttributableToOwners = ownersPlResult + , CW._statementOfChangesNetIncomeAttributableToOwners = + ownersSsResult + , CW._openingRetainedEarnings = openingRetained + , CW._retainedEarningsDividends = retainedDividends + , CW._statementOfChangesClosingRetainedEarnings = ssClosingRetained + , CW._balanceSheetRetainedEarnings = bsRetained + , CW._openingNonControllingInterests = openingNci + , CW._nonControllingInterestsPeriodShare = nciResult + , CW._nonControllingInterestsDividends = nciDividends + , CW._statementOfChangesClosingNonControllingInterests = closingNci + , CW._balanceSheetNonControllingInterests = bsNci + })) + where + fixtureAmount links key = case M.lookup key links of + Just ("amount", amount) -> pure amount + Just (direction, _) -> fail + ("expected amount direction for " ++ key ++ ", got " ++ direction) + Nothing -> fail ("missing fixture link: " ++ key) + fixtureResult links key = case M.lookup key links of + Just ("profit", amount) -> pure (CW.PeriodProfit amount) + Just ("loss", amount) -> pure (CW.PeriodLoss amount) + Just ("break-even", _) -> pure CW.PeriodBreakEven + Just (direction, _) -> fail + ("invalid period-result direction for " ++ key ++ ": " ++ direction) + Nothing -> fail ("missing fixture link: " ++ key) + fixtureBalance links key = case M.lookup key links of + Just ("credit", amount) -> pure (CW.CreditBalance amount) + Just ("debit", amount) -> pure (CW.DebitBalance amount) + Just (direction, _) -> fail + ("invalid balance direction for " ++ key ++ ": " ++ direction) + Nothing -> fail ("missing fixture link: " ++ key) + +leftErrors :: Either (NE.NonEmpty e) a -> Maybe (NE.NonEmpty e) +leftErrors (Left errors) = Just errors +leftErrors (Right _) = Nothing + +testConsolidationWorksheet :: IO () +testConsolidationWorksheet = do + fixture <- loadMinimalConsolidationFixture + validated <- case CW.validateConsolidationWorksheet fixture of + Left errors -> fail ("valid consolidation fixture rejected: " ++ show errors) + Right value -> pure value + assertEqual "consolidation worksheet: source provenance retained" + ["parent", "subsidiary"] + [ CW._sourceId source + | source <- NE.toList (CW.validatedSources validated) + ] + assertEqual "consolidation worksheet: adjustment provenance retained" + [("nci-attribution", ["parent", "subsidiary"])] + [ ( CW._adjustmentId adjustment + , NE.toList (CW._adjustmentSourceIds adjustment) + ) + | adjustment <- CW.validatedAdjustments validated + ] + let combined = CW.combinedWorksheet validated + assertEqual "consolidation worksheet: combined fixture stays balanced" + True (ECC.exactBalanced combined) + assertEqual "consolidation worksheet: combined debit total" + (200 :: MoneyDecimal) (EA.norm (EA.decL combined)) + assertEqual "consolidation worksheet: combined credit total" + (200 :: MoneyDecimal) (EA.norm (EA.decR combined)) + assertEqual "consolidation worksheet: combination preserves all sequences" + 6 (L.length (EA.vals combined)) + + let rawAdjustment = + (10 EA..@ (Not :< Cash)) EA..+ + (5 EA..@ (Not :< Cash)) EA..+ + (15 EA..@ (Not :< Sales)) :: CheckedAlgM + rawInput = CW.WorksheetInput (CW._worksheetSources fixture) + [CW.WorksheetAdjustment "raw-three-posting" + ("parent" NE.:| []) rawAdjustment] + (CW._worksheetLinkage fixture) + assertEqual "consolidation worksheet: accepts non-journal-shaped raw Alg" + True + (case CW.validateConsolidationWorksheet rawInput of + Right _ -> True + Left _ -> False) + + let sources = CW._worksheetSources fixture + links = CW._worksheetLinkage fixture + debitOnly = EC.journalFromSides + [(Debit, Cash, 10 :: MoneyDecimal)] :: CheckedAlgM + creditOnly = EC.journalFromSides + [(Credit, Sales, 10 :: MoneyDecimal)] :: CheckedAlgM + cancellingSet = debitOnly EA..+ creditOnly + cancellingInput = CW.WorksheetInput sources + [ CW.WorksheetAdjustment "bad-debit" ("parent" NE.:| []) debitOnly + , CW.WorksheetAdjustment "bad-credit" ("parent" NE.:| []) creditOnly + ] links + assertEqual "consolidation worksheet: malformed set can balance in aggregate" + True (ECC.exactBalanced cancellingSet) + assertEqual "consolidation worksheet: atomic gate rejects both malformed adjustments" + (Just + ( CW.UnbalancedAdjustment "bad-debit" 10 0 NE.:| + [CW.UnbalancedAdjustment "bad-credit" 0 10] + )) + (leftErrors (CW.validateConsolidationWorksheet cancellingInput)) + + let forbidden = EC.journalFromSides + [ (Debit, NetIncome, 10 :: MoneyDecimal) + , (Credit, RetainedEarnings, 10) + ] :: CheckedAlgM + forbiddenInput = CW.WorksheetInput sources + [CW.WorksheetAdjustment "forbidden" ("parent" NE.:| []) forbidden] + links + assertEqual "consolidation worksheet: context capability applies to raw Alg" + (Just (CW.AdjustmentPostingNotAllowed "forbidden" NetIncome + EngineGeneratedOnly NE.:| [])) + (leftErrors (CW.validateConsolidationWorksheet forbiddenInput)) + + let provenanceInput = CW.WorksheetInput sources + [CW.WorksheetAdjustment "unknown" + ("ghost" NE.:| ["ghost"]) (mempty :: CheckedAlgM)] links + assertEqual "consolidation worksheet: provenance rejects duplicate and unknown source" + (Just + ( CW.DuplicateAdjustmentSource "unknown" "ghost" NE.:| + [ CW.UnknownAdjustmentSource "unknown" "ghost" + , CW.EmptyAdjustment "unknown" + ] + )) + (leftErrors (CW.validateConsolidationWorksheet provenanceInput)) + + let mismatchedLinks = links + { CW._statementOfChangesNetIncomeAttributableToOwners = + CW.PeriodProfit 40 } + mismatchedInput = fixture { CW._worksheetLinkage = mismatchedLinks } + assertEqual "consolidation worksheet: P/L to S/S mismatch is explicit" + True + (case CW.validateConsolidationWorksheet mismatchedInput of + Left errors -> CW.OwnersPeriodResultLinkMismatch + (CW.PeriodProfit 50) (CW.PeriodProfit 40) `elem` NE.toList errors + Right _ -> False) + + let attributionLinks = links + { CW._profitOrLossNetIncome = CW.PeriodProfit 60 } + attributionInput = fixture { CW._worksheetLinkage = attributionLinks } + assertEqual "consolidation worksheet: total attribution mismatch is explicit" + True + (case CW.validateConsolidationWorksheet attributionInput of + Left errors -> CW.NetIncomeAttributionMismatch 60 70 + `elem` NE.toList errors + Right _ -> False) + + let retainedLinks = links + { CW._retainedEarningsDividends = 11 } + retainedInput = fixture { CW._worksheetLinkage = retainedLinks } + assertEqual "consolidation worksheet: retained-earnings mismatch is explicit" + True + (case CW.validateConsolidationWorksheet retainedInput of + Left errors -> CW.RetainedEarningsRollForwardMismatch 150 151 + `elem` NE.toList errors + Right _ -> False) + + let balanceSheetLinks = links + { CW._balanceSheetRetainedEarnings = CW.CreditBalance 139 } + balanceSheetInput = fixture { CW._worksheetLinkage = balanceSheetLinks } + assertEqual "consolidation worksheet: S/S to B/S mismatch is explicit" + True + (case CW.validateConsolidationWorksheet balanceSheetInput of + Left errors -> CW.BalanceSheetRetainedEarningsMismatch + (CW.CreditBalance 140) (CW.CreditBalance 139) + `elem` NE.toList errors + Right _ -> False) + + let nciLinks = links { CW._nonControllingInterestsDividends = 6 } + nciInput = fixture { CW._worksheetLinkage = nciLinks } + assertEqual "consolidation worksheet: NCI roll-forward mismatch is explicit" + True + (case CW.validateConsolidationWorksheet nciInput of + Left errors -> CW.NonControllingInterestsRollForwardMismatch 50 51 + `elem` NE.toList errors + Right _ -> False) + + let nciBalanceSheetLinks = links + { CW._balanceSheetNonControllingInterests = CW.CreditBalance 44 } + nciBalanceSheetInput = fixture + { CW._worksheetLinkage = nciBalanceSheetLinks } + assertEqual "consolidation worksheet: NCI S/S to B/S mismatch is explicit" + True + (case CW.validateConsolidationWorksheet nciBalanceSheetInput of + Left errors -> CW.BalanceSheetNonControllingInterestsMismatch + (CW.CreditBalance 45) (CW.CreditBalance 44) + `elem` NE.toList errors + Right _ -> False) + + let lossLinks = links + { CW._profitOrLossNetIncome = CW.PeriodLoss 25 + , CW._profitOrLossNetIncomeAttributableToOwners = CW.PeriodLoss 20 + , CW._statementOfChangesNetIncomeAttributableToOwners = + CW.PeriodLoss 20 + , CW._openingRetainedEarnings = CW.CreditBalance 100 + , CW._retainedEarningsDividends = 10 + , CW._statementOfChangesClosingRetainedEarnings = + CW.CreditBalance 70 + , CW._balanceSheetRetainedEarnings = CW.CreditBalance 70 + , CW._openingNonControllingInterests = CW.CreditBalance 30 + , CW._nonControllingInterestsPeriodShare = CW.PeriodLoss 5 + , CW._nonControllingInterestsDividends = 5 + , CW._statementOfChangesClosingNonControllingInterests = + CW.CreditBalance 20 + , CW._balanceSheetNonControllingInterests = CW.CreditBalance 20 + } + lossInput = fixture { CW._worksheetLinkage = lossLinks } + assertEqual "consolidation worksheet: loss roll-forwards preserve direction" + True + (case CW.validateConsolidationWorksheet lossInput of + Right _ -> True + Left _ -> False) + + let deficitLinks = links + { CW._profitOrLossNetIncome = CW.PeriodLoss 50 + , CW._profitOrLossNetIncomeAttributableToOwners = CW.PeriodLoss 50 + , CW._statementOfChangesNetIncomeAttributableToOwners = + CW.PeriodLoss 50 + , CW._openingRetainedEarnings = CW.CreditBalance 10 + , CW._retainedEarningsDividends = 0 + , CW._statementOfChangesClosingRetainedEarnings = + CW.DebitBalance 40 + , CW._balanceSheetRetainedEarnings = CW.DebitBalance 40 + , CW._openingNonControllingInterests = CW.CreditBalance 0 + , CW._nonControllingInterestsPeriodShare = CW.PeriodBreakEven + , CW._nonControllingInterestsDividends = 0 + , CW._statementOfChangesClosingNonControllingInterests = + CW.CreditBalance 0 + , CW._balanceSheetNonControllingInterests = CW.CreditBalance 0 + } + deficitInput = fixture { CW._worksheetLinkage = deficitLinks } + assertEqual "consolidation worksheet: accumulated deficit is structural" + True + (case CW.validateConsolidationWorksheet deficitInput of + Right _ -> True + Left _ -> False) + + let invalidLinks = links + { CW._openingRetainedEarnings = CW.CreditBalance (-1) } + invalidInput = fixture { CW._worksheetLinkage = invalidLinks } + assertEqual "consolidation worksheet: negative linkage amount rejected" + (Just (CW.InvalidLinkAmount CW.OpeningRetainedEarnings (-1) NE.:| [])) + (leftErrors (CW.validateConsolidationWorksheet invalidInput)) + + let wildcardAccount = + (10 EA..@ (Not :< AccountTitle)) EA..+ + (10 EA..@ (Hat :< Cash)) :: CheckedAlgM + wildcardInput = CW.WorksheetInput sources + [CW.WorksheetAdjustment "wildcard" ("parent" NE.:| []) + wildcardAccount] links + assertEqual "consolidation worksheet: wildcard error list is total" + (Just (CW.WildcardAdjustmentAccount "wildcard" NE.:| [])) + (leftErrors (CW.validateConsolidationWorksheet wildcardInput)) + + let duplicateSources = case sources of + source NE.:| rest -> source NE.:| (source : rest) + duplicateAdjustments = + [ CW.WorksheetAdjustment "same" ("parent" NE.:| []) + rawAdjustment + , CW.WorksheetAdjustment "same" ("parent" NE.:| []) + rawAdjustment + ] + duplicateInput = CW.WorksheetInput duplicateSources + duplicateAdjustments links + assertEqual "consolidation worksheet: duplicate stable IDs rejected" + True + (case CW.validateConsolidationWorksheet duplicateInput of + Left errors -> CW.DuplicateSourceId "parent" `elem` NE.toList errors + && CW.DuplicateAdjustmentId "same" `elem` NE.toList errors + Right _ -> False) + + let wildcardSource = CW.TrialBalanceSource "wild-source" + (10 :@ (HatNot :< Cash) :: CheckedAlgM) + wildcardSourceInput + :: CW.WorksheetInput String String MoneyDecimal + wildcardSourceInput = CW.WorksheetInput + (wildcardSource NE.:| []) [] links + assertEqual "consolidation worksheet: wildcard source side is total" + (Just (CW.WildcardSourceSide "wild-source" NE.:| [])) + (leftErrors (CW.validateConsolidationWorksheet wildcardSourceInput)) + + let wildcardSide = + 10 :@ (HatNot :< Cash) :: CheckedAlgM + wildcardSideInput = CW.WorksheetInput sources + [CW.WorksheetAdjustment "wild-side" ("parent" NE.:| []) + wildcardSide] links + assertEqual "consolidation worksheet: wildcard adjustment side is total" + (Just (CW.WildcardAdjustmentSide "wild-side" NE.:| [])) + (leftErrors (CW.validateConsolidationWorksheet wildcardSideInput)) + + let unbalancedSource = CW.TrialBalanceSource "unbalanced-source" + (EC.journalFromSides + [(Debit, Cash, 10 :: MoneyDecimal)] :: CheckedAlgM) + unbalancedSourceInput + :: CW.WorksheetInput String String MoneyDecimal + unbalancedSourceInput = CW.WorksheetInput + (unbalancedSource NE.:| []) [] links + assertEqual "consolidation worksheet: unbalanced source rejected" + (Just (CW.UnbalancedSourceTrialBalance + "unbalanced-source" 10 0 NE.:| [])) + (leftErrors (CW.validateConsolidationWorksheet unbalancedSourceInput)) + +trialBalanceInput + :: CheckedAlgM + -> TB.TrialBalanceStage + -> TB.TrialBalanceInput MoneyDecimal +trialBalanceInput alg stage = TB.TrialBalanceInput + { TB._trialBalanceElement = alg + , TB._trialBalanceStage = stage + , TB._temporaryBalanceExplanations = M.empty + , TB._reclassificationRules = [] + , TB._maturityEvidenceTitles = Set.empty + } + +testSharedAccountBalancePrimitives :: IO () +testSharedAccountBalancePrimitives = do + let balances = + [ TBB.NoBalance + , TBB.DebitBalance 7 + , TBB.CreditBalance 11 + ] :: [TBB.AccountBalance Int] + assertEqual "account balance: pair netting round trip" + balances (fmap (TBB.netPair . TBB.balancePair) balances) + assertEqual "account balance: structural sides" + [Side, Debit, Credit] (fmap TBB.balanceSide balances) + +testTrialBalanceValidation :: IO () +testTrialBalanceValidation = do + let reciprocalMismatch = EC.journalFromSides + [ (Debit, BranchCurrentAccount, 40 :: MoneyDecimal) + , (Credit, HeadOfficeCurrentAccount, 30) + , (Credit, CapitalStock, 10) + ] :: CheckedAlgM + reciprocalInput = trialBalanceInput reciprocalMismatch TB.BeforeClosing + expectedReciprocal = TB.ReciprocalMismatch + (TB.DebitBalance 40) (TB.CreditBalance 30) + assertEqual "trial balance: reciprocal mismatch independent of global balance" + (Just (expectedReciprocal NE.:| [])) + (leftErrors (TB.validateTrialBalance + TB.strictTrialBalancePolicy reciprocalInput)) + assertEqual "trial balance: two-sided mismatch is never a standalone waiver" + (Just (expectedReciprocal NE.:| [])) + (leftErrors (TB.validateTrialBalance + TB.standaloneTrialBalancePolicy reciprocalInput)) + let standaloneReciprocal = EC.journalFromSides + [ (Debit, BranchCurrentAccount, 40 :: MoneyDecimal) + , (Credit, CapitalStock, 40) + ] :: CheckedAlgM + standaloneInput = trialBalanceInput standaloneReciprocal TB.BeforeClosing + expectedStandalone = TB.StandaloneReciprocalBalance + BranchCurrentAccount (TB.DebitBalance 40) + standalone <- case TB.validateTrialBalance + TB.standaloneTrialBalancePolicy standaloneInput of + Left errors -> fail ("standalone reciprocal balance rejected: " ++ show errors) + Right value -> pure value + assertEqual "trial balance: standalone policy retains permitted finding" + [expectedStandalone] (TB.validatedFindings standalone) + + let explainedSuspense = EC.journalFromSides + [ (Debit, SuspensePayments, 10 :: MoneyDecimal) + , (Credit, CapitalStock, 10) + ] :: CheckedAlgM + explanation = T.pack "invoice received after reporting date" + explainedInput = (trialBalanceInput explainedSuspense TB.BeforeClosing) + { TB._temporaryBalanceExplanations = + M.singleton SuspensePayments explanation } + expectedExplained = TB.ExplainedTemporaryBalance SuspensePayments + (TB.DebitBalance 10) explanation + explained <- case TB.validateTrialBalance + TB.standaloneTrialBalancePolicy explainedInput of + Left errors -> fail ("explained suspense balance rejected: " ++ show errors) + Right value -> pure value + assertEqual "trial balance: explained temporary balance retained" + [expectedExplained] (TB.validatedFindings explained) + assertEqual "trial balance: policy can block explained temporary balance" + (Just (expectedExplained NE.:| [])) + (leftErrors (TB.validateTrialBalance + TB.strictTrialBalancePolicy explainedInput)) + let unresolvedInput = trialBalanceInput explainedSuspense TB.BeforeClosing + assertEqual "trial balance: unexplained temporary balance blocks" + (Just (TB.UnresolvedTemporaryBalance SuspensePayments + (TB.DebitBalance 10) NE.:| [])) + (leftErrors (TB.validateTrialBalance + TB.standaloneTrialBalancePolicy unresolvedInput)) + let blankInput = explainedInput + { TB._temporaryBalanceExplanations = + M.singleton SuspensePayments (T.pack " ") } + assertEqual "trial balance: blank explanation never opens the gate" + (Just (TB.BlankTemporaryExplanation SuspensePayments + (TB.DebitBalance 10) NE.:| [])) + (leftErrors (TB.validateTrialBalance + TB.standaloneTrialBalancePolicy blankInput)) + + let closingResidual = EC.journalFromSides + [ (Debit, CashOverShort, 10 :: MoneyDecimal) + , (Credit, IncomeSummary, 10) + ] :: CheckedAlgM + closingInput = trialBalanceInput closingResidual TB.AfterClosing + assertEqual "trial balance: closing devices must be zero after closing" + (Just + ( TB.ClosingDeviceResidual CashOverShort (TB.DebitBalance 10) + NE.:| + [TB.ClosingDeviceResidual IncomeSummary (TB.CreditBalance 10)] + )) + (leftErrors (TB.validateTrialBalance + TB.standaloneTrialBalancePolicy closingInput)) + let unclosedNominal = EC.journalFromSides + [ (Debit, Cash, 10 :: MoneyDecimal) + , (Credit, Sales, 10) + ] :: CheckedAlgM + assertEqual "trial balance: nominal balances must close after closing" + (Just (TB.UnclosedNominalBalance Sales + (TB.CreditBalance 10) NE.:| [])) + (leftErrors (TB.validateTrialBalance TB.standaloneTrialBalancePolicy + (trialBalanceInput unclosedNominal TB.AfterClosing))) + + let derivedResidual = EC.journalFromSides + [ (Debit, NetIncome, 10 :: MoneyDecimal) + , (Credit, CapitalStock, 10) + ] :: CheckedAlgM + assertEqual "trial balance: derived coordinates are residuals after closing" + (Just (TB.DerivedCoordinateResidual NetIncome + (TB.DebitBalance 10) NE.:| [])) + (leftErrors (TB.validateTrialBalance TB.standaloneTrialBalancePolicy + (trialBalanceInput derivedResidual TB.AfterClosing))) + + let abnormalDeposit = EC.journalFromSides + [ (Debit, Cash, 10 :: MoneyDecimal) + , (Credit, CurrentDeposits, 10) + ] :: CheckedAlgM + abnormalInput = trialBalanceInput abnormalDeposit TB.BeforeClosing + oneRule = TB.SideReclassificationRule CurrentDeposits Credit + (ShortTermLoansPayable NE.:| []) + twoRules = TB.SideReclassificationRule CurrentDeposits Credit + (BankOverdraft NE.:| [ShortTermLoansPayable]) + assertEqual "trial balance: unexplained abnormal side is explicit" + (Just (TB.UnexplainedAbnormalBalance CurrentDeposits Debit + (TB.CreditBalance 10) NE.:| [])) + (leftErrors (TB.validateTrialBalance + TB.standaloneTrialBalancePolicy abnormalInput)) + assertEqual "trial balance: unique reclassification is an instruction" + (Just (TB.AbnormalBalanceWithReclassificationRule CurrentDeposits + (TB.CreditBalance 10) ShortTermLoansPayable NE.:| [])) + (leftErrors (TB.validateTrialBalance TB.standaloneTrialBalancePolicy + abnormalInput { TB._reclassificationRules = [oneRule] })) + assertEqual "trial balance: ambiguous reclassification is never automatic" + (Just (TB.AmbiguousReclassification CurrentDeposits + (TB.CreditBalance 10) + (BankOverdraft NE.:| [ShortTermLoansPayable]) NE.:| [])) + (leftErrors (TB.validateTrialBalance TB.standaloneTrialBalancePolicy + abnormalInput { TB._reclassificationRules = [twoRules] })) + + let recordedTransfer = EC.journalFromSides + [ (Debit, CurrentDeposits, 10 :: MoneyDecimal) + , (Credit, ShortTermLoansPayable, 10) + ] :: CheckedAlgM + transferred = abnormalDeposit .+ recordedTransfer + transferredInput = (trialBalanceInput transferred TB.BeforeClosing) + { TB._reclassificationRules = [oneRule] } + assertEqual "trial balance: recorded transfer clears abnormal finding" + True + (case TB.validateTrialBalance + TB.standaloneTrialBalancePolicy transferredInput of + Right _ -> True + Left _ -> False) + assertEqual "trial balance: validation never rewrites the admitted element" + transferred + (case TB.validateTrialBalance + TB.standaloneTrialBalancePolicy transferredInput of + Right value -> TB.validatedTrialBalance value + Left _ -> mempty) + assertEqual "trial balance: validated stage is retained" + TB.BeforeClosing + (case TB.validateTrialBalance + TB.standaloneTrialBalancePolicy transferredInput of + Right value -> TB.validatedStage value + Left _ -> TB.AfterClosing) + + let invalidRule = TB.SideReclassificationRule CashOverShort Credit + (MiscellaneousIncome NE.:| []) + invalidRuleInput = (trialBalanceInput mempty TB.BeforeClosing) + { TB._reclassificationRules = [invalidRule] } + assertEqual "trial balance: inapplicable rules are explicit" + (Just (TB.InapplicableReclassificationRule invalidRule NE.:| [])) + (leftErrors (TB.validateTrialBalance + TB.standaloneTrialBalancePolicy invalidRuleInput)) + let deadRule = TB.SideReclassificationRule CurrentDeposits Debit + (Cash NE.:| []) + deadRuleInput = (trialBalanceInput mempty TB.BeforeClosing) + { TB._reclassificationRules = [deadRule] } + assertEqual "trial balance: normal-side trigger is a dead rule" + (Just (TB.InapplicableReclassificationRule deadRule NE.:| [])) + (leftErrors (TB.validateTrialBalance + TB.standaloneTrialBalancePolicy deadRuleInput)) + + let maturityBalance = EC.journalFromSides + [ (Debit, LoansReceivable, 25 :: MoneyDecimal) + , (Credit, CapitalStock, 25) + ] :: CheckedAlgM + maturityRule = TB.MaturityEvidenceRequired LoansReceivable + missingMaturity = (trialBalanceInput maturityBalance TB.BeforeClosing) + { TB._reclassificationRules = [maturityRule] } + suppliedMaturity = missingMaturity + { TB._maturityEvidenceTitles = Set.singleton LoansReceivable } + assertEqual "trial balance: maturity-sensitive title requires evidence" + (Just (TB.MissingMaturityEvidence LoansReceivable NE.:| [])) + (leftErrors (TB.validateTrialBalance + TB.standaloneTrialBalancePolicy missingMaturity)) + assertEqual "trial balance: supplied maturity evidence clears finding" + True + (case TB.validateTrialBalance + TB.standaloneTrialBalancePolicy suppliedMaturity of + Right _ -> True + Left _ -> False) + + let unbalanced = EC.journalFromSides + [(Debit, Cash, 10 :: MoneyDecimal)] :: CheckedAlgM + unbalancedInput = trialBalanceInput unbalanced TB.BeforeClosing + assertEqual "trial balance: exact global imbalance blocks" + (Just (TB.UnbalancedTrialBalance 10 0 NE.:| [])) + (leftErrors (TB.validateTrialBalance + TB.standaloneTrialBalancePolicy unbalancedInput)) + + let wildcard = 10 :@ (HatNot :< Cash) :: CheckedAlgM + wildcardInput = trialBalanceInput wildcard TB.BeforeClosing + assertEqual "trial balance: wildcard side reports without whichSide crash" + (Just (TB.WildcardTrialBalanceSide NE.:| [])) + (leftErrors (TB.validateTrialBalance + TB.standaloneTrialBalancePolicy wildcardInput)) + + let titlesFor role = + [ title + | title <- Registry.concreteAccountTitles + , Just semantics <- [Registry.accountSemantics title] + , role `elem` Registry.asemRoles semantics + ] + assertEqual "trial balance: reciprocal registry role is pinned" + [BranchCurrentAccount, HeadOfficeCurrentAccount] + (titlesFor ReciprocalAccount) + assertEqual "trial balance: suspense registry role is pinned" + [SuspensePayments, CashOverShort, SuspenseReceipts, SuspenseAccount] + (titlesFor SuspenseOrClearingAccount) + assertEqual "trial balance: closing-device registry role is pinned" + [IncomeSummary] (titlesFor ClosingDevice) + +testReportingPresentation :: IO () +testReportingPresentation = do + let reportingBalance = EC.journalFromSides + [ (Debit, Cash, 100 :: MoneyDecimal) + , (Debit, LoansReceivable, 30) + , (Debit, Purchases, 40) + , (Debit, BranchCurrentAccount, 10) + , (Debit, IncomeTaxesRefundReceivable, 5) + , (Credit, CapitalStock, 90) + , (Credit, Sales, 70) + , (Credit, AdvancesReceived, 15) + , (Credit, HeadOfficeCurrentAccount, 10) + ] :: CheckedAlgM + maturityRule = TB.MaturityEvidenceRequired LoansReceivable + reportingInput = (trialBalanceInput reportingBalance TB.BeforeClosing) + { TB._reclassificationRules = [maturityRule] + , TB._maturityEvidenceTitles = Set.singleton LoansReceivable + } + validated = case TB.validateTrialBalance + TB.strictTrialBalancePolicy reportingInput of + Right value -> value + Left errors -> error ("reporting fixture did not validate: " ++ show errors) + rationale = T.pack "material under the documented tax review" + context scope = (RP.jcciSecondGradeContext scope) + { RP._presentationAllocations = + [RP.PresentationAllocation LoansReceivable 10 20 + (T.pack "contract maturity schedule")] + , RP._presentationRelabels = + [RP.PresentationRelabel Purchases SalesCost + (T.pack "JCCI report cost-of-sales label")] + , RP._materialityDecisions = + [RP.MaterialityDecision IncomeTaxesRefundReceivable + RP.PresentSeparately rationale] + , RP._subtotalDefinitions = + [ RP.SubtotalDefinition RM.GrossProfitMetric [Sales] [SalesCost] + RP.RequireAllTitlesPresent + , RP.SubtotalDefinition RM.OrdinaryProfitMetric [Sales] [SalesCost] + RP.RequireAllTitlesPresent + ] + } + standalone = rightStatements (RP.present (context RP.Standalone) validated) + combined = rightStatements (RP.present (context RP.Combined) validated) + standaloneTitles = L.map RP._lineAccount (RP._statementLines standalone) + combinedTitles = L.map RP._lineAccount (RP._statementLines combined) + assertEqual "reporting: same validated TB changes with scope" + True (RP._statementLines standalone /= RP._statementLines combined) + assertEqual "reporting: standalone retains reciprocal lines" + True (BranchCurrentAccount `elem` standaloneTitles + && HeadOfficeCurrentAccount `elem` standaloneTitles) + assertEqual "reporting: combined eliminates reciprocal lines" + True (BranchCurrentAccount `notElem` combinedTitles + && HeadOfficeCurrentAccount `notElem` combinedTitles + && any isElimination (RP._presentationAudit combined)) + assertEqual "reporting: maturity evidence splits one title" + [ (RP.CurrentAssetsSection, 10) + , (RP.NoncurrentAssetsSection, 20) + ] + [ (RP._lineSection line, RP._lineAmount line) + | line <- RP._statementLines standalone + , RP._lineAccount line == LoansReceivable + ] + assertEqual "reporting: JCCI profile uses contract-liability label" + [T.pack "契約負債"] + [ RP._lineLabel line + | line <- RP._statementLines standalone + , RP._lineAccount line == AdvancesReceived + ] + assertEqual "reporting: Purchases is relabeled to SalesCost" + True (Purchases `notElem` standaloneTitles && SalesCost `elem` standaloneTitles) + assertEqual "reporting: GrossProfit is a subtotal, not a basis line" + ( [ RP.StatementSubtotal RM.GrossProfitMetric + (T.pack "売上総利益") (TB.CreditBalance 30) + , RP.StatementSubtotal RM.OrdinaryProfitMetric + (T.pack "経常利益") (TB.CreditBalance 30) + ] + , False + ) + ( RP._statementSubtotals standalone + , GrossProfit `elem` standaloneTitles + || OrdinaryProfit `elem` standaloneTitles + ) + assertEqual "reporting: materiality rationale survives in audit" + True (RP.MaterialityApplied IncomeTaxesRefundReceivable + RP.PresentSeparately (TB.DebitBalance 5) rationale + `elem` RP._presentationAudit standalone) + assertEqual "reporting: relabel never mutates validated bookkeeping coordinates" + True (Purchases `elem` basesAccountTitles (TB.validatedTrialBalance validated) + && SalesCost `notElem` + basesAccountTitles (TB.validatedTrialBalance validated)) + + let missingAllocation = (context RP.Standalone) + { RP._presentationAllocations = [] } + assertEqual "reporting: missing maturity evidence blocks presentation" + True (case RP.present missingAllocation validated of + Left issues -> RP.MissingPresentationAllocation LoansReceivable + `elem` NE.toList issues + Right _ -> False) + + let explainedSuspense = EC.journalFromSides + [ (Debit, SuspensePayments, 10 :: MoneyDecimal) + , (Credit, CapitalStock, 10) + ] :: CheckedAlgM + explainedInput = (trialBalanceInput explainedSuspense TB.BeforeClosing) + { TB._temporaryBalanceExplanations = M.singleton SuspensePayments + (T.pack "pending invoice") } + explainedValidated = case TB.validateTrialBalance + TB.standaloneTrialBalancePolicy explainedInput of + Right value -> value + Left errors -> error ("explained fixture rejected: " ++ show errors) + assertEqual "reporting: stricter combined context re-gates retained finding" + True (case RP.present (RP.jcciSecondGradeContext RP.Combined) + explainedValidated of + Left issues -> any isValidationBlock (NE.toList issues) + Right _ -> False) + + let contraBalance = EC.journalFromSides + [ (Debit, AccountsReceivable, 100 :: MoneyDecimal) + , (Credit, AllowanceForDoubtfulAccounts, 10) + , (Credit, CapitalStock, 90) + ] :: CheckedAlgM + contraValidated = validateFixture contraBalance + separateContext = (RP.jcciSecondGradeContext RP.Standalone) + { RP._contraPresentationRules = + [RP.PresentContraSeparately AllowanceForDoubtfulAccounts + (T.pack "show allowance as deduction")] } + netContext = (RP.jcciSecondGradeContext RP.Standalone) + { RP._contraPresentationRules = + [RP.NetContraAgainst AllowanceForDoubtfulAccounts + AccountsReceivable (T.pack "net receivables policy")] } + separateLines = RP._statementLines + (rightStatements (RP.present separateContext contraValidated)) + netLines = RP._statementLines + (rightStatements (RP.present netContext contraValidated)) + assertEqual "reporting: contra policy supports separate presentation" + True (any (\line -> RP._lineAccount line == AllowanceForDoubtfulAccounts + && RP._lineIsDeduction line) separateLines) + assertEqual "reporting: contra policy supports net presentation" + [(Debit, 90)] + [ (RP._lineSide line, RP._lineAmount line) + | line <- netLines, RP._lineAccount line == AccountsReceivable + ] + + let taxBalance = EC.journalFromSides + [ (Debit, Cash, 85 :: MoneyDecimal) + , (Debit, CorporateIncomeTaxes, 20) + , (Credit, CapitalStock, 100) + , (Credit, RefundOfIncomeTaxes, 5) + ] :: CheckedAlgM + taxValidated = validateFixture taxBalance + netTaxContext = (RP.jcciSecondGradeContext RP.Standalone) + { RP._materialityDecisions = + [RP.MaterialityDecision RefundOfIncomeTaxes + (RP.NetAgainst CorporateIncomeTaxes) + (T.pack "immaterial refund netted under tax policy")] } + taxLines = RP._statementLines + (rightStatements (RP.present netTaxContext taxValidated)) + assertEqual "reporting: materiality policy supports tax netting" + (False, [(Debit, 15)]) + ( RefundOfIncomeTaxes `elem` L.map RP._lineAccount taxLines + , [ (RP._lineSide line, RP._lineAmount line) + | line <- taxLines, RP._lineAccount line == CorporateIncomeTaxes + ] + ) + let badAllocation current noncurrent evidence = (context RP.Standalone) + { RP._presentationAllocations = + [RP.PresentationAllocation LoansReceivable current noncurrent evidence] } + assertEqual "reporting: blank allocation evidence blocks" + True (hasPresentationIssue isBlankEvidence (RP.present + (badAllocation 10 20 (T.pack " ")) validated)) + assertEqual "reporting: negative allocation blocks" + True (hasPresentationIssue isInvalidAllocation (RP.present + (badAllocation (-1) 31 (T.pack "schedule")) validated)) + assertEqual "reporting: non-summing allocation blocks" + True (hasPresentationIssue isInvalidAllocation (RP.present + (badAllocation 10 19 (T.pack "schedule")) validated)) + let duplicateAllocation = (context RP.Standalone) + { RP._presentationAllocations = + [ RP.PresentationAllocation LoansReceivable 10 20 + (T.pack "schedule A") + , RP.PresentationAllocation LoansReceivable 10 20 + (T.pack "schedule B") + ] } + assertEqual "reporting: duplicate allocation blocks" + True (hasPresentationIssue isDuplicateAllocation + (RP.present duplicateAllocation validated)) + let unexpectedAllocation = (context RP.Standalone) + { RP._presentationAllocations = + [ RP.PresentationAllocation LoansReceivable 10 20 + (T.pack "contract maturity schedule") + , RP.PresentationAllocation Cash 100 0 (T.pack "none") + ] } + assertEqual "reporting: unrequired allocation blocks" + True (hasPresentationIssue isUnexpectedAllocation + (RP.present unexpectedAllocation validated)) + + let contraRequiredInput = (trialBalanceInput contraBalance TB.BeforeClosing) + { TB._reclassificationRules = + [TB.MaturityEvidenceRequired AccountsReceivable] + , TB._maturityEvidenceTitles = Set.singleton AccountsReceivable + } + contraRequired = case TB.validateTrialBalance TB.strictTrialBalancePolicy + contraRequiredInput of + Right value -> value + Left errors -> error ("required contra fixture rejected: " ++ show errors) + netAllocatedContext = netContext + { RP._presentationAllocations = + [RP.PresentationAllocation AccountsReceivable 60 30 + (T.pack "receivable maturity schedule")] } + assertEqual "reporting: required net target can be allocated after netting" + [(RP.CurrentAssetsSection, 60), (RP.NoncurrentAssetsSection, 30)] + [ (RP._lineSection line, RP._lineAmount line) + | line <- RP._statementLines + (rightStatements (RP.present netAllocatedContext contraRequired)) + , RP._lineAccount line == AccountsReceivable + ] + let consumeRequired = (context RP.Standalone) + { RP._materialityDecisions = + [RP.MaterialityDecision LoansReceivable (RP.NetAgainst Cash) + (T.pack "must not erase maturity obligation")] } + assertEqual "reporting: explicit maturity obligation cannot be consumed" + True (hasPresentationIssue isConflictingInstruction + (RP.present consumeRequired validated)) + + let emptyValidated = validateFixture mempty + emptyStatements = rightStatements (RP.present + (RP.jcciSecondGradeContext RP.Combined) emptyValidated) + assertEqual "reporting: empty combined TB has no fabricated elimination" + ([], []) + (RP._statementLines emptyStatements, RP._presentationAudit emptyStatements) + where + rightStatements (Right statements) = statements + rightStatements (Left issues) = error ("presentation failed: " ++ show issues) + validateFixture alg = case TB.validateTrialBalance TB.strictTrialBalancePolicy + (trialBalanceInput alg TB.BeforeClosing) of + Right value -> value + Left errors -> error ("fixture did not validate: " ++ show errors) + isElimination (RP.ReciprocalAccountsEliminated _ _) = True + isElimination _ = False + isValidationBlock (RP.ValidationFindingBlocks _) = True + isValidationBlock _ = False + hasPresentationIssue predicate (Left issues) = any predicate (NE.toList issues) + hasPresentationIssue _ (Right _) = False + isBlankEvidence (RP.BlankPresentationEvidence LoansReceivable) = True + isBlankEvidence _ = False + isInvalidAllocation (RP.InvalidPresentationAllocation LoansReceivable _ _ _) = True + isInvalidAllocation _ = False + isDuplicateAllocation (RP.DuplicatePresentationAllocation LoansReceivable) = True + isDuplicateAllocation _ = False + isUnexpectedAllocation (RP.UnexpectedPresentationAllocation Cash) = True + isUnexpectedAllocation _ = False + isConflictingInstruction + (RP.ConflictingPresentationInstruction LoansReceivable) = True + isConflictingInstruction _ = False + basesAccountTitles alg = + [ title | _ :< title <- EA.bases alg ] + +testDerivedMetricsLand5 :: IO () +testDerivedMetricsLand5 = do + assertEqual "Land 5: legacy derived-coordinate ordinals and Binary bytes" + [ (NetIncome, 49, T.pack "0031") + , (GrossProfit, 54, T.pack "0036") + , (OrdinaryProfit, 55, T.pack "0037") + , (NetLoss, 64, T.pack "0040") + , (IncomeSummary, 216, T.pack "00d8") + ] + [ (title, fromEnum title, accountSemanticsBinaryHex title) + | title <- [NetIncome, GrossProfit, OrdinaryProfit, NetLoss, IncomeSummary] + ] + assertEqual "Land 5: exactly four legacy coordinates map to typed metrics" + [ (NetIncome, RM.PeriodResultMetric) + , (GrossProfit, RM.GrossProfitMetric) + , (OrdinaryProfit, RM.OrdinaryProfitMetric) + , (NetLoss, RM.PeriodResultMetric) + ] + [ (title, metric) + | title <- Registry.concreteAccountTitles + , Just metric <- [RM.metricForLegacyTitle title] + ] + + let salesOnly = 100 .@ Not :< Sales :: CheckedAlgM + afterLegacyBalancer = EAT.incomeSummaryAccount salesOnly + hatSales = 25 .@ Hat :< Sales :: CheckedAlgM + assertEqual "Land 5: period metric ignores an inserted legacy balancer" + (Right (RM.PeriodProfit 100), Right (RM.PeriodProfit 100)) + ( RM.periodResultOfAlg salesOnly + , RM.periodResultOfAlg afterLegacyBalancer + ) + assertEqual "Land 5: Hat is interpreted through account side, not as a scalar sign" + (Right (RM.PeriodLoss 25)) (RM.periodResultOfAlg hatSales) + assertEqual "Land 5: empty nominal basis is break-even" + (Right RM.PeriodBreakEven :: Either RM.MetricError (RM.PeriodResult MoneyDecimal)) + (RM.periodResultOfAlg (mempty :: CheckedAlgM)) + assertEqual "Land 5: raw metric boundary rejects wildcard sides" + (Left (RM.WildcardMetricSide Sales)) + (RM.periodResultOfAlg (10 .@ HatNot :< Sales :: CheckedAlgM)) + + let ordinaryLedger = EC.journalFromSides + [ (Debit, Cash, 100 :: MoneyDecimal) + , (Credit, Sales, 100) + ] :: CheckedAlgM + ordinaryValidated = validateBefore ordinaryLedger + assertEqual "Land 5: validated before-closing TB derives one period-result identity" + (Right (RM.PeriodProfit 100)) + (RM.periodResultOf ordinaryValidated) + + let legacyLedger = EC.journalFromSides + [ (Debit, NetIncome, 10 :: MoneyDecimal) + , (Credit, CapitalStock, 10) + ] :: CheckedAlgM + legacyValidated = validateBefore legacyLedger + assertEqual "Land 5: typed metric rejects a residual legacy coordinate" + (Left (RM.ResidualDerivedCoordinate NetIncome)) + (RM.periodResultOf legacyValidated) + assertEqual "Land 5: legacy intermediate and presentation paths are explicit alternatives" + True (case RP.present + (RP.jcciSecondGradeContext RP.Standalone) legacyValidated of + Left issues -> RP.UnpresentableBalance NetIncome + (TB.DebitBalance 10) `elem` NE.toList issues + Right _ -> False) + + let emptyValidated = validateBefore (mempty :: CheckedAlgM) + subtotal = RP.SubtotalDefinition RM.GrossProfitMetric + [Sales] [SalesCost] RP.TreatAbsentAsZero + duplicateContext = (RP.jcciSecondGradeContext RP.Standalone) + { RP._subtotalDefinitions = [subtotal, subtotal] } + assertEqual "Land 5: duplicate metric identity blocks presentation" + True (case RP.present duplicateContext emptyValidated of + Left issues -> RP.DuplicateMetricIdentity RM.GrossProfitMetric + `elem` NE.toList issues + Right _ -> False) + let absentAsZeroContext = (RP.jcciSecondGradeContext RP.Standalone) + { RP._subtotalDefinitions = [subtotal] } + assertEqual "Land 5: canonical subtotal may treat unposted titles as zero" + [RP.StatementSubtotal RM.GrossProfitMetric + (T.pack "売上総損益") TB.NoBalance] + (RP._statementSubtotals (case RP.present absentAsZeroContext emptyValidated of + Right statements -> statements + Left issues -> error ("absent-as-zero subtotal rejected: " ++ show issues))) + + let relabelledLedger = EC.journalFromSides + [ (Debit, Purchases, 30 :: MoneyDecimal) + , (Credit, Sales, 30) + ] :: CheckedAlgM + relabelledValidated = validateBefore relabelledLedger + removedTitleContext = (RP.jcciSecondGradeContext RP.Standalone) + { RP._presentationRelabels = + [RP.PresentationRelabel Purchases SalesCost (T.pack "policy")] + , RP._subtotalDefinitions = + [RP.SubtotalDefinition RM.GrossProfitMetric + [Sales] [Purchases] RP.TreatAbsentAsZero] + } + assertEqual "Land 5: absent-as-zero does not hide a relabelled non-zero title" + True (case RP.present removedTitleContext relabelledValidated of + Left issues -> RP.InvalidSubtotalDefinition RM.GrossProfitMetric + `elem` NE.toList issues + Right _ -> False) + + let Just customId = RM.mkMetricId (T.pack "ebitda-adjusted") + customDefinition = RP.SubtotalDefinition (RM.CustomMetric customId) + [Sales] [] RP.TreatAbsentAsZero + unlabelledContext = (RP.jcciSecondGradeContext RP.Standalone) + { RP._subtotalDefinitions = [customDefinition] } + assertEqual "Land 5: custom metric identity requires separate labels" + True (case RP.present unlabelledContext emptyValidated of + Left issues -> RP.UnlabelledCustomMetric customId + `elem` NE.toList issues + Right _ -> False) + let labelledContext = unlabelledContext + { RP._presentationProfile = RP.CanonicalEnglish + , RP._customMetricLabels = + [RP.CustomMetricLabel customId + (T.pack "調整後EBITDA") (T.pack "Adjusted EBITDA")] + } + assertEqual "Land 5: custom metric identity and profile label are separate" + [RP.StatementSubtotal (RM.CustomMetric customId) + (T.pack "Adjusted EBITDA") TB.NoBalance] + (RP._statementSubtotals (case RP.present labelledContext emptyValidated of + Right statements -> statements + Left issues -> error ("labelled custom metric rejected: " ++ show issues))) + let duplicateLabelContext = labelledContext + { RP._customMetricLabels = RP._customMetricLabels labelledContext + ++ RP._customMetricLabels labelledContext + } + assertEqual "Land 5: standalone label lookup rejects duplicate identities" + Nothing + (RP.metricLabel duplicateLabelContext (RM.CustomMetric customId) + TB.NoBalance) + where + validateBefore alg = case TB.validateTrialBalance + TB.strictTrialBalancePolicy (trialBalanceInput alg TB.BeforeClosing) of + Right value -> value + Left errors -> error ("Land 5 fixture did not validate: " ++ show errors) + +-- Pins the complete 4 context x 5 capability truth table of the accounting +-- posting policy, row by row, so that a change to any single cell is visible +-- as a diff here rather than only through the checked-conversion wrappers. +testPostingPolicyTruthTable :: IO () +testPostingPolicyTruthTable = do + let contexts = + [ PP.OrdinaryJournal + , PP.ClosingProcess + , PP.ConsolidationWorksheet + , PP.EngineComputation + ] + capabilities = + [ OrdinaryPosting + , ClosingOnly + , ConsolidationOnly + , EngineGeneratedOnly + , NotPostable + ] + truthTable = + [ (PP.OrdinaryJournal, OrdinaryPosting, True) + , (PP.OrdinaryJournal, ClosingOnly, False) + , (PP.OrdinaryJournal, ConsolidationOnly, False) + , (PP.OrdinaryJournal, EngineGeneratedOnly, False) + , (PP.OrdinaryJournal, NotPostable, False) + , (PP.ClosingProcess, OrdinaryPosting, True) + , (PP.ClosingProcess, ClosingOnly, True) + , (PP.ClosingProcess, ConsolidationOnly, False) + , (PP.ClosingProcess, EngineGeneratedOnly, False) + , (PP.ClosingProcess, NotPostable, False) + , (PP.ConsolidationWorksheet, OrdinaryPosting, True) + , (PP.ConsolidationWorksheet, ClosingOnly, False) + , (PP.ConsolidationWorksheet, ConsolidationOnly, True) + , (PP.ConsolidationWorksheet, EngineGeneratedOnly, False) + , (PP.ConsolidationWorksheet, NotPostable, False) + , (PP.EngineComputation, OrdinaryPosting, True) + , (PP.EngineComputation, ClosingOnly, False) + , (PP.EngineComputation, ConsolidationOnly, False) + , (PP.EngineComputation, EngineGeneratedOnly, True) + , (PP.EngineComputation, NotPostable, False) + ] + assertEqual "posting policy: truth table enumerates every context/capability pair" + [ (context, capability) + | context <- contexts + , capability <- capabilities + ] + [ (context, capability) | (context, capability, _) <- truthTable ] + assertEqual "posting policy: 4 x 5 truth table of postingAllowedIn" + [ (context, capability, expected) + | (context, capability, expected) <- truthTable + ] + [ (context, capability, PP.postingAllowedIn context capability) + | (context, capability, _) <- truthTable + ] + assertEqual "posting policy: Convert.Checked re-exports the same gate" + [ PP.postingAllowedIn context capability + | (context, capability, _) <- truthTable + ] + [ ECC.postingAllowedIn context capability + | (context, capability, _) <- truthTable + ] + assertEqual "posting policy: wildcard title is NotPostable" + NotPostable (PP.postingCapabilityFor AccountTitle) + assertEqual "posting policy: concrete titles report registry capability" + [ Registry.asemPostingCapability <$> Registry.accountSemantics title + | title <- Registry.concreteAccountTitles + ] + [ Just (PP.postingCapabilityFor title) + | title <- Registry.concreteAccountTitles + ] + +testPostingCapabilityGate :: IO () +testPostingCapabilityGate = do + let contexts = + [ ECC.OrdinaryJournal + , ECC.ClosingProcess + , ECC.ConsolidationWorksheet + , ECC.EngineComputation + ] + capabilities = + [ OrdinaryPosting + , ClosingOnly + , ConsolidationOnly + , EngineGeneratedOnly + , NotPostable + ] + allowed context capability = (context, capability) `elem` + [ (ECC.OrdinaryJournal, OrdinaryPosting) + , (ECC.ClosingProcess, OrdinaryPosting) + , (ECC.ClosingProcess, ClosingOnly) + , (ECC.ConsolidationWorksheet, OrdinaryPosting) + , (ECC.ConsolidationWorksheet, ConsolidationOnly) + , (ECC.EngineComputation, OrdinaryPosting) + , (ECC.EngineComputation, EngineGeneratedOnly) + ] + assertEqual "posting gate: closed context/capability matrix" + [ (context, capability, allowed context capability) + | context <- contexts + , capability <- capabilities + ] + [ (context, capability, ECC.postingAllowedIn context capability) + | context <- contexts + , capability <- capabilities + ] + assertEqual "posting gate: all 235 titles follow the closed matrix" + [ (context, title, ECC.postingAllowedIn context capability) + | context <- contexts + , title <- Registry.concreteAccountTitles + , Just semantics <- [Registry.accountSemantics title] + , let capability = Registry.asemPostingCapability semantics + ] + [ (context, title, accepted context title) + | context <- contexts + , title <- Registry.concreteAccountTitles + ] + assertEqual "posting gate: derived profit coordinates stay engine-only" + (replicate 4 (Just EngineGeneratedOnly)) + [ Registry.asemPostingCapability <$> Registry.accountSemantics title + | title <- [GrossProfit, OrdinaryProfit, NetIncome, NetLoss] + ] + assertEqual "posting gate: consolidation-only set is closed" + [ EquityInEarningsOfInvestee + , CumulativeTranslationAdjustment + , NonControllingInterests + , NetIncomeAttributableToNCI + , NetLossAttributableToNCI + ] + [ title + | title <- Registry.concreteAccountTitles + , Just semantics <- [Registry.accountSemantics title] + , Registry.asemPostingCapability semantics == ConsolidationOnly + ] + + assertEqual "posting gate: ordinary wrapper rejects engine-generated result" + (Left (ECC.PostingNotAllowed 0 NetIncome EngineGeneratedOnly + ECC.OrdinaryJournal NE.:| [])) + (checkedEntryM + [ (Debit, NetIncome, 10) + , (Credit, RetainedEarnings, 10) + ]) + + assertEqual "posting gate: closing admits IncomeSummary" + True + (case ECC.checkedEntryIn ECC.ClosingProcess + [ (Debit, Sales, 10 :: MoneyDecimal) + , (Credit, IncomeSummary, 10) + ] of + Right _ -> True + Left _ -> False) + assertEqual "posting gate: closing rejects engine-generated result" + True + (case ECC.checkedEntryIn ECC.ClosingProcess + [ (Debit, NetIncome, 10 :: MoneyDecimal) + , (Credit, RetainedEarnings, 10) + ] of + Left (ECC.PostingNotAllowed 0 NetIncome EngineGeneratedOnly + ECC.ClosingProcess NE.:| []) -> True + _ -> False) + + assertEqual "posting gate: consolidation admits NCI attribution" + True + (case ECC.checkedEntryIn ECC.ConsolidationWorksheet + [ (Debit, NetIncomeAttributableToNCI, 10 :: MoneyDecimal) + , (Credit, NonControllingInterests, 10) + ] of + Right _ -> True + Left _ -> False) + assertEqual "posting gate: ordinary journal rejects NCI equity" + True + (case ECC.checkedEntry + [ (Debit, Cash, 10 :: MoneyDecimal) + , (Credit, NonControllingInterests, 10) + ] of + Left (ECC.PostingNotAllowed 1 NonControllingInterests + ConsolidationOnly ECC.OrdinaryJournal NE.:| []) -> True + _ -> False) + assertEqual "posting gate: engine admits period result" + True + (case ECC.checkedEntryIn ECC.EngineComputation + [ (Debit, NetIncome, 10 :: MoneyDecimal) + , (Credit, RetainedEarnings, 10) + ] of + Right _ -> True + Left _ -> False) + + assertEqual "posting gate: text path uses ordinary context" + True + (case ECC.checkedEntryText + [ (T.pack "debit", T.pack "NetIncome", 10 :: MoneyDecimal) + , (T.pack "credit", T.pack "RetainedEarnings", 10) + ] of + Left (ECC.PostingNotAllowed 0 NetIncome EngineGeneratedOnly + ECC.OrdinaryJournal NE.:| []) -> True + _ -> False) + assertEqual "posting gate: unknown account does not create false imbalance" + True + (case ECC.checkedEntryText + [ (T.pack "debit", T.pack "UnknownAccount_X", 10 :: MoneyDecimal) + , (T.pack "credit", T.pack "Cash", 10) + ] of + Left (ECC.EntryParse 0 _ NE.:| []) -> True + _ -> False) + assertEqual "posting gate: consolidation text path admits NCI loss" + True + (case ECC.checkedEntryTextIn ECC.ConsolidationWorksheet + [ (T.pack "debit", T.pack "NonControllingInterests", 10 :: MoneyDecimal) + , (T.pack "credit", T.pack "NetLossAttributableToNCI", 10) + ] of + Right _ -> True + Left _ -> False) + assertEqual "posting gate: journal error retains txid" + True + (case checkedJournalM + [ (7, + [ (Debit, IncomeSummary, 10) + , (Credit, RetainedEarnings, 10) + ]) + ] of + Left (ECC.EntryErrors 7 + (ECC.PostingNotAllowed 0 IncomeSummary ClosingOnly + ECC.OrdinaryJournal NE.:| []) NE.:| []) -> True + _ -> False) + assertEqual "posting gate: certification rejects known disallowed title" + True + (case ECC.certifyJournalText + [ (9 :: Int, + [ (T.pack "debit", T.pack "NetIncome", 10 :: MoneyDecimal) + , (T.pack "credit", T.pack "RetainedEarnings", 10) + ]) + ] of + ECC.Rejected + (ECC.EntryErrors 9 + (ECC.PostingNotAllowed 0 NetIncome EngineGeneratedOnly + ECC.OrdinaryJournal NE.:| []) NE.:| []) -> True + _ -> False) + assertEqual "posting gate: disallowed known title outranks unresolved title" + True + (case ECC.certifyJournalText + [ (11 :: Int, + [ (T.pack "debit", T.pack "NetIncome", 10 :: MoneyDecimal) + , (T.pack "credit", T.pack "UnknownAccount_X", 10) + ]) + ] of + ECC.Rejected + (ECC.EntryErrors 11 + (ECC.PostingNotAllowed 0 NetIncome EngineGeneratedOnly + ECC.OrdinaryJournal NE.:| []) NE.:| []) -> True + _ -> False) + assertEqual "posting gate: certification honours closing context" + True + (case ECC.certifyJournalTextIn ECC.ClosingProcess + [ (10 :: Int, + [ (T.pack "debit", T.pack "Sales", 10 :: MoneyDecimal) + , (T.pack "credit", T.pack "IncomeSummary", 10) + ]) + ] of + ECC.FullyResolved _ -> True + _ -> False) + assertEqual "posting gate: certification honours engine context" + True + (case ECC.certifyJournalTextIn ECC.EngineComputation + [ (12 :: Int, + [ (T.pack "debit", T.pack "NetLoss", 10 :: MoneyDecimal) + , (T.pack "credit", T.pack "RetainedEarnings", 10) + ]) + ] of + ECC.FullyResolved _ -> True + _ -> False) + where + accepted context title = + case ECC.checkedEntryIn context + [ (Debit, title, 1 :: MoneyDecimal) + , (Credit, Cash, 1) + ] of + Right _ -> True + Left _ -> False + +checkedConvertProperties :: IO () +checkedConvertProperties = do + testPostingPolicyTruthTable + testPostingCapabilityGate + testConsolidationWorksheet + testSharedAccountBalancePrimitives + testTrialBalanceValidation + testReportingPresentation + testDerivedMetricsLand5 + + quickProp "convert-checked: certify known accounts matches checkedJournal" $ + prop_certifyKnownAccountsMatchesCheckedJournal + + quickProp "convert-checked: unresolved vocabulary preserves balance" $ + prop_certifyUnknownAccountPreservesBalance + + quickProp "convert-checked: imbalance precedes unresolved vocabulary" $ + prop_certifyImbalancePrecedesUnknownAccount + + quickProp "convert-checked: certify duplicate txid always rejected" $ + prop_certifyDuplicateTxIdAlwaysRejected + + quickProp "convert-checked: balanced unresolved totals match input" $ + prop_certifyBalancedUnresolvedTotals + + quickProp "convert-checked: checkedEntry accepts iff checked predicate" $ + forAll genCheckedEntryRows $ \rows -> + let expected = checkedEntryAcceptsSpec rows + actual = case checkedEntryM rows of + Right _ -> True + Left _ -> False + in actual == expected + + quickProp "convert-checked: checkedEntry equals journalFromSides on accept" $ + forAll genCheckedEntryRows $ \rows -> + case checkedEntryM rows of + Right alg -> alg == (EC.journalFromSides rows :: CheckedAlgM) + Left _ -> True + + quickProp "convert-checked: accepted entries form exact-balanced submonoid" $ + forAll genAcceptedEntryRows $ \rows1 -> + forAll genAcceptedEntryRows $ \rows2 -> + case (checkedEntryM rows1, checkedEntryM rows2) of + (Right alg1, Right alg2) -> ECC.exactBalanced (alg1 .+ alg2) + _ -> False + + quickProp "convert-checked: checkedJournal duplicate txid only DuplicateTxId" $ + forAll genAcceptedEntryRows $ \rows1 -> + forAll genAcceptedEntryRows $ \rows2 -> + case checkedJournalM [(1, rows1), (1, rows2)] of + Left errs -> NE.toList errs == [ECC.DuplicateTxId 1] + Right _ -> False + + quickProp "convert-checked: reconcileSources coverage and amount checks" $ + forAll genPositiveAmountMD $ \amount -> + let entry amt = [(Debit, Cash, amt), (Credit, Sales, amt)] + shifted = amount + 1 + journalResult = checkedJournalM [(1, entry amount)] + unknownResult = checkedJournalM [(1, entry amount), (2, entry 5)] + in case (journalResult, unknownResult) of + (Right journal, Right journalWithUnknown) -> + ECC.reconcileSources [(1, amount)] journal == [] + && ECC.reconcileSources [(1, amount), (2, 5)] journal + == [ECC.MissingSource 2] + && ECC.reconcileSources [(1, amount)] journalWithUnknown + == [ECC.UnknownSource 2] + && ECC.reconcileSources [(1, shifted)] journal + == [ECC.AmountMismatch 1 shifted amount] + _ -> False + +axiomProperties :: IO () +axiomProperties = do + -- Definition 6 axioms (Double; semantic equality via exact per-base nets) + quickProp "axiom: Hat involution (x^^ = x)" $ + forAll genAlgD $ \x -> netByBase ((.^) ((.^) x)) == netByBase x + quickProp "axiom: scalar on singleton (a*(v:@b) = (a*v):@b)" $ + forAll genNNDouble $ \a -> forAll genNNDouble $ \v -> forAll genBase $ \b -> + netByBase (a .* (v .@ b)) == netByBase (((a * v) .@ b) :: TestAlg) + quickProp "axiom: scalar distributes over (.+)" $ + forAll genNNDouble $ \a -> forAll genAlgD $ \x -> forAll genAlgD $ \y -> + netByBase (a .* (x .+ y)) == netByBase ((a .* x) .+ (a .* y)) + quickProp "axiom: norm additivity (norm(x+y) = norm x + norm y)" $ + forAll genAlgD $ \x -> forAll genAlgD $ \y -> + epsEq (norm (x .+ y)) (norm x + norm y) + quickProp "axiom: norm homogeneity (norm(a*x) = a*norm x, a>=0)" $ + forAll genNNDouble $ \a -> forAll genAlgD $ \x -> + epsEq (norm (a .* x)) (a * norm x) + -- derived lemmas + quickProp "lemma: bar idempotent (bar(bar x) = bar x)" $ + forAll genAlgD $ \x -> netByBase (bar (bar x)) == netByBase (bar x) + quickProp "lemma: zero identity (x .+ Zero = x)" $ + forAll genAlgD $ \x -> netByBase (x .+ EA.Zero) == netByBase x + quickProp "lemma: (.+) associative" $ + forAll genAlgD $ \x -> forAll genAlgD $ \y -> forAll genAlgD $ \z -> + netByBase ((x .+ y) .+ z) == netByBase (x .+ (y .+ z)) + -- regression: union must not relabel a value onto a zero posting's base + -- (the 0.4.1.1 bug; raw (:@) so zero-valued singletons are exercised) + quickProp "regression: union preserves per-base net (zero-base bug)" $ + forAll genNNDouble $ \v1 -> forAll genBase $ \b1 -> + forAll genNNDouble $ \v2 -> forAll genBase $ \b2 -> + let s1 = v1 :@ b1 :: TestAlg + s2 = v2 :@ b2 :: TestAlg + in netByBase (s1 .+ s2) + == M.unionWith (+) (netByBase s1) (netByBase s2) + -- construction-order independence for the exact value type (MoneyDecimal) + quickProp "MoneyDecimal: fromList per-base net is construction-order independent" $ + forAll (listOf ((,) <$> (realToFrac <$> genNNDouble) <*> genBase)) $ \ps -> + let singles = [ v :@ b | (v, b) <- ps ] :: [NNAlg] + viaList = EA.fromList singles + viaFoldr = foldr (.+) EA.Zero singles + viaFoldl = L.foldl' (.+) EA.Zero singles + in netByBase viaList == netByBase viaFoldr + && netByBase viaFoldr == netByBase viaFoldl + -- mapBasePart (Phase 3): identity + norm preservation (no value lost on collision) + quickProp "mapBasePart id preserves per-base net (MoneyDecimal)" $ + forAll genAlgN $ \x -> netByBase (EA.mapBasePart id x :: NNAlg) == netByBase x + quickProp "mapBasePart preserves norm under base collapse (MoneyDecimal)" $ + forAll genAlgN $ \x -> norm (EA.mapBasePart (const Amount) x :: NNAlg) == norm x + -- S-4: functoriality of the base-relabel map pi_kappa (Prop 2.8(4)): + -- mapBasePart (kappa' . kappa) x ~=_pi mapBasePart kappa' (mapBasePart kappa x) + -- The two kappa are non-identity, non-injective relabelers on CountUnit so the + -- composite collapses bases (Yen -> Dollar -> Amount), exercising the value + -- merge on both sides. There is no dedicated ~=_pi comparator in this suite; + -- we use 'netByBase' (per-base signed net), which is the same bar/order-robust + -- observational equality the other mapBasePart / axiom properties use -- i.e. + -- "equal after bar, compared per base". The 'kappa' relabels the BasePart + -- (= CountUnit here), with mapBasePart re-merging colliding sides, so this is + -- exactly the bar-then-map equivalence the audit note specifies. + quickProp "S-4: mapBasePart is functorial (pi_{k'.k} ~=_pi pi_k' . pi_k, MoneyDecimal)" $ + forAll genAlgN $ \x -> + let kappa, kappa' :: CountUnit -> CountUnit + kappa u = if u == Yen then Dollar else u -- Yen -> Dollar + kappa' u = if u == Dollar then Amount else u -- Dollar -> Amount + lhs = EA.mapBasePart (kappa' . kappa) x :: NNAlg + inner = EA.mapBasePart kappa x :: NNAlg + rhs = EA.mapBasePart kappa' inner :: NNAlg + in netByBase lhs == netByBase rhs + -- netPairMapBy (ν_κ pair read-out): three properties from the + -- easp-2026-06-11-netpairmapby handoff. + -- (a) signed-diff consistency: balanceMapBy == n - h of the pair. + -- n - h can be negative, so this is checked on the SIGNED value type + -- (Double); a non-negative-only type would break the n-h component. + quickProp "netPairMapBy: balanceMapBy x == n - h of netPairMapBy x (Double, signed)" $ + forAll genAlgD $ \x -> + let bm = EA.balanceMapBy Just x :: M.Map CountUnit Double + np = EA.netPairMapBy Just x :: M.Map CountUnit (Double, Double) + diff = fmap (\(n, h) -> n - h) np + -- balanceMapBy keeps zero-net keys; netPairMapBy drops them. + -- Compare on the union: a key absent from one side reads as 0. + in all (\k -> epsEq (M.findWithDefault 0 k bm) + (M.findWithDefault 0 k diff)) + (M.keys bm ++ M.keys diff) + -- (b) both pair components are non-negative (value-domain regularity). + -- Exact value type so the >= 0 check has no tolerance ambiguity. + quickProp "netPairMapBy: both components non-negative (MoneyDecimal)" $ + forAll genAlgN $ \x -> + all (\(n, h) -> n >= 0 && h >= 0) + (M.elems (EA.netPairMapBy Just x :: M.Map CountUnit (MoneyDecimal, MoneyDecimal))) + -- (c) ~=_pi invariance: like the S-4 / netByBase observational equality, + -- the pair read-out is construction-order independent (bar-then-net is + -- robust to seq order and reassociation). Exact MoneyDecimal. + quickProp "netPairMapBy: ~=_pi invariant (construction-order independent, MoneyDecimal)" $ + forAll (listOf ((,) <$> (realToFrac <$> genNNDouble) <*> genBase)) $ \ps -> + let singles = [ v :@ b | (v, b) <- ps ] :: [NNAlg] + viaList = EA.netPairMapBy Just (EA.fromList singles) + viaFoldr = EA.netPairMapBy Just (foldr (.+) EA.Zero singles) + viaFoldl = EA.netPairMapBy Just (L.foldl' (.+) EA.Zero singles) + in viaList == (viaFoldr :: M.Map CountUnit (MoneyDecimal, MoneyDecimal)) + && viaFoldr == viaFoldl + +-- ================================================================ +-- Category-theory phase 1 laws and layer boundaries (P2c) +-- ================================================================ + +categoricalPhase1Properties :: IO () +categoricalPhase1Properties = do + quickProp "P2c mapBasePart: identity holds through per-base multisets" $ + forAll genAlgN $ \x -> observe (EA.mapBasePart id x) == observe x + quickProp "P2c mapBasePart: composition holds through per-base multisets" $ + forAll genAlgN $ \x -> + let f, g :: CountUnit -> CountUnit + f u = if u == Yen || u == Dollar then Yen else u + g u = if u == Yen || u == Amount then Amount else u + in observe (EA.mapBasePart (g . f) x :: NNAlg) + == observe (EA.mapBasePart g (EA.mapBasePart f x :: NNAlg) :: NNAlg) + quickProp "P2c mapBasePart: (.+) homomorphism holds through per-base multisets" $ + forAll genAlgN $ \x -> forAll genAlgN $ \y -> + let f u = if u == Yen || u == Dollar then Amount else u + in observe (EA.mapBasePart f (x .+ y) :: NNAlg) + == observe ((EA.mapBasePart f x .+ EA.mapBasePart f y) :: NNAlg) + quickProp "P2c mapBasePart: norm is preserved" $ + forAll genAlgN $ \x -> + norm (EA.mapBasePart (const Amount) x :: NNAlg) == norm x + quickProp "P2c mapBasePart: Hat commutes under raw Eq" $ + forAll genAlgN $ \x -> + EA.mapBasePart (const Amount) ((.^) x) + == ((.^) (EA.mapBasePart (const Amount) x) :: NNAlg) + -- bar keeps the Liner constructor even when cancellation leaves one key + -- with one value; mapBasePart rebuilds that map as a singleton. Eq treats + -- the two constructors as distinct, although ℘ observes the same entry. + let identitySource = (1 .@ (Not :< Yen)) + .+ (1 .@ (Hat :< Yen)) + .+ (2 .@ (Not :< Dollar)) :: NNAlg + oneKeyLiner = bar identitySource + identityMapped = EA.mapBasePart id oneKeyLiner :: NNAlg + assertEqual "P2c mapBasePart: identity counterexample has equal multisets" + (observe oneKeyLiner) (observe identityMapped) + assertEqual "P2c mapBasePart: identity fails under raw Eq for one-key Liner" + False (identityMapped == oneKeyLiner) + + let sandwichLeft = bar + (EA.mapBasePart (const Amount) oneKeyLiner :: NNAlg) + sandwichRight = bar + (EA.mapBasePart (const Amount) identitySource :: NNAlg) + assertEqual "P2c mapBasePart: bar sandwich counterexample has equal multisets" + (observe sandwichLeft) (observe sandwichRight) + assertEqual "P2c mapBasePart: bar sandwich can fail under raw Eq" + False (sandwichLeft == sandwichRight) + + -- Three distinct source keys are read back in whatever order the source + -- HashMap traverses them (a representation detail, so it is observed at + -- run time rather than pinned). The first and last keys collide under f + -- while the middle key survives as a separate intermediate key; g then + -- merges everything. The two-pass route keeps the collision block + -- contiguous, whereas the direct pass interleaves the middle key, so the + -- raw Seq orders differ while the per-base multisets agree. + let rawX = (10 .@ (Hat :< Yen)) + .+ (20 .@ (Hat :< Dollar)) + .+ (30 .@ (Hat :< Euro)) :: NNAlg + sourceTraversal = EA.foldEntries + (\acc _ (_ :< u) -> acc ++ [u]) [] rawX + (firstU, lastU) = case sourceTraversal of + [a, _, c] -> (a, c) + other -> error ("P2c: unexpected source traversal " ++ show other) + f u = if u == lastU then firstU else u + g _ = Amount + direct = EA.mapBasePart (g . f) rawX :: NNAlg + staged = EA.mapBasePart g (EA.mapBasePart f rawX :: NNAlg) :: NNAlg + assertEqual "P2c mapBasePart: composition counterexample traverses three source keys" + 3 (length sourceTraversal) + assertEqual "P2c mapBasePart: composition raw counterexample has equal multisets" + (observe direct) (observe staged) + assertEqual "P2c mapBasePart: composition fails under raw Eq after collision" + False (direct == staged) + + let barX = (100 .@ (Not :< Yen)) + .+ (100 .@ (Hat :< Dollar)) :: NNAlg + mappedAfterBar = EA.mapBasePart (const Amount) (bar barX) :: NNAlg + barAfterMapped = bar (EA.mapBasePart (const Amount) barX :: NNAlg) + assertEqual "P2c mapBasePart: does not commute with bar under collision" + False (mappedAfterBar == barAfterMapped) + assertEqual "P2c mapBasePart: map after bar retains both source residuals" + 200 (norm mappedAfterBar) + assertEqual "P2c mapBasePart: bar after map cancels collided residuals" + 0 (norm barAfterMapped) + + quickProp "P2c foldEntries: commutative sum is construction-order independent" $ + forAll (listOf ((,) <$> (realToFrac <$> genNNDouble) <*> genBase)) $ \ps -> + let singles = [ v .@ b | (v, b) <- ps ] :: [NNAlg] + pairwise = EA.fromList singles + bulk = EA.sigma ps (\(v, b) -> v .@ b :: NNAlg) + sumEntries = EA.foldEntries (\acc v _ -> acc + v) 0 + in sumEntries pairwise == sumEntries bulk + let entries = [1 .@ (Hat :< Yen), 2 .@ (Hat :< Yen), 3 .@ (Hat :< Yen)] + :: [NNAlg] + pairwise = EA.fromList entries + bulk = EA.sigma [1, 2, 3 :: Int] + (\i -> fromIntegral i .@ (Hat :< Yen) :: NNAlg) + collect = EA.foldEntries (\acc v _ -> acc ++ [v]) [] + assertEqual "P2c foldEntries: non-commutative list append observes Seq order" + False (collect pairwise == collect bulk) + + quickProp "P2c postFromNetBy: definition equation" $ + forAll genAlgN $ \x -> + let keyOf (_ :< u) = Just u + post u v = v .@ (Not :< u) :: NNAlg + collectEntry v b = (\k -> (k, v)) <$> keyOf b + rhs = EA.sigmaFromMap + (EA.foldEntriesToMap collectEntry (bar x)) post + in EA.postFromNetBy keyOf post x == rhs + quickProp "P2c postFromNetBy: factors through bar" $ + forAll genAlgN $ \x -> + let keyOf (_ :< u) = Just u + post u v = v .@ (Not :< u) :: NNAlg + in EA.postFromNetBy keyOf post x + == EA.postFromNetBy keyOf post (bar x) + quickProp "P2c bar: idempotence holds under raw Eq" $ + forAll genAlgN $ \x -> bar (bar x) == bar x + +-- ================================================================ +-- Journal-algebra axiom properties (Phase 1.5) +-- ================================================================ + +type NNJournal = EJ.Journal String MoneyDecimal (HatBase CountUnit) + +genNote :: Gen String +genNote = elements ["a", "b", "c"] + +genPosNN :: Gen MoneyDecimal -- strictly positive (avoids zero-note drop) +genPosNN = (\d -> realToFrac (1 + d)) <$> genNNDouble + +genJournalN :: Gen NNJournal +genJournalN = sized $ \n -> do + k <- choose (0, min 30 n) + ps <- vectorOf k ((,,) <$> genPosNN <*> genBase <*> genNote) + pure (EJ.fromList [ (v :@ b) .| nt | (v, b, nt) <- ps ]) + +-- per-(note, base) signed net; exact (Rational) +netJournal :: NNJournal -> M.Map (String, CountUnit) Rational +netJournal j = M.fromList + [ ((nt, u), r) + | (nt, alg) <- HM.toList (EJ.toMap j) + , (u, r) <- M.toList (netByBase alg) ] + +journalProperties :: IO () +journalProperties = do + quickProp "journal: norm additivity (norm(j1.+j2) = norm j1 + norm j2, MoneyDecimal)" $ + forAll genJournalN $ \j1 -> forAll genJournalN $ \j2 -> + norm (j1 .+ j2) == norm j1 + norm j2 + quickProp "journal: Hat preserves the note set" $ + forAll genJournalN $ \j -> + L.sort (HM.keys (EJ.toMap ((.^) j))) == L.sort (HM.keys (EJ.toMap j)) + quickProp "journal: fromList per-(note,base) net is construction-order independent (MoneyDecimal)" $ + forAll (listOf ((,,) <$> genPosNN <*> genBase <*> genNote)) $ \ps -> + let js = [ (v :@ b) .| nt | (v, b, nt) <- ps ] :: [NNJournal] + in netJournal (EJ.fromList js) == netJournal (foldr (.+) mempty js) + +-- ================================================================ +-- Quotient decomposition properties (Phase 1, feat/quotient-decomposition) +-- +-- Encodes the dec_κ / π_κ axioms of the scaling formalization +-- (agent-notes/drafts/scaling-formalization.md §2, §7) as QuickCheck +-- properties, plus fixed sentinels for the side-sensitive non-commutation +-- cases that MUST NOT silently start commuting (they encode a semantic +-- choice, not a bug). +-- ================================================================ + +-- proper classifier: factors through the base part (never sees Hat/Not) +properKf :: HatBase CountUnit -> Maybe CountUnit +properKf (_ :< u) = Just u + +-- partial proper classifier: Yen entries fall into the residual +partialKf :: HatBase CountUnit -> Maybe CountUnit +partialKf (_ :< Yen) = Nothing +partialKf (_ :< u) = Just u + +-- side-sensitive classifier: sees the Hat/Not state (like decP/decM) +sideKf :: HatBase CountUnit -> Maybe Bool +sideKf b = Just (isHat b) + +-- residual of a partial classifier (reference implementation via filter) +residualOf :: (HatBase CountUnit -> Maybe CountUnit) -> NNAlg -> NNAlg +residualOf kf = EA.filter (\s -> s /= EA.Zero && kf (EA._hatBase s) == Nothing) + +-- per-base nets with exact-zero entries dropped (bar drops zero-net bases, +-- so commutation properties are compared modulo zero nets) +nonZeroNet :: NNAlg -> M.Map CountUnit Rational +nonZeroNet = M.filter (/= 0) . netByBase + +quotientProperties :: IO () +quotientProperties = do + -- reconstruction: Σ_k x_k (+ residual) = x (formalization Prop 2.3) + quickProp "decBy: reconstruction, total classifier (MoneyDecimal)" $ + forAll genAlgN $ \x -> + netByBase (mconcat (M.elems (EA.decBy properKf x))) == netByBase x + quickProp "decBy: reconstruction with residual, partial classifier" $ + forAll genAlgN $ \x -> + netByBase (mconcat (M.elems (EA.decBy partialKf x)) .+ residualOf partialKf x) + == netByBase x + -- norm additivity over classes (formalization Prop 2.4(1)) + quickProp "decBy: norm additivity over classes + residual (MoneyDecimal)" $ + forAll genAlgN $ \x -> + norm x == L.foldl' (+) 0 (L.map norm (M.elems (EA.decBy partialKf x))) + + norm (residualOf partialKf x) + -- proper classifier commutes with bar componentwise (Prop 2.4(4)) + quickProp "decBy: bar commutes componentwise (proper classifier)" $ + forAll genAlgN $ \x -> + M.filter (not . M.null) (M.map nonZeroNet (EA.decBy properKf (bar x))) + == M.filter (not . M.null) (M.map (nonZeroNet . bar) (EA.decBy properKf x)) + -- decBy equals the naive per-class filter loop (semantics check) + quickProp "decBy: equals naive per-class filter (MoneyDecimal)" $ + forAll genAlgN $ \x -> + let d = EA.decBy properKf x + naive k = EA.filter + (\s -> s /= EA.Zero && properKf (EA._hatBase s) == Just k) x + in all (\(k, alg) -> netByBase alg == netByBase (naive k)) (M.toList d) + -- postFromNetBy equals an independent per-key projNetNorm pipeline + quickProp "postFromNetBy: equals per-key projNetNorm reference (MoneyDecimal)" $ + forAll genAlgN $ \x -> + let kf b = if isHat b then Just (unitOf b) else Nothing + unitOf (_ :< u) = u + post u v = v .@ (Not :< u) :: NNAlg + viaApi = EA.postFromNetBy kf post x + viaRef = mconcat + [ post u s + | u <- [Yen, Dollar, Amount] + , let s = EA.projNetNorm [Hat :< u] (bar x) + , s /= 0 ] + in netByBase viaApi == netByBase viaRef + -- decTo: flatten reconstructs and norm is preserved (total classifier) + quickProp "decTo: toAlg . decTo reconstructs (total classifier, MoneyDecimal)" $ + forAll genAlgN $ \x -> + let j = EJ.decTo (\(_ :< u) -> Just (show u)) x + :: EJ.Journal String MoneyDecimal (HatBase CountUnit) + in netByBase (EJ.toAlg j) == netByBase x && norm j == norm x + -- sentinel: side-sensitive classifier does NOT commute with bar + -- (decP/decM-style split; x = v:@Not:<Yen .+ v:@Hat:<Yen nets to zero + -- globally but each side survives within its own class) + let xCancel = (5 .@ (Not :< Yen)) .+ (5 .@ (Hat :< Yen)) :: NNAlg + lhs = M.filter (not . EA.isZero) (M.map bar (EA.decBy sideKf xCancel)) + rhs = EA.decBy sideKf (bar xCancel) + assertEqual "sentinel: side-sensitive decBy does not commute with bar" + True (M.keys lhs /= M.keys rhs) + -- sentinel: whichSide-style classifier is also side-sensitive + -- (Cash homeSide = Debit, so Hat flips it to Credit: the two sides of one + -- base land in different classes — Deguchi Def 2.13) + let xCash = (100 .@ (Not :< Cash)) .+ (100 .@ (Hat :< Cash)) + :: EA.Alg MoneyDecimal (HatBase AccountTitles) + bySide = EA.decBy (\b -> Just (whichSide b)) xCash + assertEqual "sentinel: whichSide splits one base across classes (side-sensitive)" + [Credit, Debit] (L.sort (M.keys bySide)) + assertEqual "sentinel: whichSide decBy does not commute with bar" + True (M.filter (not . EA.isZero) (M.map bar bySide) + /= EA.decBy (\b -> Just (whichSide b)) (bar xCash)) + -- sentinel: π_κ (mapBasePart, non-injective) does not commute with bar + -- (formalization §2.8: coarsen-then-net /= net-then-coarsen) + let xPi = (100 .@ (Not :< Yen)) .+ (100 .@ (Hat :< Dollar)) :: NNAlg + assertEqual "sentinel: bar (mapBasePart const) nets across the class" + 0 (norm (bar (EA.mapBasePart (const Amount) xPi :: NNAlg))) + assertEqual "sentinel: mapBasePart (bar x) keeps both sides (no cross-base netting)" + 200 (norm (EA.mapBasePart (const Amount) (bar xPi) :: NNAlg)) + +-- ================================================================ +-- Bookkeeping closing-adjustment builders (Phase B) +-- ================================================================ + +type BAlg = EA.Alg Double (HatBase AccountTitles) +type BAlgM = EA.Alg MoneyDecimal (HatBase AccountTitles) + +mkA :: EB.MkBase (HatBase AccountTitles) +mkA = (:<) + +-- balanced-ness: debit-side norm equals credit-side norm (貸借一致) +isBalancedD :: BAlg -> Bool +isBalancedD x = epsEq (norm (EA.decL x)) (norm (EA.decR x)) + +bookkeepingProperties :: IO () +bookkeepingProperties = do + -- (1) balanced property: every builder produces a debit=credit entry + quickProp "bookkeeping: cogsAdjustmentEntries balanced" $ + forAll genNNDouble $ \beg -> forAll genNNDouble $ \end -> + isBalancedD (EB.cogsAdjustmentEntries mkA beg end) + quickProp "bookkeeping: depreciationIndirectEntry balanced" $ + forAll genNNDouble $ \amt -> isBalancedD (EB.depreciationIndirectEntry mkA amt) + quickProp "bookkeeping: depreciationDirectEntry balanced" $ + forAll genNNDouble $ \amt -> isBalancedD (EB.depreciationDirectEntry mkA amt Fixtures) + quickProp "bookkeeping: allowanceReplenishmentEntry balanced" $ + forAll genNNDouble $ \est -> forAll genNNDouble $ \cur -> + isBalancedD (EB.allowanceReplenishmentEntry mkA est cur) + quickProp "bookkeeping: allowanceResetEntries balanced" $ + forAll genNNDouble $ \est -> forAll genNNDouble $ \cur -> + isBalancedD (EB.allowanceResetEntries mkA est cur) + quickProp "bookkeeping: prepaidExpenseEntry balanced" $ + forAll genNNDouble $ \amt -> isBalancedD (EB.prepaidExpenseEntry mkA amt RentExpense) + quickProp "bookkeeping: unearnedRevenueEntry balanced" $ + forAll genNNDouble $ \amt -> isBalancedD (EB.unearnedRevenueEntry mkA amt RentalIncome) + quickProp "bookkeeping: accruedRevenueEntry balanced" $ + forAll genNNDouble $ \amt -> isBalancedD (EB.accruedRevenueEntry mkA amt InterestEarned) + quickProp "bookkeeping: accruedExpenseEntry balanced" $ + forAll genNNDouble $ \amt -> isBalancedD (EB.accruedExpenseEntry mkA amt InterestExpense) + quickProp "bookkeeping: corporateTaxInterimEntry balanced" $ + forAll genNNDouble $ \amt -> isBalancedD (EB.corporateTaxInterimEntry mkA amt) + -- consumption / corporate tax settlement: amounts where received >= paid, + -- total >= interim (the in-scope branch) + quickProp "bookkeeping: consumptionTaxSettlementEntry balanced (received>=paid)" $ + forAll genNNDouble $ \paid -> forAll genNNDouble $ \extra -> + isBalancedD (EB.consumptionTaxSettlementEntry mkA paid (paid + extra)) + quickProp "bookkeeping: corporateTaxSettlementEntries balanced (total>=interim)" $ + forAll genNNDouble $ \interim -> forAll genNNDouble $ \extra -> + isBalancedD (EB.corporateTaxSettlementEntries mkA (interim + extra) interim) + quickProp "bookkeeping: priorPeriodErrorCorrection balanced" $ + forAll genNNDouble $ \curr -> forAll genNNDouble $ \prior -> + isBalancedD (EB.priorPeriodErrorCorrection mkA curr prior Depreciation Land) + + -- (2) unit tests: expected bases/amounts on representative lecture figures + -- COGS (ch.24): beg 100,000 / end 50,000. In isolation this entry's + -- Purchases net = beg - end = +50,000 (so the Purchases balance becomes COGS), + -- and MerchandiseInventory net = end - beg = -50,000 (it replaces the opening + -- balance with the closing one, i.e. 100,000 - 50,000 leaves on the ledger). + let cogs = EB.cogsAdjustmentEntries mkA 100000 50000 :: BAlg + assertNear "cogs: Purchases net = beg - end (= cost of goods sold)" + 50000 (signedNet Purchases cogs) + assertNear "cogs: MerchandiseInventory net = end - beg" + (-50000) (signedNet MerchandiseInventory cogs) + -- 差額補充法, estimate>current (ch.16): 1,400 - 1,000 -> provide 400 + let repl1 = EB.allowanceReplenishmentEntry mkA 1400 1000 :: BAlg + assertNear "allowance(差額補充, shortfall): ProvisionForDoubtfulAccounts = 400" + 400 (norm (EA.projByAccountTitle ProvisionForDoubtfulAccounts repl1)) + assertNear "allowance(差額補充, shortfall): AllowanceForDoubtfulAccounts = 400" + 400 (norm (EA.projByAccountTitle AllowanceForDoubtfulAccounts repl1)) + -- 差額補充法, estimate<current (ch.16): 1,800 - 2,000 -> release 200 + let repl2 = EB.allowanceReplenishmentEntry mkA 1800 2000 :: BAlg + assertNear "allowance(差額補充, excess): ReversalOfAllowanceForDoubtfulAccounts = 200" + 200 (norm (EA.projByAccountTitle ReversalOfAllowanceForDoubtfulAccounts repl2)) + -- estimate==current -> no entry + assertEqual "allowance(差額補充, equal): Zero" + True (EA.isZero (EB.allowanceReplenishmentEntry mkA 1500 1500 :: BAlg)) + -- consumption tax (ch.23): paid 1,000 / received 20,000 -> unpaid 19,000 + let ctax = EB.consumptionTaxSettlementEntry mkA 1000 20000 :: BAlg + assertNear "consumptionTax: AccruedConsumptionTax = received - paid = 19000" + 19000 (norm (EA.projByAccountTitle AccruedConsumptionTax ctax)) + -- corporate tax (ch.23): total 800,000 / interim 500,000 -> unpaid 300,000 + let crp = EB.corporateTaxSettlementEntries mkA 800000 500000 :: BAlg + assertNear "corporateTax: AccruedCorporateIncomeTaxes = total - interim = 300000" + 300000 (norm (EA.projByAccountTitle AccruedCorporateIncomeTaxes crp)) + -- prior-period error correction (#15 anchor): patent 55,000/10yr discovered 2028 + -- current 5,500 / prior 2yr 11,000 -> debit=credit=16,500 (Patent credit) + let ppec = EB.priorPeriodErrorCorrection mkA 5500 11000 AmortizationExpense Patent :: BAlg + assertNear "priorPeriodErrorCorrection (#15): Patent credit = 16500" + 16500 (norm (EA.projByAccountTitle Patent ppec)) + assertNear "priorPeriodErrorCorrection (#15): balanced (decL == decR)" + (norm (EA.decL ppec)) (norm (EA.decR ppec)) + -- consumption-tax refund (received<paid) is rejected (out of 3-級 scope) + rRefund <- try (evaluate (norm (EB.consumptionTaxSettlementEntry mkA 5000 1000 :: BAlg))) + :: IO (Either SomeException Double) + case rRefund of + Left _ -> putStrLn "[PASS] consumptionTaxSettlementEntry rejects received<paid" + Right _ -> do putStrLn "[FAIL] consumptionTaxSettlementEntry accepted refund"; exitFailure + + -- (3) reversingEntry: involution + exact cancellation (MoneyDecimal exact) + quickProp "bookkeeping: reversingEntry is involution (MoneyDecimal)" $ + forAll genBAlgM $ \x -> EB.reversingEntry (EB.reversingEntry x) == x + quickProp "bookkeeping: bar (x .+ reversingEntry x) == Zero (MoneyDecimal)" $ + forAll genBAlgM $ \x -> bar (x .+ EB.reversingEntry x) == EA.Zero + where + -- exact per-account signed net (Not +, Hat -) for Double-based unit checks + signedNet :: AccountTitles -> BAlg -> Double + signedNet t = EA.foldEntries step 0 + where step acc v b + | getAccountTitle b == t = if isHat b then acc - v else acc + v + | otherwise = acc + +-- small exact MoneyDecimal algebra over AccountTitles bases (closing-adjustment +-- shaped: a few postings on bookkeeping titles), for the reversal properties. +genBAlgM :: Gen BAlgM +genBAlgM = sized $ \n -> do + k <- choose (0, min 8 n) + ps <- vectorOf k ((,) <$> genSmallMoney <*> genBookBase) + pure (EA.fromList [ v .@ b | (v, b) <- ps ]) + where + genSmallMoney :: Gen MoneyDecimal + genSmallMoney = fromInteger <$> choose (1, 9999) + genBookBase :: Gen (HatBase AccountTitles) + genBookBase = (:<) <$> elements [Hat, Not] + <*> elements [ Purchases, MerchandiseInventory, Depreciation + , AccumulatedDepreciation, PrepaidExpenses + , AccruedExpenses, AccruedConsumptionTax + , Cash, InterestExpense ] + +-- ================================================================ +-- Closing-document Write functions (Phase D): worksheet, +-- post-closing trial balance, account ledger +-- ================================================================ + +closingDocsTests :: IO () +closingDocsTests = do + -- A small balanced pre-adjustment ledger (ebex1-shaped): + -- opening capital 2,000,000; a cash sale of 500,000; + -- wages (cost) 140,000 paid in cash. + -- Pre-adjustment trial balance balances by construction. + let pre = (2000000 .@ (Not :< Cash)) -- 現金 (asset, debit) + .+ (2000000 .@ (Not :< CapitalStock)) -- 資本金 (equity, credit) + .+ (500000 .@ (Not :< Cash)) -- cash from sale (debit) + .+ (500000 .@ (Not :< Sales)) -- 売上 (revenue, credit) + .+ (140000 .@ (Hat :< Cash)) -- cash paid out (credit) + .+ (140000 .@ (Not :< WageExpenditure)) -- 給料 (cost, debit) + :: BAlg + -- one adjustment: accrue 10,000 of unpaid wages (費用の見越し) + let adj = (10000 .@ (Not :< WageExpenditure)) -- cost debit + .+ (10000 .@ (Not :< AccruedExpenses)) -- liability credit + :: BAlg + let combined = pre .+ adj + + -- (1) Worksheet self-check: the P/L column imbalance must equal the + -- B/S column imbalance, and both equal the net income. + -- Each account's *net* balance (diffRL) is routed by division: + -- P/L: Sales net 500,000 (credit) vs WageExpenditure net 150,000 + -- (debit) => net income 350,000. + -- B/S: Cash net 2,360,000 (debit) vs CapitalStock 2,000,000 + + -- AccruedExpenses 10,000 (credit) = 2,010,000 => 350,000. + -- We compute the column sums the same way worksheetRows does: per + -- account title, place the *net* balance into the debit or credit + -- column according to its balance side. + let titles = L.nub (EA.foldEntries (\acc _ b -> getAccountTitle b : acc) [] combined) :: [AccountTitles] + netSide t = EA.diffRL (EA.projByAccountTitle t combined) :: (Side, Double) + colSums divs = + L.foldl' (\(d,c) t -> + if classifyAccountDivision t `elem` divs + then case netSide t of + (Debit, m) -> (d + m, c) + (Credit, m) -> (d, c + m) + _ -> (d, c) + else (d, c)) (0,0) titles + (plD, plC) = colSums [Cost, Revenue] + (bsD, bsC) = colSums [Assets, Liability, Equity] + plDiff = abs (plD - plC) + bsDiff = abs (bsD - bsC) + assertNear "worksheet self-check: P/L diff = 350000" 350000 plDiff + assertNear "worksheet self-check: B/S diff = 350000" 350000 bsDiff + assertNear "worksheet self-check: P/L diff == B/S diff (= net income)" plDiff bsDiff + + -- the rendered worksheet's net-income row must carry the same figure on + -- the P/L debit and B/S credit columns (positions 6 and 9, 1-based). + let wrows = EW.worksheetRows pre adj + netRow' = last (init wrows) -- penultimate-from-end: the Net row + assertEqual "worksheet: net row label is Net Income" + (T.pack "Net Income") (head netRow') + assertEqual "worksheet: net income on P/L debit column = 350000.0" + (T.pack "350000.0") (netRow' !! 5) + assertEqual "worksheet: net income on B/S credit column = 350000.0" + (T.pack "350000.0") (netRow' !! 8) + + -- (2) Post-closing trial balance must contain only real accounts + -- (Assets/Liability/Equity) — no Cost/Revenue titles. + let pcrows = EW.postClosingTrialBalanceRows combined + titleCells = [ row !! 1 | row <- drop 1 pcrows ] -- middle column = title + forbidden = L.map (T.pack . show) [Sales, WageExpenditure] + assertEqual "post-closing TB excludes Cost/Revenue titles" + True (not (any (`elem` forbidden) titleCells)) + assertEqual "post-closing TB includes Cash" + True (T.pack (show Cash) `elem` titleCells) + assertEqual "post-closing TB includes AccruedExpenses (liability)" + True (T.pack (show AccruedExpenses) `elem` titleCells) + + -- (3) Account ledger preserves the seq: the number of posting lines for a + -- title equals the number of postings on that title (no aggregation). + -- Cash has 3 postings (2 debit, 1 credit) in `pre`. + let lrows = EW.accountLedgerRows [Cash] pre (const dummyDay) + -- drop the 2 header rows (title + sub-header); the rest are postings. + bodyLines = drop 2 lrows + cashPostings = EA.foldEntries (\acc _ b -> if getAccountTitle b == Cash then acc + 1 else acc) (0 :: Int) pre + -- each body row holds at most one debit + one credit cell; count + -- non-empty value cells (debit col=1, credit col=3). + nonEmptyVals = Prelude.length + [ () | row <- bodyLines, c <- [1,3], not (T.null (row !! c)) ] + assertEqual "account ledger: Cash posting count preserved (= 3, no aggregation)" + cashPostings nonEmptyVals + where + dummyDay :: Day + dummyDay = fromGregorian 2024 4 1 + +-- ================================================================ +-- Simulate.Lite tests (Phase 2, feat/simulate-lite) +-- ================================================================ + +-- A concrete Note type for the Lite models: (event tag, term index). +type LNote = (String, Int) +type LBaseD = HatBase AccountTitles +type LedgerD = Journal LNote MoneyDouble LBaseD -- IEEE-754 path (DET-1, BSP, equiv) +type LBaseM = HatBase AccountTitles +type LedgerM = Journal LNote MoneyDecimal LBaseM -- exact path (DET-2) + +------------------------------------------------------------------ +-- Lite test 1: boilerplate acceptance example (3 fields, 2 stages). +-- The body of this function (the World record, the two stages, the spec and +-- the run) is the "~20 line" boilerplate the design targets. +------------------------------------------------------------------ + +-- A product-only HKD world: a ledger, a scalar price, a scalar tax rate. +data MiniW f = MiniW + { mwLedger :: HK f LedgerD + , mwPrice :: HK f MoneyDouble + , mwTax :: HK f Double + } deriving Generic + +-- stage A: each agent buys 1 unit at the snapshot price (a pure message). +buyStage :: Stage MiniW Int LNote MoneyDouble LBaseD +buyStage = stageFor "buy" [1 .. 5 :: Int] $ \w t _g i -> + let amt = mwPrice w * fromIntegral i + in ((amt .@ Not :< Purchases) .+ (amt .@ Hat :< Cash)) .| ("buy", t) + +-- stage B: a single bookkeeping step paying tax on the snapshot price. +taxStage :: Stage MiniW Int LNote MoneyDouble LBaseD +taxStage = stage "tax" $ \w t -> + let amt = mwPrice w * realToFrac (mwTax w) + in ((amt .@ Not :< Sales) .+ (amt .@ Hat :< Cash)) .| ("tax", t) + +miniSpec :: SimSpec MiniW Int LNote MoneyDouble LBaseD +miniSpec = mkSimSpec (1, 3) 42 mwLedger [buyStage, taxStage] + +testLiteBoilerplate :: IO () +testLiteBoilerplate = do + let w0 = MiniW { mwLedger = carry mempty + , mwPrice = carry 10 + , mwTax = carry 0.1 } + n = runLite miniSpec w0 (realToFrac . norm . mwLedger) + -- 3 terms * (sum_{i=1..5} 10*i*2 + 10*0.1*2) = 3 * (300 + 2) = 906 + assertNear "Lite: boilerplate mini-model runs (norm)" 906.0 n + +------------------------------------------------------------------ +-- Lite test 2 (DET-2): MoneyDecimal Sequential vs ParChunk exact match. +------------------------------------------------------------------ + +data DecW f = DecW + { dwLedger :: HK f LedgerM + } deriving Generic + +decStage :: Stage DecW Int LNote MoneyDecimal LBaseM +decStage = stageFor "post" [1 .. 50 :: Int] $ \_w t g i -> + let (k, _) = randomR (1, 9 :: Int) g + amt = fromIntegral (i + k) :: MoneyDecimal + in ((amt .@ Not :< Purchases) .+ (amt .@ Hat :< Cash)) .| ("post", t) + +decSpec :: Par -> SimSpec DecW Int LNote MoneyDecimal LBaseM +decSpec par = (mkSimSpec (1, 4) 7 dwLedger [decStage]) { Lite.specParallel = par } + +testLiteDet2 :: IO () +testLiteDet2 = do + let w0 = DecW { dwLedger = carry mempty } + runP par = runLite (decSpec par) w0 (toMap . dwLedger) + seqMap = runP Sequential + parMap = runP (ParChunk 8) + assertEqual "Lite DET-2: Sequential and ParChunk produce identical ledgers (exact)" + seqMap parMap + +------------------------------------------------------------------ +-- Lite test 3 (DET-1): MoneyDouble reproducibility across two runs. +------------------------------------------------------------------ + +testLiteDet1 :: IO () +testLiteDet1 = do + let w0 = MiniW { mwLedger = carry mempty + , mwPrice = carry 10 + , mwTax = carry 0.1 } + n1 = runLite miniSpec w0 (realToFrac . norm . mwLedger) + n2 = runLite miniSpec w0 (realToFrac . norm . mwLedger) + assertNear "Lite DET-1: same spec run twice gives same norm" n1 n2 + +------------------------------------------------------------------ +-- Lite test 4 (BSP intra-stage invisibility sentinel). +-- Every agent in a stage reads the SAME snapshot. We encode the snapshot +-- ledger's norm into each agent's message; if a later agent could see an +-- earlier agent's write within the same stage, the encoded norms would differ +-- from the all-zero baseline (the ledger starts empty for term 1 stage 0). +------------------------------------------------------------------ + +data BspW f = BspW + { bwLedger :: HK f LedgerD + } deriving Generic + +-- each agent posts (1 + norm-of-snapshot-ledger). On term 1, stage 0, the +-- snapshot ledger is empty for every agent, so each posts exactly 1.0. +bspStage :: Stage BspW Int LNote MoneyDouble LBaseD +bspStage = stageFor "bsp" [1 .. 10 :: Int] $ \w t _g _i -> + let seenNorm = norm (bwLedger w) -- must be 0 for ALL agents (BSP) + amt = 1 + realToFrac seenNorm :: MoneyDouble + in ((amt .@ Not :< Purchases) .+ (amt .@ Hat :< Cash)) .| ("bsp", t) + +bspSpec :: SimSpec BspW Int LNote MoneyDouble LBaseD +bspSpec = mkSimSpec (1, 1) 0 bwLedger [bspStage] + +testLiteBspInvisibility :: IO () +testLiteBspInvisibility = do + let w0 = BspW { bwLedger = carry mempty } + n = runLite bspSpec w0 (realToFrac . norm . bwLedger) + -- 10 agents each post Not:<Purchases 1.0 + Hat:<Cash 1.0 = norm 20. + -- If intra-stage writes were visible, later agents would post > 1.0 and the + -- norm would exceed 20. + assertNear "Lite BSP: intra-stage invisibility (all agents see empty ledger)" + 20.0 n + +------------------------------------------------------------------ +-- Lite test 5: gate toy-model equivalence (3 terms, agents [1..10], norm 3300). +-- Rebuilds the gate-report.md prototype with the Lite API; same norm. +------------------------------------------------------------------ + +data GateW f = GateW + { gwLedger :: HK f LedgerD + , gwPrice :: HK f MoneyDouble + } deriving Generic + +gateStage :: Stage GateW Int LNote MoneyDouble LBaseD +gateStage = stageFor "buy" [1 .. 10 :: Int] $ \w t _g i -> + let amt = gwPrice w * fromIntegral i + in ((amt .@ Not :< Purchases) .+ (amt .@ Hat :< Cash)) .| ("buy", t) + +gateSpec :: SimSpec GateW Int LNote MoneyDouble LBaseD +gateSpec = mkSimSpec (1, 3) 1 gwLedger [gateStage] + +testLiteGateEquivalence :: IO () +testLiteGateEquivalence = do + let w0 = GateW { gwLedger = carry mempty, gwPrice = carry 10 } + n = runLite gateSpec w0 (realToFrac . norm . gwLedger) + -- norm = 3 terms * sum_{i=1..10} (10*i*2) = 3 * 2 * 10 * 55 = 3300 + assertNear "Lite: gate toy-model equivalence (norm 3300)" 3300.0 n + +------------------------------------------------------------------ +-- Lite test 6: term-boundary Field rules (Carry / ResetEach / UpdateEach). +-- One agent posts (current price) each term; the three runs differ only in the +-- price field's boundary rule, exercising each Field constructor. +------------------------------------------------------------------ + +data RuleW f = RuleW + { rwLedger :: HK f LedgerD + , rwPrice :: HK f MoneyDouble + } deriving Generic + +ruleStage :: Stage RuleW Int LNote MoneyDouble LBaseD +ruleStage = stage "post" $ \w t -> + let amt = rwPrice w + in ((amt .@ Not :< Purchases) .+ (amt .@ Hat :< Cash)) .| ("post", t) + +ruleSpec :: SimSpec RuleW Int LNote MoneyDouble LBaseD +ruleSpec = mkSimSpec (1, 3) 0 rwLedger [ruleStage] + +runRule :: Field MoneyDouble -> Double +runRule priceField = + let w0 = RuleW { rwLedger = carry mempty, rwPrice = priceField } + in realToFrac (runLite ruleSpec w0 (norm . rwLedger)) + -- norm counts both Not:<Purchases and Hat:<Cash, hence 2 * price each term + +testLiteFieldRules :: IO () +testLiteFieldRules = do + -- Carry 10: price stays 10 every term -> 3 * 2 * 10 = 60 + assertNear "Lite Field: Carry keeps the value" 60.0 (runRule (carry 10)) + -- ResetEach 5: price reset to 5 at each boundary, but stage reads BEFORE + -- the term-1 boundary commit at the same value -> 3 * 2 * 5 = 30 + assertNear "Lite Field: ResetEach restores each term" 30.0 (runRule (resetEach 5)) + -- UpdateEach 10 (*2): term1 price 10, boundary doubles -> term2 20, term3 40. + -- norm = 2 * (10 + 20 + 40) = 140 + assertNear "Lite Field: UpdateEach applies the step each boundary" + 140.0 (runRule (updateEach 10 (* 2))) + +-- regression: the boundary rule must fire once per TERM, not per stage. +-- (Parser pitfall: a trailing backtick operator after an inner lambda's +-- do-block is swallowed into the lambda body, turning the term-boundary +-- commit into a per-stage commit. Single-stage tests cannot see this.) +-- 2 identical stages x UpdateEach 10 (*2): both stages must read the SAME +-- price within a term -> norm = 2 entries * 2 stages * (10+20+40) = 280. +-- The per-stage-commit bug yields 2 * (10+20 + 40+80 + 160+320) = 1260. +testLiteBoundaryOncePerTerm :: IO () +testLiteBoundaryOncePerTerm = + assertNear "Lite: term boundary fires once per term (2 stages)" 280.0 + (let spec2 = mkSimSpec (1, 3) 0 rwLedger [ruleStage, ruleStage] + w0 = RuleW { rwLedger = carry mempty, rwPrice = updateEach 10 (* 2) } + in realToFrac (runLite spec2 w0 (norm . rwLedger))) + +-- ================================================================ +-- Simulate.Policy tests (Phase 4, feat/ledger-policy) +-- +-- LedgerPolicy = declarative retention / spill / compaction, applied at the +-- term boundary by runLiteWithPolicy. The exact MoneyDecimal value type lets us +-- assert lossless round-trips and norm/compaction invariants by strict equality. +-- ================================================================ + +-- A one-field world whose stage posts a few distinct bases per term, so that a +-- closed term has redundant per-base sequences (exercising CompressClosedTerms) +-- and a multi-term history (exercising RetainRecent + spill). +data PolW f = PolW + { pwLedger :: HK f LedgerM + } deriving Generic + +-- A single-field world for the classic-bridge test: a constructor @a@ of kind +-- @Type -> Type@ whose @a RealWorld@ is an @STRef RealWorld LedgerM@ (so it fits +-- the @SpillOptions t a payload@ shape, where @a@ is applied to the state token). +newtype LedgerRef s = LedgerRef (STRef s LedgerM) + +-- Each agent posts twice to the SAME base within the term, so the term's per-base +-- posting sequence has length 2 before compress and length 1 after. +polStage :: Stage PolW Int LNote MoneyDecimal LBaseM +polStage = stageFor "post" [1 .. 4 :: Int] $ \_w t _g i -> + let amt = fromIntegral i :: MoneyDecimal + one = 1 :: MoneyDecimal + m1 = ((amt .@ Not :< Purchases) .+ (amt .@ Hat :< Cash)) .| ("post", t) + m2 = ((one .@ Not :< Purchases) .+ (one .@ Hat :< Cash)) .| ("post", t) + in m1 .+ m2 :: Journal LNote MoneyDecimal LBaseM + +polSpec :: SimSpec PolW Int LNote MoneyDecimal LBaseM +polSpec = mkSimSpec (1, 5) 0 pwLedger [polStage] + +polW0 :: PolW InitT +polW0 = PolW { pwLedger = carry mempty } + +-- run a temp spill file, returning (result, path); caller removes the file. +withTempSpill :: String -> (FilePath -> IO a) -> IO a +withTempSpill tag act = do + let path = "/tmp/exchangealgebra_policy_" ++ tag ++ ".bin" + -- ensure no stale file from a previous run (append-mode would accumulate) + _ <- try (removeFile path) :: IO (Either SomeException ()) + r <- act path + _ <- try (removeFile path) :: IO (Either SomeException ()) + pure r + +-- Test 1 (flagship): defaultLedgerPolicy is observationally equal to runLite. +testPolicyEquivalence :: IO () +testPolicyEquivalence = do + let pureLedger = runLite polSpec polW0 (toMap . pwLedger) + polLedger <- runLiteWithPolicy Policy.defaultLedgerPolicy polSpec polW0 (toMap . pwLedger) + assertEqual "Policy: runLiteWithPolicy defaultLedgerPolicy == runLite (exact)" + pureLedger polLedger + +-- Test 2 (flagship): RetainRecent w + spillTo gives an in-memory window AND a +-- lossless restore that equals the FullAudit ledger. +testPolicyWindowRoundTrip :: IO () +testPolicyWindowRoundTrip = withTempSpill "window" $ \path -> do + let full = runLite polSpec polW0 (toMap . pwLedger) -- FullAudit reference + pol = Policy.defaultLedgerPolicy + { Policy.retain = Policy.RetainRecent 2 + , Policy.spillTo = Just path } + -- ONE policy run (append-mode spill: a second run would double the file), + -- projecting the live journal; we derive both checks from it. + residentJournal <- runLiteWithPolicy pol polSpec polW0 pwLedger + -- (a) in-memory ledger after the run contains ONLY the most recent 2 terms. + let residentMap = toMap residentJournal + residentTerms = L.sort (L.nub [ t | (_, t) <- HM.keys residentMap ]) + assertEqual "Policy: RetainRecent 2 leaves only the most recent 2 terms resident" + [4, 5] residentTerms + -- (b) restoreLedger (spill file + resident remainder) == FullAudit ledger. + restored <- Policy.restoreLedger path residentJournal :: IO LedgerM + assertEqual "Policy: restoreLedger (spill + remainder) == FullAudit ledger (lossless, exact)" + full (toMap restored) + +-- Test 3: CompressClosedTerms — norm/balance invariant, closed-term seq length 1, +-- in-progress term keeps full redundancy. +testPolicyCompressClosed :: IO () +testPolicyCompressClosed = do + let full = runLite polSpec polW0 (toMap . pwLedger) + compactedJ <- runLiteWithPolicy + (Policy.defaultLedgerPolicy { Policy.compaction = Policy.CompressClosedTerms }) + polSpec polW0 pwLedger + let fullJ = runLite polSpec polW0 pwLedger + -- (a) norm is invariant under compaction. + assertEqual "Policy: CompressClosedTerms preserves norm (exact)" + (norm fullJ) (norm compactedJ) + -- (b) balance result unchanged (still balanced overall). + assertEqual "Policy: CompressClosedTerms preserves balance" + (EA.balance fullJ) (EA.balance compactedJ) + -- (c) each CLOSED term (1..4) has at most one posting per base/side: its Alg + -- compresses to itself (idempotent), so compress . entry == entry. + let compactedMap = toMap compactedJ + closedOk = all + (\((_, t), alg) -> t == (5 :: Int) || EA.compress alg == alg) + (HM.toList compactedMap) + assertEqual "Policy: closed terms are already compressed (compress is a no-op on them)" + True closedOk + -- (d) the in-progress term (5) keeps its redundancy: in the FULL ledger term + -- 5's entry has a length-2 sequence, and the compacted ledger keeps the + -- SAME term-5 entry (untouched), i.e. it differs from its own compress. + let term5Full = HM.lookup ("post", 5) (toMap fullJ) + term5Comp = HM.lookup ("post", 5) compactedMap + assertEqual "Policy: in-progress term is untouched by CompressClosedTerms" + term5Full term5Comp + case term5Comp of + Just alg -> assertEqual "Policy: in-progress term retains its redundant sequence" + False (EA.compress alg == alg) + Nothing -> assertEqual "Policy: in-progress term present" True False + +-- Test 4: deletion-only (spillTo Nothing + RetainRecent) narrows the ledger to +-- the window and reduces its norm by exactly the discarded terms' norm. +testPolicyDeleteOnly :: IO () +testPolicyDeleteOnly = do + let pol = Policy.defaultLedgerPolicy { Policy.retain = Policy.RetainRecent 2 } + residentJournal <- runLiteWithPolicy pol polSpec polW0 pwLedger + let residentMap = toMap residentJournal + residentTerms = L.sort (L.nub [ t | (_, t) <- HM.keys residentMap ]) + -- the FullAudit ledger restricted to the same window must match exactly + -- (deletion is just a filter; the kept terms are untouched). + full = runLite polSpec polW0 pwLedger + windowOfFull = EJ.filterWithNote (\(_, t) _ -> t >= 4) full + assertEqual "Policy: delete-only leaves only the window terms" [4, 5] residentTerms + assertEqual "Policy: delete-only window equals FullAudit restricted to the window (exact)" + (toMap windowOfFull) residentMap + -- norm strictly drops (terms 1..3 were discarded with no spill). + assertEqual "Policy: discarding older terms strictly reduces norm" + True (norm residentJournal < norm full) + +-- Test 5: DET — policy runs are reproducible and Sequential == ParChunk (exact). +testPolicyDeterminism :: IO () +testPolicyDeterminism = withTempSpill "det" $ \_ -> do + let pol = Policy.defaultLedgerPolicy { Policy.retain = Policy.RetainRecent 3 } + specPar p = polSpec { Lite.specParallel = p } + r1 <- runLiteWithPolicy pol (specPar Sequential) polW0 (toMap . pwLedger) + r2 <- runLiteWithPolicy pol (specPar Sequential) polW0 (toMap . pwLedger) + rP <- runLiteWithPolicy pol (specPar (ParChunk 2)) polW0 (toMap . pwLedger) + assertEqual "Policy DET-1: same policy run twice is identical" r1 r2 + assertEqual "Policy DET-2: Sequential == ParChunk under policy (exact)" r1 rP + +-- Test 6 (classic bridge): policySpillOptions drives the classic engine and the +-- result restores losslessly, mirroring the existing binary-spill restore test. +-- We exercise the derived chunk extraction + eviction directly (no full +-- StateSpace needed) by checking the option fields it builds. +testPolicyClassicBridge :: IO () +testPolicyClassicBridge = withTempSpill "bridge" $ \path -> do + -- Build a ledger spanning terms 1..3, spill terms 1..2 via the policy-derived + -- chunk extractor, keep term 3 as the remainder, then restore == whole ledger. + let pol = Policy.defaultLedgerPolicy + { Policy.retain = Policy.RetainRecent 1, Policy.spillTo = Just path } + whole :: LedgerM + whole = EJ.fromList + [ (1 .@ Not :< Purchases) .| ("post", 1) + , (2 .@ Not :< Purchases) .| ("post", 2) + , (3 .@ Not :< Purchases) .| ("post", 3) ] + -- the option built by the bridge; we use its spillExtractChunk to carve + -- terms 1..2 and write them, exactly as runSimulationWithSpill would. + opts = Policy.policySpillOptions pol 2 + (\(LedgerRef r) -> readSTRef r) + (\f (LedgerRef r) -> modifySTRef' r f) + :: ES.SpillOptions Int LedgerRef LedgerM + -- emulate a single spill of the [1,2] chunk + eviction of term <= 2. + ref <- LedgerRef <$> stToIO (newSTRef whole) + chunk <- case ES.spillExtractChunk opts of + Just extract -> stToIO (extract (1, 2) ref) + Nothing -> error "policySpillOptions must set spillExtractChunk" + withFile path WriteMode $ \h -> ES.spillWriteChunk opts h (1, 2) chunk + stToIO (ES.spillDeleteRange opts (1, 2) ref) + let LedgerRef r0 = ref + remainder <- stToIO (readSTRef r0) + -- remainder is now only term 3; restore merges spill + remainder == whole. + restored <- Policy.restoreLedger path remainder :: IO LedgerM + assertEqual "Policy bridge: policySpillOptions chunk keeps spilled-range terms" + (toMap (EJ.filterWithNote (\(_, t) _ -> t >= 1 && t <= 2) whole)) (toMap chunk) + assertEqual "Policy bridge: after eviction the remainder is only the kept window" + (toMap (EJ.filterWithNote (\(_, t) _ -> t > 2) whole)) (toMap remainder) + assertEqual "Policy bridge: restore (spill + remainder) == whole ledger (lossless)" + (toMap whole) (toMap restored) + +-- Test 7 (HasTermAxis): termOf returns the LAST Note component for pair/triple. +testPolicyHasTermAxis :: IO () +testPolicyHasTermAxis = do + assertEqual "Policy HasTermAxis: pair termOf = snd" (7 :: Int) (Policy.termOf ("e", 7 :: Int)) + assertEqual "Policy HasTermAxis: triple termOf = 3rd" (9 :: Int) + (Policy.termOf ("e1", "e2", 9 :: Int)) + +-- ================================================================ +-- Simulate.Network tests (Phase 3, feat/trade-network) +-- +-- Property + unit tests for the TradeNetwork / InputCoefficients separation, +-- the deterministic generators, the smart-constructor invariants, and the +-- edge-summation sigmaEdges. All read-outs are Ord-ascending (no hash order). +-- ================================================================ + +type NetJD = Journal (Int, Int) MoneyDecimal (HatBase CountUnit) + +-- a tiny per-edge journal builder used by the sigmaEdges equivalence test +edgeJ :: Int -> Int -> NetJD +edgeJ i j = ((fromIntegral (i + 2 * j) :: MoneyDecimal) .@ Not :< Amount) .| (i, j) + +-- Test 1: completeNetwork makes sigmaEdges coincide with the all-pairs sum. +-- "The notation is unchanged; only the set Σ runs over changes." +testNetCompleteEquiv :: IO () +testNetCompleteEquiv = do + let ks = [1 .. 6 :: Int] + viaEdges = sigmaEdges (completeNetwork ks) edgeJ :: NetJD + viaPairs = EJ.sigma2When ks ks (/=) edgeJ :: NetJD + assertEqual "Network: sigmaEdges complete == all-pairs sigma2When (exact)" + (toMap viaPairs) (toMap viaEdges) + +-- Test 2: determinism (DET-1). Same StdGen -> identical edges for every +-- generator, checked by running each twice and comparing. +testNetDeterminism :: IO () +testNetDeterminism = do + let ks = [1 .. 30 :: Int] + g = mkStdGen 42 + twice f = assertEqual ("Network DET-1: " ++ fst f) (edges (snd f g)) (edges (snd f g)) + twice ("kRegular", \s -> kRegular s ks 4) + twice ("erdosRenyi", \s -> erdosRenyi s ks 0.3) + twice ("scaleFree", \s -> scaleFree s ks 3) + twice ("sectorBlock",\s -> sectorBlock s [(k, k `mod` 3) | k <- ks] (\(a,b) -> if a==b then 0.5 else 0.1)) + +-- Test 3: smart constructors reject the four illegal cases. +testNetSmartConstructor :: IO () +testNetSmartConstructor = do + assertEqual "Network: self-loop rejected" + (Left SelfLoop) (tradeNetwork [1,2] [(1,1)] :: Either NetworkError (TradeNetwork Int)) + assertEqual "Network: duplicate edge rejected" + (Left DuplicateEdge) (tradeNetwork [1,2] [(1,2),(1,2)] :: Either NetworkError (TradeNetwork Int)) + let Right g = tradeNetwork [1,2,3] [(1,3)] :: Either NetworkError (TradeNetwork Int) + assertEqual "Network: coefficient outside network rejected" + (Left CoefOutsideNetwork) + (inputCoefficients g [(2,3,0.5)] :: Either NetworkError (InputCoefficients Int Double)) + assertEqual "Network: negative coefficient rejected" + (Left NegativeCoefficient) + (inputCoefficients g [(1,3,-0.5)] :: Either NetworkError (InputCoefficients Int Double)) + assertEqual "Network: duplicate coefficient rejected" + (Left DuplicateCoefficient) + (inputCoefficients g [(1,3,0.2),(1,3,0.3)] :: Either NetworkError (InputCoefficients Int Double)) + +-- Test 4: Hawkins-Simon — every buyer's column sum is strictly below 1. +testNetHawkinsSimon :: IO () +testNetHawkinsSimon = do + let g = completeNetwork [1 .. 12 :: Int] + a = randomCoefficients (mkStdGen 11) defaultCoefOptions g :: InputCoefficients Int Double + ok = all (\j -> sum (Prelude.map snd (inputsOf a j)) < 1.0) (nodes g) + assertEqual "Network: randomCoefficients (hawkinsSimon) all column sums < 1" True ok + +-- Test 5: generator structure. +testNetGeneratorStructure :: IO () +testNetGeneratorStructure = do + let ks = [1 .. 8 :: Int] + kr = kRegular (mkStdGen 3) ks 3 :: TradeNetwork Int + assertEqual "Network: kRegular in-degree = min k (N-1)" + (replicate (length ks) 3) + (Prelude.map (length . suppliersOf kr) (nodes kr)) + -- erdosRenyi p=1 == complete, p=0 == empty + assertEqual "Network: erdosRenyi p=1 == completeNetwork edges" + (edges (completeNetwork ks)) + (edges (erdosRenyi (mkStdGen 0) ks 1.0 :: TradeNetwork Int)) + assertEqual "Network: erdosRenyi p=0 has no edges" + 0 (edgeCount (erdosRenyi (mkStdGen 0) ks 0.0 :: TradeNetwork Int)) + -- scaleFree edge count is deterministic: C(m+1,2) + (N-m-1)*m + let n = length ks; m = 2 + expected = (m * (m + 1) `div` 2) + (n - m - 1) * m + assertEqual "Network: scaleFree edge count matches preferential-attachment formula" + expected (edgeCount (scaleFree (mkStdGen 9) ks m :: TradeNetwork Int)) + +-- Test 6: out/in adjacency consistency on an arbitrary generated network. +-- (i,j) in edges <=> i in suppliersOf j <=> j in buyersOf i +testNetAdjacencyConsistency :: IO () +testNetAdjacencyConsistency = do + let ks = [1 .. 25 :: Int] + g = erdosRenyi (mkStdGen 77) ks 0.25 :: TradeNetwork Int + es = edges g + fwd = all (\(i,j) -> i `elem` suppliersOf g j && j `elem` buyersOf g i) es + -- and the reverse: every (i,j) reconstructed from suppliersOf equals edges + viaSuppliers = L.sort [ (i, j) | j <- nodes g, i <- suppliersOf g j ] + viaBuyers = L.sort [ (i, j) | i <- nodes g, j <- buyersOf g i ] + assertEqual "Network: edges <=> suppliersOf (forward)" True fwd + assertEqual "Network: edges == reconstruction from suppliersOf" (L.sort es) viaSuppliers + assertEqual "Network: edges == reconstruction from buyersOf" (L.sort es) viaBuyers + +-- Test 7: CSV round-trip — parse . render == id (render is a test helper). +renderEdgeCsv :: [(T.Text, T.Text)] -> T.Text +renderEdgeCsv rows = T.unlines (T.pack "from,to" : [ a <> T.pack "," <> b | (a, b) <- rows ]) + +renderCoefCsv :: [(T.Text, T.Text, Double)] -> T.Text +renderCoefCsv rows = + T.unlines (T.pack "from,to,coef" : + [ a <> T.pack "," <> b <> T.pack "," <> T.pack (show c) | (a, b, c) <- rows ]) + +testNetCsvRoundTrip :: IO () +testNetCsvRoundTrip = do + let eRows = [(T.pack "a", T.pack "b"), (T.pack "b", T.pack "c"), (T.pack "a", T.pack "c")] + assertEqual "Network: edge CSV parse . render == id" + (Right eRows) (parseEdgeCsv (renderEdgeCsv eRows)) + let cRows = [(T.pack "a", T.pack "b", 0.25), (T.pack "b", T.pack "c", 0.5)] + assertEqual "Network: coef CSV parse . render == id" + (Right cRows) (parseCoefCsv (renderCoefCsv cRows)) + -- ingestion helpers agree with the network/coefficient invariants + let Right (g, a) = coefficientsFromTable [(1,3,0.2),(2,3,0.5)] + :: Either NetworkError (TradeNetwork Int, InputCoefficients Int Double) + assertEqual "Network: coefficientsFromTable edges" [(1,3),(2,3)] (edges g) + assertEqual "Network: coefficientsFromTable inputsOf" [(1,0.2),(2,0.5)] (inputsOf a 3) + -- fromCoefficientMatrix drops zero cells from the support + let m i j = if i < j then fromIntegral (i + j) else 0 :: Double + (gm, am) = fromCoefficientMatrix [1,2,3 :: Int] m + assertEqual "Network: fromCoefficientMatrix support drops zeros" + [(1,2),(1,3),(2,3)] (edges gm) + assertEqual "Network: fromCoefficientMatrix coefficient" (Just 4.0) (coefficient am 1 3) + -- networkFromTable derives nodes from rows + let Right gt = networkFromTable [(1,2),(2,3)] :: Either NetworkError (TradeNetwork Int) + assertEqual "Network: networkFromTable derives node set" [1,2,3] (nodes gt) + +-- Test 8: the requested sparse regimes have exactly m*N edges. +testIndustrialNetworkEdgeCount :: IO () +testIndustrialNetworkEdgeCount = do + let cases = [(200, 5, 20), (1000, 4, 10)] + forM_ cases $ \(n, k, m) -> do + let economy = industrialNetwork 2025 n k m + assertEqual ("Industrial network: exact |E|=mN for " ++ show (n,k,m)) + (m * n) (edgeCount (ieNetwork economy)) + let capacityLimited = industrialNetwork 1 10 1 20 + assertEqual "Industrial network: capacity shortage uses every eligible pair" + 45 (edgeCount (ieNetwork capacityLimited)) + let nearOne = industrialNetworkWith + defaultIndustrialOptions { ioExponent = 1.001 } 1 1000 3 5 + assertEqual "Industrial network: gamma near 1 keeps every size finite" + True (all (\w -> w > 0 && not (isNaN w) && not (isInfinite w)) + (M.elems (ieSize nearOne))) + assertEqual "Industrial network: gamma near 1 retains exact |E|=mN" + 5000 (edgeCount (ieNetwork nearOne)) + +-- Test 9: every edge obeys the ordered-sector DAG invariant and is unique. +testIndustrialNetworkStructure :: IO () +testIndustrialNetworkStructure = do + let economy = industrialNetwork 19 500 5 12 + es = industrialEdges economy + sectors = ieSector economy + valid (i, j) = + let si = sectors M.! i + sj = sectors M.! j + in i /= j && (si < sj || (si == sj && i < j)) + assertEqual "Industrial network: no duplicate edges" + (length es) (Set.size (Set.fromList es)) + assertEqual "Industrial network: sector order and intra-sector id DAG" + True (all valid es) + +-- Test 10: the integer seed fixes sectors, sizes, and edges. +testIndustrialNetworkDeterminism :: IO () +testIndustrialNetworkDeterminism = do + let a = industrialNetwork 4242 300 5 8 + b = industrialNetwork 4242 300 5 8 + assertEqual "Industrial network: same seed gives identical economy" a b + +-- Test 11: one-sector economies use the id order as a DAG and still hit m*N. +testIndustrialNetworkKOne :: IO () +testIndustrialNetworkKOne = do + let n = 200 + m = 20 + economy = industrialNetwork 3 n 1 m + es = industrialEdges economy + assertEqual "Industrial network: K=1 exact |E|=mN" (m * n) (length es) + assertEqual "Industrial network: K=1 edges are increasing ids" + True (all (uncurry (<)) es) + +-- Test 12: market-scale construction smoke. There is deliberately no timing +-- assertion; forcing the full 1.28M-edge economy catches accidental all-pairs +-- construction and latent exceptions while remaining machine-independent. +testIndustrialNetworkLarge :: IO () +testIndustrialNetworkLarge = do + economy <- evaluate (force (industrialNetwork 2025 64000 5 20)) + assertEqual "Industrial network: N=64000 smoke exact |E|=mN" + (64000 * 20) (edgeCount (ieNetwork economy)) + +-- Test 13: exact one-pass flow identities, divisibility, and tax cancellation. +testIndustrialFlowsIdentities :: IO () +testIndustrialFlowsIdentities = do + let rate = TaxRate 1 10 + den = taxDenominator rate + economy = industrialNetwork 2025 300 5 12 + flows = industrialFlows rate economy + net = ieNetwork economy + js = firms economy + z i j = M.findWithDefault 0 (i,j) (flowTrade flows) + x j = flowOutput flows M.! j + input j = flowInput flows M.! j + va j = flowValueAdded flows M.! j + f j = flowFinalDemand flows M.! j + incoming j = sum [ z i j | i <- suppliersOf net j ] + outgoing j = sum [ z j m | m <- buyersOf net j ] + allAmounts = M.elems (flowTrade flows) + ++ M.elems (flowOutput flows) + ++ M.elems (flowInput flows) + ++ M.elems (flowValueAdded flows) + ++ M.elems (flowFinalDemand flows) + taxReceivedTrade = sum + [ taxOf rate (z i j) | i <- js, j <- buyersOf net i ] + taxPaidTrade = sum + [ taxOf rate (z i j) | j <- js, i <- suppliersOf net j ] + finalTax = sum [ taxOf rate (f j) | j <- js ] + netTax = taxReceivedTrade + finalTax - taxPaidTrade + expectedTax = taxNumerator rate * sum (Prelude.map f js) `div` den + assertEqual "Industrial flows: all final demand positive" True (all ((> 0) . f) js) + assertEqual "Industrial flows: all value added non-negative" True (all ((>= 0) . va) js) + assertEqual "Industrial flows: output = orders + final demand" + True (all (\j -> x j == outgoing j + f j) js) + assertEqual "Industrial flows: output = input + value added" + True (all (\j -> x j == incoming j + va j && input j == incoming j) js) + assertEqual "Industrial flows: every amount divisible by tax denominator" + True (all (\amount -> amount `mod` den == 0) allAmounts) + assertEqual "Industrial flows: sum value added = sum final demand" + (sum (Prelude.map f js)) (sum (Prelude.map va js)) + assertEqual "Industrial flows: trade output tax equals trade input tax" + taxReceivedTrade taxPaidTrade + assertEqual "Industrial flows: trade tax cancels and net tax equals final-demand tax" + expectedTax netTax + +-- Test 14: zero allocations are retained per edge, and a hand-built economy +-- outside the ordered DAG is rejected before backward substitution. +testIndustrialFlowEdgeCases :: IO () +testIndustrialFlowEdgeCases = do + let rate = TaxRate 1 10 + economy = industrialNetwork 11 50 3 5 + zeroFlows = industrialFlowsWith (FlowOptions 10 0.5) rate economy + assertEqual "Industrial flows: sub-denominator inputs permit z_ij=0" + True (not (M.null (flowTrade zeroFlows)) && any (== 0) (M.elems (flowTrade zeroFlows))) + let Right badNetwork = tradeNetwork [1,2] [(2,1)] + :: Either NetworkError (TradeNetwork Int) + badEconomy = IndustrialEconomy + { ieNetwork = badNetwork + , ieSector = M.fromList [(1,0),(2,0)] + , ieSize = M.fromList [(1,1),(2,1)] } + rejected <- try (evaluate (force (industrialFlows rate badEconomy))) + :: IO (Either SomeException (IndustrialFlows Int)) + assertEqual "Industrial flows: unordered hand-built economy rejected" + True (case rejected of Left _ -> True; Right _ -> False) + +-- ================================================================ +-- MarketModel equivalence tests (Phase 5, feat/market-scale-experiments) +-- +-- The examples/market/MarketModel.hs core cannot be imported here (it declares +-- an orphan `instance StateTime Int` that would clash with the SICE harness's +-- `instance StateTime SimTerm`), so the trade simple/tuned stages and a small +-- BSP world are re-stated minimally (per the Phase 5 plan §2 commit 3 note). +-- We check the two properties the plan puts in CI: +-- (a) tradeStageSimple ≡ tradeStageTuned, EXACTLY, under MoneyDecimal; +-- (b) Sequential ≡ ParChunk (DET-2) for the whole 3-stage model, exactly. +-- (Perf ratios are out of CI; they live in run-market-experiments.sh.) +-- ================================================================ + +-- 4-axis base (AccountTitles, owner, counterparty, CountUnit), mirroring +-- MarketModel.MBase. It is exactly the SICE harness's SimHatBase2, so we reuse +-- that type (and its ExBaseClass / Element Int / BaseClass Int instances) +-- instead of re-declaring them. +type MktFirm = SimCompany -- = Int + +-- ADT event tag mirroring MarketModel.MTag (typo'd tags become compile errors, +-- not silently-empty projections). 'MktPlank' is the explicit blank tag. +data MktTag = MktPlank | MktTrade | MktProduction | MktReport | MktClosing | MktCarryover + deriving (Show, Eq, Ord, Enum, Bounded, Generic) +instance Hashable MktTag +-- needed so the spill / runLiteWithPolicy window-transparency test can serialise +-- a @Journal MktNote v b@ (derived structurally from Generic). +instance Binary.Binary MktTag +instance Note MktTag where + plank = MktPlank + +type MktNote = (MktTag, Int) +type MktBase = SimHatBase2 -- = HatBase (AccountTitles, Int, Int, CountUnit) +type MktLedgM = Journal MktNote MoneyDecimal MktBase + +data MktW v f = MktW + { mkLedger :: HK f (Journal MktNote v MktBase) + , mkNet :: HK f (TradeNetwork MktFirm) + , mkCoef :: HK f (InputCoefficients MktFirm v) + } deriving Generic + +-- own-product classifier shared by the mirror. +mktOwnerOfProduct :: BasePart MktBase -> Maybe MktFirm +mktOwnerOfProduct bp = case bp of + (Products, o, c, _) | o == c -> Just o + _ -> Nothing + +-- opening stock read from the (MktCarryover, t) note (indexed per-note), +-- mirroring MarketModel.openingMap (carryover-based O(term) inventory). +mktOpening :: (HatVal v, Real v) + => Int -> Journal MktNote v MktBase -> M.Map MktFirm v +mktOpening t ledger = + EA.balanceMapBy mktOwnerOfProduct + (EJ.toAlg (EJ.projWithNote [(MktCarryover, t)] ledger)) + +-- single-firm opening read (indexed per-note + per-base), mirroring +-- MarketModel.openingOf: balanceBy over firm j's own-product base only. +mktOpeningOf :: (HatVal v, Real v) + => Int -> MktFirm -> Journal MktNote v MktBase -> v +mktOpeningOf t j ledger = + EA.balanceBy [Not :< (Products, j, j, Amount)] + [Hat :< (Products, j, j, Amount)] + (EJ.toAlg (EJ.projWithNote [(MktCarryover, t)] ledger)) + +-- single-firm inventory-connected demand, mirroring MarketModel.demandOf. +mktDemandOf :: (HatVal v, Real v) + => Double -> Int -> MktFirm -> Journal MktNote v MktBase -> Double +mktDemandOf target t j ledger = + max 0 (target - realToFrac (mktOpeningOf t j ledger)) + +mktPurchase :: (HatVal v) => v -> MktFirm -> MktFirm -> EA.Alg v MktBase +mktPurchase amt i j = + amt .@ Not :< (Products, j, j, Amount) + .+ amt .@ Hat :< (Cash, j, j, Yen) + .+ amt .@ Not :< (Purchases, j, j, Yen) + .+ amt .@ Not :< (Cash, i, i, Yen) + .+ amt .@ Not :< (Sales, i, i, Yen) + .+ amt .@ Hat :< (Products, i, i, Amount) + +mktOrderAmt :: (HatVal v, Real v) + => InputCoefficients MktFirm v -> Double -> MktFirm -> MktFirm -> Double +mktOrderAmt coef d i j = + realToFrac (maybe 0 id (coefficient coef i j)) * d + +-- per-firm trade stage (stageFor over the firm list), mirroring +-- MarketModel.tradeStageSimple: buyer j folds its in-edges (suppliersOf). +mktTradeSimple :: (HatVal v, Real v) => [MktFirm] -> Double -> Stage (MktW v) Int MktNote v MktBase +mktTradeSimple fs target = stageOf MktTrade fs $ \w t _g j -> + -- single-note stage: emit the bare Alg; the runner attaches (MktTrade, t). + let net = mkNet w; coef = mkCoef w + d = mktDemandOf target t j (mkLedger w) + sup = suppliersOf net j + one i = let amt = realToFrac (mktOrderAmt coef d i j) + in if amt <= 0 then mempty else mktPurchase amt i j + in EA.sigma sup one + +mktTradeTuned :: (HatVal v, Real v) => [MktFirm] -> Double -> Stage (MktW v) Int MktNote v MktBase +mktTradeTuned fs target = stageOf MktTrade fs $ \w t _g j -> + -- single-note stage: see 'mktTradeSimple'. + let net = mkNet w; coef = mkCoef w + d = mktDemandOf target t j (mkLedger w) + sup = suppliersOf net j + accum = L.foldl' step M.empty sup + step acc i = + let amt = realToFrac (mktOrderAmt coef d i j) + in if amt <= 0 then acc + else L.foldl' (\m (b, v) -> M.insertWith (+) b v m) acc + [ (Not :< (Products, j, j, Amount), amt) + , (Hat :< (Cash, j, j, Yen), amt) + , (Not :< (Purchases, j, j, Yen), amt) + , (Not :< (Cash, i, i, Yen), amt) + , (Not :< (Sales, i, i, Yen), amt) + , (Hat :< (Products, i, i, Amount), amt) ] + in EA.sigmaFromMap accum (\b v -> v .@ b) + +mktProduction :: (HatVal v, Real v) => [MktFirm] -> Double -> Stage (MktW v) Int MktNote v MktBase +mktProduction fs target = stageOf MktProduction fs $ \w t _g j -> + -- single-note stage: emit the bare Alg; the runner attaches (MktProduction, t). + let amt = realToFrac (mktDemandOf target t j (mkLedger w)) + in if amt <= 0 then mempty + else (amt .@ Hat :< (Products, j, j, Amount)) + .+ (amt .@ Not :< (SalesCost, j, j, Yen)) + +mktReport :: (HatVal v) => Stage (MktW v) Int MktNote v MktBase +mktReport = stageOf MktReport [()] $ \w t _g () -> + -- single-note aggregate stage: emit the bare Alg; runner attaches (MktReport, t). + let flow = EJ.toAlg (EJ.projWithNote [(MktTrade, t), (MktProduction, t)] (mkLedger w)) + shortageK b = case b of + Hat :< (Products, o, c, _) | o == c -> Just o + _ -> Nothing + in EA.postFromNetBy shortageK (\j v -> v .@ Not :< (Products, j, j, Amount)) flow + +-- carryover stage (mirror): net this term's own-product stock and roll the +-- positive surplus into (MktCarryover, t+1). Mirrors MarketModel.carryoverStage. +mktCarryover :: (HatVal v, Real v) => Stage (MktW v) Int MktNote v MktBase +mktCarryover = stage "closing" $ \w t -> + let termAlg = EJ.toAlg (EJ.filterByAxis 1 (NoteAxisKey (t :: Int)) (mkLedger w)) + netMap = EA.balanceMapBy mktOwnerOfProduct termAlg + perFirm (j, v) = + if v <= 0 then mempty + else ((v .@ Hat :< (Products, j, j, Amount)) .| (MktClosing, t)) + <> ((v .@ Not :< (Products, j, j, Amount)) .| (MktCarryover, t + 1)) + in mconcat [ perFirm kv | kv <- M.toList netMap ] + +-- a fixed small (G, A) used by both equivalence tests. +mktBuild :: (HatVal v) => Int -> (TradeNetwork MktFirm, InputCoefficients MktFirm v) +mktBuild n = + let (gG, gA) = split (mkStdGen 2025) + fs = [1 .. n] + net = erdosRenyi gG fs 0.3 + a = randomCoefficients gA defaultCoefOptions net + in (net, a) + +mktSpec :: (HatVal v, Real v) + => Bool -> Int -> Int -> Par -> SimSpec (MktW v) Int MktNote v MktBase +mktSpec tuned n lastT par = + let fs = [1 .. n] in + (mkSimSpec (1, lastT) 2025 mkLedger + [ (if tuned then mktTradeTuned else mktTradeSimple) fs 10 + , mktProduction fs 10 + , mktReport + , mktCarryover ]) + { Lite.specParallel = par } + +mktW0 :: (HatVal v) => Int -> MktW v InitT +mktW0 n = let (net, a) = mktBuild n + in MktW { mkLedger = carry mempty, mkNet = carry net, mkCoef = carry a } + +-- (a) simple ≡ tuned, exactly, under MoneyDecimal (N=30, T=5). +-- the redundant-algebra-correct "same result": net each note's Alg per base +-- ('bar' drops the cancelled part and any zero-padding), keeping the Hat/Not +-- side. simple and tuned differ ONLY in seq redundancy (simple keeps the +-- per-edge posting sequence; tuned pre-sums per base), so they are equal exactly +-- after netting. (norm additivity already holds; this is the stronger per-base +-- exact check.) +nettedMktMap :: Journal MktNote MoneyDecimal MktBase + -> HM.HashMap MktNote (EA.Alg MoneyDecimal MktBase) +nettedMktMap = toMap . EJ.map EA.bar + +testMarketSimpleTunedEqual :: IO () +testMarketSimpleTunedEqual = do + let simpleL = runLite (mktSpec False 30 5 Sequential) (mktW0 30) mkLedger + :: MktLedgM + tunedL = runLite (mktSpec True 30 5 Sequential) (mktW0 30) mkLedger + assertEqual "Market: tradeStageSimple == tradeStageTuned (MoneyDecimal, exact per-base net)" + (nettedMktMap simpleL) (nettedMktMap tunedL) + -- gross volume must also agree: bar-equality alone cannot detect an + -- accidental early Hat/Not netting in the tuned path (bar is idempotent, + -- but the pre-bar norm would shrink). norm pins the gross posting volume. + assertEqual "Market: simple/tuned gross volume (norm) agrees (no early netting)" + (norm simpleL) (norm tunedL) + +-- (b) DET-2: Sequential ≡ ParChunk, exactly, under MoneyDecimal (simple path). +testMarketSeqParEqual :: IO () +testMarketSeqParEqual = do + let seqM = runLite (mktSpec False 30 5 Sequential) (mktW0 30) (toMap . mkLedger) + :: HM.HashMap MktNote (EA.Alg MoneyDecimal MktBase) + parM = runLite (mktSpec False 30 5 (ParChunk 8)) (mktW0 30) (toMap . mkLedger) + assertEqual "Market DET-2: Sequential == ParChunk (MoneyDecimal, exact)" + seqM parM + +-- (c) sanity: the report's net shortage is strictly positive (Hawkins-Simon), +-- and the complete-network setting also runs (a participating-set sanity). +testMarketShortagePositive :: IO () +testMarketShortagePositive = do + let finalSh = runLite (mktSpec False 24 4 Sequential) (mktW0 24) + (\final -> norm (EJ.projWithNote [(MktReport, 4)] (mkLedger final))) + :: MoneyDecimal + assertEqual "Market: final-term net shortage is strictly positive (Hawkins-Simon)" + True (finalSh > 0) + -- complete network on a tiny N just exercises the dense edge set end-to-end. + let (gG, gA) = split (mkStdGen 2025) + cnet = completeNetwork [1 .. 8 :: MktFirm] + ccoef = randomCoefficients gA defaultCoefOptions cnet :: InputCoefficients MktFirm MoneyDecimal + cw0 = MktW { mkLedger = carry mempty, mkNet = carry cnet, mkCoef = carry ccoef } + cfs = [1 .. 8 :: MktFirm] + cspec = (mkSimSpec (1, 3) 2025 mkLedger + [ mktTradeSimple cfs 10, mktProduction cfs 10, mktReport, mktCarryover ]) + cNorm = runLite cspec cw0 (norm . mkLedger) :: MoneyDecimal + _ = gG + assertEqual "Market: complete-network run produces a positive ledger norm" + True (cNorm > 0) + +-- (d) WINDOW-TRANSPARENCY SENTINEL (Phase 5 fix, modification 3): +-- the carryover bookkeeping makes the model self-contained per term, so a +-- RetainRecent window must NOT change the observable result. Assert that +-- RetainRecent 2 (+ spill) and RetainAll produce the EXACT SAME final-term +-- report norm AND final carryover map (MoneyDecimal, so equality is exact). +-- This permanently guards against the bug this round fixed (a full-ledger +-- inventory sweep silently re-reading a window-truncated net: 9974.74 vs +-- 9993.56). N=40, T=8 so the window (2) is strictly smaller than the history. +testMarketWindowTransparent :: IO () +testMarketWindowTransparent = withTempSpill "market_window" $ \path -> do + let n = 40; lastT = 8 + spec = mktSpec False n lastT Sequential + w0 = mktW0 n + -- project the two observables we pin: the final-term report norm and the + -- final carryover map (the next-term opening, keyed by firm). + project final = + let lj = mkLedger final :: MktLedgM + reportN = norm (EJ.projWithNote [(MktReport, lastT)] lj) :: MoneyDecimal + carryM = EA.balanceMapBy mktOwnerOfProduct + (EJ.toAlg (EJ.projWithNote [(MktCarryover, lastT + 1)] lj)) + :: M.Map MktFirm MoneyDecimal + in (reportN, carryM) + polAll = Policy.defaultLedgerPolicy { Policy.retain = Policy.RetainAll } + polWin = Policy.defaultLedgerPolicy + { Policy.retain = Policy.RetainRecent 2, Policy.spillTo = Just path } + (allN, allM) <- runLiteWithPolicy polAll spec w0 project + (winN, winM) <- runLiteWithPolicy polWin spec w0 project + assertEqual "Market window-transparency: final report norm equal under RetainAll vs RetainRecent 2 + spill" + allN winN + assertEqual "Market window-transparency: final carryover map equal under RetainAll vs RetainRecent 2 + spill" + allM winM + +-- (e) stageOf AUTO-NOTE SENTINEL: a 'stageOf' stage and the equivalent manual +-- 'stageFor' that writes @.| (tag, t)@ itself must produce the EXACT SAME ledger +-- (MoneyDecimal, so equality is exact). This pins the semantics of the runner's +-- single auto-attachment of @(stTag, t)@: moving the note from the stage body +-- into 'runStage' changes nothing observable (incl. the zero-drop at the sigma +-- commit). The manual stages below are byte-for-byte the bodies of the migrated +-- mirror stages, but tagged explicitly with the OLD @if isZero then mempty@ form. +mktTradeSimpleManual :: (HatVal v, Real v) + => [MktFirm] -> Double -> Stage (MktW v) Int MktNote v MktBase +mktTradeSimpleManual fs target = stageFor "trade" fs $ \w t _g j -> + let net = mkNet w; coef = mkCoef w + d = mktDemandOf target t j (mkLedger w) + sup = suppliersOf net j + one i = let amt = realToFrac (mktOrderAmt coef d i j) + in if amt <= 0 then mempty else mktPurchase amt i j + alg = EA.sigma sup one + in if EA.isZero alg then mempty else alg .| (MktTrade, t) + +mktProductionManual :: (HatVal v, Real v) + => [MktFirm] -> Double -> Stage (MktW v) Int MktNote v MktBase +mktProductionManual fs target = stageFor "production" fs $ \w t _g j -> + let amt = realToFrac (mktDemandOf target t j (mkLedger w)) + in if amt <= 0 then mempty + else ((amt .@ Hat :< (Products, j, j, Amount)) + .+ (amt .@ Not :< (SalesCost, j, j, Yen))) + .| (MktProduction, t) + +mktReportManual :: (HatVal v) => Stage (MktW v) Int MktNote v MktBase +mktReportManual = stage "report" $ \w t -> + let flow = EJ.toAlg (EJ.projWithNote [(MktTrade, t), (MktProduction, t)] (mkLedger w)) + shortageK b = case b of + Hat :< (Products, o, c, _) | o == c -> Just o + _ -> Nothing + sh = EA.postFromNetBy shortageK (\j v -> v .@ Not :< (Products, j, j, Amount)) flow + in if EA.isZero sh then mempty else sh .| (MktReport, t) + +-- the same 4-stage spec as 'mktSpec' but with the three single-note stages +-- expressed via manual stageFor + explicit @.| (tag, t)@ (carryover unchanged). +mktSpecManual :: (HatVal v, Real v) + => Int -> Int -> Par -> SimSpec (MktW v) Int MktNote v MktBase +mktSpecManual n lastT par = + let fs = [1 .. n] in + (mkSimSpec (1, lastT) 2025 mkLedger + [ mktTradeSimpleManual fs 10 + , mktProductionManual fs 10 + , mktReportManual + , mktCarryover ]) + { Lite.specParallel = par } + +testMarketStageOfAutoNote :: IO () +testMarketStageOfAutoNote = do + let stageOfL = runLite (mktSpec False 30 5 Sequential) (mktW0 30) (toMap . mkLedger) + :: HM.HashMap MktNote (EA.Alg MoneyDecimal MktBase) + manualL = runLite (mktSpecManual 30 5 Sequential) (mktW0 30) (toMap . mkLedger) + assertEqual "Market stageOf auto-note: stageOf ledger == manual stageFor + .| (tag, t) (MoneyDecimal, exact)" + stageOfL manualL + +-- ================================================================ +-- ExchangeAlgebra.Optimize: pluggable solvers (Annealing / GA) +-- ================================================================ + +-- | Shared annealing configuration: minimize over 'Double' with a +-- uniform-step neighbor, geometric cooling and Metropolis acceptance. +optAnnealCfg :: OA.AnnealingConfig Double +optAnnealCfg = OA.AnnealingConfig + { OA.acDirection = O.Minimize + , OA.acSteps = 2000 + , OA.acSchedule = OA.geometricCooling 1.0 0.995 + , OA.acNeighbor = \g x -> let (d, g') = randomR (-0.5, 0.5) g in (x + d, g') + , OA.acAccept = OA.metropolis + , OA.acSeed = 20260717 + } + +optSphere :: UV.Vector Double -> Double +optSphere v = UV.sum (UV.map (\x -> (x - 1) ** 2) v) + +-- | Annealing locates the minimum of a 1-D quadratic (seed-deterministic), +-- and the reported score is the returned candidate's objective value +-- (score contract: no re-evaluation, user orientation). +testOptimizeAnnealingQuadratic :: IO () +testOptimizeAnnealingQuadratic = do + (best, score) <- O.optimize OA.Annealing optAnnealCfg + (\x -> return ((x - 3) ** 2)) 0 + assertEqual "Optimize.Annealing: quadratic minimum located (|x-3| < 0.2)" + True (abs (best - 3) < 0.2) + assertNear "Optimize.Annealing: score equals returned candidate's value" + ((best - 3) ** 2) score + +-- | GA approaches the sphere minimum, keeps the dimension, and respects +-- per-gene bounds. +testOptimizeGASphere :: IO () +testOptimizeGASphere = do + let cfg = OG.defaultGAConfig { OG.gaSeed = 20260717, OG.gaGenerations = 80 } + (best, score) <- O.optimize OG.GA cfg (return . optSphere) (UV.replicate 3 0) + assertEqual "Optimize.GA: chromosome dimension preserved" 3 (UV.length best) + assertEqual "Optimize.GA: sphere minimum approached (score < 0.05)" + True (score < 0.05) + let bs = UV.replicate 3 (-0.5, 0.5) + bCfg = OG.defaultGAConfig { OG.gaSeed = 3 + , OG.gaGenerations = 40 + , OG.gaBounds = Just bs } + (bBest, _) <- O.optimize OG.GA bCfg (return . optSphere) (UV.replicate 3 0) + assertEqual "Optimize.GA: bounds respected by every gene" + True (UV.all (\x -> x >= -0.5 && x <= 0.5) bBest) + +-- | Maximize reports the score in the user's orientation. +testOptimizeGAMaximize :: IO () +testOptimizeGAMaximize = do + let cfg = OG.defaultGAConfig { OG.gaDirection = O.Maximize + , OG.gaSeed = 7 + , OG.gaGenerations = 80 } + (_, score) <- O.optimize OG.GA cfg (return . negate . optSphere) + (UV.replicate 3 0) + assertEqual "Optimize.GA: Maximize reports user-oriented score (> -0.05)" + True (score > -0.05) + +-- | Acceptance-criteria demo: the objective runs in @ST s@ (mutable +-- evaluation counter), and the solver evaluates exactly once per step +-- plus once for the initial candidate. +testOptimizeSTObjective :: IO () +testOptimizeSTObjective = do + let cfg = optAnnealCfg { OA.acSteps = 100 } + (best, score, evals) = runST $ do + ref <- newSTRef (0 :: Int) + (b, s) <- O.optimize OA.Annealing cfg + (\x -> modifySTRef' ref (+ 1) >> return ((x - 3) ** 2)) 0 + n <- readSTRef ref + return (b, s, n) + assertEqual "Optimize: ST objective evaluated once per step + initial" + (OA.acSteps cfg + 1) evals + assertEqual "Optimize: ST run returns finite (best, score)" + True (not (isNaN best) && not (isNaN score) && not (isInfinite score)) + +-- | Same seed, same (deterministic) objective => identical result. +testOptimizeDeterminism :: IO () +testOptimizeDeterminism = do + r1 <- O.optimize OA.Annealing optAnnealCfg (\x -> return ((x - 3) ** 2)) 0 + r2 <- O.optimize OA.Annealing optAnnealCfg (\x -> return ((x - 3) ** 2)) 0 + assertEqual "Optimize.Annealing: same seed => identical result" r1 r2 + let cfg = OG.defaultGAConfig { OG.gaSeed = 11, OG.gaGenerations = 20 } + s1 <- O.optimize OG.GA cfg (return . optSphere) (UV.replicate 3 0) + s2 <- O.optimize OG.GA cfg (return . optSphere) (UV.replicate 3 0) + assertEqual "Optimize.GA: same seed => identical result" s1 s2 + +-- | Fail-fast contract: non-finite objective scores and invalid +-- configurations are rejected with 'error', never silently absorbed. +testOptimizeFailFast :: IO () +testOptimizeFailFast = do + r <- try (O.optimize OA.Annealing optAnnealCfg (\_ -> return (0 / 0)) 0) + case (r :: Either SomeException (Double, Double)) of + Left _ -> putStrLn "[PASS] Optimize.Annealing: NaN objective rejected (fail-fast)" + Right v -> do + putStrLn ("[FAIL] Optimize.Annealing: NaN objective accepted: " ++ show v) + exitFailure + let badCfg = OG.defaultGAConfig { OG.gaEliteCount = 999 } + r2 <- try (O.optimize OG.GA badCfg (return . optSphere) (UV.replicate 3 0)) + case (r2 :: Either SomeException (UV.Vector Double, Double)) of + Left _ -> putStrLn "[PASS] Optimize.GA: invalid config rejected (fail-fast)" + Right v -> do + putStrLn ("[FAIL] Optimize.GA: invalid config accepted: " ++ show v) + exitFailure + +main :: IO () +main = do + testAccountTitlesBinary + testAccountTitleClassification + testReplaceNotesMatchesInsert + testMapPosting + testMapMaybePosting + testProjMultiPatternOnePass + testProjNormFastPath + testProjDuplicateExact + testProjExactWildcardOverlap + testProjNormBarIdentity + testProjWithBaseNorm + testProjWithNoteNorm + testProjWithBaseNormBothSided + testBasesNotSideRegression + testNumericToleranceScaleAware + testMoneyDecimalExactOrderIndependent + testSigmaMergePath + testSameBaseSeqOrderPathDependence + testSigma2When + testSigmaFromMap + testJournalFromListStrict + testUnionZeroSingletonBase + testScalarRejectsNegative + testProjConcreteNoIndexForce + testLinerReservedFieldsPoisoned + testJournalSigmaMergePath + testJournalSigma2When + testJournalSigmaOn + testJournalSigmaOnFromMap + testFilterByAxisEquivalent + testFilterByAxisWithDeltaUpdates + testFinalStockTransferAlgEquivalence + testFinalStockTransferJournalEquivalence + testFinalStockTransferAggregatedAlias + testFinalStockRegistryClosedDiff + testFinalStockRuleReference + testVocabOrdinalPin + testPreVland2SemanticsClosedDiff + testIncomeSummaryBalancedNoCrash + testSpillDecisionSingleSource + testRestoreJournalFromBinarySpill + testSpillCheckedReaderWellFormed + testSpillCheckedReaderTruncated + testSpillCheckedReaderStaleAppend + testSpillCheckedReaderOverlap + testSpillCheckedReaderGap + testSpillCheckedReaderEmptyRange + testSpillCheckedReaderEmptyFile + testSimulateEx1Default + testCsvTranspose + testCsvWriteCSV + testCsvWriteCSVWithQuotes + testCsvWriteCSVEmpty + testWriteBSPinned + testWritePLPinned + testWriteJournalPinned + testWriteCompoundTrialBalancePinned + testWriteAccountOfJournalPinned + testLiteBoilerplate + testLiteDet2 + testLiteDet1 + testLiteBspInvisibility + testLiteGateEquivalence + testLiteFieldRules + testLiteBoundaryOncePerTerm + testPolicyEquivalence + testPolicyWindowRoundTrip + testPolicyCompressClosed + testPolicyDeleteOnly + testPolicyDeterminism + testPolicyClassicBridge + testPolicyHasTermAxis + testNetCompleteEquiv + testNetDeterminism + testNetSmartConstructor + testNetHawkinsSimon + testNetGeneratorStructure + testNetAdjacencyConsistency + testNetCsvRoundTrip + testIndustrialNetworkEdgeCount + testIndustrialNetworkStructure + testIndustrialNetworkDeterminism + testIndustrialNetworkKOne + testIndustrialNetworkLarge + testIndustrialFlowsIdentities + testIndustrialFlowEdgeCases + testMarketSimpleTunedEqual + testMarketSeqParEqual + testMarketShortagePositive + testMarketWindowTransparent + testMarketStageOfAutoNote + testConvertCsvRoundTrip + testAssistDescriptionsDrift + testAssistDescribeAccount + testAssistAllAccountInfos + testAccountMetadataLand1 + testAccountMetadataLand1Golden + testAccountInfoLand1Migration + testAssistSuggestAccounts + testPostVocabGolden + testAccountSemanticsPrechangeGolden + testRegistryGolden + testJcciAccountNameCoverage + testAccountLabelsLand4a + testRegistryWildcards + testRegistryContraLand2 + testLand2SemanticsClosedDiff + testLand2InfoClosedDiff + testLand2SuggestClosedDiff + testLand2Contract + testLand2PimoFlip + testLand2ExchangeRelation + testLand2IsContraInstances + testLand2AiDivision + testLand3PresentationGroups + testLand2Presentation + testLand2PresentationClosedDiff + testLand2HatNotPolicy + checkedConvertProperties + axiomProperties + categoricalPhase1Properties + journalProperties + quotientProperties + bookkeepingProperties + closingDocsTests + testOptimizeAnnealingQuadratic + testOptimizeGASphere + testOptimizeGAMaximize + testOptimizeSTObjective + testOptimizeDeterminism + testOptimizeFailFast diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -4,4 +4,22 @@ main :: IO () main = doctest [ "-isrc" - , "src/ExchangeAlgebra.hs"] + , "src/ExchangeAlgebra.hs" + , "src/ExchangeAlgebra/Algebra/Internal.hs" + -- not reachable from the umbrella above; listed explicitly so + -- its Haddock examples are checked too. + , "src/ExchangeAlgebra/Simulate/Network.hs" + , "src/ExchangeAlgebra/Simulate/Policy.hs" + -- closing-adjustment builders: not re-exported from the + -- umbrella, so listed explicitly to check its examples too. + , "src/ExchangeAlgebra/Bookkeeping.hs" + -- dependency-free input-conversion core: not re-exported from + -- the umbrella, so listed explicitly to check its examples too. + , "src/ExchangeAlgebra/Convert.hs" + , "src/ExchangeAlgebra/Convert/Csv.hs" + , "src/ExchangeAlgebra/Convert/Checked.hs" + , "src/ExchangeAlgebra/Assist.hs" + , "src/ExchangeAlgebra/Reporting/Group.hs" + -- optimization layer: not re-exported from the umbrella, + -- so listed explicitly to check its examples too. + , "src/ExchangeAlgebra/Optimize.hs"]