exchangealgebra (empty) → 0.4.0.0
raw patch · 17 files changed
+7086/−0 lines, 17 filesdep +Chartdep +Chart-cairodep +arraysetup-changed
Dependencies added: Chart, Chart-cairo, array, async, base, binary, bytestring, containers, deepseq, directory, doctest, exchangealgebra, hashable, mtl, non-negative, numeric-prelude, parallel, random, scientific, text, time, unicode-show, unordered-containers, vector
Files
- ChangeLog.md +76/−0
- LICENSE +39/−0
- README.md +256/−0
- Setup.hs +2/−0
- exchangealgebra.cabal +134/−0
- src/ExchangeAlgebra.hs +64/−0
- src/ExchangeAlgebra/Algebra.hs +1399/−0
- src/ExchangeAlgebra/Algebra/Base.hs +596/−0
- src/ExchangeAlgebra/Algebra/Base/Element.hs +612/−0
- src/ExchangeAlgebra/Algebra/Transfer.hs +688/−0
- src/ExchangeAlgebra/Journal.hs +739/−0
- src/ExchangeAlgebra/Journal/Transfer.hs +145/−0
- src/ExchangeAlgebra/Simulate.hs +699/−0
- src/ExchangeAlgebra/Simulate/Visualize.hs +573/−0
- src/ExchangeAlgebra/Write.hs +317/−0
- test/Spec.hs +740/−0
- test/doctests.hs +7/−0
+ ChangeLog.md view
@@ -0,0 +1,76 @@+# Changelog for ExchangeAlgebra++## 0.4.0.0 - 2026-05-18++First release prepared for Hackage publication.++### Highlights+- First Hackage-ready release with full metadata and dependency version bounds.+- LSM-style `Journal` with spill-to-disk support for large simulations.+- Significant performance improvements across `Algebra`, `Journal`, and the simulation engine.++### Added+- LSM-style `Journal` data structure with spill engine and binary spill restore.+- Boilerplate-reducing helpers for state-space simulation+ (`UpdatableSTRef`, `UpdatableSTArray`, generalized `Updatable` instances).+- Sparse `sigma` map APIs (`sigmaFromMap`, `sigma2When`, `sigmaOnFromMap`, etc.)+ and a map-based fold path for purchases.+- `filterByAxis` for `Journal` and matching tests.+- `finalStockTransfer` fast path for both `Algebra` and `Journal`.+- `restoreJournalFromBinarySpill` and related spill utilities in `ExchangeAlgebra.Write`.+- New examples covering ripple-effect and stock simulations.+- Self-contained `writeCSV` / `csvTranspose` in `ExchangeAlgebra.Write`+ (removes the previous Git-only `csv-parser` dependency).++### Changed+- Refactored Journal axis indexing for nested-`IntMap` storage.+- Refactored `ExchangeAlgebra.Algebra` and the simulation pipeline for sparse processing.+- Optimized projection paths (`proj`, `projNorm`, `projWithBaseNorm`, `projWithNoteNorm`).+- Optimized `Hashable` / `Binary` instances and `Element` equality.+- Optimized the transfer engine and `finalStockTransfer` path.+- Refined `sim2` readability and stabilized build warnings.++### Fixed+- Debit/credit side classification and related accounting outputs.+- Various ripple seed comparison output mismatches.++### Build / packaging+- Bumped Stackage resolver from `lts-22.6` (GHC 9.6.3) to `lts-24.4` (GHC 9.10.2).+- Added explicit version bounds for all library dependencies.+- Added `synopsis`, `category`, and corrected `description` URL in `package.yaml`.+- Removed Git-only `csv-parser` (CSVParserT) dependency, replaced with+ in-tree `writeCSV` / `csvTranspose` in `ExchangeAlgebra.Write`.+- Added CSV write tests (`testCsvWriteCSV`, `testCsvTranspose`, etc.).+- Removed unused `bifunctors` dependency (dead import in `ExchangeAlgebra.Algebra`).++### Breaking changes+- Removed the non-hierarchical top-level module `ExchangeAlgebraJournal`.+ Use `ExchangeAlgebra.Journal` (for the Journal data model) or the+ top-level `ExchangeAlgebra` (for the Algebra data model) instead.+ The `ExchangeAlgebra` top-level remains an Algebra-layer umbrella; Journal+ users should import `ExchangeAlgebra.Journal` as the unqualified umbrella+ and qualify `ExchangeAlgebra.Algebra` as needed.++### Documentation+- Added extension guidance and import guidance to the Haddock of+ `ExchangeAlgebra.Algebra.Base.Element`, clarifying that user code should+ import `Element` via the higher-level umbrella modules.++## 0.3.0.0++- Integrated the high-speed `ExchangeAlgebra.Map` library into the main `ExchangeAlgebra` module.+- Added basic ripple-effect modules and Leontief inverse computation.+- Switched the internal data structure to `HashMap` for faster lookups.+- Added `ExchangeAlgebra.Simulate` and parallelized ripple effect computation.+- Generalized simulation functions and adopted `ST s` for `StateSpace`.+- Added `sigma` / `sigmaM` helpers for summation over indices.++## 0.2.0.0++- Added `ExchangeAlgebra.Journal` (Journal with summary support).+- Added initial example programs and test infrastructure.++## 0.1.0.0++- Initial development release of the Exchange Algebra library+ (algebraic description of bookkeeping based on Hiroshi Deguchi's framework).
+ LICENSE view
@@ -0,0 +1,39 @@+Open World License++Copyright 2019 Kaya Akagi++We require the following additional license in addition to the MIT license.+We believe that open source software should contribute to promoting more openness+and more diversity of societies.+When you check yes of all the following checklist then you can use this software+under the MIT license. This Open World License should be included in this software.++(1) I love the diversity of societies.+(2) I hate dictatorship. +(3) I love the openness of societies.+(4) I can access the Internet freely in a place where this software is used.+(5) The customer can access the Internet freely in the place where the+ application system, that is developed by this software, will be used.+++MIT License++Copyright (c) 2019 Kaya Akagi++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,256 @@+# exchangealgebra++`exchangealgebra` is a Haskell library for [Exchange Algebra](https://www.springer.com/gp/book/9784431209850),+an algebraic description of bookkeeping systems developed by Hiroshi Deguchi. It treats bookkeeping entries+as elements of a scaled basis algebra, so journaling, closing, transfer, and simulation can be written as+function composition and projection.++The library is used in the preprint+[*Accounting State Space as the Minimal Unit for Economic Agent-Based Modeling*](https://doi.org/10.21203/rs.3.rs-8485050/v1)+(Akagi, 2026) as the minimal unit for economic agent-based simulation and+ripple-effect analysis. See the [Publications section](#publications-using-this-library) for citation details.++- Book: <https://www.springer.com/gp/book/9784431209850>+- Paper: <https://repository.kulib.kyoto-u.ac.jp/dspace/bitstream/2433/82987/1/0809-7.pdf>+- Haddock: [haddock/index.html](https://htmlpreview.github.io/?https://raw.githubusercontent.com/yakagika/ExchangeAlgebra/master/haddock/index.html)++## Installation++The package is on Hackage. Pin a specific version in your Stack project:++```yaml+# stack.yaml+extra-deps:+ - exchangealgebra-0.4.0.0+```++```yaml+# package.yaml (your project)+dependencies:+ - exchangealgebra+```++If you need an unreleased revision, you can also point `extra-deps` at a+specific Git commit instead:++```yaml+extra-deps:+ - git: https://github.com/yakagika/ExchangeAlgebra.git+ commit: <commit-sha>+```++Requirements:+- 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`)++## How to consume this package++Three common use cases:++### 1. Use it as a library dependency++Add `exchangealgebra` to your project's `build-depends` via the Hackage+`extra-deps` pin above (or the Git pin for unreleased revisions). The+`examples/` directory is **not** needed for this; it is only shipped in+this Git repository.++### 2. Run the bundled examples++Clone the repository and build from the root:++```bash+git clone https://github.com/yakagika/ExchangeAlgebra.git+cd ExchangeAlgebra+stack build+stack exec -- sim1 # or ebex1, ripple, cge, ...+```++See the [examples directory](https://github.com/yakagika/ExchangeAlgebra/tree/master/examples)+for the full catalogue and runtime prerequisites (uv for Python plots,+output directories, etc.).++### 3. Copy or fork a single example++If you want to start from one example without pulling the whole repository,+[`degit`](https://github.com/Rich-Harris/degit) (or its maintained successor `tiged`)+lets you grab just the subtree without git history:++```bash+npx degit yakagika/ExchangeAlgebra/examples my-examples+cd my-examples+# then edit freely as a starting point+```++A Git sparse-checkout with a standalone `examples/stack.yaml` is planned so that+`cd examples && stack build` works after a sparse-clone; this will land together+with the first Hackage release.++## Module Overview++The public modules are organised into two parallel layers.++### Foundation layer (Algebra)++|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`)|++### Journal layer — metadata-aware basis algebra++|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`)|++### Simulation / IO layer++|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|++### Umbrella entry modules++|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|++Importing both `ExchangeAlgebra` and `ExchangeAlgebra.Journal` unqualified causes name+collisions on `sigma`, `fromList`, `map`, `filter`, and friends. See the recommended import+patterns below.++## Recommended import patterns++### Simple single-period bookkeeping++```haskell+import ExchangeAlgebra -- Algebra-layer umbrella++main = do+ let e = 100 :@ Hat :< Cash .+ 100 :@ Not :< Sales+ putStr (showBS e)+```++### Journal-based work (multi-period, notes, simulation)++```haskell+import ExchangeAlgebra.Journal -- pulls in the type classes and the Journal API+import qualified ExchangeAlgebra.Algebra as EA+import qualified ExchangeAlgebra.Journal as EJ+import qualified ExchangeAlgebra.Journal.Transfer as EJT+import qualified ExchangeAlgebra.Simulate as ES+import ExchangeAlgebra.Simulate -- unqualified, for StateSpace, Updatable, etc.+import ExchangeAlgebra.Write -- writeBS / writeIOMatrix and friends+```++Even in Journal-centric code you will frequently reach into the Algebra layer (for the `Alg`+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.**++## A note on visualization++`ExchangeAlgebra.Simulate.Visualize` provides Chart-based PNG rendering, but **we recommend+writing CSV output and visualising it from a separate Python script** for production-quality+plotting.++### Why++- Chart / Chart-cairo transitively pull in cairo / pango / freetype system libraries, which+ makes the build environment heavier to set up.+- For academic work, matplotlib / seaborn / pandas are more flexible than Chart.+- Using CSV as an intermediate format cleanly separates "compute" from "plot".+- The same CSVs can be reused with R / Julia / Excel if you need them.++### Recommended workflow++```haskell+-- Haskell side: write the simulation outputs to CSV+import ExchangeAlgebra.Write (writeIOMatrix)+import qualified ExchangeAlgebra.Simulate.Visualize as ESV+ -- qualified access to writeFuncResults etc.++main = do+ -- ... run the simulation ...+ writeIOMatrix "result/io.csv" matrix+ ESV.writeFuncResults header range world "result/profit.csv"+```++```bash+# Plotting side: run a standalone script with uv + PEP 723 inline deps+uv run --script visualize.py+```++```python+# visualize.py+# /// script+# requires-python = ">=3.10"+# dependencies = ["pandas>=2.0", "matplotlib>=3.7"]+# ///+import pandas as pd, matplotlib.pyplot as plt+df = pd.read_csv("result/profit.csv")+df.plot(); plt.savefig("result/profit.png")+```++Concrete runnable examples of this pattern live under the `examples/` sub-package+(see [the examples directory on GitHub](https://github.com/yakagika/ExchangeAlgebra/tree/master/examples)).++### If you still want to plot from Haskell++If keeping everything in Haskell is important to your workflow, `plotLineVector`,+`plotMultiLines`, and `plotWldsDiffLine` in `ExchangeAlgebra.Simulate.Visualize` write PNGs+directly and work without any Python setup.++## Examples++Runnable usage examples are collected in the `examples/` sub-package on GitHub.+See the [examples directory](https://github.com/yakagika/ExchangeAlgebra/tree/master/examples)+and its [README](https://github.com/yakagika/ExchangeAlgebra/blob/master/examples/README.md) for details.++```bash+stack build+stack exec -- ebex1 # Introductory bookkeeping example+stack exec -- sim1 # 100-term simulation (+ Python visualization)+stack exec -- ripple # 10-agent ripple-effect simulation+stack exec -- cge # CGE model+```++## Documentation++- Haddock: <https://htmlpreview.github.io/?https://raw.githubusercontent.com/yakagika/ExchangeAlgebra/master/haddock/index.html>+- A tutorial / guided walkthrough is planned, based on an upcoming paper.++## License++Dual licensed under MIT and the Open World License (OWL). See `LICENSE` for details.++## Publications using this library++- Kaya Akagi.+ *Accounting State Space as the Minimal Unit for Economic Agent-Based+ Modeling: Advancing Ripple Effect Analysis in Real-Time Economy.*+ Research Square, preprint (Version 1), posted 5 January 2026.+ DOI: [10.21203/rs.3.rs-8485050/v1](https://doi.org/10.21203/rs.3.rs-8485050/v1)++ The ripple-effect simulations reported in this preprint are driven by+ `ExchangeAlgebra.Simulate` and the ripple example family under+ [`examples/deterministic/ripple/`](https://github.com/yakagika/ExchangeAlgebra/tree/master/examples/deterministic/ripple).++If you use this library in academic work, please cite the preprint above.+A `CITATION.cff` file at the repository root provides BibTeX and+plain-text forms via GitHub's "Cite this repository" button.++## References++- Hiroshi Deguchi. *Economics as an Agent-Based Complex System:+ Toward Agent-Based Social Systems Sciences.* Springer, 2004.+ ISBN 978-4-431-20985-0.+ <https://openlibrary.org/isbn/9784431209850>+- Hiroshi Deguchi. Exchange Algebra (PDF).+ <https://repository.kulib.kyoto-u.ac.jp/dspace/bitstream/2433/82987/1/0809-7.pdf>
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ exchangealgebra.cabal view
@@ -0,0 +1,134 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: b82362d388c7bd4bf8ed038200e10484428d995a6bab1ebd91c900e9f8c1acbe++name: exchangealgebra+version: 0.4.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+homepage: https://github.com/yakagika/ExchangeAlgebra#readme+bug-reports: https://github.com/yakagika/ExchangeAlgebra/issues+author: Kaya Akagi+maintainer: yakagika@icloud.com+copyright: 2018-2026 Kaya Akagi+license: OtherLicense+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/yakagika/ExchangeAlgebra++library+ exposed-modules:+ ExchangeAlgebra+ ExchangeAlgebra.Algebra+ ExchangeAlgebra.Algebra.Base+ ExchangeAlgebra.Algebra.Base.Element+ ExchangeAlgebra.Algebra.Transfer+ ExchangeAlgebra.Journal+ ExchangeAlgebra.Journal.Transfer+ ExchangeAlgebra.Simulate+ ExchangeAlgebra.Simulate.Visualize+ ExchangeAlgebra.Write+ other-modules:+ Paths_exchangealgebra+ hs-source-dirs:+ src+ build-depends:+ Chart ==1.9.*+ , Chart-cairo ==1.9.*+ , array >=0.5.5 && <0.6+ , async ==2.2.*+ , base >=4.17 && <5+ , binary ==0.8.*+ , bytestring >=0.11 && <0.13+ , 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.*+ , random ==1.2.*+ , scientific >=0.3.7 && <0.4+ , text >=2.0 && <2.2+ , time >=1.12 && <1.15+ , unicode-show ==0.1.*+ , unordered-containers >=0.2.19 && <0.3+ , vector ==0.13.*+ default-language: Haskell2010++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+ build-depends:+ Chart ==1.9.*+ , Chart-cairo ==1.9.*+ , array >=0.5.5 && <0.6+ , async ==2.2.*+ , base >=4.17 && <5+ , binary ==0.8.*+ , bytestring >=0.11 && <0.13+ , containers >=0.6 && <0.8+ , deepseq >=1.4 && <1.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.*+ , random ==1.2.*+ , scientific >=0.3.7 && <0.4+ , text >=2.0 && <2.2+ , time >=1.12 && <1.15+ , unicode-show ==0.1.*+ , unordered-containers >=0.2.19 && <0.3+ , vector ==0.13.*+ default-language: Haskell2010++test-suite ExchangeAlgebra-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_exchangealgebra+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-Wl,-no_warn_duplicate_libraries+ build-depends:+ Chart ==1.9.*+ , Chart-cairo ==1.9.*+ , array >=0.5.5 && <0.6+ , async ==2.2.*+ , base >=4.17 && <5+ , binary ==0.8.*+ , bytestring >=0.11 && <0.13+ , containers >=0.6 && <0.8+ , deepseq >=1.4 && <1.6+ , directory ==1.3.*+ , 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.*+ , random ==1.2.*+ , scientific >=0.3.7 && <0.4+ , text >=2.0 && <2.2+ , time >=1.12 && <1.15+ , unicode-show ==0.1.*+ , unordered-containers >=0.2.19 && <0.3+ , vector ==0.13.*+ default-language: Haskell2010
+ src/ExchangeAlgebra.hs view
@@ -0,0 +1,64 @@+++{- |+ Module : ExchangeAlgebra+ 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>++ == Quick start++ 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+ recommended entry point for simple single-period bookkeeping:++ > import ExchangeAlgebra+ >+ > -- A minimal exchange: 100 units of cash debited, 100 credited to sales.+ > entry :: Alg Double (HatBase AccountTitles)+ > entry = 100 :@ Hat :< Cash .+ 100 :@ Not :< Sales++ 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+ code should use qualified imports for the Algebra layer:++ > import ExchangeAlgebra.Journal -- umbrella + type classes+ > import qualified ExchangeAlgebra.Algebra as EA+ > import qualified ExchangeAlgebra.Journal as EJ+ > import qualified ExchangeAlgebra.Journal.Transfer as EJT++ == Full examples++ Runnable examples (elementary bookkeeping, ripple-effect simulations,+ a CGE model) live in the repository, not on Hackage:++ <https://github.com/yakagika/ExchangeAlgebra/tree/master/examples>++ See the repository's @README.md@ for installation and consumption+ patterns.++-}+++module ExchangeAlgebra+ ( module ExchangeAlgebra.Algebra+ , module ExchangeAlgebra.Algebra.Transfer+ , module ExchangeAlgebra.Write+ , module ExchangeAlgebra.Simulate ) where++import ExchangeAlgebra.Algebra+import ExchangeAlgebra.Algebra.Transfer+import ExchangeAlgebra.Write+import ExchangeAlgebra.Simulate
+ src/ExchangeAlgebra/Algebra.hs view
@@ -0,0 +1,1399 @@+{-# 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+ , 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 Control.Parallel.Strategies (rpar, rseq, runEval, using, Strategy, rdeepseq)+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.+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 = error $ "on isNearlyNum: " ++ show x ++ ", " ++ show y++------------------------------------------------------------+-- * 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+union (v1:@b1) (v2:@b2)+ | isZeroValue v1 = case isZeroValue v2 of+ True -> Zero+ False -> v2:@b1+ | isZeroValue v2 = v1:@b2+ | 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 isNearlyNum h n 1e-13 of -- precision 13 digits+ 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+ balance xs | (norm . decR) xs == (norm . decL) xs = True+ | otherwise = False++ -- |+ diffRL xs | r > l = (Credit, r - l)+ | l > r = (Debit, l -r)+ | otherwise = (Side,0)+ 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) hs++ 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 isNearlyNum h n 1e-13+ 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
+ src/ExchangeAlgebra/Algebra/Base.hs view
@@ -0,0 +1,596 @@+{- |+ Module : ExchangeAlgebra.Algebra.Base+ 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>++-}++{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE DeriveGeneric #-}+++module ExchangeAlgebra.Algebra.Base+ ( module ExchangeAlgebra.Algebra.Base+ , module ExchangeAlgebra.Algebra.Base.Element) where++import ExchangeAlgebra.Algebra.Base.Element++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+customError msg = error (msg ++ "\nCallStack:\n" ++ prettyCallStack callStack)++------------------------------------------------------------------+-- * Base conditions+------------------------------------------------------------------++-- ** Base+------------------------------------------------------------------+{- | Base class definition.+ Any type that is an instance of this class qualifies as a base.+-}++class (Element a) => BaseClass a where+ compareBase :: a -> a -> Ordering+ compareBase = compareElement++instance (Element e1, Element e2)+ => BaseClass (e1, e2) where++instance (Element e1, Element e2, Element e3)+ => BaseClass (e1, e2, e3) where++instance (Element e1, Element e2, Element e3, Element e4)+ => BaseClass (e1, e2, e3, e4) where++instance (Element e1, Element e2, Element e3, Element e4, Element e5)+ => BaseClass (e1, e2, e3, e4, e5) where++instance (Element e1, Element e2, Element e3, Element e4, Element e5, Element e6)+ => BaseClass (e1, e2, e3, e4, e5, e6) 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.+class (BaseClass a, BaseClass (BasePart a), AxisDecompose (BasePart a)) => HatBaseClass a where+ -- | The type of the base part excluding the Hat.+ type BasePart a+ -- | Extract the base part excluding the Hat. Complexity: O(1)+ base :: (BaseClass (BasePart a)) => a -> BasePart a+ -- | Extract the Hat part. Complexity: O(1)+ hat :: a -> Hat++ -- | Reconstruct a base from a Hat and a BasePart. Complexity: O(1)+ merge :: Hat -> BasePart a -> a++ -- | Convert to the Hat side. Complexity: O(1)+ toHat :: a -> a+ -- | Convert to the Not side. Complexity: O(1)+ toNot :: a -> a+ -- | Reverse Hat/Not. Complexity: O(1)+ revHat :: a -> a+ -- | Test whether the base is Hat. Complexity: O(1)+ isHat :: a -> Bool+ -- | Test whether the base is Not. Complexity: O(1)+ isNot :: a -> Bool++ -- | Compare bases with Hat. Defaults to 'compareBase'. Complexity: O(k)+ compareHatBase :: a -> a -> Ordering+ compareHatBase = compareBase++------------------------------------------------------------------+-- | Hat definition+data Hat = Hat+ | Not+ | HatNot+ deriving (Enum, Eq, Ord, Show, Generic)++instance Hashable Hat where+instance Binary.Binary Hat++instance Element Hat where+ wiledcard = HatNot++ {-# INLINE equal #-}+ equal Hat Hat = True+ equal Hat Not = False+ equal Not Hat = False+ equal Not Not = True+ equal _ _ = True++instance BaseClass Hat where++data BaseForSingleHat = BaseForSingleHat+ deriving (Eq,Ord,Generic)++instance Show BaseForSingleHat where+ show _ = ""++instance Hashable BaseForSingleHat where+instance Binary.Binary BaseForSingleHat++instance Element BaseForSingleHat where+ wiledcard = BaseForSingleHat+ equal _ _ = True++instance BaseClass BaseForSingleHat where++instance HatBaseClass Hat where+ type BasePart Hat = BaseForSingleHat+ hat = id+ base x = BaseForSingleHat++ merge Hat _ = Hat+ merge Not _ = Not++ {-# INLINE toHat #-}+ toHat _ = Hat++ {-# INLINE toNot #-}+ toNot _ = Not++ {-# INLINE revHat #-}+ revHat Hat = Not+ revHat Not = Hat++ {-# INLINE isHat #-}+ isHat Hat = True+ isHat Not = False++ {-# INLINE isNot #-}+ isNot = not . isHat+------------------------------------------------------------------++-- | Base with Hat. Attaches a Hat (decrease) / Not (increase) label to a base+-- element such as an account title. Use the constructor @(:<)@ as in @Hat :< Cash@.+data HatBase a where+ (:<) :: (BaseClass a) => {_hat :: Hat, _base :: a } -> HatBase a++instance (BaseClass a, Binary.Binary a) => Binary.Binary (HatBase a) where+ put (h :< b) = Binary.put h >> Binary.put b+ get = (:<) <$> Binary.get <*> Binary.get++instance Show (HatBase a) where+ show (h :< b) = show h ++ ":<" ++ show b++instance Eq (HatBase a) where+ {-# INLINE (==) #-}+ (==) (h1 :< b1) (h2 :< b2) = h1 == h2 && b1 == b2+ {-# INLINE (/=) #-}+ (/=) x y = not (x == y)++instance Ord (HatBase a) where+ {-# INLINE compare #-}+ compare (h :< b) (h' :< b') =+ case compare b b' of+ EQ -> compare h h'+ x -> x++instance (BaseClass a) => Hashable (HatBase a) where+ hashWithSalt salt (h:<b) = salt `hashWithSalt` h+ `hashWithSalt` b++-- | Element (HatBase a)+-- haveWiledcard+-- >>> haveWiledcard (HatNot:<Amount :: HatBase CountUnit)+-- True+--+-- (.==)+-- >>> Not:<(Cash, Yen) == Not:<(Cash,(.#))+-- False+--+-- >>> Not:<(Cash, Yen) .== Not:<(Cash,(.#))+-- True+--+-- compareElement+-- >>> type Test = HatBase CountUnit+-- >>> compareHatBase (Not:<Amount :: Test) (Not:<(.#) :: Test)+-- EQ+--+-- ignoreWiledcard+-- >>> ignoreWiledcard (Not:<(Products,Yen)) (Hat:<(Products,Amount))+-- Hat:<(Products,Amount)+--+-- >>> ignoreWiledcard (Not:<(Products,Yen)) (Hat:<(Products,(.#)))+-- Hat:<(Products,Yen)+--+-- >>> ignoreWiledcard (Not:<(Cash,(.#))) (HatNot:<((.#),Amount))+-- Not:<(Cash,Amount)+++instance (BaseClass a) => Element (HatBase a) where+ wiledcard = HatNot :<wiledcard++ haveWiledcard (h:<b)+ = isWiledcard h+ || haveWiledcard b++ {-# INLINE equal #-}+ equal (h1:<b1) (h2:<b2) = h1 .== h2 && b1 .== b2++ ignoreWiledcard (h1:<b1) (h2:<b2)+ = (ignoreWiledcard h1 h2) :< (ignoreWiledcard b1 b2)+++ compareElement (h1:<b1) (h2:<b2)+ = case compareElement b1 b2 of+ EQ -> compareElement h1 h2+ x -> x++instance (BaseClass a) => BaseClass (HatBase a) where++instance (BaseClass a, AxisDecompose a) => HatBaseClass (HatBase a) where+ type BasePart (HatBase a) = a++ hat = _hat++ base = _base++ merge = (:<)++ {-# INLINE toHat #-}+ toHat (h:<b) = Hat:<b++ {-# INLINE toNot #-}+ toNot (h:<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"++ {-# INLINE isNot #-}+ isNot = not . isHat++------------------------------------------------------------+-- * 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.+--+-- Complexity: O(1)+{-# INLINE switchSide #-}+switchSide :: Side -> Side+switchSide Credit = Debit+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)++-- | 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++-- | BaseClass ⊃ HatBaseClass ⊃ ExBaseClass+--+-- Extended type class for bases that carry an account title.+-- Provides access to and modification of account titles, account divisions, PIMO classification,+-- credit/debit determination, and fixed/current classification.+class (HatBaseClass a) => ExBaseClass a where+ -- | Retrieve the account title from a base. Complexity: O(1)+ getAccountTitle :: a -> AccountTitles++ -- | Change the account title of a base. Complexity: O(1)+ setAccountTitle :: a -> AccountTitles -> a++ -- | Account title setter operator. An alias for @setAccountTitle@. Complexity: O(1)+ {-# INLINE (.~) #-}+ (.~) :: a -> AccountTitles -> a+ (.~) = setAccountTitle++ -- | Retrieve the account division (Assets/Equity/Liability/Cost/Revenue). Complexity: O(1)+ {-# INLINE whatDiv #-}+ whatDiv :: a -> AccountDivision+ whatDiv = classifyAccountDivision . getAccountTitle++ -- | Retrieve the PIMO classification (PS/IN/MS/OUT). Complexity: O(1)+ {-# INLINE whatPIMO #-}+ whatPIMO :: a -> PIMO+ whatPIMO x =+ case whatDiv x of+ Assets -> PS+ Equity -> MS+ Liability -> MS+ Cost -> OUT+ Revenue -> IN++ -- | Determine whether a base belongs to the Credit or Debit side.+ -- Takes the Hat/Not reversal into account. 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 ..]++ -- | Retrieve the fixed/current classification.+ -- Returns Current, Fixed, or Other based on the account title.+ --+ -- 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+++-- | Type class for determining correspondences between account divisions.+-- Tests whether two account divisions form a pair in double-entry bookkeeping+-- (e.g., Assets <=> Liability).+--+-- Complexity: O(1)+class AccountBase a where+ -- | 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)++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++-- | 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)+ deriving (Ord, Show, Eq)++instance AccountBase PIMO where+ PS <=> IN = True+ IN <=> PS = True+ PS <=> MS = True+ MS <=> PS = True+ IN <=> OUT = True+ OUT <=> IN = True+ MS <=> OUT = True+ OUT <=> MS = True+ _ <=> _ = False+++------------------------------------------------------------------+-- * Simple bases (can be extended as needed)+-- Tuples are used so that the same accessor functions can be shared.+-- This approach was chosen over the DuplicateRecordFields extension+-- because it has fewer restrictions and looks cleaner.+------------------------------------------------------------------++-- ** 1-element bases+-- *** Account title only (exchange algebra base)+instance BaseClass AccountTitles where++instance ExBaseClass (HatBase AccountTitles) where+ getAccountTitle (h :< a) = a+ setAccountTitle (h :< a) b = h :< b++-- *** Name only (redundant algebra base)+instance BaseClass Name where++-- *** CountUnit only (redundant algebra base)+instance BaseClass CountUnit where++-- *** Day only (redundant algebra base)+instance BaseClass Day where++-- *** TimeOfDay only (redundant algebra base)+instance BaseClass TimeOfDay where++-- ***+++-- ** 2-element bases++-- | Basic BaseClass with 2 elements++instance ExBaseClass (HatBase (AccountTitles, Day)) where+ getAccountTitle (h:< (a, d)) = a+ setAccountTitle (h:< (a, d)) b = h:< (b, d)++instance ExBaseClass (HatBase (AccountTitles, Name)) where+ getAccountTitle (h:< (a, n)) = a+ setAccountTitle (h:< (a, n)) b = h:< (b, n)++instance ExBaseClass (HatBase (CountUnit, AccountTitles)) where+ getAccountTitle (h:< (u, a)) = a+ setAccountTitle (h:< (u, a)) 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)++-- ** 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)++-- ** 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)+++-- ** 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)
+ src/ExchangeAlgebra/Algebra/Base/Element.hs view
@@ -0,0 +1,612 @@+{- |+ Module : ExchangeAlgebra.Algebra.Base.Element+ 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>++ == Extending with user-defined types++ To use your own type as a basis component, declare an 'Element' instance.+ A single distinguished value must serve as the wildcard used by the+ transfer engine and by projection operations:++ @+ data Company = CompanyA | CompanyB | CompanyWildcard+ deriving (Eq, Ord, Show, Generic, Hashable, Typeable)++ instance Element Company where+ wiledcard = CompanyWildcard+ @++ == Import guidance++ User code rarely needs to import this module directly. The 'Element'+ class and its associated symbols are re-exported from+ "ExchangeAlgebra.Algebra.Base", and transitively from+ "ExchangeAlgebra.Algebra", "ExchangeAlgebra.Journal", and the top-level+ "ExchangeAlgebra". The module path of this file may be reorganized in+ future versions; prefer importing from the higher-level modules.++-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE DeriveGeneric #-}++module ExchangeAlgebra.Algebra.Base.Element+ ( module ExchangeAlgebra.Algebra.Base.Element+ , module Data.Hashable+ , module GHC.Generics) where++import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Time as Time+import Data.Time+import GHC.Generics (Generic)+import Data.Hashable+import Data.Typeable (Typeable, cast, typeOf)+import qualified Data.Binary as Binary++------------------------------------------------------------------+-- * Element (components of bases)+------------------------------------------------------------------++-- | Element Class: a type must be an instance of this class to serve as a component of a basis.+--+-- Each component of a basis must be an instance of this type class.+-- It provides wildcard-based pattern matching, enabling flexible basis+-- specification in transfer transformations and projections.+class (Eq a, Ord a, Show a, Hashable a, Typeable a) => Element a where++ -- | The wildcard value. Used for pattern matching in search, transfer transformation, etc.+ --+ -- Complexity: O(1)+ wiledcard :: 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++ -- | Determines whether the value is exactly the wildcard.+ --+ -- Complexity: O(1)+ {-# INLINE isWiledcard #-}+ isWiledcard :: a -> Bool+ isWiledcard a = a == wiledcard++ -- | 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+ | before == after = before+ | isWiledcard after = before+ | otherwise = after++ -- | Wildcard-aware equality test.+ -- Returns True if either operand is a wildcard.+ --+ -- 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+ | otherwise = a == b++ -- | Equality operator that treats wildcards as equal.+ -- Unlike '==', @(.==)@ matches tuples that partially contain wildcards.+ --+ -- 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++ -- | Inequality operator that treats wildcards as equal. Negation of @(.==)@.+ --+ -- Complexity: O(k)+ {-# INLINE (./=) #-}+ (./=) :: a -> a -> Bool+ (./=) a b = not (a .== b)++ -- | Wildcard-aware comparison.+ -- Returns EQ if the two values are equal under @(.==)@.+ --+ -- Complexity: O(k)+ {-# INLINE compareElement #-}+ compareElement :: a -> a -> Ordering+ compareElement x y+ | x .== y = EQ+ | otherwise = compare x y++ -- | Wildcard-aware less-than comparison.+ --+ -- Complexity: O(k)+ (.<) :: a -> a -> Bool+ (.<) x y = compareElement x y == LT++ -- | Wildcard-aware greater-than comparison.+ --+ -- Complexity: O(k)+ (.>) :: a -> a -> Bool+ (.>) x y = compareElement x y == GT++ -- | Wildcard-aware less-than-or-equal comparison.+ --+ -- Complexity: O(k)+ (.<=) :: a -> a -> Bool+ (.<=) x y = compareElement x y /= GT++ -- | Wildcard-aware greater-than-or-equal comparison.+ --+ -- Complexity: O(k)+ (.>=) :: a -> a -> Bool+ (.>=) x y = compareElement x y /= LT++ -- | Wildcard-aware maximum.+ --+ -- Complexity: O(k)+ maxElement :: a -> a -> a+ maxElement x y+ | x .>= y = x+ | otherwise = y++ -- | Wildcard-aware minimum.+ --+ -- Complexity: O(k)+ minElement :: a -> a -> a+ minElement x y+ | x .<= y = x+ | otherwise = y++-- | An existential type that holds each axis of a basis with its type erased.+-- Used to decompose multi-dimensional bases (tuples) into per-axis keys for indexing.+data AxisKey = forall a. Element a => AxisKey !a++instance Eq AxisKey where+ AxisKey x == AxisKey y = case cast y of+ Nothing -> False+ Just y' -> x == y'++instance Hashable AxisKey where+ hashWithSalt salt (AxisKey x) = salt `hashWithSalt` (typeOf x) `hashWithSalt` x++{-# INLINE axisIsWildcard #-}+axisIsWildcard :: AxisKey -> Bool+axisIsWildcard (AxisKey x) = isWiledcard 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+-- is decomposed into a separate t'AxisKey'.+--+-- Complexity: O(k) (k is the number of tuple components)+class (Element a) => AxisDecompose a where+ toAxisKeys :: a -> [AxisKey]++instance {-# OVERLAPPABLE #-} Element a => AxisDecompose a where+ {-# INLINE toAxisKeys #-}+ toAxisKeys a = [AxisKey a]++-- | Shorthand notation for the wildcard. An alias for @wiledcard@.+-- Write @(.#)@ when specifying patterns in projections and transfer transformations.+--+-- Complexity: O(1)+{-# INLINE (.#) #-}+(.#) :: Element a => a+(.#) = wiledcard++infix 4 .==+infix 4 ./=+------------------------------------------------------------------+-- * Elements+------------------------------------------------------------------++-- ** 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)++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+ {-# INLINE get #-}+ get = toEnum . fromIntegral <$> Binary.getWord8++instance Element AccountTitles where+ {-# INLINE wiledcard #-}+ wiledcard = AccountTitle++++-- | Name :: Name of an item+type Name = Text++-- | Subject of an account title+type Subject = Text+instance Element Text where++ {-# INLINE wiledcard #-}+ wiledcard = T.empty++-- | Currency unit or physical quantity+data CountUnit = Yen+ | Dollar+ | Euro+ | CNY+ | Amount+ | CountUnit+ deriving (Show, Ord, Eq, Enum,Generic)++instance Hashable CountUnit where+ {-# INLINE hashWithSalt #-}+ hashWithSalt salt x = hashWithSalt salt (fromEnum x)++instance Binary.Binary CountUnit where+ {-# INLINE put #-}+ put = Binary.putWord8 . fromIntegral . fromEnum+ {-# INLINE get #-}+ get = toEnum . fromIntegral <$> Binary.getWord8++instance Element CountUnit where++ {-# INLINE wiledcard #-}+ wiledcard = 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++-- 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++instance Element Day where+ wiledcard = ModifiedJulianDay 0++instance (Element a ,Element b)+ => Element (a, b) where++ {-# INLINE wiledcard #-}+ wiledcard = (wiledcard, wiledcard)++ {-# INLINE haveWiledcard #-}+ haveWiledcard (a,b)+ = isWiledcard a+ || isWiledcard 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 compareElement #-}+ compareElement (a1, a2) (b1, b2)+ = case compareElement a1 b1 of+ EQ -> compareElement a2 b2+ x -> x++instance {-# OVERLAPPING #-} (Element a, Element b)+ => AxisDecompose (a, b) where+ {-# INLINE toAxisKeys #-}+ toAxisKeys (a, b) = [AxisKey a, AxisKey b]++instance (Element a, Element b, Element c)+ => Element (a, b, c) where++ {-# INLINE wiledcard #-}+ wiledcard = ( wiledcard+ , wiledcard+ , wiledcard)++ {-# INLINE haveWiledcard #-}+ haveWiledcard (a,b,c)+ = isWiledcard a+ || isWiledcard b+ || isWiledcard c+++ {-# INLINE equal #-}+ equal (a1, a2, a3) (b1, b2, b3)+ = (a1 .== b1)+ && (a2 .== b2)+ && (a3 .== b3)++ {-# INLINE ignoreWiledcard #-}+ ignoreWiledcard (a1, a2, a3) (b1, b2, b3)+ = ( ignoreWiledcard a1 b1+ , ignoreWiledcard a2 b2+ , ignoreWiledcard a3 b3)++ {-# INLINE compareElement #-}+ compareElement (a1, a2, a3) (b1, b2, b3)+ = compareElement ((a1, a2), a3)+ ((b1, b2), b3)++instance {-# OVERLAPPING #-} (Element a, Element b, Element c)+ => AxisDecompose (a, b, c) where+ {-# INLINE toAxisKeys #-}+ toAxisKeys (a, b, c) = [AxisKey a, AxisKey b, AxisKey c]+++instance (Element a, Element b, Element c, Element d)+ => Element (a, b, c, d) where++ {-# INLINE wiledcard #-}+ wiledcard = ( wiledcard+ , wiledcard+ , wiledcard+ , wiledcard)+++ {-# INLINE haveWiledcard #-}+ haveWiledcard (a,b,c,d)+ = isWiledcard a+ || isWiledcard b+ || isWiledcard c+ || isWiledcard d++ {-# INLINE equal #-}+ equal (a1, a2, a3, a4) (b1, b2, b3, b4)+ = (a1 .== b1)+ && (a2 .== b2)+ && (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 compareElement #-}+ compareElement (a1, a2, a3, a4) (b1, b2, b3, b4)+ = compareElement ((a1, a2, a3), a4)+ ((b1, b2, b3), b4)++instance {-# OVERLAPPING #-} (Element a, Element b, Element c, Element d)+ => AxisDecompose (a, b, c, d) where+ {-# INLINE toAxisKeys #-}+ toAxisKeys (a, b, c, d) = [AxisKey a, AxisKey b, AxisKey c, AxisKey d]+++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 haveWiledcard #-}+ haveWiledcard (a,b,c,d,e)+ = isWiledcard a+ || isWiledcard b+ || isWiledcard c+ || isWiledcard d+ || isWiledcard e++ {-# INLINE equal #-}+ equal (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)+ = (a1 .== b1)+ && (a2 .== b2)+ && (a3 .== b3)+ && (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 compareElement #-}+ compareElement (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)+ = compareElement ((a1, a2, a3, a4), a5)+ ((b1, b2, b3, b4), b5)++instance {-# OVERLAPPING #-} (Element a, Element b, Element c, Element d, Element e)+ => AxisDecompose (a, b, c, d, e) where+ {-# INLINE toAxisKeys #-}+ toAxisKeys (a, b, c, d, e) = [AxisKey a, AxisKey b, AxisKey c, AxisKey d, AxisKey e]+++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 haveWiledcard #-}+ haveWiledcard (a,b,c,d,e,f)+ = isWiledcard a+ || isWiledcard b+ || isWiledcard c+ || isWiledcard d+ || isWiledcard e+ || isWiledcard f++ {-# INLINE equal #-}+ equal (a1, a2, a3, a4, a5, a6) (b1, b2, b3, b4, b5, b6)+ = (a1 .== b1)+ && (a2 .== b2)+ && (a3 .== b3)+ && (a4 .== b4)+ && (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 compareElement #-}+ compareElement (a1, a2, a3, a4, a5, a6) (b1, b2, b3, b4, b5, b6)+ = compareElement ((a1, a2, a3, a4, a5), a6)+ ((b1, b2, b3, b4, b5), b6)++instance {-# OVERLAPPING #-} (Element a, Element b, Element c, Element d, Element e, Element f)+ => AxisDecompose (a, b, c, d, e, f) where+ {-# INLINE toAxisKeys #-}+ toAxisKeys (a, b, c, d, e, f) = [AxisKey a, AxisKey b, AxisKey c, AxisKey d, AxisKey e, AxisKey f]+++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 haveWiledcard #-}+ haveWiledcard (a,b,c,d,e,f,g)+ = isWiledcard a+ || isWiledcard b+ || isWiledcard c+ || isWiledcard d+ || isWiledcard e+ || isWiledcard f+ || isWiledcard g++ {-# INLINE equal #-}+ equal (a1, a2, a3, a4, a5, a6, a7) (b1, b2, b3, b4, b5, b6, b7)+ = (a1 .== b1)+ && (a2 .== b2)+ && (a3 .== b3)+ && (a4 .== b4)+ && (a5 .== b5)+ && (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 compareElement #-}+ compareElement (a1, a2, a3, a4, a5, a6, a7) (b1, b2, b3, b4, b5, b6, b7)+ = compareElement ((a1, a2, a3, a4, a5, a6), a7)+ ((b1, b2, b3, b4, b5, b6), b7)++instance {-# OVERLAPPING #-} (Element a, Element b, Element c, Element d, Element e, Element f, Element g)+ => AxisDecompose (a, b, c, d, e, f, g) where+ {-# INLINE toAxisKeys #-}+ toAxisKeys (a, b, c, d, e, f, g) = [AxisKey a, AxisKey b, AxisKey c, AxisKey d, AxisKey e, AxisKey f, AxisKey g]
+ src/ExchangeAlgebra/Algebra/Transfer.hs view
@@ -0,0 +1,688 @@+{- |+ Module : ExchangeAlgebra.Algebra.Transfer+ 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>++-}+++{-# LANGUAGE GADTs #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PostfixOperators #-}++++module ExchangeAlgebra.Algebra.Transfer+ ( Size+ , TransTable (..)+ , isNullTable+ , transfer+ , table+ , TransTableParts+ , (.->)+ , (|%)+ , createTransfer+ , incomeSummaryAccount+ , netIncomeTransfer+ , grossProfitTransfer+ , ordinaryProfitTransfer+ , retainedEarningTransfer+ , finalStockTransferStep+ , finalStockTransfer+ ) where++import 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+------------------------------------------------------------------+-- ** Transfer transformation+type Size = Int++-- | Transfer transformation table+data TransTable n b where+ NullTable :: (HatVal n, HatBaseClass b) => TransTable n b+ TransTable :: (HatVal n, HatBaseClass b)+ => { _size :: Size+ , _before :: b {- ^ Base before transformation -}+ , _transFunc :: (n -> n) {- ^ Value transformation function -}+ , _after :: b {- ^ Base after transformation -}+ , _left :: TransTable n b+ , _right :: TransTable n b }+ -> TransTable n b++-- | Tests whether the transfer table is empty.+--+-- Complexity: O(1)+{-# INLINE isNullTable #-}+isNullTable :: TransTable n b -> Bool+isNullTable NullTable = True+isNullTable _ = False++instance (HatBaseClass b) => Show (TransTable n b) where+ show NullTable = "[]"+ show (TransTable s b f a l r) = "[(" ++ ushow b+ ++ ","+ ++ ushow a+ ++ ",<function>)"+ ++ (if isNullTable l then "" else "," ++ (Prelude.tail. Prelude.init .ushow) l)+ ++ (if isNullTable r then "" else "," ++ (Prelude.tail. Prelude.init .ushow) r)+ ++ "]"++instance (HatVal n,HatBaseClass b) => Semigroup (TransTable n b) where+ (<>) = union+ stimes = stimesIdempotentMonoid++instance (HatVal n, HatBaseClass b) => Monoid (TransTable n b) where+ mempty = NullTable+ mconcat = unions+ mappend = (<>)++{-# INLINE union #-}+union ::(HatBaseClass b) => TransTable n b -> TransTable n b -> TransTable n b+union t1 NullTable = t1+union NullTable t2 = t2+union t1 (TransTable _ b f a NullTable NullTable) = insertR b f a t1+union (TransTable _ b f a NullTable NullTable) t2 = insert b f a t2+union t1@(TransTable _ b1 f1 a1 l1 r1) t2 = case split b1 t2 of+ (l2, r2) | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1+ | otherwise -> link b1 f1 a1 l1l2 r1r2+ where !l1l2 = union l1 l2+ !r1r2 = union r1 r2++{-# INLINE link #-}+link :: (HatVal n, HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b -> TransTable n b+link kx fx x NullTable r = insertMin kx fx x r+link kx fx x l NullTable = insertMax kx fx x l+link kx fx x l@(TransTable sizeL ky fy y ly ry) r@(TransTable sizeR kz fz z lz rz)+ | delta*sizeL < sizeR = balanceL kz fz z (link kx fx x l lz) rz+ | delta*sizeR < sizeL = balanceR ky fy y ly (link kx fx x ry r)+ | otherwise = bin kx fx x l r++{-# INLINE bin #-}+bin :: (HatVal n, HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b -> TransTable n b+bin k f x l r+ = TransTable (size l + size r + 1) k f x l r++{-# INLINE split #-}+split :: (HatBaseClass b) => b -> TransTable n b -> (TransTable n b, TransTable n b)+split !k0 t0 = toPair $ go k0 t0+ where+ go k t =+ case t of+ NullTable -> NullTable :*: NullTable+ TransTable _ kx fx x l r -> case compareElement k kx of+ LT -> let (lt :*: gt) = go k l in lt :*: link kx fx x gt r+ GT -> let (lt :*: gt) = go k r in link kx fx x l lt :*: gt+ EQ -> (l :*: r)++{-# INLINE insertMax #-}+insertMax,insertMin :: (HatVal n, HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b+insertMax kx fx x t+ = case t of+ NullTable -> singleton kx fx x+ TransTable _ ky fy y l r+ -> balanceR ky fy y l (insertMax kx fx x r)++{-# INLINE insertMin #-}+insertMin kx fx x t+ = case t of+ NullTable -> singleton kx fx x+ TransTable _ ky fy y l r+ -> balanceL ky fy y (insertMin kx fx x l) r++{-# INLINE unions #-}+unions :: (HatVal n, Foldable f, HatBaseClass b) => f (TransTable n b) -> TransTable n b+unions ts = Foldable.foldl' union NullTable ts++{-# INLINE 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+size (TransTable s _ _ _ _ _) = s+++-- | transfer+-- Transfer transformation replaces the bases of algebra elements with other bases.+-- The values of the transformed entries remain unchanged. For example, given an algebra element a:+-- a = 6^ < e1 > +2 < e2 > +2 < e3 > +4 < e4 > +5^ < e5 > and the following transformation definition t:+-- ( from) < e1 > -> (to) < eA >+-- ( from) < e2 > -> (to) < eA >+-- ( from) < e3 > -> (to) < eA >+-- The transformation result r is as follows:+-- r = 6^ < e1 > +2 < e2 > +2 < e3 > +4 < e4 > +5^ < e5 >+-- + 6 < e 1 > + 6 ^ < e A >+-- + 2 ^ < e 2 > + 2 < e A >+-- + 2 ^ < e 3 > + 2 < e A >+-- = 6 ^ < e 1 > + 2 < e 2 > + 2 < e 3 > + 4 < e 4 > + 5 ^ < e 5 >+-- = 6 ^ < e 1 > + 2 < e 2 > + 2 < e 3 > + 4 < e 4 > + 5 ^ < e 5 >+-- + 6 < e 1 > + 6 ^ < e A > + 2 ^ < e 2 > + 4 < e A > + 2 ^ < e 3 >+--+--+-- >>> type Test = Alg Double (HatBase (AccountTitles, CountUnit))+-- >>> x = 1:@Hat:<(Cash,Yen) .+ 1:@Not:<(Products,Amount) :: Test+-- >>> y = 2:@Not:<(Cash,Yen) .+ 2:@Hat:<(Deposits,Yen) :: Test+-- >>> transfer (x .+ y) $ table $ Not:<(Products,Amount) :-> Not:<(Products,Yen) |% id ++ Hat:<(Products,Amount) :-> Hat:<(Products,Yen) |% id+-- 1.00:@Hat:<(Cash,Yen) .+ 2.00:@Not:<(Cash,Yen) .+ 2.00:@Hat:<(Deposits,Yen) .+ 1.00:@Not:<(Products,Yen)+--+-- Wildcards match but are not transformed+-- >>> type Test = Alg Double (HatBase (AccountTitles, CountUnit))+-- >>> x = 1:@Hat:<(Cash,Yen) .+ 1:@Not:<(Products,Amount) :: Test+-- >>> y = 2:@Not:<(Cash,Yen) .+ 2:@Hat:<(Deposits,Yen) :: Test+-- >>> transfer (x .+ y) $ table $ HatNot:<(Products,Amount) :-> HatNot:<(Products,Yen) |% id+-- 1.00:@Hat:<(Cash,Yen) .+ 2.00:@Not:<(Cash,Yen) .+ 2.00:@Hat:<(Deposits,Yen) .+ 1.00:@Not:<(Products,Yen)+--+-- >>> instance Element Int where wiledcard = -1+-- >>> type Test = Alg Double (HatBase (AccountTitles, Int,CountUnit))+-- >>> x = 1:@Hat:<(Cash,(.#),Yen) .+ 1:@Not:<(Products,1,Yen) :: Test+-- >>> transfer x $ table $ HatNot:<((.#),(.#),Yen) :-> HatNot:<((.#),(.#),Amount) |% id+-- 1.00:@Hat:<(Cash,-1,Amount) .+ 1.00:@Not:<(Products,1,Amount)+++data IndexedRule n b+ = IndexedUnique !b !(n -> n) !b+ | IndexedAmbiguous++data TransferIndex n b = TransferIndex+ { tiTree :: !(TransTable n b)+ , tiByHatTitle :: !(HM.HashMap (Hat, AccountTitles) (IndexedRule n b))+ }++{-# INLINE transferWithResolver #-}+transferWithResolver :: (HatVal n, HatBaseClass b)+ => (b -> Maybe ((n -> n), b))+ -> Alg n b+ -> Alg n b+transferWithResolver resolve = EA.map step+ where+ step (v :@ hb) = case resolve hb of+ Nothing -> v :@ hb+ Just (f, hb') ->+ let !v' = f v+ in if isZeroValue v'+ then Zero+ else v' :@ hb'+ step x = x++{-# INLINE resolveByTree #-}+resolveByTree :: (HatVal n, HatBaseClass b)+ => TransTable n b+ -> b+ -> Maybe ((n -> n), b)+resolveByTree NullTable _ = Nothing+resolveByTree (TransTable _ hb2 f a l r) hb1+ | hb1 ./= hb2 = case compareElement hb1 hb2 of+ LT -> resolveByTree l hb1+ GT -> resolveByTree r hb1+ EQ -> error $ "transfer: " ++ show hb1 ++ "," ++ show hb2+ | otherwise = Just (f, ignoreWiledcard hb1 a)++{-# INLINE ruleEntries #-}+ruleEntries :: TransTable n b -> [(b, n -> n, b)]+ruleEntries NullTable = []+ruleEntries (TransTable _ b f a l r) =+ ruleEntries l ++ ((b, f, a) : ruleEntries r)++{-# INLINE baseKey #-}+baseKey :: (ExBaseClass b) => b -> Maybe (Hat, AccountTitles)+baseKey b+ | isWiledcard h = Nothing+ | haveWiledcard at = Nothing+ | otherwise = Just (h, at)+ where+ h = hat b+ at = getAccountTitle b++buildTransferIndex :: (HatVal n, ExBaseClass b) => TransTable n b -> TransferIndex n b+buildTransferIndex t =+ TransferIndex t $+ Foldable.foldl' addRule HM.empty (ruleEntries t)+ where+ addRule acc (before, f, after) =+ case baseKey before of+ Nothing -> acc+ Just k ->+ HM.alter+ (\entry -> case entry of+ Nothing -> Just (IndexedUnique before f after)+ Just _ -> Just IndexedAmbiguous+ )+ k+ acc++{-# INLINE resolveByIndex #-}+resolveByIndex :: (HatVal n, ExBaseClass b)+ => TransferIndex n b+ -> b+ -> Maybe ((n -> n), b)+resolveByIndex idx hb =+ case baseKey hb >>= (`HM.lookup` tiByHatTitle idx) of+ Just (IndexedUnique before f after)+ | hb .== before -> Just (f, ignoreWiledcard hb after)+ | otherwise -> resolveByTree (tiTree idx) hb+ _ -> resolveByTree (tiTree idx) hb++{-# INLINE transfer #-}+transfer :: (HatVal n, HatBaseClass b) => Alg n b -> TransTable n b -> Alg n b+transfer alg NullTable = alg+transfer alg tt = transferWithResolver (resolveByTree tt) alg++{-# INLINE singleton #-}+singleton :: (HatVal n,HatBaseClass b) => b ->(n -> n) -> b -> TransTable n b+singleton before f after = TransTable 1 before f after NullTable NullTable++{-# INLINE insert #-}+insert :: (HatVal n,HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b+insert b = go b b+ where+ {-# INLINE go #-}+ go :: (HatVal n,HatBaseClass b) => b -> b -> (n -> n) -> b -> TransTable n b -> TransTable n b+ go orig !_ f x NullTable = singleton (lazy orig) f x+ go orig !bx fx x t@(TransTable sy by fy y l r) =+ case compareElement bx by of+ LT | l' `ptrEq` l -> t+ | otherwise -> balanceL by fy y l' r+ where !l' = go orig bx fx x l+ GT | r' `ptrEq` r -> t+ | otherwise -> balanceR by fy y l r'+ where !r' = go orig bx fx x r+ EQ | x `ptrEq` y && (lazy orig `seq` (orig `ptrEq` by)) -> t+ | otherwise -> TransTable sy (lazy orig) fx x l r++{-# INLINE insertR #-}+insertR :: (HatVal n,HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b+insertR kx0 = go kx0 kx0+ where+ {-# INLINE go #-}+ go :: (HatVal n,HatBaseClass b) => b -> b -> (n -> n) -> b -> TransTable n b -> TransTable n b+ go orig !_ fx ax NullTable = singleton (lazy orig) fx ax+ go orig !bx fx ax t@(TransTable _ by fy ay l r) =+ case compareElement bx by of+ LT | l' `ptrEq` l -> t+ | otherwise -> balanceL by fy ay l' r+ where !l' = go orig bx fx ax l+ GT | r' `ptrEq` r -> t+ | otherwise -> balanceR by fy ay l r'+ where !r' = go orig bx fx ax r+ EQ -> t++-- | 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+++{-# INLINE ptrEq #-}+ptrEq :: a -> a -> Bool+ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)++delta = 3+ratio = 2++balanceL :: (HatVal n, HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b -> TransTable n b+balanceL b f a l r = case r of+ NullTable -> case l of+ NullTable -> TransTable 1 b f a NullTable NullTable+ (TransTable _ _ _ _ NullTable NullTable)+ -> TransTable 2 b f a l NullTable++ (TransTable _ lb lf la NullTable (TransTable _ lrb lrf lra _ _))+ -> TransTable 3 lrb lrf lra (TransTable 1 lb lf la NullTable NullTable) (TransTable 1 b f a NullTable NullTable)++ (TransTable _ lb lf la ll@(TransTable _ _ _ _ _ _) NullTable)+ -> TransTable 3 lb lf la ll (TransTable 1 b f a NullTable NullTable)++ (TransTable ls lb lf la ll@(TransTable lls _ _ _ _ _) lr@(TransTable lrs lrb lrf lra lrl lrr))+ | lrs < ratio*lls -> TransTable (1+ls) lb lf la ll (TransTable (1+lrs) b f a lr NullTable)+ | otherwise -> TransTable (1+ls) lrb lrf lra (TransTable (1+lls+size lrl) lb lf la ll lrl) (TransTable (1+size lrr) b f a lrr NullTable)++ (TransTable rs _ _ _ _ _) -> case l of+ NullTable -> TransTable (1+rs) b f a NullTable r++ (TransTable ls lb lf la ll lr)+ | ls > delta*rs -> case (ll, lr) of+ (TransTable lls _ _ _ _ _, TransTable lrs lrb lrf lra lrl lrr)+ | lrs < ratio*lls -> TransTable (1+ls+rs) lb lf la ll (TransTable (1+rs+lrs) b f a lr r)+ | otherwise -> TransTable (1+ls+rs) lrb lrf lra (TransTable (1+lls+size lrl) lb lf la ll lrl) (TransTable (1+rs+size lrr) b f a lrr r)+ (_, _) -> error "Failure in Data.Map.balanceL"+ | otherwise -> TransTable (1+ls+rs) b f a l r++balanceR :: (HatVal n, HatBaseClass b) => b -> (n -> n) -> b -> TransTable n b -> TransTable n b -> TransTable n b+balanceR b f a l r = case l of+ NullTable -> case r of+ NullTable+ -> TransTable 1 b f a NullTable NullTable -- Leaf nodes are Null++ (TransTable _ _ _ _ NullTable NullTable)+ -> TransTable 2 b f a NullTable r++ (TransTable _ rb rf ra NullTable rr@(TransTable _ _ _ _ _ _))+ -> TransTable 3 rb rf ra (TransTable 1 b f a NullTable NullTable) rr++ (TransTable _ rb rf ra (TransTable _ rlb rlf rla _ _) NullTable)+ -> TransTable 3 rlb rlf rla (TransTable 1 b f a NullTable NullTable) (TransTable 1 rb rf ra NullTable NullTable)++ (TransTable rs rb rf ra rl@(TransTable rls rlb rlf rla rll rlr) rr@(TransTable rrs _ _ _ _ _))+ | rls < ratio*rrs -> TransTable (1+rs) rb rf ra (TransTable (1+rls) b f a NullTable rl) rr+ | otherwise -> TransTable (1+rs) rlb rlf rla (TransTable (1+size rll) b f a NullTable rll) (TransTable (1+rrs+size rlr) rb rf ra rlr rr)++ (TransTable ls _ _ _ _ _) -> case r of+ NullTable -> TransTable (1+ls) b f a l NullTable++ (TransTable rs rb rf ra rl rr)+ | rs > delta*ls -> case (rl, rr) of+ (TransTable rls rlb rlf rla rll rlr, TransTable rrs _ _ _ _ _)+ | rls < ratio*rrs -> TransTable (1+ls+rs) rb rf ra (TransTable (1+ls+rls) b f a l rl) rr+ | otherwise -> TransTable (1+ls+rs) rlb rlf rla (TransTable (1+ls+size rll) b f a l rll) (TransTable (1+rrs+size rlr) rb rf ra rlr rr)+ (_, _) -> error "Failure in Data.Map.balanceR"+ | otherwise -> TransTable (1+ls+rs) b f a l r++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)++++-- | make TransTable from list+--+-- >>> ExchangeAlgebra.Algebra.Transfer.fromList [(Hat:<(Cash),Hat:<(Building),(id :: NN.Double -> NN.Double) ),(Not:<(Building),Not:<(Cash),id)]+-- [(Hat:<Cash,Hat:<Building,<function>),(Not:<Building,Not:<Cash,<function>)]++fromList :: (HatVal n, HatBaseClass b) => [(b,b,(n -> n))] -> TransTable n b+fromList [] = NullTable+fromList [(b1,a1, f1)] = a1 `seq` TransTable 1 b1 f1 a1 NullTable NullTable+fromList ((b1,a1, f1) : xs0) | not_ordered b1 xs0 = a1 `seq` fromList' (TransTable 1 b1 f1 a1 NullTable NullTable) xs0+ | otherwise = a1 `seq` go (1::Int) (TransTable 1 b1 f1 a1 NullTable NullTable) xs0+ where+ {-# INLINE not_ordered #-}+ not_ordered _ [] = False+ not_ordered kx ((ky, _, _) : _) = kx >= ky++ {-# INLINE fromList' #-}+ fromList' t0 xs = Foldable.foldl' ins t0 xs+ where ins t (k,x,f) = insert k f x t++ {-# INLINE go #-}+ go !_ t [] = t+ go _ t [(kx, x, fx)] = x `seq` insertMax kx fx x t+ go s l xs@((kx, x, fx) : xss) | not_ordered kx xss = fromList' l xs+ | otherwise = case create s xss of+ (r, ys, []) -> x `seq` go (s `shiftL` 1) (link kx fx x l r) ys+ (r, _, ys) -> x `seq` fromList' (link kx fx x l r) ys++ {-# INLINE create #-}+ create _ [] = (NullTable, [], [])+ create s xs@(xp : xss)+ | s == 1 = case xp of (kx, x, fx) | not_ordered kx xss -> x `seq` (TransTable 1 kx fx x NullTable NullTable, [], xss)+ | otherwise -> x `seq` (TransTable 1 kx fx x NullTable NullTable, xss, [])+ | otherwise = case create (s `shiftR` 1) xs of+ res@(_, [], _) -> res+ (l, [(ky, y, fy)], zs) -> y `seq` (insertMax ky fy y l, [], zs)+ (l, ys@((ky, y, fy):yss), _) | not_ordered ky yss -> (l, [], ys)+ | otherwise -> case create (s `shiftR` 1) yss of+ (r, zs, ws) -> y `seq` (link ky fy y l r, zs, ws)+++-- | make TransTable from list+-- same as fromList+-- >>> table $ Hat:<(Cash) :-> Hat:<(Building) |% (id :: NN.Double -> NN.Double) ++ Hat:<(Building) :-> Hat:<(Cash) |% id+-- [(Hat:<Cash,Hat:<Building,<function>),(Hat:<Building,Hat:<Cash,<function>)]+{-# INLINE table #-}+table :: (HatVal n, HatBaseClass b) => [(b,b,(n -> n))] -> TransTable n b+table = ExchangeAlgebra.Algebra.Transfer.fromList++-- | A part of a transfer rule. Represents a source-to-target base pair in @from :-> to@ form.+data TransTableParts b where+ (:->) :: (HatBaseClass b) => b -> b -> TransTableParts b++-- | Transfer rule construction operator. @from .-> to@ produces a 'TransTableParts'.+--+-- Complexity: O(1)+{-# INLINE (.->) #-}+(.->) :: (HatBaseClass b) => b -> b -> TransTableParts b+(.->) b1 b2 = b1 :-> b2++instance (HatBaseClass b) => Show (TransTableParts b) where+ show (b1 :-> b2) = show b1 ++ " :-> " ++ show b2++-- | Syntax to make list for makeList+--+-- >>> 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>)]+{-# INLINE (|%) #-}+(|%) :: (HatVal n, HatBaseClass b) => TransTableParts b -> (n -> n) -> [(b,b,(n -> n))]+(|%) (b1 :-> b2) f = [(b1,b2,f)]++infixr 8 .->+infixr 8 :->+infixr 7 |%++instance (HatVal n) => Show (n -> n) where+ show f = "<function>"++-- | Build an indexed fast transfer function from a list of transfer rules.+-- More efficient than @transfer@ when repeatedly applying the same TransTable.+--+-- Complexity: Build O(r log r) (r = number of rules); apply O(s) (s = number of entries)+createTransfer :: (HatVal n, ExBaseClass b) => [(b,b,(n -> n))] -> (Alg n b -> Alg n b)+createTransfer tt =+ let !tb = table tt+ !idx = buildTransferIndex tb+ in \ts -> transferWithResolver (resolveByIndex idx) ts++-- * Closing transfer entries++-- | Income Summary Account: compute net income for the current period.+incomeSummaryAccount :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b+incomeSummaryAccount alg = let (dc,diff) = diffRL alg+ in let x = case dc of+ Credit -> diff :@ (toNot wiledcard) .~ NetIncome+ Debit -> diff :@ (toNot wiledcard) .~ NetLoss+ in alg .+ x++-- | Net income transfer. Transfers NetIncome/NetLoss to RetainedEarnings.+--+-- 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++-- ** Journalizing++-- | Transfer to Gross Profit.+-- Consolidates Sales, Purchases, WageExpenditure, Depreciation, and ValueAdded into GrossProfit.+--+-- 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 wiledcard) .~ Depreciation :-> (toHat wiledcard) .~ GrossProfit |% id+ ++ (toHat wiledcard) .~ Depreciation :-> (toNot wiledcard) .~ GrossProfit |% id+ ------------------------------------------------------------------+ ++ (toNot wiledcard) .~ ValueAdded :-> (toNot wiledcard) .~ GrossProfit |% id+ ++ (toHat wiledcard) .~ ValueAdded :-> (toHat wiledcard) .~ GrossProfit |% id+ ------------------------------------------------------------------+ ++ (toNot wiledcard) .~ Sales :-> (toNot wiledcard) .~ GrossProfit |% id+ ++ (toHat wiledcard) .~ Sales :-> (toHat wiledcard) .~ GrossProfit |% id+ ------------------------------------------------------------------+ ++ (toNot wiledcard) .~ Purchases :-> (toHat wiledcard) .~ GrossProfit |% id+ ++ (toHat wiledcard) .~ Purchases :-> (toNot wiledcard) .~ GrossProfit |% id++-- | Ordinary Profit Transfer+--+-- >>> type Test = Alg Double (HatBase (CountUnit, AccountTitles))+-- >>> x = 2279.0:@Not:<(Yen,Depreciation) .+ 500475.0:@Not:<(Yen,InterestEarned) :: Test+-- >>> ordinaryProfitTransfer x+-- 2279.00:@Hat:<(Yen,OrdinaryProfit) .+ 500475.00:@Not:<(Yen,OrdinaryProfit)++ordinaryProfitTransfer :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b+ordinaryProfitTransfer+ = createTransfer+ $ (toNot wiledcard) .~ GrossProfit :-> (toNot wiledcard) .~ OrdinaryProfit |% id+ ++ (toHat wiledcard) .~ GrossProfit :-> (toHat wiledcard) .~ OrdinaryProfit |% id+ ------------------------------------------------------------------+ ++ (toNot wiledcard) .~ InterestEarned :-> (toNot wiledcard) .~ OrdinaryProfit |% id+ ++ (toHat wiledcard) .~ InterestEarned :-> (toHat wiledcard) .~ OrdinaryProfit |% id+ ------------------------------------------------------------------+ ++ (toNot wiledcard) .~ InterestExpense :-> (toHat wiledcard) .~ OrdinaryProfit |% id+ ++ (toHat wiledcard) .~ InterestExpense :-> (toNot wiledcard) .~ OrdinaryProfit |% id+ ------------------------------------------------------------------+ ++ (toNot wiledcard) .~ SubsidyIncome :-> (toNot wiledcard) .~ OrdinaryProfit |% id+ ++ (toHat wiledcard) .~ SubsidyIncome :-> (toHat wiledcard) .~ OrdinaryProfit |% id+ ------------------------------------------------------------------+ ++ (toNot wiledcard) .~ TaxesExpense :-> (toHat wiledcard) .~ OrdinaryProfit |% id+ ++ (toHat wiledcard) .~ TaxesExpense :-> (toNot wiledcard) .~ OrdinaryProfit |% id+ -- Government+ ++ (toNot wiledcard) .~ TaxesRevenue :-> (toNot wiledcard) .~ OrdinaryProfit |% id+ ++ (toHat wiledcard) .~ TaxesRevenue :-> (toHat wiledcard) .~ OrdinaryProfit |% id+ ------------------------------------------------------------------+ ++ (toNot wiledcard) .~ CentralBankPaymentIncome :-> (toNot wiledcard) .~ OrdinaryProfit |% id+ ++ (toHat wiledcard) .~ CentralBankPaymentIncome :-> (toHat wiledcard) .~ OrdinaryProfit |% id+ ------------------------------------------------------------------+ ++ (toNot wiledcard) .~ Depreciation :-> (toHat wiledcard) .~ OrdinaryProfit |% id+ ++ (toHat wiledcard) .~ Depreciation :-> (toNot wiledcard) .~ OrdinaryProfit |% id+ ------------------------------------------------------------------+ ++ (toNot wiledcard) .~ WageExpenditure :-> (toHat wiledcard) .~ OrdinaryProfit |% id+ ++ (toHat wiledcard) .~ WageExpenditure :-> (toNot wiledcard) .~ OrdinaryProfit |% id+ ------------------------------------------------------------------+ ++ (toNot wiledcard) .~ SubsidyExpense :-> (toHat wiledcard) .~ OrdinaryProfit |% id+ ++ (toHat wiledcard) .~ SubsidyExpense :-> (toNot wiledcard) .~ OrdinaryProfit |% id+ ------------------------------------------------------------------+ -- Household+ ++ (toNot wiledcard) .~ WageEarned :-> (toNot wiledcard) .~ OrdinaryProfit |% id+ ++ (toHat wiledcard) .~ WageEarned :-> (toHat wiledcard) .~ OrdinaryProfit |% id+ ------------------------------------------------------------------+ ++ (toNot wiledcard) .~ ConsumptionExpenditure :-> (toHat wiledcard) .~ OrdinaryProfit |% id+ ++ (toHat wiledcard) .~ ConsumptionExpenditure :-> (toNot wiledcard) .~ OrdinaryProfit |% id+ -- CentralBank+ ++ (toNot wiledcard) .~ CentralBankPaymentExpense :-> (toHat wiledcard) .~ OrdinaryProfit |% id+ ++ (toHat wiledcard) .~ CentralBankPaymentExpense :-> (toNot wiledcard) .~ OrdinaryProfit |% id+++-- | Transfer to Retained Earnings.+-- Transfers OrdinaryProfit to RetainedEarnings.+--+-- Complexity: O(s) (s = total number of scalar entries)+retainedEarningTransfer :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b+retainedEarningTransfer+ = createTransfer+ $ (toNot wiledcard) .~ OrdinaryProfit :-> (toNot wiledcard) .~ RetainedEarnings |% id+ ++ (toHat wiledcard) .~ OrdinaryProfit :-> (toHat wiledcard) .~ RetainedEarnings |% id++data FinalStockSide+ = FinalStockKeep+ | FinalStockFlip++{-# 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++-- | 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.+--+-- Complexity: O(s) (s = total number of scalar entries)+{-# INLINE finalStockTransferStep #-}+finalStockTransferStep :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b+finalStockTransferStep = EA.map go+ where+ go (v :@ hb) = case finalStockRule (getAccountTitle hb) of+ Nothing -> v :@ hb+ Just FinalStockKeep ->+ v :@ setAccountTitle hb RetainedEarnings+ Just FinalStockFlip ->+ v :@ setAccountTitle (revHat hb) RetainedEarnings+ go x = x++-- | Final Stock Transfer (closing entries).+-- Transfers all cost and revenue accounts to RetainedEarnings and cancels via the bar operation.+--+-- Complexity: O(s) (s = total number of scalar entries)+finalStockTransfer ::(HatVal n, ExBaseClass b) => Alg n b -> Alg n b+finalStockTransfer = (.-) . finalStockTransferStep
+ src/ExchangeAlgebra/Journal.hs view
@@ -0,0 +1,739 @@+{- |+ Module : ExchangeAlgebra.Journal+ 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>+++-}++{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}++module ExchangeAlgebra.Journal+ ( module ExchangeAlgebra.Algebra.Base+ , HatVal(..)+ , HatBaseClass(..)+ , Redundant(..)+ , Exchange(..)+ , pattern (:@)+ , (.@)+ , Note(..)+ , NoteAxisKey(..)+ , NoteAxisPosting+ , Journal(..)+ , pattern ExchangeAlgebra.Journal.Zero+ , (.|)+ , toAlg+ , toMap+ , fromMap+ , fromList+ , sigma+ , sigma2When+ , sigmaOn+ , sigmaOnFromMap+ , sigmaM+ , map+ , insert+ , projWithNote+ , projWithBase+ , projWithNoteBase+ , projWithBaseNorm+ , projWithNoteNorm+ , filterWithNote+ , filterByAxis+ , gather+ ) where++import qualified ExchangeAlgebra.Algebra as EA+import ExchangeAlgebra.Algebra.Base+import ExchangeAlgebra.Algebra ( HatVal(..)+ , HatBaseClass(..)+ , Alg(..)+ , Redundant(..)+ , Exchange(..)+ , pattern (:@)+ , (.@))+import Prelude hiding (map, filter)+import qualified Data.HashMap.Strict as Map+import qualified Data.IntMap.Strict as IntMap+import Data.IntMap.Strict (IntMap)+import qualified Data.HashSet as HSet+import Data.HashSet (HashSet)+import Control.Parallel.Strategies (using, parTraversable, rdeepseq, NFData)+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+import Data.Typeable (Typeable, cast, typeOf)++------------------------------------------------------------------+-- * NoteAxisKey+------------------------------------------------------------------++-- | An existential type that holds each axis of a Note with its type erased.+-- Used to decompose multi-dimensional Note types (tuples) into per-axis keys+-- for indexing, mirroring how @AxisKey@ works for basis elements in 'Alg'.+data NoteAxisKey = forall a. (Eq a, Hashable a, Typeable a) => NoteAxisKey !a++instance Eq NoteAxisKey where+ NoteAxisKey x == NoteAxisKey y = case cast y of+ Nothing -> False+ Just y' -> x == y'++instance Hashable NoteAxisKey where+ hashWithSalt salt (NoteAxisKey x) = salt `hashWithSalt` typeOf x `hashWithSalt` x++------------------------------------------------------------------+-- * NoteAxisPosting+------------------------------------------------------------------++-- | Per-axis index for Note keys.+-- Maps axis_number -> axis_value -> set of Notes.+-- Mirrors @AxisPosting@ in 'Alg'.+type NoteAxisPosting n = IntMap (Map.HashMap NoteAxisKey (HashSet n))++{-# INLINE emptyNoteAxisPosting #-}+emptyNoteAxisPosting :: NoteAxisPosting n+emptyNoteAxisPosting = IntMap.empty++{-# INLINE insertNoteAxisPosting #-}+-- | Complexity: O(d) where d is the number of axes in the Note+insertNoteAxisPosting :: (Eq n, Hashable n) => [NoteAxisKey] -> n -> NoteAxisPosting n -> NoteAxisPosting n+insertNoteAxisPosting !keys !note !idx =+ snd $ L.foldl' step (0 :: Int, idx) keys+ where+ step (!axis, !acc) !k =+ let !axisMap = IntMap.findWithDefault Map.empty axis acc+ !notes0 = Map.lookupDefault HSet.empty k axisMap+ !notes1 = HSet.insert note notes0+ !axisMap' = Map.insert k notes1 axisMap+ !acc' = IntMap.insert axis axisMap' acc+ in (axis + 1, acc')++{-# INLINE deleteNoteAxisPosting #-}+-- | Complexity: O(d) where d is the number of axes in the Note+deleteNoteAxisPosting :: (Eq n, Hashable n) => [NoteAxisKey] -> n -> NoteAxisPosting n -> NoteAxisPosting n+deleteNoteAxisPosting !keys !note !idx =+ snd $ L.foldl' step (0 :: Int, idx) keys+ where+ step (!axis, !acc) !k =+ case IntMap.lookup axis acc of+ Nothing -> (axis + 1, acc)+ Just axisMap ->+ case Map.lookup k axisMap of+ Nothing -> (axis + 1, acc)+ Just notes0 ->+ let !notes1 = HSet.delete note notes0+ !axisMap' = if HSet.null notes1+ then Map.delete k axisMap+ else Map.insert k notes1 axisMap+ !acc' = if Map.null axisMap'+ then IntMap.delete axis acc+ else IntMap.insert axis axisMap' acc+ in (axis + 1, acc')++{-# INLINE queryNoteAxisPosting #-}+-- | Query the NoteAxisPosting index for a single axis.+-- Returns the set of Notes whose value matches on the specified axis.+--+-- Complexity: O(1) (two map lookups)+queryNoteAxisPosting :: Int -> NoteAxisKey -> NoteAxisPosting n -> HashSet n+queryNoteAxisPosting !axis !key !idx =+ case IntMap.lookup axis idx of+ Nothing -> HSet.empty+ Just axisMap -> Map.lookupDefault HSet.empty key axisMap++------------------------------------------------------------------+-- * Note+------------------------------------------------------------------++-- | Type class for journal annotations (notes attached to postings).+-- @plank@ represents a blank note (analogous to @mempty@ in @Monoid@).+--+-- @toNoteAxisKeys@ decomposes a Note into per-axis keys for AxisPosting+-- 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.+class (Show a, Eq a, Ord a, Hashable a, Typeable a) => Note a where+ plank :: a+ isPlank :: a -> Bool+ isPlank x = x == plank+ -- | Decompose a Note into per-axis keys for AxisPosting indexing.+ -- Default: single axis with the Note itself.+ toNoteAxisKeys :: a -> [NoteAxisKey]+ toNoteAxisKeys a = [NoteAxisKey a]++-- | Default instance for using @Int@ as a time axis (Term).+-- @plank = -1@ is distinguished from non-negative term numbers.+--+-- In simulations, typically used as @type Term = Int@.+--+-- >>> (plank :: Int)+-- -1+--+-- >>> isPlank (0 :: Int)+-- False+--+-- >>> isPlank (-1 :: Int)+-- True+instance Note Int where+ plank = -1++instance Note String where+ plank = ""++instance Note T.Text where+ plank = ""++instance (Note a, Note b) => Note (a, b) where+ plank = (plank, plank)+ toNoteAxisKeys (a, b) = [NoteAxisKey a, NoteAxisKey b]++instance (Note a, Note b, Note c) => Note (a, b, c) where+ plank = (plank, plank, plank)+ toNoteAxisKeys (a, b, c) = [NoteAxisKey a, NoteAxisKey b, NoteAxisKey c]++instance (Note a, Note b, Note c, Note d) => Note (a, b, c, d) where+ plank = (plank, plank, plank, plank)+ toNoteAxisKeys (a, b, c, d) = [NoteAxisKey a, NoteAxisKey b, NoteAxisKey c, NoteAxisKey d]++------------------------------------------------------------------+-- * Journal+------------------------------------------------------------------++-- | Transaction data with annotations.+-- 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.+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++deltaCompactThreshold :: Int+deltaCompactThreshold = 128++-- | Build Note axis index from map keys.+{-# INLINE buildNoteAxisPosting #-}+buildNoteAxisPosting :: Note n => Map.HashMap n a -> NoteAxisPosting n+buildNoteAxisPosting =+ Map.foldlWithKey'+ (\acc n _ -> insertNoteAxisPosting (toNoteAxisKeys n) n acc)+ emptyNoteAxisPosting++-- | Smart constructor for Journal.+-- Base axis index is lazy; 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+ where+ ~baseIdx = buildNoteAxisPosting base+ !deltaIdx = buildNoteAxisPosting delta++-- | Construct a Journal from a HashMap.+--+-- Complexity: O(1). Base axis index is built lazily on first axis query.+{-# 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++-- | Retrieve all entries of a Journal as a HashMap.+-- Merges the base and delta layers.+--+-- Complexity: O(n) where n is the number of Notes+{-# INLINE toMap #-}+toMap :: (HatVal v, HatBaseClass b, Note n)+ => Journal n v b -> Map.HashMap n (Alg v b)+toMap = materializeMap++{-# INLINE materializeMap #-}+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++{-# 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+ (Nothing, Nothing) -> Nothing+ (Just d, Nothing) -> Just d+ (Nothing, Just b) -> Just b+ (Just d, Just b) -> Just (b .+ d)++{-# INLINE compactIfNeeded #-}+compactIfNeeded :: (HatVal v, HatBaseClass b, Note n)+ => Journal n v b -> Journal n v b+compactIfNeeded j@(Journal base delta ver _ _)+ | Map.size delta < deltaCompactThreshold = j+ | otherwise = mkJournal (Map.unionWith (.+) base delta) Map.empty (ver + 1)++{-# 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)+ | Map.null rhs = j+ | otherwise = compactIfNeeded $ Journal base delta' (ver + 1) 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)++instance ( Note n+ , HatVal v+ , HatBaseClass b+ , Binary.Binary n+ , Binary.Binary (Alg v b)+ ) => Binary.Binary (Journal n v b) where+ {-# INLINABLE put #-}+ {-# INLINABLE get #-}+ put j = do+ let !m = toMap j+ Binary.put (Map.size m :: Int)+ Map.foldrWithKey+ (\n alg k -> Binary.put n >> Binary.put alg >> k)+ (pure ())+ m+ get = do+ n <- Binary.get :: Binary.Get Int+ fromMap <$> go n Map.empty+ where+ go !remaining !acc+ | remaining <= 0 = pure acc+ | otherwise = do+ k <- Binary.get+ v <- Binary.get+ go (remaining - 1) (Map.insert k v acc)++-- | Test whether the Journal is empty (zero).+--+-- 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++pattern Zero :: (HatVal v, HatBaseClass b, Note n) => Journal n v b+pattern Zero <- (isZero -> True)+ where+ Zero = mkJournal Map.empty Map.empty 0++-- | 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++infixr 2 .|++------------------------------------------------------------------+-- Show+------------------------------------------------------------------+instance (HatVal v, HatBaseClass b, Note n) => Show (Journal n v b) where+ show js+ | Map.null m = "0"+ | otherwise = Map.foldrWithKey f "" m+ where+ m = toMap js+ f k a t+ | isPlank k = if t == "" then show a else t ++ " .+ " ++ show a+ | otherwise = foldr (\x y -> if y == ""+ then show x ++ ".|" ++ show k+ else y ++ " .+ " ++ show x ++ ".|" ++ show k)+ t+ (EA.toASCList a)+------------------------------------------------------------------++instance (HatVal v, HatBaseClass b, Note n) => Semigroup (Journal n v b) where+ {-# INLINE (<>) #-}+ (<>) = addJournal++-- | Journal addition. Appends right-hand entries to the left-hand side.+--+-- Complexity: Amortized O(size(rhs)); O(n) compaction when the delta exceeds the threshold+--+-- >>> type Test = Journal String Double (HatBase AccountTitles)+-- >>> x = 20.00:@Not:<Cash .+ 20.00:@Hat:<Deposits .| "Withdrawal" :: Test+-- >>> y = 10.00:@Hat:<Cash .+ 10.00:@Not:<Deposits .| "Deposits" :: Test+-- >>> x .+ y+-- 10.00:@Not:<Deposits.|"Deposits" .+ 10.00:@Hat:<Cash.|"Deposits" .+ 20.00:@Hat:<Deposits.|"Withdrawal" .+ 20.00:@Not:<Cash.|"Withdrawal"+addJournal :: (HatVal v, HatBaseClass b, Note n)+ => Journal n v b -> Journal n v b -> Journal n v b+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+ mappend = (<>)++instance (HatVal v, HatBaseClass b, Note n) => Redundant (Journal n) v b where+ (.^) = map (.^)+ (.+) = mappend+ (.*) x = map ((.*) x)+ norm = norm . toAlg+ (.-) x = map (.-) (gather plank x)+ compress = map compress++instance (Note n, HatVal v, ExBaseClass b) => Exchange (Journal n) v b where+ decR js = map (EA.filter (\x -> x /= EA.Zero && (whichSide . EA._hatBase) x == Credit)) js+ decL xs = map (EA.filter (\x -> x /= EA.Zero && (whichSide . EA._hatBase) x == Debit)) xs+ decP xs = map (EA.filter (\x -> x /= EA.Zero && (isHat . EA._hatBase) x)) xs+ decM xs = map (EA.filter (\x -> x /= EA.Zero && (not . isHat . EA._hatBase) x)) xs++ balance xs+ | (norm . decR) xs == (norm . decL) xs = True+ | otherwise = False++ diffRL xs+ | r > l = (Credit, r - l)+ | l > r = (Debit, l - r)+ | otherwise = (Side, 0)+ where+ r = (norm . decR) xs+ l = (norm . decL) xs++------------------------------------------------------------------+-- | fromList+--+-- >>> 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"+fromList :: (HatVal v, HatBaseClass b, Note n)+ => [Journal n v b] -> Journal n v b+fromList = foldr (.+) mempty++------------------------------------------------------------------+{-# INLINE mergeJournalMap #-}+mergeJournalMap :: (HatVal v, HatBaseClass b, Note n)+ => 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+ | otherwise =+ let !acc1 = Map.foldlWithKey' mergeOne acc base+ in Map.foldlWithKey' mergeOne acc1 delta+ where+ mergeOne !m !n !alg+ | EA.isZero alg = m+ | otherwise = Map.insertWith (.+) n alg m++{-# INLINE mergeJournalMapIfNonZero #-}+mergeJournalMapIfNonZero :: (HatVal v, HatBaseClass b, Note n)+ => Map.HashMap n (Alg v b)+ -> Journal n v b+ -> Map.HashMap n (Alg v b)+mergeJournalMapIfNonZero !acc js+ | isZero js = acc+ | otherwise = mergeJournalMap acc js++-- | Summation function that applies a function to each list element and sums the resulting Journals.+--+-- Complexity: O(|xs| * union cost)+{-# INLINE sigma #-}+sigma :: (HatVal v, HatBaseClass b, Note n)+ => [a] -> (a -> Journal n v b) -> Journal n v b+sigma xs f = fromMap $ L.foldl' step Map.empty xs+ where+ step !acc !x = mergeJournalMapIfNonZero acc (f x)++-- | Conditional summation over a double loop (Journal version).+-- Applies the function only to pairs that satisfy the condition across all combinations of two lists, and sums the results.+--+-- Complexity: O(|xs| * |ys| * union cost)+{-# INLINE sigma2When #-}+sigma2When :: (HatVal v, HatBaseClass b, Note n)+ => [a]+ -> [c]+ -> (a -> c -> Bool)+ -> (a -> c -> Journal n v b)+ -> Journal n v b+sigma2When xs ys cond f =+ fromMap $ L.foldl' outer Map.empty xs+ where+ outer !acc !x = L.foldl' (inner x) acc ys+ inner !x !acc !y+ | cond x y = mergeJournalMapIfNonZero acc (f x y)+ | otherwise = acc++-- | Sum each list element as an Alg on the specified Note and store the result in a Journal.+-- Returns an empty Journal if the result is zero.+--+-- Complexity: O(|xs| * union cost)+{-# INLINE sigmaOn #-}+sigmaOn :: (HatVal v, HatBaseClass b, Note n)+ => n+ -> [a]+ -> (a -> Alg v b)+ -> Journal n v b+sigmaOn n xs f =+ let !alg = EA.sigma xs f+ in if EA.isZero alg+ then mempty+ else alg .| n++-- | Sum Alg values from Map keys and values on the specified Note and store the result in a Journal.+-- Map version of 'sigmaOn'.+--+-- Complexity: O(|map| * union cost)+{-# INLINE sigmaOnFromMap #-}+sigmaOnFromMap :: (HatVal v, HatBaseClass b, Note n, Ord k)+ => n+ -> M.Map k v+ -> (k -> v -> Alg v b)+ -> Journal n v b+sigmaOnFromMap n kvs f =+ let !alg = EA.sigmaFromMap kvs f+ in if EA.isZero alg+ then mempty+ else alg .| n++-- | Summation in a monadic context. Applies a monadic function to each element and mconcats the results.+--+-- Complexity: O(|xs| * cost(f))+sigmaM :: (Monoid m, Monad m0) => [a] -> (a -> m0 m) -> m0 m+sigmaM xs f = mconcat <$> CM.forM xs f++------------------------------------------------------------------+-- | Combine entries from all Notes in a Journal into a single Alg.+--+-- 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 _ _ _) =+ EA.unionsMerge (Map.elems base ++ Map.elems delta)++------------------------------------------------------------------+-- | Apply function f to the entry of each Note in the Journal.+-- Applies to merged Note entries (base + delta), preserving semantics.+--+-- Complexity: O(j * cost(f)) where j is the number of Notes+map :: (HatVal v, HatBaseClass b, Note n)+ => (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++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++-- | Insert x into y. If x's Note already exists in y, it is overwritten with x's value.+--+-- >>> type Test = Journal String Double (HatBase AccountTitles)+-- >>> x = 10.00:@Not:<Cash .| "A" :: Test+-- >>> y = 20.00:@Not:<Cash .| "B" :: Test+-- >>> z = 30.00:@Hat:<Cash .| "A" :: Test+-- >>> insert z (x .+ y)+-- 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))++------------------------------------------------------------------+-- | projWithNote+-- Projecting with 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+-- >>> z = 3.00:@Hat:<Yen .+ 3.00:@Not:<Amount .| "fish" :: Test+-- >>> projWithNote ["dog","cat"] (x .+ y .+ z)+-- 1.00:@Not:<Amount.|"cat" .+ 1.00:@Hat:<Yen.|"cat" .+ 2.00:@Not:<Amount.|"dog" .+ 2.00:@Hat:<Yen.|"dog"+projWithNote :: (HatVal v, HatBaseClass b, Note n)+ => [n] -> Journal n v b -> Journal n v b+projWithNote ns js+ | any isPlank ns = js+projWithNote [n] js = fromMap $ case lookupNote n js of+ Nothing -> Map.empty+ Just a -> Map.singleton n a+projWithNote ns js =+ fromMap $+ S.foldl'+ (\acc n -> case lookupNote n js of+ Nothing -> acc+ Just a -> Map.insert n a acc)+ Map.empty+ (S.fromList ns)++------------------------------------------------------------------+-- | projWithBase+-- Projecting with Base.+--+-- >>> 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+-- >>> z = 3.00:@Hat:<Yen .+ 3.00:@Not:<Amount .| "fish" :: Test+-- >>> projWithBase [Not:<Amount] (x .+ y .+ z)+-- 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 #-}+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.+--+-- Complexity: O(j * proj cost) where j is the number of Notes+projWithBaseNorm :: (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)++------------------------------------------------------------------+-- | projWithNoteBase+-- Projecting with Note and Base.+--+-- >>> 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+-- >>> z = 3.00:@Hat:<Yen .+ 3.00:@Not:<Amount .| "fish" :: Test+-- >>> projWithNoteBase ["dog","fish"] [Not:<Amount] (x .+ y .+ z)+-- 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 #-}+projWithNoteBase _ [] _ = mempty+projWithNoteBase ns bs js+ | any isPlank ns = projWithBase bs js+projWithNoteBase [n] bs js = fromMap $ case lookupNote n js of+ Nothing -> Map.empty+ Just a -> Map.singleton n (EA.proj bs a)+projWithNoteBase [] bs js = projWithBase bs js+projWithNoteBase ns bs js =+ fromMap $+ S.foldl'+ (\acc n -> case lookupNote n js of+ Nothing -> acc+ Just a -> Map.insert n (EA.proj bs a) acc)+ 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.+--+-- Complexity: O(|ns| * proj cost)+projWithNoteNorm :: (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+ Nothing -> 0+ Just a -> EA.projNorm bs a+projWithNoteNorm [] bs js = projWithBaseNorm bs js+projWithNoteNorm ns bs js =+ S.foldl'+ (\acc n -> case lookupNote n js of+ Nothing -> acc+ Just a -> acc + EA.projNorm 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+ #-}++------------------------------------------------------------------+-- | Filter by a predicate on Note-entry pairs.+-- Applies the filter to both the base and delta layers.+--+-- 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+ !delta' = Map.filterWithKey f delta+ in mkJournal base' delta' ver++-- | 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.+--+-- Axis numbers are 0-indexed. For a Note type @(EventName, Term)@:+--+-- * axis 0 corresponds to EventName+-- * axis 1 corresponds to Term+--+-- For non-tuple Note types, axis 0 is the only valid axis.+--+-- Complexity: O(|result|) after index construction; O(n) for first base-axis query on a Journal value+--+-- >>> type Test = Journal (String, Int) Double (HatBase AccountTitles)+-- >>> x = 10.00:@Not:<Cash .| ("A", 1) :: Test+-- >>> y = 20.00:@Hat:<Cash .| ("B", 1) :: Test+-- >>> z = 30.00:@Not:<Cash .| ("A", 2) :: Test+-- >>> filterByAxis 0 (NoteAxisKey "A") (x .+ y .+ z)+-- 10.00:@Not:<Cash.|("A",1) .+ 30.00:@Not:<Cash.|("A",2)+--+-- >>> filterByAxis 1 (NoteAxisKey (1 :: Int)) (x .+ y .+ z)+-- 10.00:@Not:<Cash.|("A",1) .+ 20.00:@Hat:<Cash.|("B",1)+{-# 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) =+ let !matched = HSet.union+ (queryNoteAxisPosting axis key baseIdx)+ (queryNoteAxisPosting axis key deltaIdx)+ !result = HSet.foldl'+ (\acc n -> case lookupNote n j of+ Nothing -> acc+ Just alg -> Map.insert n alg acc)+ Map.empty+ matched+ in fromMap result++------------------------------------------------------------------+-- | gather+-- Gathers all Alg into one on the given Note.+--+-- >>> type Test = Journal String Double (EA.HatBase EA.AccountTitles)+-- >>> x = 20.00:@Not:<Cash .+ 20.00:@Hat:<Deposits .| "Withdrawal" :: Test+-- >>> y = 10.00:@Hat:<Cash .+ 10.00:@Not:<Deposits .| "Deposits" :: Test+-- >>> gather "A" (x .+ y)+-- 10.00:@Not:<Deposits.|"A" .+ 20.00:@Hat:<Deposits.|"A" .+ 20.00:@Not:<Cash.|"A" .+ 10.00:@Hat:<Cash.|"A"+gather :: (HatVal v, HatBaseClass b, Note n)+ => n -> Journal n v b -> Journal n v b+gather n js = (toAlg js) .| n
+ src/ExchangeAlgebra/Journal/Transfer.hs view
@@ -0,0 +1,145 @@+{- |+ Module : ExchangeAlgebra.Journal.Transfer+ 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>++-}+++{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PostfixOperators #-}++++module ExchangeAlgebra.Journal.Transfer+ ( TransTable (..)+ , isNullTable+ , table+ , TransTableParts+ , (.->)+ , (|%)+ , ExchangeAlgebra.Journal.Transfer.transfer+ , ExchangeAlgebra.Journal.Transfer.incomeSummaryAccount+ , ExchangeAlgebra.Journal.Transfer.netIncomeTransfer+ , ExchangeAlgebra.Journal.Transfer.grossProfitTransfer+ , ExchangeAlgebra.Journal.Transfer.ordinaryProfitTransfer+ , ExchangeAlgebra.Journal.Transfer.retainedEarningTransfer+ , 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 (..)+ , isNullTable+ , table+ , TransTableParts+ , (.->)+ , (|%)+ , finalStockTransferStep+ , retainedEarningTransfer+ , ordinaryProfitTransfer+ , grossProfitTransfer)+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.+--+-- Complexity: O(j * s) (j = number of Notes, s = number of scalar entries per Note)+{-# INLINE transfer #-}+transfer :: (HatVal v, HatBaseClass b, Note n)+ => Journal n v b -> TransTable v b -> Journal n v b+transfer js tb = EJ.map (\x -> EAT.transfer x tb) js++createTransfer :: (Note n, HatVal v, ExBaseClass b)+ => [(b,b,(v -> v))] -> (Journal n v b -> Journal n v b)+createTransfer tt = \ts -> transfer ts $ EAT.table tt++-- * Closing transfer entries++-- | 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.+--+-- 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 let x = case dc of+ Credit -> diff :@ (toNot wiledcard) .~ NetIncome+ Debit -> diff :@ (toNot wiledcard) .~ NetLoss+ in js .+ ( x .| plank)++-- | Net income transfer (Journal version). Transfer NetIncome/NetLoss to RetainedEarnings for each Note.+--+-- Complexity: O(j * s) (j = number of Notes, s = number of scalar entries per Note)+netIncomeTransfer :: (Note n, HatVal v, ExBaseClass b) => Journal n v b -> Journal n v b+netIncomeTransfer = EJ.map EAT.netIncomeTransfer++-- ** Journalizing++-- | Gross profit transfer (Journal version). Aggregate sales and cost accounts into GrossProfit for each Note.+--+-- 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+--+-- >>> type Test = Journal String Double (HatBase (CountUnit, AccountTitles))+-- >>> x = 2279.0:@Not:<(Yen,Depreciation) .| "A" :: Test+-- >>> y = 500475.0:@Not:<(Yen,InterestEarned) .| "B" :: Test+-- >>> ExchangeAlgebra.Journal.Transfer.ordinaryProfitTransfer ( x .+ y)+-- 2279.00:@Hat:<(Yen,OrdinaryProfit).|"A" .+ 500475.00:@Not:<(Yen,OrdinaryProfit).|"B"++ordinaryProfitTransfer :: (Note n, HatVal v, ExBaseClass b) => Journal n v b -> Journal n v b+ordinaryProfitTransfer = EJ.map EAT.ordinaryProfitTransfer++-- | Retained earnings transfer (Journal version). Transfer OrdinaryProfit to RetainedEarnings for each Note.+--+-- Complexity: O(j * s)+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.+--+-- Complexity: O(j * s)+finalStockTransfer ::(Note n, HatVal v, ExBaseClass b) => Journal n v b -> Journal n v b+finalStockTransfer = (.-) . EJ.map finalStockTransferStep+
+ src/ExchangeAlgebra/Simulate.hs view
@@ -0,0 +1,699 @@+{- |+ Module : ExchangeAlgebra.Simulate+ Copyright : (c) Kaya Akagi. 2018-2026+ Maintainer : yakagika@icloud.com++ Released under the OWL license++ State-space framework for Exchange-Algebra-based simulation:+ 'StateSpace', 'Updatable', 'runSimulation', ripple-effect utilities+ ('rippleEffect', 'leontiefInverse'), spill-to-disk ledger support,+ and parallel scenario execution ('runScenarios').++ 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>++ == Application note++ The design of this module — the accounting state space as the minimal+ unit for agent-based simulation, and the ripple-effect utilities — is+ described in:++ Kaya Akagi. /Accounting State Space as the Minimal Unit for Economic/+ /Agent-Based Modeling: Advancing Ripple Effect Analysis in Real-Time/+ /Economy./ Research Square, preprint (Version 1), posted 5 January 2026.+ <https://doi.org/10.21203/rs.3.rs-8485050/v1>++ Runnable companions to the preprint live in the repository under+ @examples\/deterministic\/ripple\/@+ (<https://github.com/yakagika/ExchangeAlgebra/tree/master/examples/deterministic/ripple>).++-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DerivingVia #-}+module ExchangeAlgebra.Simulate+ (StateTime+ ,initTerm+ ,lastTerm+ ,nextTerm+ ,prevTerm+ ,UpdatePattern(..)+ ,Updatable(unwrap, Inner)+ ,initialize+ ,updatePattern+ ,copy+ ,modify+ ,update+ ,initAll+ ,updateAll+ ,StateSpace(event,randomSeeds)+ ,normal+ ,normal'+ ,updateGen+ ,InitVariables+ ,UpdatableSTRef(..)+ ,UpdatableSTArray(..)+ ,modifyArray+ ,Event(..)+ ,eventAll+ ,SpillOptions(..)+ ,SpillDeletePolicy(..)+ ,mkSpillOptions+ ,mkBinarySpillOptions+ ,defaultSpillWriter+ ,defaultBinarySpillWriter+ ,readBinarySpillFile+ ,runSimulation+ ,runSimulationWithSpill+ ,runScenarios+ ,runScenariosWithSpill+ ,leontiefInverse+ ,rippleEffect) where++import Control.Monad+import Control.Concurrent.Async (mapConcurrently)+import Data.Coerce (Coercible, coerce)+import GHC.Generics+import System.Random+import Data.Ix+import Data.Kind+import Control.Monad.ST+import Data.Array.ST hiding (modifyArray)+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++------------------------------------------------------------------+-- | Type class defining the time axis for simulations.+--+-- @nextTerm@ and @prevTerm@ have default implementations via @succ@ / @pred@,+-- so for uniformly-spaced time axes only @initTerm@ and @lastTerm@ need to be defined.+--+-- @+-- type Term = Int+--+-- instance StateTime Term where+-- initTerm = 1+-- lastTerm = 100+-- -- nextTerm and prevTerm use the defaults (succ, pred)+-- @+class (Eq t, Show t, Ord t, Enum t, Ix t) => StateTime t where+ initTerm :: t+ lastTerm :: t+ -- | Return the next term. Defaults to @succ@.+ nextTerm :: t -> t+ nextTerm = succ+ -- | Return the previous term. Defaults to @pred@.+ prevTerm :: t -> t+ prevTerm = pred++-- | Type class for initialization parameters.+-- Parameters referenced during initialization at the start of a simulation.+-- Values referenced during simulation execution should be included in 'Updatable'.+class (Eq e, Show e) => InitVariables e where++------------------------------------------------------------------+-- | Type class for event types.+-- Used to enumerate events executed at each term of the simulation.+-- By default, 'minBound' / 'maxBound' from 'Bounded' are used.+class (Ord e, Show e, Enum e, Eq e, Bounded e) => Event e where+ -- | The first event. Defaults to @minBound@.+ fstEvent :: e+ fstEvent = minBound+ -- | The last event. Defaults to @maxBound@.+ lastEvent :: e+ lastEvent = maxBound++------------------------------------------------------------------+-- | Update pattern for advancing to the next term. Specifies how each Updatable field is updated.+data UpdatePattern = Copy -- ^ Copy the previous term's state as-is+ | Modify -- ^ Update by modifying the previous term's state+ | DoNothing -- ^ Do nothing (used when all terms are pre-generated during initialization)+ deriving (Show, Eq)++------------------------------------------------------------------+-- | Type class for updatable fields that constitute a StateSpace.+-- Provides an interface for initialization, copying, and modification.+-- Through Generic-based automatic derivation, initAll/updateAll of StateSpace are auto-implemented.+class (StateTime t,InitVariables v)+ => Updatable t v (a :: Type -> Type) s | a s -> t v where+ type Inner a s+ unwrap :: a s -> Inner a s++ -- Currently StdGen returns the same value for all instance initializations+ -- (the random number generator is not being advanced).+ -- To use different random numbers per instance, use updateGen or similar.+ -- Planned: allow advancing a shared random number generator across instances.+ initialize :: StdGen -> t -> v -> ST s (a s)++ updatePattern :: (a s) -> ST s UpdatePattern++ {-# INLINE copy #-}+ copy :: StdGen -> t -> v -> (a s) -> ST s ()+ copy _ _ _ _ = undefined++ {-# INLINE modify #-}+ modify :: StdGen -> t -> v -> (a s) -> ST s ()+ modify _ _ _ _ = undefined++ {-# INLINE update #-}+ update :: StdGen -> t -> v -> (a s) -> ST s ()+ update g t v x = do+ p <- updatePattern x+ case p of+ DoNothing -> return ()+ Copy -> copy g t v x+ Modify -> modify g t v x+++-- | Type class for newtype wrappers around @STRef@.+--+-- @_unwrapURef@ and @_wrapURef@ have @Coercible@-based default implementations,+-- so newtype wrappers only need an empty instance declaration.+--+-- @+-- newtype SP s = SP (STRef s Double)+--+-- -- Empty instance is sufficient thanks to Coercible defaults+-- instance UpdatableSTRef SP s Double+--+-- -- Previous boilerplate (no longer needed):+-- -- instance UpdatableSTRef SP s Double where+-- -- _unwrapURef (SP x) = x+-- -- _wrapURef x = SP x+-- @+class UpdatableSTRef wrapper s b | wrapper s -> b where+ -- | Unwrap to the inner @STRef@.+ -- For newtype wrappers, the @Coercible@ default is used.+ _unwrapURef :: wrapper s -> STRef s b+ default _unwrapURef :: (Coercible (wrapper s) (STRef s b)) => wrapper s -> STRef s b+ _unwrapURef = coerce++ -- | Wrap an @STRef@ into the newtype.+ -- For newtype wrappers, the @Coercible@ default is used.+ _wrapURef :: STRef s b -> wrapper s+ default _wrapURef :: (Coercible (STRef s b) (wrapper s)) => STRef s b -> wrapper s+ _wrapURef = coerce++ newURef :: b -> ST s (wrapper s)+ newURef b = b `seq` (_wrapURef <$> newSTRef b)++ readURef :: wrapper s -> ST s b+ readURef = readSTRef . _unwrapURef++ writeURef :: wrapper s -> b -> ST s ()+ writeURef x v = v `seq` writeSTRef (_unwrapURef x) v++ modifyURef :: wrapper s -> (b -> b) -> ST s ()+ modifyURef x f = modifySTRef' (_unwrapURef x) f++++-- | Modify the value at a given index of an array using a function. Evaluates strictly before writing back.+--+-- Complexity: O(1)+{-# INLINE modifyArray #-}+modifyArray ::(MArray a t m, Ix i) => a i t -> i -> (t -> t) -> m ()+modifyArray ar e f = do+ x <- readArray ar e+ let y = f x+ y `seq` writeArray ar e y+++-- | Type class for newtype wrappers around @STArray@.+--+-- @_unwrapUArray@ and @_wrapUArray@ have @Coercible@-based default implementations,+-- so newtype wrappers only need an empty instance declaration.+--+-- @+-- newtype ICTable s = ICTable (STArray s (Int, Int) Double)+--+-- -- Empty instance is sufficient thanks to Coercible defaults+-- instance UpdatableSTArray ICTable s (Int, Int) Double+--+-- -- Previous boilerplate (no longer needed):+-- -- instance UpdatableSTArray ICTable s (Int, Int) Double where+-- -- _unwrapUArray (ICTable arr) = arr+-- -- _wrapUArray arr = ICTable arr+-- @+class (Ix b) => UpdatableSTArray wrapper s b c | wrapper s -> b c where+ -- | Unwrap to the inner @STArray@.+ -- For newtype wrappers, the @Coercible@ default is used.+ _unwrapUArray :: wrapper s -> STArray s b c+ default _unwrapUArray :: (Coercible (wrapper s) (STArray s b c)) => wrapper s -> STArray s b c+ _unwrapUArray = coerce++ -- | Wrap an @STArray@ into the newtype.+ -- For newtype wrappers, the @Coercible@ default is used.+ _wrapUArray :: STArray s b c -> wrapper s+ default _wrapUArray :: (Coercible (STArray s b c) (wrapper s)) => STArray s b c -> wrapper s+ _wrapUArray = coerce++ getUBounds :: wrapper s -> ST s (b,b)+ getUBounds = getBounds . _unwrapUArray++ newUArray :: (b,b) -> c -> ST s (wrapper s)+ newUArray b c = c `seq` (_wrapUArray <$> newArray b c)++ readUArray :: wrapper s -> b -> ST s c+ readUArray arr = readArray (_unwrapUArray arr)++ writeUArray :: wrapper s -> b -> c -> ST s ()+ writeUArray arr idx v = v `seq` writeArray (_unwrapUArray arr) idx v++ modifyUArray :: wrapper s -> b -> (c -> c) -> ST s ()+ modifyUArray x f = modifyArray (_unwrapUArray x) f++------------------------------------------------------------------+-- | Type class defining the world state for a simulation.+-- Initialize with initAll, update state each term with updateAll, and execute event processing with event.+-- Through DefaultSignatures with Generic, initAll and updateAll can be automatically derived.+class (StateTime t,InitVariables v, Event e)+ => StateSpace t v e (a :: Type -> Type) s | a s -> t v e where+ {-# INLINE initAll #-}+ initAll :: StdGen -> t -> v -> ST s (a s)++ -- DefaultSignatures extension+ default initAll :: (Generic (a s), GUpdatable t v (Rep (a s)) s)+ => StdGen -> t -> v -> ST s (a s)+ initAll g t v = GHC.Generics.to <$> gInitialize g t v++ -- DefaultSignatures extension+ {-# INLINE updateAll #-}+ updateAll :: StdGen -> t -> v -> a s -> ST s ()+ default updateAll :: (Generic (a s), GUpdatable t v (Rep (a s)) s)+ => StdGen -> t -> v -> a s -> ST s ()+ updateAll g t v a = gUpdate g t v (GHC.Generics.from a)++ -- Event processing+ event :: a s -> t -> e -> ST s ()++ -- Specify the starting term+ initT :: v -> a s -> ST s t+ initT _ _ = return initTerm++ -- Specify the ending term+ lastT :: v -> a s -> ST s t+ lastT _ _ = return lastTerm++ -- | Define the random seed (default 42).+ -- The random seed can also be explicitly defined.+ -- Currently unused.+ randomSeeds :: a s -> ST s Int+ randomSeeds _ = return 42+++-- | Execute all events in order. Calls @event@ from @fstEvent@ through @lastEvent@.+--+-- Complexity: O(|events| * cost(event))+{-# INLINE eventAll #-}+eventAll :: forall t v e a s. (StateSpace t v e a s) => a s -> t -> ST s ()+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)+ => StdGen -> a s -> v -> ST s ()+simulate g wld v = loop g wld initTerm v+ where+ {-# 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+ | otherwise = do+ 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.+--+-- Complexity: O(T * (updateAll + eventAll)) (T = number of terms)+runSimulation :: (StateSpace t v e a RealWorld)+ => StdGen -> v -> IO (a RealWorld)+runSimulation gen v = stToIO $ do+ wld <- initAll gen initTerm v+ simulate gen wld v+ pure wld++-- | Run simulation with periodic spill.+-- This function keeps existing behavior and additionally writes extracted+-- accounting payload every N terms (and at the last term).+runSimulationWithSpill :: (StateSpace t v e a RealWorld)+ => SpillOptions t a payload+ -> StdGen+ -> v+ -> IO (a RealWorld)+runSimulationWithSpill opts gen v = do+ wld <- stToIO $ initAll gen initTerm v+ tStart <- stToIO $ initT v wld+ tEnd <- stToIO $ lastT v wld+ withFile (spillFilePath opts) WriteMode $ \h -> do+ (wld', lastSpilledEnd) <- loop h wld tStart tStart tEnd Nothing+ spillFinalRemainder h wld' tStart tEnd lastSpilledEnd+ pure wld'+ where+ 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+ Nothing -> pure ()+ Just delRange -> stToIO $ spillDeleteRange opts delRange wld++ spillFinalRemainder h wld tStart tEnd lastSpilledEnd =+ let remainderStart = case lastSpilledEnd of+ Nothing -> tStart+ Just x -> nextTerm x+ in when (remainderStart <= tEnd) $+ spillChunk h remainderStart tEnd wld++ loop h wld t chunkStart tEnd lastSpilledEnd = do+ stToIO $ updateAll gen t v wld+ stToIO $ eventAll wld t+ let isLast = t == tEnd+ (nextChunkStart, nextLastSpilledEnd) <- if shouldSpill chunkStart t isLast+ then spillChunk h chunkStart t wld >> pure (nextTerm t, Just t)+ else pure (chunkStart, lastSpilledEnd)+ if isLast+ then pure (wld, nextLastSpilledEnd)+ else loop h wld (nextTerm t) nextChunkStart tEnd nextLastSpilledEnd++-- | Run multiple simulation scenarios concurrently and return results as a @Map@.+--+-- Each scenario is a @(name, parameters)@ pair. All scenarios share the same+-- random seed and are executed in parallel.+--+-- @+-- let gen = mkStdGen 2025+-- scenarios = [(\"default\", defaultEnv), (\"plus\", plusEnv)]+-- results <- runScenarios gen scenarios+-- -- results :: Map String (World RealWorld)+-- @+runScenarios :: (StateSpace t v e a RealWorld)+ => StdGen -> [(String, v)] -> IO (M.Map String (a RealWorld))+runScenarios gen scenarios = do+ results <- mapConcurrently (\(_, v) -> runSimulation gen v) scenarios+ pure $ M.fromList $ zip (fmap fst scenarios) results++-- | Run multiple simulation scenarios concurrently with periodic spill.+--+-- The spill options builder receives the scenario name, allowing per-scenario+-- file paths and logging.+--+-- @+-- results <- runScenariosWithSpill+-- (\\name -> mkBinarySpillOptions 50 (dir ++ name ++ \".bin\") extract)+-- gen+-- scenarios+-- @+runScenariosWithSpill :: (StateSpace t v e a RealWorld)+ => (String -> SpillOptions t a payload)+ -> StdGen+ -> [(String, v)]+ -> IO (M.Map String (a RealWorld))+runScenariosWithSpill buildOpts gen scenarios = do+ results <- mapConcurrently+ (\(name, v) -> runSimulationWithSpill (buildOpts name) gen v)+ scenarios+ pure $ M.fromList $ zip (fmap fst scenarios) results++-- Helper type class for Generic-based automatic derivation+class (StateTime t,InitVariables v)+ => GUpdatable t v a s where+ gInitialize :: StdGen -> t -> v -> ST s (a s)++ gUpdate :: StdGen -> t -> v -> a s -> ST s ()++-- GUpdatable instance for constructors+instance (StateTime t,InitVariables v)+ => GUpdatable t v U1 s where+ gInitialize _ _ _ = return U1+ gUpdate _ _ _ _ = return ()++-- | GUpdatable instance for primitive types+instance (StateTime t, InitVariables v, Updatable t v a s)+ => GUpdatable t v (K1 i (a s)) s where+ gInitialize g t v = K1 <$> initialize g t v+ gUpdate g t v (K1 x) = update g t v x++-- | GUpdatable instance for sum types+instance (StateTime t, InitVariables v, GUpdatable t v p s, GUpdatable t v q s)+ => GUpdatable t v (p :+: q) s where+ gInitialize g t v = gInitialize g t v+ gUpdate g t v (L1 p) = gUpdate g t v p+ gUpdate g t v (R1 q) = gUpdate g t v q++-- | GUpdatable instance for product types (record fields)+instance (StateTime t, InitVariables v, GUpdatable t v p s, GUpdatable t v q s)+ => GUpdatable t v (p :*: q) s where+ gInitialize g t v = (:*:) <$> gInitialize g t v <*> gInitialize g t v+ gUpdate g t v (x :*: y) = gUpdate g t v y >> gUpdate g t v x++-- GUpdatable instance for metadata wrappers+instance (StateTime t, InitVariables v, GUpdatable t v f s)+ => GUpdatable t v (M1 p l f) s where -- Metadata is ignored+ gInitialize g t v = M1 <$> gInitialize g t v+ gUpdate g t v (M1 f) = gUpdate g t v f++------------------------------------------------------------------+-- * Ripple Effect Analysis+------------------------------------------------------------------++-- | Generate Identity Matrix+identity :: Int -> IO (IOArray (Int, Int) Double)+identity n = newArray ((1, 1), (n, n)) 0 >>= \arr -> do+ forM_ [1..n] $ \i -> writeArray arr (i, i) 1+ return arr++-- | Calculate inverse matrix with Gauss-Jordan Method+inverse :: IOArray (Int, Int) Double -> IO (IOArray (Int, Int) Double)+inverse mat = do+ bnds <- getBounds mat+ let ((1,1),(n,_)) = bnds+ inv <- identity n++ forM_ [1..n] $ \i -> do+ pivot <- readArray mat (i,i)+ forM_ [1..n] $ \j -> do+ modifyArray mat (i,j) (/pivot)+ modifyArray inv (i,j) (/pivot)+ forM_ [1..n] $ \k -> when (k /= i) $ do+ factor <- readArray mat (k,i)+ forM_ [1..n] $ \j -> do+ mVal <- readArray mat (i,j)+ iVal <- readArray inv (i,j)+ modifyArray mat (k,j) (\x -> x - factor * mVal)+ modifyArray inv (k,j) (\x -> x - factor * iVal)++ return inv++{- | Calculate Leontief's Inverse Matrix+ex.+main :: IO ()+main = do+ mat <- newListArray ((1,1),(2,2)) [0.2, 0.3, 0.4, 0.1]+ result <- leontiefInverse mat+ putStrLn "Leontief Inverse (ripple effect matrix):"+ writeLeontiefInverse "output.csv" result+-}++leontiefInverse :: IOArray (Int, Int) Double -> IO (IOArray (Int, Int) Double)+leontiefInverse a = do+ bnds <- getBounds a+ temp <- newArray bnds 0+ forM_ (range bnds) $ \(i,j) -> do+ val <- readArray a (i,j)+ writeArray temp (i,j) (if i == j then 1 - val else -val)+ inverse temp++-- | Calculate the ripple effect of a demand increase in a specific industry using the inverse matrix.+-- Returns the ripple effect on each industry when a one-unit demand increase occurs in the specified industry.+--+-- Complexity: O(n) (n = number of industries)+rippleEffect :: Int -> IOArray (Int, Int) Double -> IO (IOArray (Int, Int) Double)+rippleEffect industry inverseArr = do+ ((r1,c1),(r2,c2)) <- getBounds inverseArr+ result <- newArray ((r1,c1),(r2,c2)) 0+ forM_ [r1..r2] $ \i -> do+ val <- readArray inverseArr (i, industry)+ writeArray result (i, industry) val+ return result+++------------------------------------------------------------------+-- * Random number utilities+------------------------------------------------------------------++-- ** Normal distribution+-- cf. https://hackage.haskell.org/package/normaldistribution-1.1.0.3/docs/src/Data-Random-Normal.html++-- | Approximate normal distribution using the Box-Muller method (internal function).+-- Generates a pair of standard normal random numbers from a pair of uniform random numbers.+--+-- Complexity: O(1)+boxMuller :: Floating a => a -> a -> (a,a)+boxMuller u1 u2 = (r * cos t, r * sin t) where r = sqrt (-2 * log u1)+ t = 2 * pi * u2++-- | Generate a random number following the standard normal distribution N(0,1). Uses the Box-Muller method.+--+-- Complexity: O(1)+normal :: (RandomGen g, Random a, Floating a) => g -> (a,g)+normal g0 = (fst $ boxMuller u1 u2, g2)+ where+ (u1,g1) = randomR (0,1) g0+ (u2,g2) = randomR (0,1) g1++-- | Generate a random number following the normal distribution N(mean, sigma) with specified mean and standard deviation.+--+-- Complexity: O(1)+normal' :: (RandomGen g, Random a, Floating a) => (a,a) -> g -> (a,g)+normal' (mean, sigma) g = (x * sigma + mean, g') where (x, g') = normal g++-- | Advance the random number generator a specified number of times.+-- When sharing a single random number generator across multiple variables,+-- repeat the advancement an appropriate number of times to avoid generating the same random numbers, especially during initialization.+--+-- Complexity: O(n)+updateGen :: (RandomGen g) => g -> Prelude.Int -> g+updateGen g n+ | n <= 1 = g'+ | otherwise = updateGen g' (n-1)+ where+ (_,g') = (genWord32 g)
+ src/ExchangeAlgebra/Simulate/Visualize.hs view
@@ -0,0 +1,573 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}++{- |+ Module : ExchangeAlgebra.Simulate.Visualize+ 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.Simulate.Visualize (Title+ ,FileName+ ,Label+ ,GridColumns+ ,GridMatrix+ ,TimeSeries+ ,TimeSerieses+ ,Header+ ,gridLine+ ,plotLine+ ,plotMultiLines+ ,plotWldsDiffLine+ ,plotLineVector+ ,writeFuncResults+ ,writeFuncResultsWithContext) where++import ExchangeAlgebra.Simulate+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+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+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Unboxed.Mutable as VUM+import Data.Array.ST+import qualified Data.Set as Set+import System.IO (IOMode(WriteMode), withFile)++type Title = String+type FileName = String+type Label = String++type TimeSeries t = (Label, [[(t, Double)]])+type TimeSerieses t = [(TimeSeries t)]+type GridColumns t = [TimeSerieses t]+type GridMatrix t = [GridColumns t]++chunkN :: Int -> [a] -> [[a]]+chunkN _ [] = []+chunkN n xs =+ let (front, back) = splitAt n xs+ in front : chunkN n back+++------------------------------------------------------------------+-- * Grid Graph+------------------------------------------------------------------+------------------------------------------------------------------+-- ** Single Line+------------------------------------------------------------------++-- | Plot the specified output of each agent as a line graph divided into a grid.+-- Splits into grid columns of 3, and outputs as a PNG file.+--+-- Complexity: O(|range| * T) (T = number of terms)+plotLine+ :: ( StateTime t+ , Enum t+ , PlotValue t+ , Ord i+ , Show i+ , Ix i+ , Enum i+ )+ => (a RealWorld -> t -> i -> ST RealWorld Double)+ -> (i,i) -- ^ Range (start, end)+ -> a RealWorld -- ^ World state or similar+ -> FileName -- ^ Directory name for output files+ -> Title -- ^ Graph title+ -> IO ()+plotLine f (start,end) wld fileDir titleStr = do+ gridMatrix <- funcArray f (start,end) wld+ let gridRenderable = createGrid gridMatrix+ CM.void $ renderableToFile def (fileDir ++ "/" ++ titleStr ++ ".png")+ $ fillBackground def+ $ gridToRenderable+ $ createTitle titleStr `wideAbove` gridRenderable++ where+ -- | Arrange the entire grid vertically to create a single Grid+ createGrid = aboveN . map createRow++ -- | Arrange each row horizontally to create a single row+ createRow = besideN . map createColumn++ -- | Plot the time series data contained in each column+ createColumn seriesGroup = layoutToGrid $ execEC $ do+ CM.forM_ seriesGroup $ \(label, seriesData) ->+ plot $ linePlot label seriesData++ -- | Render a single time series as a line plot+ linePlot label seriesData = liftEC $ do+ plot_lines_values .= [concat seriesData]+ plot_lines_title .= label+ plot_lines_style . line_color .= opaque blue++ -- | Set the graph title+ createTitle name = setPickFn nullPickFn $+ label titleStyle HTA_Centre VTA_Centre name++ -- | Define the title font style+ titleStyle :: FontStyle+ titleStyle = def+ { _font_size = 15+ , _font_weight = FontWeightBold+ }++{-# INLINE funcArray #-}+funcArray :: ( StateTime t+ , Enum t+ , PlotValue t+ , Ord i+ , Show i+ , Ix i+ , Enum i)+ => (a RealWorld -> t -> i -> ST RealWorld Double)+ -> (i,i) -- ^ Range (start, end)+ -> a RealWorld+ -> IO (GridMatrix t)++funcArray f (start,end) wld = stToIO $ do+ arr <- newArray ((start, initTerm), (end, lastTerm)) 0+ CM.forM_ [initTerm .. lastTerm ] $ \t+ -> CM.forM_ [start .. end] $ \i+ -> writeArray arr (i, t) =<< f wld t i++ gridLine arr++++-- | Split STArray data into a grid with 3 columns and return as a GridMatrix.+-- Each cell contains the time series data for one agent (index).+--+-- Complexity: O(|agents| * T) (T = number of terms)+gridLine :: (Ord a, Show a, Ix a, StateTime t)+ => STArray s (a,t) Double+ -> ST s (GridMatrix t)+gridLine arr = do+ idx <- getBounds arr+ let as = Set.toAscList+ $ Set.fromList+ $ L.map fst+ $ range idx++ cells <- CM.forM as $ \e -> do+ xs <- CM.forM [initTerm .. lastTerm] $ \t -> do+ v <- readArray arr (e, t)+ pure (t, v)+ pure [(show e, [xs])]++ pure (chunkN 3 cells)++------------------------------------------------------------------+-- ** Multi lines+------------------------------------------------------------------+-- | Color Palette+colorPalette :: [AlphaColour Double]+colorPalette =+ [ opaque red+ , opaque blue+ , opaque green+ , opaque orange+ , opaque magenta+ , opaque cyan+ , opaque black+ , opaque grey+ , opaque brown+ , opaque violet+ ]++-- | Plot the results of multiple worlds/functions with color coding in each grid cell.+-- Used for comparing different scenarios.+--+-- Complexity: O(|worlds| * |range| * T)+{-# INLINE plotMultiLines #-}+plotMultiLines+ :: ( StateTime t+ , Enum t+ , PlotValue t+ , Ord i+ , Show i+ , Ix i+ , Enum i+ )+ => [Label]+ -> [(a RealWorld -> t -> i -> ST RealWorld Double)] -- ^ Functions to generate graph data+ -> (i,i) -- ^ Range (start, end)+ -> [a RealWorld] -- ^ World states or similar+ -> FilePath -- ^ Output directory+ -> String -- ^ Graph title+ -> IO ()+plotMultiLines xs fs (start,end) wlds fileDir titleStr = do+ gridMatrix <- funcArrays xs fs (start,end) wlds+ let gridRenderable = createGrid gridMatrix+ CM.void $ renderableToFile def (fileDir ++ "/" ++ titleStr ++ ".png")+ $ fillBackground def+ $ gridToRenderable+ $ createTitle titleStr `wideAbove` gridRenderable+ where+ -- | Arrange the entire grid vertically+ createGrid = aboveN . map createRow++ -- | Arrange each row's grid horizontally+ createRow = besideN . map createColumn++ -- | 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++ -- | Render time series data as a colored line plot+ linePlot idx label seriesData = liftEC $ do+ plot_lines_values .= [concat seriesData]+ plot_lines_title .= label+ plot_lines_style . line_color .= colorPalette !! (idx `mod` length colorPalette)++ -- | Set the graph title+ createTitle name = setPickFn nullPickFn $+ label titleStyle HTA_Centre VTA_Centre name++ -- | Title font style+ titleStyle :: FontStyle+ titleStyle = def+ { _font_size = 15+ , _font_weight = FontWeightBold+ }++{-# INLINE funcArrays #-}+funcArrays :: ( StateTime t+ , Enum t+ , PlotValue t+ , Ord i+ , Show i+ , Ix i+ , Enum i)+ => [Label]+ -> [(a RealWorld -> t -> i -> ST RealWorld Double)]+ -> (i,i) -- ^ Range (start, end)+ -> [a RealWorld]+ -> IO (GridMatrix t)++funcArrays xs fs (start,end) wlds = stToIO $ do+ arrs <- CM.forM (zip wlds fs) $ \(wld,f) -> do+ arr <- newArray ((start, initTerm), (end, lastTerm)) 0+ CM.forM_ [initTerm .. lastTerm ] $ \t+ -> CM.forM_ [start .. end] $ \i+ -> writeArray arr (i, t) =<< f wld t i+ return arr++ gridLines xs arrs+++-- | Extension of gridLine that+-- groups multiple series into the same cell+gridLines+ :: (Ord a, Show a, Ix a, StateTime t)+ => [Label]+ -> [STArray s (a, t) Double]+ -> ST s (GridMatrix t)+gridLines xs arrs = do+ idx <- getBounds (head arrs)+ let as = Set.toAscList+ $ Set.fromList+ $ L.map fst+ $ range idx++ cells <- CM.forM as $ \e -> do+ timeVals <- CM.forM arrs $ \arr -> do+ -- Time series for each series+ ts <- CM.forM [initTerm .. lastTerm] $ \ t -> do+ v <- readArray arr (e,t)+ return (t, v)+ return ts+ -- Group two series into the same cell+ -- TimeSeries has type (String, [[(Term, Double)]])+ -- Multiple series form TimeSerieses = [TimeSeries]+ let cell = map (\(l,vs) -> (show e ++ "_" ++ show l, [vs]))+ $ zip xs timeVals+ pure cell++ pure (chunkN 3 cells)++------------------------------------------------------------------+-- | Plot the difference between two worlds in a grid.+-- Each cell plots @f wld1 t i - f wld2 t i@.+--+-- Complexity: O(|range| * T)+plotWldsDiffLine :: ( StateTime t+ , Enum t+ , PlotValue t+ , Ord i+ , Show i+ , Ix i+ , Enum i+ )+ => (a RealWorld -> t -> i -> ST RealWorld Double)+ -> (i,i)+ -> (a RealWorld, a RealWorld)+ -> FilePath -- ^ Output directory+ -> String -- ^ Graph title+ -> IO ()++plotWldsDiffLine f (start,end) wlds fileDir titleStr = do+ gridMatrix <- funcDiffArray f (start,end) wlds+ let gridRenderable = createGrid gridMatrix+ CM.void $ renderableToFile def (fileDir ++ "/" ++ titleStr ++ ".png")+ $ fillBackground def+ $ gridToRenderable+ $ createTitle titleStr `wideAbove` gridRenderable++ where+ -- | Arrange the entire grid vertically to create a single Grid+ createGrid = aboveN . map createRow++ -- | Arrange each row horizontally to create a single row+ createRow = besideN . map createColumn++ -- | Plot the time series data contained in each column+ createColumn seriesGroup = layoutToGrid $ execEC $ do+ CM.forM_ seriesGroup $ \(label, seriesData) ->+ plot $ linePlot label seriesData++ -- | Render a single time series as a line plot+ linePlot label seriesData = liftEC $ do+ plot_lines_values .= [concat seriesData]+ plot_lines_title .= label+ plot_lines_style . line_color .= opaque blue++ -- | Set the graph title+ createTitle name = setPickFn nullPickFn $+ label titleStyle HTA_Centre VTA_Centre name++ -- | Define the title font style+ titleStyle :: FontStyle+ titleStyle = def+ { _font_size = 15+ , _font_weight = FontWeightBold+ }++{-# INLINE funcDiffArray #-}+funcDiffArray :: ( StateTime t+ , Enum t+ , PlotValue t+ , Ord i+ , Show i+ , Ix i+ , Enum i)+ => (a RealWorld -> t -> i -> ST RealWorld Double)+ -> (i,i) -- ^ Range (start, end)+ -> (a RealWorld,a RealWorld)+ -> IO (GridMatrix t)++funcDiffArray f (start,end) wlds = stToIO $ do+ arr <- newArray ((start, initTerm), (end, lastTerm)) 0+ CM.forM_ [initTerm .. lastTerm ] $ \t+ -> CM.forM_ [start .. end] $ \i+ -> f (fst wlds) t i >>= \v1+ -> f (snd wlds) t i >>= \v2+ -> writeArray arr (i, t) (v1-v2)++ gridLine arr++--------------------------------------------------------------------------------+-- 1. Function to create an (i, t) -> Double array using Vector+--------------------------------------------------------------------------------++-- | Corresponds to the original funcArray. Treats (i, t) as a 2D index and stores the value of f wld t i.+-- A version that replaces the internal implementation from STArray with Unboxed Vector.+funcArrayVector+ :: ( Show i, Enum i, Enum t, StateTime t )+ => (a RealWorld -> t -> i -> ST RealWorld Double) -- ^ Computation function f+ -> ((i,t),(i,t)) -- ^ Range (start, end)+ -> a RealWorld -- ^ World state or similar+ -> ST RealWorld (GridMatrix t) -- ^ Returns the completed immutable Vector+funcArrayVector f ((i1,t1),(i2,t2)) wld = do+ let iCount = fromEnum i2 - fromEnum i1 + 1+ tCount = fromEnum t2 - fromEnum t1 + 1+ totalCount = iCount * tCount++ -- Initialize a Mutable Vector of length totalCount with 0.0+ mvec <- VUM.replicate totalCount 0.0++ -- Compute and write f wld t i in a nested loop+ CM.forM_ [fromEnum t1 .. fromEnum t2] $ \te -> do+ let t = toEnum te+ CM.forM_ [fromEnum i1 .. fromEnum i2] $ \ie -> do+ let i = toEnum ie+ idx = (te - fromEnum t1) * iCount+ + (ie - fromEnum i1)+ VUM.write mvec idx =<< f wld t i++ -- Finally freeze into an immutable Vector+ gridLineVector ((i1,t1),(i2,t2)) =<< VU.freeze mvec++--------------------------------------------------------------------------------+-- 2. Build GridMatrix t from a Vector (equivalent to the original gridLine)+--------------------------------------------------------------------------------++-- | Convert 2D (i, t) data into columns split every 3 cells, forming a GridMatrix.+gridLineVector+ :: forall t i. ( Enum i, Enum t, StateTime t, Show i )+ => ((i,t),(i,t)) -- ^ (start, end)+ -> VU.Vector Double -- ^ Element count = (end - start + 1) * (lastTerm - initTerm + 1)+ -> ST RealWorld (GridMatrix t)+gridLineVector ((i1,t1),(i2,t2)) vec = do+ -- List of possible values of i (ascending)+ let iVals = [fromEnum i1 .. fromEnum i2]+ let iCount = length iVals+ let tVals = [fromEnum t1 .. fromEnum t2]+ cells <- CM.forM iVals $ \ie -> do+ let iVal = (toEnum (ie :: Int) :: i) -- i :: i+ -- Extract the (t, value) series+ let series :: [(t, Double)]+ series =+ [ (toEnum te, VU.unsafeIndex vec (flattenIndex iCount (ie - fromEnum i1) (te - fromEnum t1)))+ | te <- tVals+ ]+ -- TimeSeries has type (Label, [[(t,Double)]]) so+ -- shape it into [[(t,Double)]]+ ts :: [(Label, [[(t,Double)]])]+ ts = [(show iVal, [series])]+ pure ts++ pure (chunkN 3 cells)+ where+ -- flattenIndex iCount iIndex tIndex = tIndex * iCount + iIndex+ flattenIndex :: Int -> Int -> Int -> Int+ flattenIndex width x y = y * width + x++--------------------------------------------------------------------------------+-- 3. Function to draw (i, t) line graphs using a Vector-based approach+--------------------------------------------------------------------------------++-- | Draw line graphs using Unboxed Vectors.+-- Equivalent to 'plotLine', but uses Unboxed Vectors instead of STArray internally,+-- providing better memory efficiency for large-scale data.+--+-- Complexity: O(|range| * T)+plotLineVector+ :: ( Enum i, Enum t, StateTime t, Show i, PlotValue t )+ => (a RealWorld -> t -> i -> ST RealWorld Double)+ -> ((i,t),(i,t)) -- ^ (start, end)+ -> a RealWorld -- ^ World state+ -> FilePath -- ^ Output directory+ -> String -- ^ Graph title+ -> IO ()+plotLineVector f idx wld outDir titleStr = do+ -- 2. Convert to GridMatrix (gridLineVector)+ gridMatrix :: GridMatrix t <- stToIO $ funcArrayVector f idx wld++ -- 3. Render the chart+ let gridRenderable = createGrid gridMatrix+ CM.void $ renderableToFile def (outDir ++ "/" ++ titleStr ++ ".png")+ $ fillBackground def+ $ gridToRenderable+ $ createTitle titleStr `wideAbove` gridRenderable++ where+ -- | Arrange the entire grid vertically+ createGrid = aboveN . map createRow++ -- | Arrange one row (GridColumns t) horizontally+ createRow = besideN . map createColumn++ -- | Plot multiple TimeSeries contained in one column (TimeSerieses t)+ createColumn seriesGroup = layoutToGrid $ execEC $ do+ CM.forM_ seriesGroup $ \(label, seriesData) ->+ plot $ linePlot label seriesData++ linePlot label seriesData = liftEC $ do+ plot_lines_values .= [concat seriesData]+ plot_lines_title .= label+ plot_lines_style . line_color .= opaque blue++ createTitle name =+ setPickFn nullPickFn $+ label titleStyle HTA_Centre VTA_Centre name++ titleStyle :: FontStyle+ titleStyle = def+ { _font_size = 15+ , _font_weight = FontWeightBold+ }+++type Header = T.Text++-- | Build a context for each term, then evaluate multiple functions together and output to CSV.+-- By sharing each term's context, expensive preprocessing (e.g., termJournal, transfer) is reduced to once per term.+-- Uses streaming output, so memory usage does not depend on the number of terms.+--+-- Complexity: O(T * (cost(buildCtx) + |funcs| * cost(f)))+writeFuncResultsWithContext+ :: ( StateTime t+ , Show x+ , Num x+ )+ => (a RealWorld -> t -> ST RealWorld c)+ -> [(Header, c -> ST RealWorld x)]+ -> (t,t)+ -> a RealWorld+ -> FilePath+ -> IO ()+writeFuncResultsWithContext buildCtx funcs (tStart,tEnd) wld path = do+ withFile path WriteMode $ \h -> do+ TIO.hPutStrLn h (toCsvRow (T.pack "Time" : map fst funcs))+ CM.forM_ [tStart .. tEnd] $ \t -> do+ vals <- stToIO $ do+ ctx <- buildCtx wld t+ CM.forM funcs $ \(_, f) -> f ctx+ let row = T.pack (show t) : map (T.pack . show) vals+ TIO.hPutStrLn h (toCsvRow row)++-- | Output the results of given functions as CSV time series data.+-- Internally uses streaming output via 'writeFuncResultsWithContext'.+--+-- Complexity: O(T * |funcs| * cost(f))+writeFuncResults+ :: ( StateTime t+ , Show x+ , Num x+ )+ => [(Header,(a RealWorld -> t -> ST RealWorld x))]+ -> (t,t)+ -> a RealWorld+ -> FilePath+ -> IO ()+writeFuncResults funcs range wld path =+ writeFuncResultsWithContext+ (\_ t -> return t)+ (map (\(header, f) -> (header, \t -> f wld t)) funcs)+ range+ wld+ path++{-# INLINE toCsvRow #-}+toCsvRow :: [T.Text] -> T.Text+toCsvRow = T.intercalate (T.pack ",") . map escapeCsv++{-# INLINE escapeCsv #-}+escapeCsv :: T.Text -> T.Text+escapeCsv t+ | T.any isSpecial t = T.concat [T.pack "\"", T.replace (T.pack "\"") (T.pack "\"\"") t, T.pack "\""]+ | otherwise = t+ where+ isSpecial c = c == ',' || c == '"' || c == '\n' || c == '\r'
+ src/ExchangeAlgebra/Write.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE FlexibleContexts #-}+{- |+ Module : ExchangeAlgebra.Write+ 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.Write+ ( -- * CSV utilities+ writeCSV+ , csvTranspose+ -- * Balance Sheet / P&L / Journal output+ , writeBS+ , writePL+ , writeJournal+ , writeAccountOf+ , writeCompoundTrialBalance+ -- * Simulation output+ , writeTermIO+ , writeIOMatrix+ -- * Spill / Restore+ , restoreJournalFromBinarySpill+ -- * Helpers+ , tshow+ , toSameLength+ ) where++import qualified ExchangeAlgebra.Algebra as EA+import ExchangeAlgebra.Algebra+import qualified ExchangeAlgebra.Journal as EJ++import qualified ExchangeAlgebra.Algebra.Transfer as ET++import ExchangeAlgebra.Simulate++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 Data.Array.IO+import Data.Time (Day)+import System.IO (openFile, IOMode(WriteMode), hClose)+import qualified Data.Text.IO as TIO++-- | Transpose a matrix of Text, padding shorter rows with empty Text.+csvTranspose :: [[T.Text]] -> [[T.Text]]+csvTranspose [] = []+csvTranspose mx = [ [ getCell r i | r <- mx ] | i <- [0 .. maxLen - 1] ]+ where+ maxLen = L.maximum (L.map L.length mx)+ getCell row i+ | i < L.length row = row !! i+ | otherwise = T.empty++-- | Write a matrix of Text as a CSV file. Each cell is quoted.+writeCSV :: FilePath -> [[T.Text]] -> IO ()+writeCSV path rows = do+ h <- openFile path WriteMode+ mapM_ (TIO.hPutStrLn h . toCsvLine) rows+ hClose h+ where+ toCsvLine = T.intercalate (T.pack ",") . L.map quoteCell+ quoteCell t = T.concat [T.pack "\"", T.replace (T.pack "\"") (T.pack "\"\"") t, T.pack "\""]++-- | Helper to convert from Show to Text.+--+-- Complexity: O(show cost)+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.+--+-- 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+ 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)+ assetsText = L.map (tshow . getAccountTitle . _hatBase) (EA.toList assets)+ assetsValue = L.map (tshow . _val) (EA.toList assets)+ liabilityText = L.map (tshow . getAccountTitle . _hatBase) (EA.toList liability)+ liabilityValue = L.map (tshow . _val) (EA.toList liability)+ equityText = L.map (tshow . getAccountTitle . _hatBase) (EA.toList equity)+ equityValue = L.map (tshow . _val) (EA.toList equity)+ result = csvTranspose+ [ [T.pack "Asset"] ++ assetsText ++ [T.pack "Total"]+ , [T.empty] ++ assetsValue ++ [creditTotal]+ , [T.pack "Liability"] ++ liabilityText ++ [T.pack "Equity"] ++ equityText ++ [T.pack "Total"]+ , [T.empty] ++ liabilityValue ++ [T.empty] ++ equityValue ++ [debitTotal]+ ]++-- | Output a Profit and Loss Statement in CSV format.+-- Decomposes into costs and revenues for output.+--+-- 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+ 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)+ costText = L.map (tshow . getAccountTitle . _hatBase) (EA.toList cost)+ costValue = L.map (tshow . _val) (EA.toList cost)+ revenueText = L.map (tshow . getAccountTitle . _hatBase) (EA.toList revenue)+ revenueValue = L.map (tshow . _val) (EA.toList revenue)+ (ct, rt) = toSameLength costText revenueText+ (cv, rv) = toSameLength costValue revenueValue+ result = csvTranspose+ [ [T.pack "Cost"] ++ ct ++ [T.pack "Total"]+ , [T.empty] ++ cv ++ [creditTotal]+ , [T.pack "Revenue"] ++ rt ++ [T.pack "Total"]+ , [T.empty] ++ rv ++ [debitTotal]+ ]++-- | Pad two lists to the same length. Appends empty text to the shorter list.+--+-- Complexity: O(max(|xs|, |ys|))+toSameLength :: [T.Text] -> [T.Text] -> ([T.Text],[T.Text])+toSameLength xs ys =+ case compare lx ly of+ EQ -> (xs, ys)+ LT -> (xs ++ replicate (ly - lx) T.empty, ys)+ GT -> (xs, ys ++ replicate (lx - ly) T.empty)+ where+ lx = Prelude.length xs+ ly = Prelude.length ys++-- | Output journal entries in CSV format.+-- Groups by date and records the debit/credit account titles and amounts for each day.+--+-- Complexity: O(s * log d) (s = number of entries, d = number of distinct dates)+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])+++-- | Output account ledgers in CSV format.+--+-- __Note__: Not yet implemented. Calling this will raise an exception.+writeAccountOf :: (HatVal n, HatBaseClass b, ExBaseClass b)+ => [AccountTitles]+ -> FilePath+ -> Alg n b+ -> (b -> Day)+ -> IO ()+writeAccountOf _ _ _ _ = undefined+++-- | 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.+--+-- 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])+ 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+ (dbt', cbt') = case dc of+ Credit -> (dbt + diff, cbt)+ Debit -> (dbt, cbt + diff)+ line = case dc of+ Credit -> [ tshow diff+ , tshow xl+ , tshow a+ , tshow xr+ , T.empty+ ]+ Debit -> [ T.empty+ , tshow xl+ , tshow a+ , tshow xr+ , tshow diff+ ]+ in (accLines ++ [line], dbt', dt + xr, cbt', ct + xl)+++------------------------------------------------------------------+-- Write Functions for Simulation+------------------------------------------------------------------++-- | Output the Input-Output Table for a specified term in CSV format.+-- 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)+ => 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)+ writeCSV path ((T.pack "" : L.map tshow cols) : body)++-- | Output a 2D IOArray (Input-Output Table or ripple effect matrix) in CSV format.+--+-- Complexity: O(r * c) (r = number of rows, c = number of columns)+writeIOMatrix :: FilePath -> IOArray (Int, Int) Double -> IO ()+writeIOMatrix path arr = do+ ((r1, c1), (r2, c2)) <- getBounds arr+ 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)+ 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
@@ -0,0 +1,740 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++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++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)++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)" 29.01925920375148 (stocks1 !! 5)+ -- 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)" 592.9260354913148 (stocks100 !! 5)+ -- 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++-- | 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+ testSigmaMergePath+ testSigma2When+ testSigmaFromMap+ testJournalSigmaMergePath+ testJournalSigma2When+ testJournalSigmaOn+ testJournalSigmaOnFromMap+ testFilterByAxisEquivalent+ testFilterByAxisWithDeltaUpdates+ testFinalStockTransferAlgEquivalence+ testFinalStockTransferJournalEquivalence+ testRestoreJournalFromBinarySpill+ testSimulateEx1Default+ testCsvTranspose+ testCsvWriteCSV+ testCsvWriteCSVWithQuotes+ testCsvWriteCSVEmpty
+ test/doctests.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import Test.DocTest++main :: IO ()+main = doctest [ "-isrc"+ , "src/ExchangeAlgebra.hs"]