packages feed

exchangealgebra 0.4.1.2 → 0.5.0.0

raw patch · 41 files changed

+24208/−3266 lines, 41 filesdep +Decimaldep +QuickCheck

Dependencies added: Decimal, QuickCheck

Files

ChangeLog.md view
@@ -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 `<function>` 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:<b` and `Not:<b`): the left-hand side is the gross norm (sums both+  sides), the right-hand side is the bar-netted read-out (verified 14.0 vs 6.0+  on a both-sided base). Had the rule fired under `-O`, optimized and+  unoptimized builds would silently disagree. The Haddock of+  `projWithBaseNorm`/`projWithNoteNorm` — which claimed the false equivalence —+  now states the correct identity+  `projWithBaseNorm bs js == norm (map bar (projWithBase bs js))`, and a+  regression test pins both the netted and the gross value.++- `incomeSummaryAccount` (both `ExchangeAlgebra.Algebra.Transfer` and+  `ExchangeAlgebra.Journal.Transfer`): no longer crashes with+  "Non-exhaustive patterns" on a balanced ledger (audit R1). When credit and+  debit totals are equal, `diffRL` reports the wildcard `Side` and net income is+  zero; the function now returns its input unchanged (balanced ledger = identity)+  instead of matching only `Credit`/`Debit`. No `NetIncome`/`NetLoss` posting is+  added in this case (appending a zero posting is not an identity for `Journal`,+  since `(.|)` builds a singleton that drives version/compaction). A+  balanced-ledger regression test now runs every closing transfer.++- `proj` and `projNorm` (`ExchangeAlgebra.Algebra`): the multi-pattern paths now+  use __set semantics__ — a query list is treated as a set, so duplicate queries+  or an exact base overlapping a wildcard query select each posting __at most+  once__ (audit R7). Previously the multi-pattern path merged per-query results+  with sequence concatenation, double counting any posting matched by more than+  one query (the single-pattern path already returned only the first match, so+  the two paths disagreed). __Results of multi-pattern `proj`/`projNorm` can now+  differ__ from prior releases when a query list contains overlapping or+  duplicate patterns. The Haddock now documents the set semantics and the+  `projNorm bs x == norm (bar (proj bs x))` identity (bar-netted norm).++- `Simulate.Lite`: under `ParChunk`, the first stage message is now forced to+  normal form in the calling thread before the remaining messages are sparked.+  Previously all sparks raced to force the shared snapshot's lazily-built index+  structures, which could abort a run with a spurious RTS `<<loop>>`+  (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
README.md view
@@ -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:<Cash .+ 2 :@ Not:<Sales   -- numeric literals work directly+```++**FP vs exact, made concrete (measured).** In the bundled `sim1`, the same+stock value matches both types where it lands on an exactly-representable result+(`stock(t=1, c=6) = 30.0` under `MoneyDouble` *and* `MoneyDecimal`), but diverges+in the last ULP once FP rounding accumulates over terms+(`stock(t=100, c=6)`: `767.960563480499` under `MoneyDouble` vs+`767.9605634804993` under `MoneyDecimal`). The cost of that exactness is real and+was measured: in `sim2` (all-pairs purchases over a spill-to-disk ledger),+`MoneyDecimal` ran **~5–7× slower** in wall-clock and used **~15% more memory**+than `MoneyDouble` (consistent at `EA_LASTC`/`EA_LASTTERM` of 40/30 and 80/50 —+e.g. 23.3 s → 4.4 s and 1.42 GB → 1.19 GB at 80/50). The boxed `Integer`-mantissa+decimal arithmetic dominates the runtime, so this is the exactness ↔ speed+trade-off in concrete numbers. `MoneyDouble` is exactly as fast as+bare `Double` (a zero-cost wrapper) and runs everywhere `Double` does — its+subtraction is *signed*, so the negative intermediates that arise inside+`bar` / `(.-)` are fine. (`Number.NonNegative.Double` is **not** a usable value+type for this reason: its `(-)` *errors* on a negative result, which the algebra's+netting produces constantly. Its `HatVal` instance is **deprecated since 0.5.0.0+and will be removed in 0.6** — use `MoneyDouble` for a non-negative-by-convention+FP money type instead.)++**Boundary pattern (simulations).** Keep ABM parameters, input coefficients and+random draws as `Double`, and convert (`realToFrac`) only where a value *enters+the ledger*; convert reported stocks/profits back to `Double` for visualization.+The ledger arithmetic in between is then exact. The bundled bookkeeping and+simulation examples follow this pattern; the numeric-method examples+(`ripple/*`, `CGE`) stay `Double` because they are inherently floating-point.++**Large scale: precision × memory trade-off.** Retaining every posting is `O(n)`+regardless of value type; `MoneyDecimal` adds a constant factor (~2.5× per value box)+on top. For very large simulations weigh exactness against that overhead — or use+the spill-to-disk path (below) to keep memory constant.++**`fromList` ordering contract.** `EJ.fromList` is a strict `O(N)` left fold. It+preserves the *multiset* of postings exactly. When two postings collide on the+same note **and** base they land in one ordered sequence; that sequence's order is+observable through `Eq` / `Show` / `toAlg` / `Binary`, and for `Double` through the+last-ULP of `norm` / `bar`. For `MoneyDecimal` the order never affects+`norm` / `bar` / balance. (`Integer` is intentionally not offered — it cannot+represent the fractional relative prices the ABM work depends on.)++### Migrating to 0.5.0.0++`0.5.0.0` is a major (breaking) release. Most users need no changes — `Double`+ledgers keep working and render identically. Four things to know:++- **Custom `HatVal` instances**: `HatVal` dropped its `RealFloat` superclass and+  added `showValue :: n -> 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).
+ docs/migration-0.5-derived-metrics.md view
@@ -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.
exchangealgebra.cabal view
@@ -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 <https://github.com/yakagika/ExchangeAlgebra#readme> 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
src/ExchangeAlgebra.hs view
@@ -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
+ src/ExchangeAlgebra/Accounting/PostingPolicy.hs view
@@ -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)
src/ExchangeAlgebra/Algebra.hs view
@@ -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.--    <https://www.springer.com/gp/book/9784431209850>--    <https://repository.kulib.kyoto-u.ac.jp/dspace/bitstream/2433/82987/1/0809-7.pdf>---}---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:<Cash .+ 10:@Hat:<Deposits)--- 10.00:@Hat:<Cash .+ 10.00:@Not:<Deposits------ bar calculation--- >>> x = 10:@Not:<Cash .+ 10:@Hat:<Deposits--- >>> y = 5:@Hat:<Cash .+ 5:@Not:<Deposits--- >>> (.-) $ x .+ y--- 5.00:@Not:<Cash .+ 5.00:@Hat:<Deposits------ norm calculation--- >>> norm $ 10:@Not:<Cash .+ 10:@Hat:<Deposits--- 20.0------ (.*) calculation--- >>> (.*) 5 $ 10:@Not:<Cash .+ 10:@Hat:<Deposits--- 50.00:@Not:<Cash .+ 50.00:@Hat:<Deposits------ compress calculation--- >>> compress $ 10:@Not:<Cash .+ 5:@Hat:<Cash .+ 3:@Not:<Cash--- 5.00:@Hat:<Cash .+ 13.00:@Not:<Cash--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. 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:<Yen .+ 1:@Not:<Amount :: Test--- >>> y = 2:@Hat:<Yen .+ 2:@Not:<Amount :: Test--- >>> union x y--- 1.00:@Hat:<Yen .+ 2.00:@Hat:<Yen .+ 1.00:@Not:<Amount .+ 2.00:@Not:<Amount-{-# INLINE union #-}--- | Complexity:---   - singleton/singleton and singleton/liner cases: O(n * d * index-build)---   - liner/liner case: O(n + m) for map union plus O((n+m) * d * index-build)--- where n and m are distinct key counts on each side.-union :: (HatVal n, HatBaseClass b) =>  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:<Cash,1:@Not:<Deposits, 2:@Hat:<Cash, 2:@Not:<Deposits] :: [Test]--- >>> fromList xs--- 1.00:@Hat:<Cash .+ 2.00:@Hat:<Cash .+ 1.00:@Not:<Deposits .+ 2.00:@Not:<Deposits------  >>> type Test = Alg NN.Double (HatBase CountUnit)---  >>> x = 1:@Hat:<Yen .+ 1:@Not:<Amount :: Test---  >>> y = 2:@Hat:<Yen .+ 2:@Not:<Amount :: Test---  >>> fromList [x,y]---  1.00:@Hat:<Yen .+ 2.00:@Hat:<Yen .+ 1.00:@Not:<Amount .+ 2.00:@Not:<Amount--fromList ::(HatVal v, HatBaseClass b ) => [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:<Yen)--- 1.00:@Hat:<Yen .+ 2.00:@Hat:<Yen--{-# INLINE sigma #-}-sigma :: (HatVal v, HatBaseClass b) => [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:<Deposits,10.00:@Hat:<Cash]------ you need define type variables to use this for Zero--- >>> 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:<Yen .+ 1:@Not:<Amount :: Test--- >>> y = 2:@Not:<Yen .+ 2:@Hat:<Amount :: Test--- >>> map (\ (x:@hb) ->  x:@(toHat hb)) $ x .+ y--- 1.00:@Hat:<Yen .+ 2.00:@Hat:<Yen .+ 1.00:@Hat:<Amount .+ 2.00:@Hat:<Amount------ >>> 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:<Yen .+ 1:@Not:<Amount :: Test--- >>> y = 2:@Not:<Yen .+ 2:@Hat:<Amount :: Test--- >>> filter (isHat . _hatBase) $ x .+ y--- 1.00:@Hat:<Yen .+ 2.00:@Hat:<Amount------ >>> type Test = Alg Double (HatBase CountUnit)--- >>> x = 1:@Hat:<Yen .+ 1:@Not:<Amount :: Test--- >>> y = 2:@Not:<Yen .+ 2:@Hat:<Amount :: Test--- >>> filter ((1 <). _val) $ x .+ y--- 2.00:@Not:<Yen .+ 2.00:@Hat:<Amount---filter :: (HatVal v, HatBaseClass b) => (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:<Yen .+ 1:@Not:<Amount :: Test--- >>> y = 2:@Not:<Yen .+ 2:@Hat:<Amount :: Test--- >>> proj [Hat:<Yen] $ x .+ y--- 1.00:@Hat:<Yen------ >>> type Test = Alg NN.Double (HatBase CountUnit)--- >>> x = 1:@Hat:<Yen .+ 1:@Not:<Amount :: Test--- >>> y = 2:@Not:<Yen .+ 2:@Hat:<Amount :: Test--- >>> proj [HatNot:<Amount] $ x .+ y--- 2.00:@Hat:<Amount .+ 1.00:@Not:<Amount------ >>> 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:<Yen :: Test)--- EQ------ >>> type Test = Alg NN.Double (HatBase CountUnit)--- >>> x = 1:@Hat:<Yen .+ 1:@Not:<Amount :: Test--- >>> y = 2:@Not:<Yen .+ 2:@Hat:<Amount :: Test--- >>> proj [Not:<(.#)] $ x .+ y--- 2.00:@Not:<Yen .+ 1.00:@Not:<Amount------------------------------------------------------------------proj :: (HatVal v, HatBaseClass b)  => [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:<Cash .+ 30 :@ Hat:<Cash :: T--- >>> balanceBy [Not:<Cash] [Hat:<Cash] alg--- 70.0------ >>> balanceBy [Hat:<Cash] [Not:<Cash] alg--- -70.0-balanceBy :: (HatVal n, HatBaseClass b) => [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:<Cash .+ 20 :@ Hat:<Deposits .+ 5 :@ Hat:<Cash :: T--- >>> 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.++    <https://www.springer.com/gp/book/9784431209850>++    <https://repository.kulib.kyoto-u.ac.jp/dspace/bitstream/2433/82987/1/0809-7.pdf>++    '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
src/ExchangeAlgebra/Algebra/Base.hs view
@@ -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:<Amount :: HatBase CountUnit)+--  haveWildcard+-- >>> haveWildcard (HatNot:<Amount :: HatBase CountUnit) -- True -- -- (.==)@@ -214,29 +230,29 @@ -- >>> compareHatBase (Not:<Amount :: Test) (Not:<(.#) :: Test) -- EQ ----- ignoreWiledcard--- >>> 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 :<wiledcard+    wildcard = HatNot :<wildcard -    haveWiledcard (h:<b)-        = isWiledcard h-       || haveWiledcard b+    haveWildcard (h:<b)+        = isWildcard h+       || haveWildcard b      {-# INLINE equal #-}     equal (h1:<b1) (h2:<b2) = h1 .== h2 && b1 .== b2 -    ignoreWiledcard (h1:<b1) (h2:<b2)-        = (ignoreWiledcard h1 h2) :< (ignoreWiledcard b1 b2)+    ignoreWildcard (h1:<b1) (h2:<b2)+        = (ignoreWildcard h1 h2) :< (ignoreWildcard b1 b2)       compareElement (h1:<b1) (h2:<b2)@@ -256,19 +272,19 @@     merge = (:<)      {-# INLINE toHat #-}-    toHat (h:<b) = Hat:<b+    toHat (_:<b) = Hat:<b      {-# INLINE toNot #-}-    toNot (h:<b) = Not:<b+    toNot (_:<b) = Not:<b      {-# INLINE revHat #-}     revHat (Hat :< b) = Not :< b     revHat (Not :< b) = Hat :< b      {-# INLINE isHat #-}-    isHat  (Hat :< b)    = True-    isHat  (Not :< b)    = False-    isHat  (HatNot :< b) = customError "called HatNot"+    isHat  (Hat :< _)    = True+    isHat  (Not :< _)    = False+    isHat  (HatNot :< _) = customError "called HatNot"      {-# INLINE isNot #-}     isNot  = not . isHat@@ -277,13 +293,6 @@ -- * Define ExBase ------------------------------------------------------------ --- | Credit/Debit distinction. Credit is the credit side, Debit is the debit side.--- Side is a wildcard.-data Side   = Credit -- ^ Credit side-            | Debit  -- ^ Debit side-            | Side   -- ^ Wildcard-            deriving (Ord, Show, Eq)- -- | Reverse the credit/debit side. Swaps Credit and Debit. -- The wildcard Side is returned unchanged. --@@ -294,62 +303,30 @@ switchSide Debit  = Credit switchSide Side   = Side --- | 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)+-- | Default (home) side of an account division before any contra reversal:+-- Assets\/Cost are debit-normal, Liability\/Equity\/Revenue are credit-normal.+-- The actual home side of a base is this, reversed when 'isContra' holds+-- (contract: @isContra b == (homeSide of b \/= defaultSide (whatDiv b))@).+--+-- Complexity: O(1)+{-# INLINE defaultSide #-}+defaultSide :: AccountDivision -> 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)
+ src/ExchangeAlgebra/Algebra/Base/Account/JcciAliases.hs view
@@ -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 _ = []
+ src/ExchangeAlgebra/Algebra/Base/Account/Registry.hs view
@@ -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)
+ src/ExchangeAlgebra/Algebra/Base/Account/Types.hs view
@@ -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)
src/ExchangeAlgebra/Algebra/Base/Element.hs view
@@ -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)
+ src/ExchangeAlgebra/Algebra/Internal.hs view
@@ -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.++    <https://www.springer.com/gp/book/9784431209850>++    <https://repository.kulib.kyoto-u.ac.jp/dspace/bitstream/2433/82987/1/0809-7.pdf>++-}+++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:<Cash .+ 10:@Hat:<Deposits)+-- 10.00:@Hat:<Cash .+ 10.00:@Not:<Deposits+--+-- bar calculation+-- >>> x = 10:@Not:<Cash .+ 10:@Hat:<Deposits+-- >>> y = 5:@Hat:<Cash .+ 5:@Not:<Deposits+-- >>> (.-) $ x .+ y+-- 5.00:@Not:<Cash .+ 5.00:@Hat:<Deposits+--+-- norm calculation+-- >>> norm $ 10:@Not:<Cash .+ 10:@Hat:<Deposits+-- 20.0+--+-- (.*) calculation+-- >>> (.*) 5 $ 10:@Not:<Cash .+ 10:@Hat:<Deposits+-- 50.00:@Not:<Cash .+ 50.00:@Hat:<Deposits+--+-- compress calculation+-- >>> compress $ 10:@Not:<Cash .+ 5:@Hat:<Cash .+ 3:@Not:<Cash+-- 5.00:@Hat:<Cash .+ 13.00:@Not:<Cash+--+-- == Redundant-algebra axioms (Akagi 2026, Appendix A, Definition 6)+--+-- The operations above satisfy the following /axioms/ (the paper states five;+-- they are verified as QuickCheck properties in @test\/Spec.hs@, see+-- @axiomProperties@):+--+--   1. Hat involution:        @(.^) ((.^) x) = x@+--   2. Scalar on an element:   @a '.*' (v ':@' b) = (a*v) ':@' b@+--   3. Scalar distribution:    @a '.*' (x '.+' y) = (a '.*' x) '.+' (a '.*' y)@+--   4. Norm homogeneity:       @'norm' (a '.*' x) = a * 'norm' x@  (for @a >= 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:<Cash .+ 50:@Not:<Sales :: Alg Double (HatBase AccountTitles))+    -- 150.0+    --+    -- 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+-- 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:<Yen .+ 1:@Not:<Amount :: Test+-- >>> y = 2:@Hat:<Yen .+ 2:@Not:<Amount :: Test+-- >>> union x y+-- 1.00:@Hat:<Yen .+ 2.00:@Hat:<Yen .+ 1.00:@Not:<Amount .+ 2.00:@Not:<Amount+{-# INLINE union #-}+-- | Complexity:+--   - singleton/singleton and singleton/liner cases: O(n * d * index-build)+--   - liner/liner case: O(n + m) for map union plus O((n+m) * d * index-build)+-- where n and m are distinct key counts on each side.+union :: (HatVal n, HatBaseClass b) =>  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:<Cash,1:@Not:<Deposits, 2:@Hat:<Cash, 2:@Not:<Deposits] :: [Test]+-- >>> fromList xs+-- 1.00:@Hat:<Cash .+ 2.00:@Hat:<Cash .+ 1.00:@Not:<Deposits .+ 2.00:@Not:<Deposits+--+--  >>> type Test = Alg Double (HatBase CountUnit)+--  >>> x = 1:@Hat:<Yen .+ 1:@Not:<Amount :: Test+--  >>> y = 2:@Hat:<Yen .+ 2:@Not:<Amount :: Test+--  >>> fromList [x,y]+--  1.00:@Hat:<Yen .+ 2.00:@Hat:<Yen .+ 1.00:@Not:<Amount .+ 2.00:@Not:<Amount++fromList ::(HatVal v, HatBaseClass b ) => [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:<Yen)+-- 1.00:@Hat:<Yen .+ 2.00:@Hat:<Yen++{-# INLINE sigma #-}+sigma :: (HatVal v, HatBaseClass b) => [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:<Deposits,10.00:@Hat:<Cash]+--+-- you need define type variables to use this for Zero+-- >>> 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:<Yen .+ 1:@Not:<Amount :: Test+-- >>> y = 2:@Not:<Yen .+ 2:@Hat:<Amount :: Test+-- >>> map (\ (x:@hb) ->  x:@(toHat hb)) $ x .+ y+-- 1.00:@Hat:<Yen .+ 2.00:@Hat:<Yen .+ 1.00:@Hat:<Amount .+ 2.00:@Hat:<Amount+--+-- >>> 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:<Yen .+ 1:@Not:<Amount :: Test+-- >>> y = 2:@Not:<Yen .+ 2:@Hat:<Amount :: Test+-- >>> filter (isHat . _hatBase) $ x .+ y+-- 1.00:@Hat:<Yen .+ 2.00:@Hat:<Amount+--+-- >>> type Test = Alg Double (HatBase CountUnit)+-- >>> x = 1:@Hat:<Yen .+ 1:@Not:<Amount :: Test+-- >>> y = 2:@Not:<Yen .+ 2:@Hat:<Amount :: Test+-- >>> filter ((1 <). _val) $ x .+ y+-- 2.00:@Not:<Yen .+ 2.00:@Hat:<Amount+++filter :: (HatVal v, HatBaseClass b) => (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:<Yen :: T) :: T+-- 10.00:@Hat:<Yen+--+-- >>> norm (mapBasePart (const Amount) (10:@Not:<Yen .+ 5:@Not:<Dollar :: T) :: T)+-- 15.0+mapBasePart :: (HatVal v, HatBaseClass b, HatBaseClass b')+            => (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:<Yen .+ 1:@Not:<Amount :: Test+-- >>> y = 2:@Not:<Yen .+ 2:@Hat:<Amount :: Test+-- >>> proj [Hat:<Yen] $ x .+ y+-- 1.00:@Hat:<Yen+--+-- >>> type Test = Alg Double (HatBase CountUnit)+-- >>> x = 1:@Hat:<Yen .+ 1:@Not:<Amount :: Test+-- >>> y = 2:@Not:<Yen .+ 2:@Hat:<Amount :: Test+-- >>> proj [HatNot:<Amount] $ x .+ y+-- 2.00:@Hat:<Amount .+ 1.00:@Not:<Amount+--+-- >>> 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:<Yen :: Test)+-- EQ+--+-- >>> type Test = Alg Double (HatBase CountUnit)+-- >>> x = 1:@Hat:<Yen .+ 1:@Not:<Amount :: Test+-- >>> y = 2:@Not:<Yen .+ 2:@Hat:<Amount :: Test+-- >>> proj [Not:<(.#)] $ x .+ y+-- 2.00:@Not:<Yen .+ 1.00:@Not:<Amount+--+------------------------------------------------------------++proj :: (HatVal v, HatBaseClass b)  => [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:<Cash .+ 30 :@ Hat:<Cash :: T+-- >>> balanceBy [Not:<Cash] [Hat:<Cash] alg+-- 70.0+--+-- >>> balanceBy [Hat:<Cash] [Not:<Cash] alg+-- -70.0+balanceBy :: (HatVal n, HatBaseClass b) => [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:<k] - projNetNorm [Hat:<k]@ per key.+-- @keyOf@ sees only the 'BasePart', not the Hat\/Not side, so it cannot split one+-- key across sides.+--+-- This replaces @[ (k, balanceBy [Not:<k] [Hat:<k] alg) | k <- keys ]@ — one+-- wildcard projection per key — with a single fold; the result is identical up to+-- floating-point reassociation. For per-key reporting over many keys this is the+-- difference between @O(keys * entries)@ and @O(entries)@.+--+-- The values are /signed/ net balances and may be negative, so use a signed value+-- type (e.g. 'Double', @MoneyDouble@, @MoneyDecimal@); a non-negative-only type+-- such as @Number.NonNegative.Double@ is unsuitable here. Keys whose net is zero+-- are kept (like 'foldEntriesToMap'); filter afterwards if undesired.+--+-- Complexity: O(total number of entries) — a single fold, no per-key projection.+--+-- >>> type T = Alg Double (HatBase AccountTitles)+-- >>> let alg = 100 :@ Not:<Cash .+ 30 :@ Hat:<Cash .+ 50 :@ Not:<Deposits :: T+-- >>> 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:<Cash .+ 30 :@ Hat:<Cash .+ 50 :@ Not:<Deposits :: T+-- >>> 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:<Cash .+ 20 :@ Hat:<Deposits .+ 5 :@ Hat:<Cash :: T+-- >>> 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:<Cash .+ 30 :@ Hat:<Cash .+ 50 :@ Not:<Deposits :: T+-- >>> 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:<Products .+ 130 :@ Hat:<Products .+ 20 :@ Not:<Cash :: T+-- >>> let shortageKey b = case b of { Hat :< Products -> Just () ; _ -> Nothing }+-- >>> norm (postFromNetBy shortageKey (\_ v -> v :@ Not:<Products .+ v :@ Hat:<Cash) stock)+-- 60.0+{-# INLINE postFromNetBy #-}+postFromNetBy :: (HatVal v, HatBaseClass b, Ord k)+              => (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:<CapitalStock .+ 30:@Not:<Cash .+ 20:@Not:<RetainedEarnings :: Test+-- >>> 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:<AllowanceForDoubtfulAccounts .+ 20:@Hat:<AllowanceForDoubtfulAccounts .+ 30:@Not:<Cash .+ 10:@Hat:<Cash :: Test+-- >>> projContraAssets x+-- 20.00:@Hat:<AllowanceForDoubtfulAccounts .+ 100.00:@Not:<AllowanceForDoubtfulAccounts+projContraAssets :: (HatVal n, ExBaseClass b) => 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" #-}
src/ExchangeAlgebra/Algebra/Transfer.hs view
@@ -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                                                     ++ ",<function>)"@@ -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:<Cash,Hat:<Building,<function>),(Not:<Building,Not:<Cash,<function>)]  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:<Cash,Hat:<Building,<function>),(Hat:<Building,Hat:<Cash,<function>)] {-# 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),<function>),(Not:<(Yen,Building),Not:<(Yen,Cash),<function>)]+-- >>> 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 = "<function>"+-- NB. A universal @instance (HatVal n) => Show (n -> n)@ used to live here for+-- the sake of showing raw rule-list tuples in one doctest. It leaked a function+-- Show instance into every downstream module, so it was removed (design-review+-- C5); 'TransTable''s own 'Show' prints @<function>@ without it.  -- | Build an indexed fast transfer function from a list of transfer rules. -- 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
+ src/ExchangeAlgebra/Assist.hs view
@@ -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
+ src/ExchangeAlgebra/Assist/Descriptions.hs view
@@ -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)
+ src/ExchangeAlgebra/Bookkeeping.hs view
@@ -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.++    <https://www.springer.com/gp/book/9784431209850>++    <https://repository.kulib.kyoto-u.ac.jp/dspace/bitstream/2433/82987/1/0809-7.pdf>++    == 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   (貸) <asset>   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     -- (貸) <asset>++------------------------------------------------------------------+-- * 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   (貸) <expense>   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      -- (貸) <expense>++-- | Deferral of unearned revenue (収益の前受; 前受収益):+--+-- > (借) <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    -- (借) <revenue>+    .+ up   mk amt UnearnedRevenue  -- (貸) 前受収益++-- | Accrual of accrued revenue (収益の未収; 未収収益):+--+-- > (借) 未収収益   amt   (貸) <revenue>   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    -- (貸) <revenue>++-- | Accrual of an accrued expense (費用の未払; 未払費用):+--+-- > (借) <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    -- (借) <expense>+    .+ 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.+--+-- > (借) \<expense\>         current   (貸) \<asset\>   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 分だけ減額)
+ src/ExchangeAlgebra/Consolidation/Worksheet.hs view
@@ -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
+ src/ExchangeAlgebra/Convert.hs view
@@ -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:<Cash+-- >>> postingFromSide Credit Sales (1000 :: Double)+-- 1000.00:@Not:<Sales+postingFromSide :: (HatVal v)+                => 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:<Cash .+ 1000.00:@Not:<Sales+journalFromSides :: (HatVal v)+                 => [(Side, AccountTitles, v)] -> Alg v (HatBase AccountTitles)+journalFromSides = foldr (\(s, a, v) acc -> postingFromSide s a v .+ acc) mempty
+ src/ExchangeAlgebra/Convert/Checked.hs view
@@ -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)
+ src/ExchangeAlgebra/Convert/Csv.hs view
@@ -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:<Cash .+ 1000.00:@Not:<Sales+parseJournalCsv :: (HatVal v, Fractional v)+                => 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)
src/ExchangeAlgebra/Journal.hs view
@@ -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:<Cash .| z) | z <- ["Loan Payment","Purchace Apple"]] :: [Test] -- >>> fromList x -- 1.00:@Hat:<Cash.|"Purchace Apple" .+ 1.00:@Hat:<Cash.|"Loan Payment"------ NOTE: kept as @foldr (.+) mempty@ deliberately. A strict @foldl'@ merge was--- tried (plan WI-1) but it changes the accumulation order. This is a redundant--- algebra that preserves same-base postings as an ordered sequence (audit trail),--- and 'Double' addition is non-associative, so reordering shifts the last-ULP--- result of 'norm' and breaks exact-value tests (doctest here + sim1). Reordering--- is an observable behaviour change, not a transparent optimization.--- See plans/in-progress/LAZY_EVAL_AUDIT.md (WI-1) for the safe redesign. fromList :: (HatVal v, HatBaseClass b, Note n)          => [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:<Cash .+ 30 :@ Hat:<Cash .+ 50 :@ Not:<Deposits :: Alg Double (HatBase AccountTitles)+-- >>> 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:<Cash .| "A" :: Test@@ -582,13 +718,15 @@ -- 20.00:@Not:<Cash.|"B" .+ 30.00:@Hat:<Cash.|"A" insert :: (HatVal v, HatBaseClass b, Note n)         => 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:<Yen .+ 1.00:@Not:<Amount .| "cat"  :: Test -- >>> y = 2.00:@Hat:<Yen .+ 2.00:@Not:<Amount .| "dog"  :: Test@@ -623,24 +761,36 @@ -- 3.00:@Not:<Amount.|"fish" .+ 1.00:@Not:<Amount.|"cat" projWithBase :: (HatVal v, HatBaseClass b, Note n)              => [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:<Yen .+ 1.00:@Not:<Amount .| "cat"  :: Test -- >>> y = 2.00:@Not:<Yen .+ 2.00:@Hat:<Amount .| "dog"  :: Test@@ -649,7 +799,7 @@ -- 3.00:@Not:<Amount.|"fish" projWithNoteBase :: (HatVal v, HatBaseClass b, Note n)                  => [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)
src/ExchangeAlgebra/Journal/Transfer.hs view
@@ -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
+ src/ExchangeAlgebra/Optimize.hs view
@@ -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)
+ src/ExchangeAlgebra/Optimize/Annealing.hs view
@@ -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
+ src/ExchangeAlgebra/Optimize/GA.hs view
@@ -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
+ src/ExchangeAlgebra/Reporting/Group.hs view
@@ -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 ]
+ src/ExchangeAlgebra/Reporting/Metric.hs view
@@ -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)
+ src/ExchangeAlgebra/Reporting/Presentation.hs view
@@ -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]+    )
src/ExchangeAlgebra/Simulate.hs view
@@ -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
+ src/ExchangeAlgebra/Simulate/Lite.hs view
@@ -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 @<<loop>>@ (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))
+ src/ExchangeAlgebra/Simulate/Network.hs view
@@ -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:<Amount) .| (i,j) :: J+-- >>> 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
+ src/ExchangeAlgebra/Simulate/Policy.hs view
@@ -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
+ src/ExchangeAlgebra/Simulate/Spill.hs view
@@ -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
src/ExchangeAlgebra/Simulate/Visualize.hs view
@@ -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
+ src/ExchangeAlgebra/TrialBalance/Balance.hs view
@@ -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)
+ src/ExchangeAlgebra/TrialBalance/Validation.hs view
@@ -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+    ]
+ src/ExchangeAlgebra/Value.hs view
@@ -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:<Cash .+ 2 :@ Not:<Sales   -- 10.5 and 2 are MoneyDecimal literals++    == Rounding++    The core algebra only adds/subtracts, which is exact for t'MoneyDecimal' and needs no+    rounding. Rounding is only needed by /multiplication and division/ (tax ratios,+    proration, scalar product) at the point a monetary amount is /finalised/. Use+    'bankersRound': it rounds half-to-even (the unbiased financial default; also GHC's+    'Prelude.round' and IEEE-754's default mode). A ceiling variant ('ceilingRound') is+    provided for the previous @rounding = ceiling@ behaviour and for jurisdictions whose+    rules differ. There is no single correct rule (e.g. Japanese consumption tax rounding+    varies by company), so the rounding function is explicit and swappable.+-}+module ExchangeAlgebra.Value+    ( MoneyDecimal(..)+    , toDecimal+    , bankersRound+    , ceilingRound+    , MoneyDouble(..)+    , toDouble+    ) where++import           ExchangeAlgebra.Algebra (HatVal (..), Nearly (..))+import           Data.Decimal            (Decimal, DecimalRaw (Decimal), roundTo')+import           Data.Word               (Word8)+import           Data.Hashable           (Hashable (..))+import           Control.DeepSeq         (NFData (..))+import qualified Data.Binary             as Binary++-- | A non-negative exact decimal value (wraps 'Data.Decimal.Decimal').+--+-- Non-negativity is a /soft/ invariant, the same as for the @Double@ instance:+-- it is not enforced by the constructor (intermediate subtraction inside @bar@/@(.-)@+-- can produce negatives), but 'isErrorValue' reports @x < 0@ so the @(.@)@ smart+-- constructor rejects negative postings.+newtype MoneyDecimal = MoneyDecimal Decimal+  -- Num/Fractional are derived so numeric literals (@10.5@, @0.08@) work directly,+  -- with no @MoneyDecimal@ wrapper at use sites. Show/Eq/Ord delegate to t'Decimal'.+  -- 'Real' (and thus 'toRational') is derived so values can be converted to/from+  -- @Double@ via 'realToFrac' at the simulation boundary: ABM parameters, input+  -- coefficients and random draws stay 'Double', and are converted to t'MoneyDecimal'+  -- only where they enter a ledger; final stock/profit amounts convert back for+  -- reporting. The ledger arithmetic in between is exact.+  deriving newtype (Eq, Ord, Show, Num, Fractional, Real)++-- | Project out the underlying t'Decimal'.+toDecimal :: MoneyDecimal -> 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)
src/ExchangeAlgebra/Write.hs view
@@ -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 | <titles...> | Total+-- >       | <values...> | <asset total>+-- > Liability | <titles...> | Equity | <titles...> | Total+-- >           | <values...> |        | <values...> | <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:<Cash) .+ (60 .@ Not:<LoansPayable) .+ (40 .@ Not:<CapitalStock) :: T+-- >>> 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:<AccountsReceivable) .+ (100 .@ Not:<AllowanceForDoubtfulAccounts) .+ (900 .@ Not:<CapitalStock) :: T+-- >>> 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 | <titles...> | Total+-- >      | <values...> | <revenue total>+-- > Revenue | <titles...> | Total+-- >         | <values...> | <cost 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:<Sales) .+ (300 .@ Not:<SalesCost) :: T+-- >>> 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:<SalesRebates) :: T+-- >>> 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:+--+-- > <Title>+-- > 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)--------------------------------------------------------------------
test/Spec.hs view
@@ -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
test/doctests.hs view
@@ -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"]