diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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). diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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: +- Paper: +- 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: +``` + +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: +- 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. + +- Hiroshi Deguchi. Exchange Algebra (PDF). + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/exchangealgebra.cabal b/exchangealgebra.cabal new file mode 100644 --- /dev/null +++ b/exchangealgebra.cabal @@ -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 +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 diff --git a/src/ExchangeAlgebra.hs b/src/ExchangeAlgebra.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra.hs @@ -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. + + + + + + == 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: + + + + 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 diff --git a/src/ExchangeAlgebra/Algebra.hs b/src/ExchangeAlgebra/Algebra.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Algebra.hs @@ -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. + + + + + +-} + + +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:>> x = 10:@Not:>> y = 5:@Hat:>> (.-) $ x .+ y +-- 5.00:@Not:>> norm $ 10:@Not:>> (.*) 5 $ 10:@Not:>> compress $ 10:@Not: Redundant a n b where + -- | Hat operation. Flips Hat/Not on all elements. + -- Complexity: O(1) for singleton, O(n) for Liner (n is the number of base keys) + (.^) :: a n b -> a n b + + -- | Bar operation. Cancels Hat/Not on the same base and retains only the difference. + -- Complexity: O(n) (n is the number of base keys) + (.-) :: a n b -> a n b + + -- | Alias for bar operation. Identical to @(.-)@. + bar :: a n b -> a n b + bar = (.-) + + -- | Aggregates values on the same base. Sums while preserving the Hat/Not distinction. + -- Complexity: O(n) (n is the number of base keys) + compress :: a n b -> a n b + + -- | Addition of algebra elements. Alias for the Monoid @<>@ operation. + -- Complexity: O(union cost) + (.+) :: a n b -> a n b -> a n b + + -- | Scalar product. Multiplies all element values by a scalar. + -- Complexity: O(1) for singleton, O(n) for Liner + (.*) :: n -> a n b -> a n b + + -- | Norm. Returns the sum of all element values. + -- Complexity: O(n) (n is the number of base keys) + norm :: a n b -> n + + -- | Addition in an Applicative context. + -- Complexity: O(union cost) + {-# INLINE (<+) #-} + (<+) :: (Applicative f) => f (a n b) -> f (a n b) -> f (a n b) + (<+) x y = (.+) <$> x <*> y + + +infixr 7 .^ +infixr 2 .- +infixr 3 .+ +infixr 3 <+ + +------------------------------------------------------------ +-- ** Definition of Exchange Algebra +------------------------------------------------------------ + +-- | Type class for Exchange Algebra. In addition to Redundant Algebra, provides +-- debit(R)/credit(L) decomposition, stock increase(P)/decrease(M) decomposition, and balance checking. +class (Redundant a n b ) => Exchange a n b where + -- | Extracts only the debit side elements. Complexity: O(s) + decR :: a n b -> a n b + -- | Extracts only the credit side elements. Complexity: O(s) + decL :: a n b -> a n b + -- | Extracts only the Hat (stock increase) side elements. Complexity: O(s) + decP :: a n b -> a n b + -- | Extracts only the Not (stock decrease) side elements. Complexity: O(s) + decM :: a n b -> a n b + -- | Checks whether the norms of debit and credit sides are equal. Complexity: O(s) + balance :: a n b -> Bool + -- | Returns the debit-credit difference as a (Side, difference) pair. Complexity: O(s) + diffRL :: a n b -> (Side, n) + + +------------------------------------------------------------------ +-- * Algebra +------------------------------------------------------------------ + +-- | Type class for algebra element values. +-- Provides zero-value and error-value predicates. +-- Instances are defined for @Double@ and @NN.Double@ (non-negative reals). +class ( Show n + , Ord n + , Eq n + , Nearly n + , Fractional n + , RealFloat n + , Num n) => HatVal n where + + -- | Zero value. Complexity: O(1) + zeroValue :: n + + -- | Tests whether the value is zero. Complexity: O(1) + isZeroValue :: n -> Bool + isZeroValue x + | zeroValue == x = True + | otherwise = False + + -- | Tests whether the value is an error value (NaN, Infinity, etc.). Complexity: O(1) + isErrorValue :: n -> Bool + + +instance RealFloat NN.Double where + floatRadix = floatRadix . NN.toNumber + floatDigits = floatDigits . NN.toNumber + floatRange = floatRange . NN.toNumber + decodeFloat = decodeFloat . NN.toNumber + encodeFloat m e = NN.fromNumber (encodeFloat m e) + exponent = exponent . NN.toNumber + significand = NN.fromNumber . significand . NN.toNumber + scaleFloat n = NN.fromNumber . scaleFloat n . NN.toNumber + isNaN = isNaN . NN.toNumber + isInfinite = isInfinite . NN.toNumber + isDenormalized = isDenormalized . NN.toNumber + isNegativeZero = isNegativeZero . NN.toNumber + isIEEE = isIEEE . NN.toNumber + +instance HatVal NN.Double where + {-# INLINE zeroValue #-} + zeroValue = 0 + {-# INLINE isErrorValue #-} + isErrorValue x = isNaN (NN.toNumber x) + || isInfinite (NN.toNumber x) + +instance HatVal Prelude.Double where + {-# INLINE zeroValue #-} + zeroValue = 0 + + {-# INLINE isErrorValue #-} + isErrorValue x = isNaN x + || isInfinite x + || x < 0 + +data Pair v where + Pair :: {_hatSide :: !(Seq v) + ,_notSide :: !(Seq v)} -> Pair v + deriving (Eq) + +instance (Binary.Binary v) => Binary.Binary (Pair v) where + {-# INLINABLE put #-} + {-# INLINABLE get #-} + put (Pair hs ns) = do + Binary.put (Seq.length hs :: Int) + Foldable.foldr (\x k -> Binary.put x >> k) (pure ()) hs + Binary.put (Seq.length ns :: Int) + Foldable.foldr (\x k -> Binary.put x >> k) (pure ()) ns + get = do + hsLen <- Binary.get :: Binary.Get Int + hs <- go hsLen Seq.empty + nsLen <- Binary.get :: Binary.Get Int + ns <- go nsLen Seq.empty + pure (Pair hs ns) + where + go :: Binary.Binary a => Int -> Seq a -> Binary.Get (Seq a) + go n !acc + | n <= 0 = pure acc + | otherwise = do + x <- Binary.get + go (n - 1) (acc Seq.|> x) + + +instance (HatVal v) => Ord (Pair v) where + {-# INLINE compare #-} + compare (Pair hs1 ns1) (Pair hs2 ns2) = compare ((sum hs1) - (sum ns1)) ((sum hs2) - (sum ns2)) + + (<) x y | compare x y == LT = True + | otherwise = False + + (>) x y | compare x y == GT = True + | otherwise = False + + (<=) x y | compare x y == LT = True + | compare x y == EQ = True + | otherwise = False + + (>=) x y | compare x y == GT = True + | compare x y == EQ = True + | otherwise = False + + max x y | x >= y = x + | otherwise = y + + min x y | x <= y = x + | otherwise = y + +{-# INLINE nullPair #-} +-- | Complexity: O(1) +nullPair :: Pair v +nullPair = Pair Seq.empty Seq.empty + +{-# INLINE isNullPair #-} +-- | Complexity: O(1) +isNullPair :: Pair v -> Bool +isNullPair (Pair hs ns) = Seq.null hs && Seq.null ns + +{-# INLINE pairAppend #-} +-- | Complexity: O(log(min(h1,h2)) + log(min(n1,n2))) +-- where h1/h2 and n1/n2 are the lengths of the appended 'Seq's on each side. +pairAppend :: Pair v -> Pair v -> Pair v +pairAppend (Pair x1 y1) (Pair x2 y2) = + let !hs = x1 Seq.>< x2 + !ns = y1 Seq.>< y2 + in Pair hs ns + +-- | Algebra element. An element of exchange algebra consisting of a value-base pair. +-- Zero is the zero element, @(:@)@ is a singleton, and Liner is a HashMap-based multi-element representation. +data Alg v b where + Zero :: Alg v b + (:@) :: {_val :: !v, _hatBase :: !b} -> Alg v b + Liner :: { _realg :: !(Map.HashMap (BasePart b) (Pair v)) + , _axisPosting :: ~(IntMap.IntMap (Map.HashMap AxisKey IntSet.IntSet)) + , _bpToId :: ~(Map.HashMap (BasePart b) Int) + , _idToBp :: ~(IntMap.IntMap (BasePart b)) + , _nextBpId :: ~Int + , _allBpIds :: ~IntSet.IntSet + } -> Alg v b + +instance ( HatBaseClass b + , Binary.Binary v + , Binary.Binary b + , Binary.Binary (BasePart b) + ) => Binary.Binary (Alg v b) where + {-# INLINABLE put #-} + {-# INLINABLE get #-} + put Zero = Binary.put (0 :: Int) + put (v :@ b) = do + Binary.put (1 :: Int) + Binary.put v + Binary.put b + put (Liner m _ _ _ _ _) = do + Binary.put (2 :: Int) + Binary.put (Map.size m :: Int) + Map.foldrWithKey + (\bp p k -> Binary.put bp >> Binary.put p >> k) + (pure ()) + m + + get = do + tag <- Binary.get + case (tag :: Int) of + 0 -> pure Zero + 1 -> (:@) <$> Binary.get <*> Binary.get + 2 -> do + n <- Binary.get :: Binary.Get Int + linerFromMap <$> go n Map.empty + _ -> fail ("Binary decode failure for Alg: unknown tag " ++ show tag) + where + go n !acc + | n <= 0 = pure acc + | otherwise = do + bp <- Binary.get + p <- Binary.get + go (n - 1) (Map.insert bp p acc) + +type AxisPosting = IntMap.IntMap (Map.HashMap AxisKey IntSet.IntSet) + +{-# INLINE emptyAxisPosting #-} +-- | Complexity: O(1) +emptyAxisPosting :: AxisPosting +emptyAxisPosting = IntMap.empty + +{-# INLINE insertAxisPosting #-} +-- | Complexity: O(d * (hash-insert + intset-insert)) +-- In practice this is near O(d), where d is the number of axes in the base part. +insertAxisPosting :: [AxisKey] -> Int -> AxisPosting -> AxisPosting +insertAxisPosting !keys !bpId !idx = + snd $ L.foldl' step (0 :: Int, idx) keys + where + step (!axis, !acc) !k = + let !axisMap = IntMap.findWithDefault Map.empty axis acc + !ids0 = Map.lookupDefault IntSet.empty k axisMap + !ids1 = IntSet.insert bpId ids0 + !axisMap' = Map.insert k ids1 axisMap + !acc' = IntMap.insert axis axisMap' acc + in (axis + 1, acc') + +{-# INLINE queryAxisPosting #-} +-- | Complexity: O(d + intersection cost) +-- d is the number of axes; intersections are performed in ascending set-size order. +queryAxisPosting :: [AxisKey] -> AxisPosting -> IntSet.IntSet -> IntSet.IntSet +queryAxisPosting !keys !idx !allIds = + case matchedSets of + Left () -> IntSet.empty + Right [] -> allIds + Right xs -> + let !(x:rest) = L.sortOn IntSet.size xs + in L.foldl' IntSet.intersection x rest + where + matchedSets = + L.foldl' collect (Right []) (zip [0 :: Int ..] keys) + + collect (Left ()) _ = Left () + collect (Right acc) (!axis, !k) + | axisIsWildcard k = Right acc + | otherwise = + case IntMap.lookup axis idx of + Nothing -> Left () + Just axisMap -> case Map.lookup k axisMap of + Nothing -> Left () + Just ids -> Right (ids : acc) + +{-# INLINE linerFromMap #-} +-- | Complexity: O(n * d * (hash-insert + intset-insert)) +-- n is the number of distinct base keys in the map. +linerFromMap :: (HatBaseClass b) + => Map.HashMap (BasePart b) (Pair v) + -> Alg v b +linerFromMap m = Liner m idx bpToId idToBp nextBpId allIds + where + ~(idx, bpToId, idToBp, nextBpId, allIds) = + Map.foldlWithKey' + (\(!idxAcc, !bpToIdAcc, !idToBpAcc, !nextId, !allIdsAcc) bp _ -> + let !bpId = nextId + !idx' = insertAxisPosting (toAxisKeys bp) bpId idxAcc + !bpToId' = Map.insert bp bpId bpToIdAcc + !idToBp' = IntMap.insert bpId bp idToBpAcc + !allIds' = IntSet.insert bpId allIdsAcc + in (idx', bpToId', idToBp', bpId + 1, allIds')) + (emptyAxisPosting, Map.empty, IntMap.empty, 0, IntSet.empty) + m + +-- | Tests whether the algebra element is zero (empty). +-- +-- Complexity: O(1) +isZero :: Alg v b -> Bool +isZero Zero = True +isZero _ = False + +{-# INLINE singleton #-} +-- | Complexity: O(1) +singleton :: (HatVal v, HatBaseClass b) => v -> b -> Alg v b +singleton v b | isZeroValue v = Zero + | isErrorValue v = error $ "errorValue at (.@) val: " + ++ show v + ++ show ":@" + ++ show b + | otherwise = v :@ b + +{-# INLINE (.@) #-} +-- | Smart constructor that builds an algebra element from a value and a base. +-- Returns Zero for zero values, and throws an exception for error values. +-- +-- Complexity: O(1) +(.@) :: (HatVal n, HatBaseClass b) => n -> b -> Alg n b +(.@) v b = singleton v b + +-- | Constructs an algebra element in an Applicative context. Lifted version of @(.@)@. +-- +-- Complexity: O(1) + Applicative effects +(<@) :: (HatVal n, Applicative f, HatBaseClass b) + => f n -> b -> f (Alg n b) +(<@) v b = (.@) <$> v <*> (pure b) + + +infixr 6 :@ +infixr 6 .@ +infixr 6 <@ + +-- | Complexity: O(digits(v)) +-- Formatting cost is proportional to the textual precision of the number. +showV :: (HatVal v) => v -> String +showV v = D.formatScientific D.Generic (Just 2) (D.fromFloatDigits v) + +instance (HatVal v, HatBaseClass b) => Eq (Alg v b) where + (==) Zero Zero = True + (==) Zero _ = False + (==) _ Zero = False + (==) (v1:@b1) (v2:@b2) = (v1 == v2) && (b1 == b2) + (==) (Liner m1 _ _ _ _ _) (Liner m2 _ _ _ _ _) = m1 == m2 + (==) _ _ = False + (/=) x y = not (x == y) + +instance (HatVal v, HatBaseClass b) => Ord (Alg v b) where + {-# INLINE compare #-} + compare Zero Zero = EQ + compare Zero _ = LT + compare _ Zero = GT + + compare (v:@b) (Liner _ _ _ _ _ _) = LT + compare (Liner _ _ _ _ _ _) (v:@b) = GT + compare (v1:@b1) (v2:@b2) + | b1 == b2 = compare v1 v2 + | b1 > b2 = GT + | b1 < b2 = LT + + compare (Liner m1 _ _ _ _ _) (Liner m2 _ _ _ _ _) = compare m1 m2 + + (<) x y | compare x y == LT = True + | otherwise = False + + (>) x y | compare x y == GT = True + | otherwise = False + + (<=) x y | compare x y == LT = True + | compare x y == EQ = True + | otherwise = False + + (>=) x y | compare x y == GT = True + | compare x y == EQ = True + | otherwise = False + + max x y | x >= y = x + | otherwise = y + + min x y | x <= y = x + | otherwise = y + +instance (HatVal v, HatBaseClass b) => Show (Alg v b) where + show Zero = "0" + show (v:@b) = (showV v) ++ ":@" ++ show b + show xs = let ls = toASCList xs + in go ls + where + go [] = "0" + go [y] = show y + go (y:ys) = show y ++ " .+ " ++ go ys + + +instance NFData (Alg v b) where + rnf Zero = Zero `seq` () + rnf (v:@b) = v `seq` b `seq` () + rnf (Liner m _ _ _ _ _) = Map.foldrWithKey (\k v acc -> k `seq` v `seq` acc) () m +------------------------------------------------------------------ +-- Semigroup +------------------------------------------------------------------ + +instance (HatVal n, HatBaseClass b) => Semigroup (Alg n b) where + {-# INLINE (<>) #-} + -- | Associative law ;convert to right join + (<>) = union + + + +-- | union two trees +-- +-- >>> type Test = Alg NN.Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Hat:>> union x y +-- 1.00:@Hat: Alg n b -> Alg n b -> Alg n b +union Zero x = x +union x Zero = x +-- singletons +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:>> fromList xs +-- 1.00:@Hat:>> type Test = Alg NN.Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Hat:>> fromList [x,y] +-- 1.00:@Hat: [Alg v b] -> Alg v b +fromList = mconcat + + + +-- | Summation function that applies a function to each element of a list and sums the results. +-- Complexity: O(sum of HashMap union costs over produced elements). +-- +-- >>> type Test = Alg NN.Double (HatBase CountUnit) +-- >>> sigma [1,2] (\x -> x:@Hat: [a] -> (a -> Alg v b) -> Alg v b +sigma xs f = mkAlgFromMap $ L.foldl' step Map.empty xs + where + step !acc !x = mergeAlgMapIfNonZero acc (f x) + +-- | Conditional summation over a double loop. For all combinations of two lists, +-- applies the function only to pairs that satisfy the condition and sums the results. +-- +-- Complexity: O(|xs| * |ys| * union cost) +{-# INLINE sigma2When #-} +sigma2When :: (HatVal v, HatBaseClass b) + => [a] + -> [c] + -> (a -> c -> Bool) + -> (a -> c -> Alg v b) + -> Alg v b +sigma2When xs ys cond f = + mkAlgFromMap $ L.foldl' outer Map.empty xs + where + outer !acc !x = L.foldl' (inner x) acc ys + inner !x !acc !y + | cond x y = mergeAlgMapIfNonZero acc (f x y) + | otherwise = acc + +-- | Summation using keys and values from a Map. Skips entries with zero values. +-- +-- Complexity: O(|map| * union cost) +{-# INLINE sigmaFromMap #-} +sigmaFromMap :: (HatVal v, HatBaseClass b, Ord k) + => M.Map k v + -> (k -> v -> Alg v b) + -> Alg v b +sigmaFromMap kvs f = + mkAlgFromMap $ M.foldlWithKey' step Map.empty kvs + where + step !acc !k !v + | isZeroValue v = acc + | otherwise = mergeAlgMapIfNonZero acc (f k v) + +-- | Converts an algebra element to a list. +-- Complexity: O(s) (s is the total number of scalar entries) +-- +-- >>> toList (10:@Hat:<(Cash) .+ 10:@Hat:<(Deposits) .+ Zero :: Alg NN.Double (HatBase AccountTitles)) +-- [10.00:@Hat:>> toList Zero :: [Alg NN.Double (HatBase AccountTitles)] +-- [] +toList :: (HatVal v, HatBaseClass b) => Alg v b -> [Alg v b] +toList Zero = [] +toList (v:@b) = [v:@b] +toList (Liner m _ _ _ _ _) = Map.foldlWithKey' f [] m + where + f :: (HatVal v, HatBaseClass b) => [Alg v b] -> BasePart b -> Pair v -> [Alg v b] + f xs b Pair {_hatSide = hs, _notSide = ns} + = Foldable.foldl' (g Hat b) (Foldable.foldl' (g Not b) xs ns) hs + + g :: (HatVal v, HatBaseClass b) => Hat -> BasePart b -> [Alg v b] -> v -> [Alg v b] + g h b ys v + | isZeroValue v = ys + | otherwise = (v :@ (merge h b)):ys + +{-# INLINE foldEntries #-} +-- | Strict left fold over scalar entries without building an intermediate list. +foldEntries :: (HatVal v, HatBaseClass b) + => (acc -> v -> b -> acc) + -> acc + -> Alg v b + -> acc +foldEntries _ !acc Zero = acc +foldEntries f !acc (v :@ b) + | isZeroValue v = acc + | otherwise = f acc v b +foldEntries f !acc (Liner m _ _ _ _ _) = + Map.foldlWithKey' step acc m + where + step !acc0 !bp (Pair hs ns) = + let !hatBase = merge Hat bp + !notBase = merge Not bp + !acc1 = Foldable.foldl' (\a v -> if isZeroValue v then a else f a v hatBase) acc0 hs + in Foldable.foldl' (\a v -> if isZeroValue v then a else f a v notBase) acc1 ns + +{-# INLINE toASCList #-} +-- | Complexity: O(s log s), dominated by sorting the list representation. +toASCList :: (HatVal v, HatBaseClass b) => Alg v b -> [Alg v b] +toASCList = L.sort . toList + + +-- | map +-- Complexity: O(s + c), where s is traversed scalar entries and c is transformed output size. +-- +-- >>> type Test = Alg Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Not:>> map (\ (x:@hb) -> x:@(toHat hb)) $ x .+ y +-- 1.00:@Hat:>> type Test = Alg Double Hat +-- >>> x = 1:@Hat .+ 1:@Not :: Test +-- >>> y = 2:@Not .+ 2:@Hat :: Test +-- >>> map (\ (x:@hb) -> (2 * x):@hb) $ x .+ y +-- 2.00:@Hat .+ 4.00:@Hat .+ 2.00:@Not .+ 4.00:@Not + +map :: (HasCallStack,HatVal v, HatBaseClass b) + => (Alg v b -> Alg v b) -> Alg v b -> Alg v b +map f Zero = Zero +map f (v:@b) = let v2:@b2 = f (v:@b) + in case isZeroValue v2 of + True -> Zero + False -> (v2 :@ b2) +map f (Liner m _ _ _ _ _) = mkAlgFromMap $ (Map.foldrWithKey (p f) dnilMap m) Map.empty + where + {-# INLINE dnilMap #-} + dnilMap = id + {-# INLINE dappendMap #-} + dappendMap = (.) + {-# INLINE dsingleMap #-} + dsingleMap (bp, p') = Map.insertWith pairAppend bp p' + + {-# INLINE p #-} + p :: (HatVal v, HatBaseClass b) + => (Alg v b -> Alg v b) + -> BasePart b + -> Pair v + -> DMap (BasePart b) (Pair v) + -> DMap (BasePart b) (Pair v) + p f b Pair {_hatSide=hs, _notSide=ns} accDList = + let (dl1, hs2) = q f Hat b hs + (dl2, ns2) = q f Not b ns + prefix = dappendMap dl1 dl2 + in case (Seq.null hs2, Seq.null ns2) of + (True,True) -> dappendMap prefix accDList + (True,False) -> dappendMap prefix + . dappendMap (dsingleMap (b, nullPair{_notSide = ns2})) + $ accDList + (False,True) -> dappendMap prefix + . dappendMap (dsingleMap (b, nullPair{_hatSide = hs2})) + $ accDList + (False,False) -> dappendMap prefix + . dappendMap (dsingleMap (b, Pair hs2 ns2)) + $ accDList + {-# INLINE q #-} + q :: (HatVal v, HatBaseClass b) + => (Alg v b -> Alg v b) + -> Hat + -> BasePart b + -> Seq v + -> (DMap (BasePart b) (Pair v), Seq v) + q f h b vs = Foldable.foldl' (r f h b) (dnilMap, Seq.empty) vs + + {-# INLINE r #-} + r :: (HatVal v, HatBaseClass b) + => (Alg v b -> Alg v b) + -> Hat + -> BasePart b + -> (DMap (BasePart b) (Pair v), Seq v) + -> v + -> (DMap (BasePart b) (Pair v), Seq v) + r f h b (dlAcc,vsAcc) v = case f (v:@(merge h b)) of + Zero -> (dlAcc, vsAcc) + ------------------------------------------------------------------ + v2:@b2 + | isZeroValue v2 -> (dlAcc, vsAcc) + | b2 .== (merge h b) -> (dlAcc, v2 Seq.<| vsAcc) + | isHat (hat b2) -> (dappendMap dlAcc (dsingleMap ( base b2 + ,nullPair{_hatSide = Seq.singleton v2})) + ,vsAcc ) + | otherwise -> (dappendMap dlAcc (dsingleMap ( base b2 + ,nullPair{_notSide = Seq.singleton v2} )) + ,vsAcc ) + +-- Difference list definition +type DList a = [a] -> [a] +type DMap k v = Map.HashMap k v -> Map.HashMap k v + +{-# INLINE dnil #-} +-- | Complexity: O(1) +dnil :: DList a +dnil = id + +{-# INLINE dappend #-} +-- | Complexity: O(1) +dappend :: DList a -> DList a -> DList a +dappend = (.) -- Function composition + +{-# INLINE dsingle #-} +-- | Complexity: O(1) +dsingle :: a -> DList a +dsingle x = \rest -> x : rest + +{-# INLINE dToList #-} +-- | Complexity: O(k), where k is the resulting list length. +dToList :: DList a -> [a] +dToList dl = dl [] + +{-# INLINE dFromList #-} +-- | Complexity: O(k) to capture the prefix list xs. +dFromList :: [a] -> DList a +dFromList xs = (xs ++) + + +{-# INLINE filter #-} +-- | filter +-- Complexity: O(s), where s is total number of scalar entries. +-- +-- >>> type Test = Alg Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Not:>> filter (isHat . _hatBase) $ x .+ y +-- 1.00:@Hat:>> type Test = Alg Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Not:>> filter ((1 <). _val) $ x .+ y +-- 2.00:@Not: (Alg v b -> Bool) -> Alg v b -> Alg v b +filter f Zero = Zero +filter f (v:@b) | f (v:@b) = v:@b + | otherwise = Zero + +filter f (Liner m _ _ _ _ _) = + -- Build a new Map using mapMaybeWithKey + let m' = Map.mapMaybeWithKey + (\basePart (Pair hs ns) -> + -- Filter each of hs and ns + let hs' = filterSide basePart Hat hs + ns' = filterSide basePart Not ns + in + -- Remove the entry (Nothing) if both become empty + if Seq.null hs' && Seq.null ns' + then Nothing + else Just (Pair hs' ns')) + m + in + -- If the resulting Map is empty, return Zero; otherwise Liner m' + if Map.null m' then Zero else linerFromMap m' + where + ---------------------------------------------------------------- + -- Filter function that constructs "v:@(merge h basePart)" from + -- basePart and Hat/Not, and tests whether it satisfies predicate f + ---------------------------------------------------------------- + -- filterSide :: BasePart b -> Hat -> Seq v -> Seq v + {-# INLINE filterSide #-} + filterSide bp h = Seq.filter (\val -> f (val :@ merge h bp)) + +------------------------------------------------------------ +-- | proj +-- Complexity: +-- exact single-key path: expected O(1) +-- wildcard single-key path: O(queryAxisPosting + c * verify) +-- multi-pattern path: O(sum pattern costs + union costs) +-- +-- where c is candidate count returned by the posting index. +-- >>> type Test = Alg NN.Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Not:>> proj [Hat:>> type Test = Alg NN.Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Not:>> proj [HatNot:>> type Test = Alg NN.Double (HatBase (AccountTitles, CountUnit)) +-- >>> x = 1:@Hat:<(Cash,Yen) .+ 1:@Not:<(Products,Amount) :: Test +-- >>> y = 2:@Not:<(Cash,Yen) .+ 2:@Hat:<(Deposits,Yen) :: Test +-- >>> proj [Hat:<((.#),Yen)] $ x .+ y +-- 1.00:@Hat:<(Cash,Yen) .+ 2.00:@Hat:<(Deposits,Yen) +-- +-- >>> type Test = HatBase CountUnit +-- >>> compareHatBase (Not:<(.#) :: Test) (Not:>> type Test = Alg NN.Double (HatBase CountUnit) +-- >>> x = 1:@Hat:>> y = 2:@Not:>> proj [Not:<(.#)] $ x .+ y +-- 2.00:@Not: [b] -> Alg v b -> Alg v b +proj [] _ = Zero +proj _ Zero = Zero +proj [b] (v:@b2) + | b .== b2 = v:@b2 + | otherwise = Zero +proj [b] (Liner m idx _ idToBp _ allIds) = + mkAlgFromMap $ projSingleMap b m idx idToBp allIds +proj (b:bs) (v:@b2) + | b .== b2 = v:@b2 + | otherwise = proj bs (v:@b2) +proj (b:bs) (Liner m idx _ idToBp _ allIds) = + mkAlgFromMap $ + L.foldl' + (\acc q -> Map.unionWith pairAppend acc (projSingleMap q m idx idToBp allIds)) + Map.empty + (b:bs) + +{-# INLINE choosePairByHat #-} +-- | Complexity: O(1) +choosePairByHat :: Hat -> Pair v -> Pair v +choosePairByHat h Pair {_hatSide = hs, _notSide = ns} = + case h of + Hat -> nullPair {_hatSide = hs} + Not -> nullPair {_notSide = ns} + HatNot -> Pair {_hatSide = hs, _notSide = ns} + +{-# INLINE projSingleMap #-} +-- | Complexity: +-- - wildcard path: O(queryAxisPosting + c * verify) +-- - exact path: expected O(1) +projSingleMap + :: (HatBaseClass b) + => b + -> Map.HashMap (BasePart b) (Pair v) + -> AxisPosting + -> IntMap.IntMap (BasePart b) + -> IntSet.IntSet + -> Map.HashMap (BasePart b) (Pair v) +projSingleMap b m idx idToBp allIds + | haveWiledcard bp = + let !ids = queryAxisPosting (toAxisKeys bp) idx allIds + in IntSet.foldl' + (\acc bpId -> case IntMap.lookup bpId idToBp of + Nothing -> acc + Just bp0 -> case Map.lookup bp0 m of + Nothing -> acc + Just p -> if bp .== bp0 + then Map.insert bp0 (choosePairByHat h p) acc + else acc) + Map.empty + ids + | otherwise = case Map.lookup bp m of + Nothing -> Map.empty + Just p -> Map.singleton bp (choosePairByHat h p) + where + !bp = base b + !h = hat b + +{-# INLINE mkAlgFromMap #-} +-- | Complexity: O(n) to inspect shape and possibly rebuild index. +mkAlgFromMap :: (HatVal v, HatBaseClass b) => Map.HashMap (BasePart b) (Pair v) -> Alg v b +mkAlgFromMap m + | Map.null m = Zero + | otherwise = case Map.toList m of + [(b, p)] -> Maybe.fromMaybe (linerFromMap $ Map.singleton b p) (singlePairToAlg b p) + _ -> linerFromMap m + +{-# INLINE singlePairToAlg #-} +-- | Complexity: O(1) +singlePairToAlg :: (HatVal v, HatBaseClass b) => BasePart b -> Pair v -> Maybe (Alg v b) +singlePairToAlg b (Pair hs ns) = case (Seq.viewl hs, Seq.viewl ns) of + (Seq.EmptyL, n Seq.:< nsRest) | Seq.null nsRest -> Just (n :@ merge Not b) + (h Seq.:< hsRest, Seq.EmptyL) | Seq.null hsRest -> Just (h :@ merge Hat b) + _ -> Nothing + +------------------------------------------------------------------ + +-- | Projects only the credit side elements. +-- Use this instead of decL when the base contains non-Enum elements such as Text or Int. +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projCredit :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projCredit = filter (\x -> (whichSide . _hatBase) x == Credit) + +-- | Projects only the debit side elements. +-- Use this instead of decR when the base contains non-Enum elements such as Text or Int. +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projDebit :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projDebit = filter (\x -> (whichSide . _hatBase) x == Debit) + +-- | Projects only the elements matching the specified account title. +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projByAccountTitle :: (HatVal n, ExBaseClass b) => AccountTitles -> Alg n b -> Alg n b +projByAccountTitle at alg = filter (f at) alg + where + f :: (HatVal n,ExBaseClass b) => AccountTitles -> Alg n b -> Bool + f at Zero = False + f at x = ((getAccountTitle ._hatBase) x) .== at + +-- | Complexity: O(cost(proj) + cost(bar) + cost(norm)). +projNorm :: (HatVal n, HatBaseClass b) => [b] -> Alg n b -> n +projNorm [] _ = 0 +projNorm _ Zero = 0 +projNorm bs (v :@ b) + | L.any (.== b) bs = v + | otherwise = 0 +projNorm [b] (Liner m idx _ idToBp _ allIds) = + foldProjectedNorm (projSingleMap b m idx idToBp allIds) +projNorm bs (Liner m idx _ idToBp _ allIds) = + foldProjectedNorm $ + L.foldl' + (\acc q -> Map.unionWith pairAppend acc (projSingleMap q m idx idToBp allIds)) + Map.empty + bs + +{-# INLINE foldProjectedNorm #-} +-- | Complexity: O(k), where k is the number of projected base keys. +foldProjectedNorm :: (HatVal n) => Map.HashMap k (Pair n) -> n +foldProjectedNorm = Map.foldl' (\acc p -> acc + barNormPair p) 0 + +{-# INLINE barNormPair #-} +-- | Complexity: O(h + n), where h/n are side lengths within the pair. +barNormPair :: (HatVal n) => Pair n -> n +barNormPair (Pair hs ns) = + let !h = Foldable.foldl' (+) 0 hs + !n = Foldable.foldl' (+) 0 ns + in if 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:>> balanceBy [Not:>> balanceBy [Hat: [b] -> [b] -> Alg n b -> n +balanceBy plusBases minusBases alg = + projNorm plusBases alg - projNorm minusBases alg + +-- | Fold algebra entries into a @Map@, combining values with @(+)@. +-- +-- The selector function examines each entry @(v, b)@ and optionally returns +-- a @(key, value)@ pair. Values for duplicate keys are summed. +-- +-- >>> type T = Alg Double (HatBase AccountTitles) +-- >>> let alg = 10 :@ Hat:>> let f v (Hat :< a) = Just (a, v); f _ _ = Nothing +-- >>> foldEntriesToMap f alg +-- fromList [(Cash,15.0),(Deposits,20.0)] +foldEntriesToMap :: (HatVal v, HatBaseClass b, Ord k) + => (v -> b -> Maybe (k, v)) + -> Alg v b + -> M.Map k v +foldEntriesToMap f = foldEntries step M.empty + where + step acc v b = case f v b of + Just (k, v') -> M.insertWith (+) k v' acc + Nothing -> acc + +-- | Projects only current assets. +-- Extracts asset items classified as current from the debit side. +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projCurrentAssets :: ( HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projCurrentAssets = (filter (\x -> (fixedCurrent . _hatBase) x == Current)) + . (filter (\x -> (whatDiv . _hatBase) x == Assets)) + . projDebit + +-- | Projects only fixed assets. +-- Extracts asset items classified as fixed from the debit side. +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projFixedAssets :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projFixedAssets = (filter (\x -> (fixedCurrent . _hatBase) x == Fixed)) + . (filter (\x -> (whatDiv . _hatBase) x == Assets)) + . projDebit + +-- | Projects only deferred assets. +-- Tax-specific deferred assets are presented under "investments and other assets" with appropriate items such as long-term prepaid expenses. +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projDeferredAssets :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projDeferredAssets = (filter (\x -> (fixedCurrent . _hatBase) x == Other)) + . (filter (\x -> (whatDiv . _hatBase) x == Assets)) + . projDebit + +-- | Projects only current liabilities. +-- Extracts liability items classified as current from the credit side. +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projCurrentLiability :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projCurrentLiability = (filter (\x -> (fixedCurrent . _hatBase) x == Current)) + . (filter (\x -> (whatDiv . _hatBase) x == Liability)) + . projCredit + +-- | Projects only fixed liabilities. +-- Extracts liability items classified as fixed from the credit side. +-- +-- Complexity: O(s) (s is the total number of scalar entries) +projFixedLiability :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projFixedLiability = (filter (\x -> (fixedCurrent . _hatBase) x == Fixed)) + . (filter (\x -> (whatDiv . _hatBase) x == Liability)) + . projCredit + +-- | Projects only capital stock. +-- +-- __Note__: Not yet implemented. Calling this will throw an exception. +projCapitalStock :: (HatVal n, ExBaseClass b) => Alg n b -> Alg n b +projCapitalStock = undefined + + +-- * Balance + +{- | Handling when the balance does not hold -} +-- Complexity: O(1) currently (undefined placeholder). +forceBalance = undefined + + +-- * Rounding + +-- | Rounding (ceiling). +-- Applied to the results of division and multiplication; uses ceiling rounding by default. +-- This should be applied to all multiplication and division of account titles. +-- +-- Complexity: O(1) +rounding :: NN.Double -> NN.Double +rounding = fromIntegral . ceiling diff --git a/src/ExchangeAlgebra/Algebra/Base.hs b/src/ExchangeAlgebra/Algebra/Base.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Algebra/Base.hs @@ -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. + + + + + +-} + +{-# 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:>> haveWiledcard (HatNot:>> Not:<(Cash, Yen) == Not:<(Cash,(.#)) +-- False +-- +-- >>> Not:<(Cash, Yen) .== Not:<(Cash,(.#)) +-- True +-- +-- compareElement +-- >>> type Test = HatBase CountUnit +-- >>> compareHatBase (Not:>> 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 : 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: 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) diff --git a/src/ExchangeAlgebra/Algebra/Base/Element.hs b/src/ExchangeAlgebra/Algebra/Base/Element.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Algebra/Base/Element.hs @@ -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. + + + + + + == 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] diff --git a/src/ExchangeAlgebra/Algebra/Transfer.hs b/src/ExchangeAlgebra/Algebra/Transfer.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Algebra/Transfer.hs @@ -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. + + + + + +-} + + +{-# 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 + ++ ",)" + ++ (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:),(Not:)] + +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:),(Hat:)] +{-# 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),),(Not:<(Yen,Building),Not:<(Yen,Cash),)] +{-# INLINE (|%) #-} +(|%) :: (HatVal n, HatBaseClass b) => TransTableParts b -> (n -> n) -> [(b,b,(n -> n))] +(|%) (b1 :-> b2) f = [(b1,b2,f)] + +infixr 8 .-> +infixr 8 :-> +infixr 7 |% + +instance (HatVal n) => Show (n -> n) where + show f = "" + +-- | 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 diff --git a/src/ExchangeAlgebra/Journal.hs b/src/ExchangeAlgebra/Journal.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Journal.hs @@ -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. + + + + + + +-} + +{-# 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:>> y = 10.00:@Hat:>> x .+ y +-- 10.00:@Not: 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:>> fromList x +-- 1.00:@Hat: [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:>> y = 20.00:@Not:>> z = 30.00:@Hat:>> insert z (x .+ y) +-- 20.00:@Not: Journal n v b -> Journal n v b -> Journal n v b +-- Complexity: O(n + m) where n, m are the number of Notes in each Journal +insert x y = fromMap (Map.union (toMap x) (toMap y)) + +------------------------------------------------------------------ +-- | projWithNote +-- Projecting with Note. +-- +-- >>> type Test = Journal String Double (HatBase CountUnit) +-- >>> x = 1.00:@Hat:>> y = 2.00:@Hat:>> z = 3.00:@Hat:>> projWithNote ["dog","cat"] (x .+ y .+ z) +-- 1.00:@Not: [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:>> y = 2.00:@Not:>> z = 3.00:@Hat:>> projWithBase [Not: [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:>> y = 2.00:@Not:>> z = 3.00:@Hat:>> projWithNoteBase ["dog","fish"] [Not: [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:>> y = 20.00:@Hat:>> z = 30.00:@Not:>> filterByAxis 0 (NoteAxisKey "A") (x .+ y .+ z) +-- 10.00:@Not:>> filterByAxis 1 (NoteAxisKey (1 :: Int)) (x .+ y .+ z) +-- 10.00:@Not: 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:>> y = 10.00:@Hat:>> gather "A" (x .+ y) +-- 10.00:@Not: n -> Journal n v b -> Journal n v b +gather n js = (toAlg js) .| n diff --git a/src/ExchangeAlgebra/Journal/Transfer.hs b/src/ExchangeAlgebra/Journal/Transfer.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Journal/Transfer.hs @@ -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. + + + + + +-} + + +{-# 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 + diff --git a/src/ExchangeAlgebra/Simulate.hs b/src/ExchangeAlgebra/Simulate.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Simulate.hs @@ -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. + + + + + + == 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. + + + Runnable companions to the preprint live in the repository under + @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) diff --git a/src/ExchangeAlgebra/Simulate/Visualize.hs b/src/ExchangeAlgebra/Simulate/Visualize.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Simulate/Visualize.hs @@ -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. + + + + + +-} + + +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' diff --git a/src/ExchangeAlgebra/Write.hs b/src/ExchangeAlgebra/Write.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeAlgebra/Write.hs @@ -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. + + + + + +-} + +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) + +------------------------------------------------------------------ diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Test.DocTest + +main :: IO () +main = doctest [ "-isrc" + , "src/ExchangeAlgebra.hs"]