From 2dd69238ca760652c2e4d63bf04c91b4027d6308 Mon Sep 17 00:00:00 2001 From: LunaStev Date: Wed, 28 Oct 2026 23:00:18 +0900 Subject: [PATCH] docs: document every public API and integrate searchable Haskell reference --- .github/workflows/python-wheels.yml | 4 +- .github/workflows/validate.yml | 4 +- docs/getting-started/installation.md | 15 +- docs/guides/troubleshooting.md | 2 +- docs/reference/c.md | 516 +++++++++++++++++++-- docs/reference/haskell.md | 41 +- docs/reference/python.md | 395 ++++++++++++++-- docs/reference/wave.md | 206 ++++++-- docs/stylesheets/api.css | 26 ++ mkdocs.yml | 2 + src/HMath/API/Algebra.hs | 62 ++- src/HMath/API/Buffer.hs | 81 ++++ src/HMath/API/Convergence.hs | 37 +- src/HMath/API/Shape.hs | 68 ++- src/HMath/Algorithms.hs | 122 +++++ src/HMath/Autodiff.hs | 28 +- src/HMath/Backend.hs | 94 +++- src/HMath/Basic.hs | 20 + src/HMath/Calculus.hs | 18 +- src/HMath/Combinatorics.hs | 77 +++ src/HMath/Constants.hs | 102 ++++ src/HMath/DataStructure.hs | 179 +++++++ src/HMath/DeepLearning/Core.hs | 23 + src/HMath/DeepLearning/Layers.hs | 30 +- src/HMath/DeepLearning/Metrics.hs | 6 + src/HMath/DeepLearning/Precision.hs | 20 +- src/HMath/Discrete.hs | 108 ++++- src/HMath/Expression.hs | 175 ++++++- src/HMath/Geometry/Collision.hs | 4 + src/HMath/Geometry/Internal.hs | 126 +++++ src/HMath/Geometry/Primitives.hs | 4 + src/HMath/Geometry/Spatial.hs | 18 +- src/HMath/Graph/Analysis.hs | 57 +++ src/HMath/Graph/Core.hs | 162 ++++++- src/HMath/Graph/Flow.hs | 50 +- src/HMath/Graph/Paths.hs | 19 + src/HMath/Image/Color.hs | 8 + src/HMath/Image/Core.hs | 51 ++ src/HMath/Image/Filter.hs | 33 ++ src/HMath/Image/Histogram.hs | 4 + src/HMath/Image/Measure.hs | 15 + src/HMath/Image/Spatial.hs | 4 + src/HMath/Interchange/Array.hs | 92 ++++ src/HMath/Interchange/Binary.hs | 10 + src/HMath/Interchange/Compression.hs | 9 + src/HMath/Interchange/IO.hs | 9 + src/HMath/Interchange/Numpy.hs | 10 + src/HMath/Interchange/Text.hs | 18 + src/HMath/Interpolation.hs | 3 + src/HMath/MachineLearning/Clustering.hs | 36 +- src/HMath/MachineLearning/Decomposition.hs | 21 +- src/HMath/MachineLearning/Internal.hs | 104 +++++ src/HMath/MachineLearning/Neighbors.hs | 12 +- src/HMath/MachineLearning/Preprocessing.hs | 8 +- src/HMath/MachineLearning/Regression.hs | 10 +- src/HMath/Matrix/Advanced.hs | 128 +++++ src/HMath/Matrix/Decomposition.hs | 94 +++- src/HMath/Matrix/LAPACK.hs | 119 ++++- src/HMath/Matrix/QR.hs | 64 +++ src/HMath/Numeric.hs | 282 ++++++++++- src/HMath/ODE.hs | 23 +- src/HMath/Optimization/Common.hs | 44 +- src/HMath/Optimization/Constrained.hs | 22 +- src/HMath/Optimization/FirstOrder.hs | 7 + src/HMath/Optimization/Global.hs | 4 + src/HMath/Optimization/Local.hs | 12 + src/HMath/PDE.hs | 9 +- src/HMath/Probability.hs | 14 + src/HMath/Root.hs | 44 ++ src/HMath/Scalar.hs | 237 ++++++++++ src/HMath/Signal.hs | 15 +- src/HMath/Sparse.hs | 149 ++++++ src/HMath/Special.hs | 8 +- src/HMath/Statistics.hs | 12 + src/HMath/Statistics/Advanced.hs | 9 +- src/HMath/Symbolic.hs | 165 ++++++- src/HMath/Tensor.hs | 401 ++++++++++++++++ src/HMath/Tensor/Mutable.hs | 50 ++ src/HMath/TimeSeries/Core.hs | 34 ++ src/HMath/TimeSeries/Diagnostics.hs | 19 +- src/HMath/TimeSeries/Models.hs | 92 +++- src/HMath/Trigonometry.hs | 218 +++++++++ src/HMath/Units.hs | 366 ++++++++++++++- src/HMath/Vector.hs | 135 ++++++ tools/build_docs.py | 39 +- tools/check_api_docs.py | 149 ++++++ tools/check_docs_links.py | 58 +++ tools/check_haskell_doc_examples.py | 23 + tools/haskell_reference.py | 214 +++++++++ 89 files changed, 6430 insertions(+), 187 deletions(-) create mode 100644 docs/stylesheets/api.css create mode 100644 tools/check_api_docs.py create mode 100644 tools/check_docs_links.py create mode 100644 tools/check_haskell_doc_examples.py create mode 100644 tools/haskell_reference.py diff --git a/.github/workflows/python-wheels.yml b/.github/workflows/python-wheels.yml index 240881b..ddb0f33 100644 --- a/.github/workflows/python-wheels.yml +++ b/.github/workflows/python-wheels.yml @@ -4,9 +4,9 @@ name: Python wheels on: push: branches: [master] - paths-ignore: ['docs/**', 'mkdocs.yml', 'requirements-docs.txt', 'tools/build_docs.py', 'README.md'] + paths-ignore: ['docs/**', 'mkdocs.yml', 'requirements-docs.txt', 'tools/build_docs.py', 'tools/check_api_docs.py', 'tools/check_haskell_doc_examples.py', 'tools/check_docs_links.py', 'tools/haskell_reference.py', 'README.md'] pull_request: - paths-ignore: ['docs/**', 'mkdocs.yml', 'requirements-docs.txt', 'tools/build_docs.py', 'README.md'] + paths-ignore: ['docs/**', 'mkdocs.yml', 'requirements-docs.txt', 'tools/build_docs.py', 'tools/check_api_docs.py', 'tools/check_haskell_doc_examples.py', 'tools/check_docs_links.py', 'tools/haskell_reference.py', 'README.md'] workflow_call: outputs: version: diff --git a/.github/workflows/validate.yml b/.github/workflows/validate.yml index bd9b604..789342f 100644 --- a/.github/workflows/validate.yml +++ b/.github/workflows/validate.yml @@ -4,9 +4,9 @@ name: Validate on: push: branches: [master] - paths-ignore: ['docs/**', 'mkdocs.yml', 'requirements-docs.txt', 'tools/build_docs.py', 'README.md'] + paths-ignore: ['docs/**', 'mkdocs.yml', 'requirements-docs.txt', 'tools/build_docs.py', 'tools/check_api_docs.py', 'tools/check_haskell_doc_examples.py', 'tools/check_docs_links.py', 'tools/haskell_reference.py', 'README.md'] pull_request: - paths-ignore: ['docs/**', 'mkdocs.yml', 'requirements-docs.txt', 'tools/build_docs.py', 'README.md'] + paths-ignore: ['docs/**', 'mkdocs.yml', 'requirements-docs.txt', 'tools/build_docs.py', 'tools/check_api_docs.py', 'tools/check_haskell_doc_examples.py', 'tools/check_docs_links.py', 'tools/haskell_reference.py', 'README.md'] workflow_dispatch: inputs: full-matrix: diff --git a/docs/getting-started/installation.md b/docs/getting-started/installation.md index 4a36e56..c823c66 100644 --- a/docs/getting-started/installation.md +++ b/docs/getting-started/installation.md @@ -15,30 +15,25 @@ library are not needed for normal Python use. Use the interpreter belonging to your project or IDE environment: ```sh -python -m pip install --upgrade pip -python -m pip install --upgrade --only-binary=:all: "hmath-python>=1.0.1" +pip install hmath-python python -c "from hmath import add; print(add(2, 3))" ``` The expected result is `5.0`. The distribution name is `hmath-python`; the import name is `hmath`. -`--only-binary=:all:` makes unsupported platforms fail with a package-selection -error instead of unexpectedly attempting a source build. - For a new environment: ```sh python -m venv .venv . .venv/bin/activate -python -m pip install --upgrade pip -python -m pip install --only-binary=:all: "hmath-python>=1.0.1" +pip install hmath-python ``` ## Optional integrations ```sh -python -m pip install --upgrade --only-binary=:all: "hmath-python[numpy,cffi]>=1.0.1" +pip install "hmath-python[numpy,cffi]" ``` NumPy enables array conversion and zero-copy views. The `hmath_cffi` module @@ -46,8 +41,8 @@ provides an alternative cffi wrapper; the default `hmath` module uses ctypes. ## Upgrade from 1.0.0 -Version 1.0.0 shipped Python wrappers without the native library. Upgrade using -the command above. Do not copy a random `libhmath.so` into your system library +Version 1.0.0 shipped Python wrappers without the native library. For an existing +installation, run `pip install --upgrade hmath-python` in that environment. Do not copy a random `libhmath.so` into your system library directory. If `HMATH_LIBRARY` was set as an earlier workaround, remove that override to let the fixed wheel load its own library. diff --git a/docs/guides/troubleshooting.md b/docs/guides/troubleshooting.md index 73b5053..b973cb3 100644 --- a/docs/guides/troubleshooting.md +++ b/docs/guides/troubleshooting.md @@ -6,7 +6,7 @@ The 1.0.0 Python distribution omitted the native library. Upgrade to 1.0.1 or newer using your application's interpreter: ```sh -python -m pip install --upgrade --only-binary=:all: "hmath-python>=1.0.1" +pip install --upgrade hmath-python ``` In PyCharm, use the interpreter selected in the project's Python interpreter diff --git a/docs/reference/c.md b/docs/reference/c.md index 8cf3dfa..92a2e68 100644 --- a/docs/reference/c.md +++ b/docs/reference/c.md @@ -1,46 +1,496 @@ -# C ABI reference +# C ABI -The ABI epoch is **1**, independent of the package version. Query it with -`hmath_abi_version()` and compare it with `HMATH_ABI_VERSION`. +Include `hmath.h` for the stable ABI-1 interface and `hmath_dlpack.h` for +DLPack exchange. The ABI epoch is independent of package release numbers. +The [C integration guide](../guides/c.md) gives a complete compilable client. -| Area | Public API | -| --- | --- | -| Version and diagnostics | `hmath_abi_version`, `hmath_library_version`, `hmath_build_info`, `hmath_backend_version`, `hmath_last_error_code`, `hmath_last_error_message`, `hmath_status_string` | -| Runtime | `hmath_init`, `hmath_runtime_shutdown`, legacy `hmath_shutdown` | -| Contexts | `hmath_context_create`, `retain`, `release`, `cancel`, `reset` | -| Construction | `hmath_tensor_copy`, `hmath_tensor_borrow`, `hmath_vector_copy`, `hmath_matrix_copy` | -| Lifetime | `hmath_tensor_retain`, `hmath_tensor_release` | -| Inspection and storage | `hmath_tensor_rank`, `count`, `metadata`, `copy_to`, `data`, `reshape` | -| Allocation | `hmath_buffer_alloc`, `hmath_buffer_free` | -| Checked kernels | `hmath_scalar_add`, `hmath_tensor_sum`, `dot`, `add`, `matmul`, `map`, `hmath_batch_sum` | -| Legacy kernels | `hmath_add_f64`, `hmath_factorial`, `hmath_mean_f64`, `hmath_dot_f64` | +## Types, bounds, and ownership -Names abbreviated in the table retain the family prefix. The declarations -below are included directly from the public header, so signatures and -ownership comments have a single source of truth. +`hmath_tensor` and `hmath_context` are opaque reference-counted handles. +`hmath_vector` and `hmath_matrix` alias `hmath_tensor`; their constructors select +rank one and two. Every successful constructor/result owns **one reference**. +Retain before handing an additional owner to another thread. Never release your +last reference concurrently with its use. NULL retain/release is harmless; +other pointers must identify live objects and correctly sized buffers. -## Public declarations and contracts +Elements are finite IEEE binary64 (`double`). `HMATH_MAX_RANK` is 8 and +`HMATH_MAX_ELEMENTS` is 1,048,576. Shapes/strides are `size_t` arrays; strides +count **elements**, not bytes, and must be nonnegative. Rank zero has one +element; zero-sized dimensions are allowed. Shapes, products, reachable storage +spans, and numerical work are bounded. C cannot verify arbitrary addresses or +the actual allocation behind a supplied buffer. -```c ---8<-- "include/hmath.h" -``` +Checked functions return `hmath_status`. `HMATH_OK` (0) is success; otherwise +read `hmath_last_error_message()` immediately on the same thread. The status +[table](python.md#native-status-codes) lists every code. Kernel failures can +include runtime unavailable, cancellation, contained Haskell exceptions, and +non-finite arithmetic. Constructors clear their output handle to NULL on error; +scalar outputs are written only on success. Never pass a live owned handle as +an output slot without releasing it first. -## CPU DLPack exchange +Metadata, allocation, and ownership operations do not require an initialized +GHC runtime. Numerical kernels require successful `hmath_init()`. A NULL +kernel context disables cancellation. Cancellation is cooperative before/after +bounded Haskell kernels, and between callback elements. It does not forcibly +interrupt a running Haskell kernel. -DLPack exchange is available through the separate public header below. Read -its ownership-transfer and deleter contracts before exporting or importing -an array. Only supported CPU tensor layouts are accepted. +## Version and diagnostics -```c ---8<-- "include/hmath_dlpack.h" -``` +### `hmath_abi_version` + +`uint32_t hmath_abi_version(void)` + +**Parameters:** none. **Returns:** ABI epoch, currently 1. Compare against +`HMATH_ABI_VERSION` before using the interface. No initialization or allocation +is needed. Example: `if (hmath_abi_version() != HMATH_ABI_VERSION) return 1;`. + +### `hmath_library_version` + +`const char *hmath_library_version(void)` + +**Parameters:** none. **Returns:** a borrowed, immutable, NUL-terminated package +version string, such as `"1.0.1"`. Do not free it. No runtime initialization +is needed. Use for diagnostics rather than ABI negotiation. + +### `hmath_build_info` + +`const char *hmath_build_info(void)` + +**Parameters:** none. **Returns:** a borrowed static description of the native +build (C11, threaded GHC runtime, binary64, rank bound). Do not free or parse it +as a stable machine-readable schema. Example: `puts(hmath_build_info());`. + +### `hmath_backend_version` + +`const char *hmath_backend_version(void)` + +**Parameters:** none. **Returns:** a borrowed static description of the backend +used by the C tensor kernels. This describes those kernels, independently of +Haskell's separately selected BLAS/LAPACK providers. Do not free it. + +### `hmath_last_error_code` + +`hmath_status hmath_last_error_code(void)` + +**Parameters:** none. **Returns:** the current thread's last checked status. +Queries, retain/release, and cancellation do not clear it. Successful checked +calls replace it with `HMATH_OK`. It does not return another thread's failure. + +### `hmath_last_error_message` + +`const char *hmath_last_error_message(void)` + +**Parameters:** none. **Returns:** a borrowed thread-local NUL-terminated error +message, valid until the next checked operation on this thread. Copy it before +another checked call if it must survive. Do not free it. + +### `hmath_status_string` + +`const char *hmath_status_string(hmath_status status)` + +**Parameters:** a status code. **Returns:** its borrowed static generic label; +unknown codes return `"unknown status"`. This does not replace the more specific +thread-local diagnostic. Example: `puts(hmath_status_string(HMATH_SHAPE_ERROR));`. + +## Runtime + +### `hmath_init` + +`int hmath_init(void)` + +**Parameters:** none. **Returns:** `HMATH_INIT_OK` (0) on successful or repeated +initialization; `HMATH_INIT_ALREADY_SHUT_DOWN` (1) after final shutdown. HMath +owns its GHC runtime: do not combine it with independently initialized GHC +libraries. Call before numerical kernels: `if (hmath_init() != 0) return 1;`. + +### `hmath_runtime_shutdown` + +`hmath_status hmath_runtime_shutdown(void)` + +**Parameters:** none. **Returns:** `HMATH_OK` after final shutdown or `HMATH_BUSY` +while a checked/legacy call or callback is active. Join workers, then retry a +busy result. Successful shutdown is irreversible; only the process owner +should invoke it. Release owned resources before shutdown. + +### `hmath_shutdown` + +`void hmath_shutdown(void)` + +**Parameters:** none. **Returns:** nothing. Legacy wrapper around final shutdown; +if busy, leaves the runtime running and records the error. Prefer the checked +`hmath_runtime_shutdown()` for new clients; otherwise inspect the last error. + +## Cancellation contexts + +### `hmath_context_create` + +`hmath_status hmath_context_create(hmath_context **out)` + +**Parameters:** non-NULL output slot. **Returns:** `HMATH_OK` and one owned, +initially uncancelled context. **Errors:** invalid output pointer or allocation +failure (NULL result). Example: `hmath_context *ctx = NULL;` followed by +`hmath_context_create(&ctx)`; release the context after its users finish. + +### `hmath_context_retain` + +`void hmath_context_retain(hmath_context *context)` + +**Parameters:** a live context or NULL. **Returns:** nothing; adds one owned +reference, or does nothing for NULL. Retain before giving a second owner access. +This does not reset cancellation or update the last diagnostic. + +### `hmath_context_release` + +`void hmath_context_release(hmath_context *context)` + +**Parameters:** an owned context reference or NULL. **Returns:** nothing; +destroys it on final release. Every successful create/retain needs one release. +Do not release the final reference while a kernel still uses this context. + +### `hmath_context_cancel` + +`void hmath_context_cancel(hmath_context *context)` + +**Parameters:** a live context or NULL. **Returns:** nothing. Atomically requests +cancellation of current/future work using this context. NULL is a no-op. It is +safe to request cancellation from another thread; the caller must keep its +reference alive. Does not clear the error message. + +### `hmath_context_reset` + +`void hmath_context_reset(hmath_context *context)` + +**Parameters:** a live context or NULL. **Returns:** nothing. Clear the cancelled +flag for reuse, **only after no operation is using the context**. NULL is a +no-op. Reset does not restart a shut down runtime. + +## Tensor construction + +### `hmath_tensor_copy` + +`hmath_status hmath_tensor_copy(const double *data, size_t count, const size_t *shape, size_t rank, hmath_tensor **out)` + +**Parameters:** `count` readable finite doubles, `rank` dimensions, and a non-NULL +output slot. `count` must equal the shape product; NULL data is allowed only +for zero elements, and NULL shape for rank zero. +**Returns:** one owned contiguous row-major copy. The caller retains ownership +of the input. **Errors:** invalid pointers/data, shape/count mismatch, exceeded +bounds, or allocation failure. See the complete example below. + +### `hmath_tensor_borrow` + +`hmath_status hmath_tensor_borrow(const double *data, size_t storage_count, const size_t *shape, const size_t *strides, size_t rank, hmath_buffer_deleter deleter, void *userdata, hmath_tensor **out)` + +**Parameters:** aligned immutable storage containing `storage_count` readable +doubles; shape and optional element strides (NULL means row-major); optional +`deleter(userdata, data)` and its borrowed userdata; output slot. All reachable +offsets must fit the storage. Keep data and userdata live/immutable until release. +**Returns:** one owned zero-copy tensor. On final storage release, invokes the +deleter exactly once on the releasing thread. The callback must not throw or +call shutdown. **Errors:** invalid/non-finite storage, shape/span/budget violation, +or allocation failure. Failure does not consume input ownership or call the deleter. +Example: borrow a static `const double[3]` with shape `{3}`, NULL strides/deleter. + +### `hmath_vector_copy` + +`hmath_status hmath_vector_copy(const double *data, size_t count, hmath_vector **out)` + +**Parameters:** `count` readable finite doubles and output slot. +**Returns:** a new owned contiguous tensor with shape `(count)`. +**Errors:** the same input, budget, and allocation errors as `hmath_tensor_copy`. +Example: `hmath_vector_copy(values, 3, &vector)`. + +### `hmath_matrix_copy` + +`hmath_status hmath_matrix_copy(const double *data, size_t count, size_t rows, size_t columns, hmath_matrix **out)` + +**Parameters:** flat row-major data, its count, two dimensions, and output slot. +**Returns:** a new owned `(rows, columns)` tensor. +**Errors:** construction errors, including `count != rows * columns`. +Example: `hmath_matrix_copy(values, 6, 2, 3, &matrix)`. + +## Tensor ownership and inspection + +### `hmath_tensor_retain` + +`void hmath_tensor_retain(hmath_tensor *tensor)` + +**Parameters:** a live tensor or NULL. **Returns:** nothing; adds one owned +reference for a new owner, or does nothing for NULL. It copies no values. +Balance each retain with a release. Does not change the last diagnostic. + +### `hmath_tensor_release` + +`void hmath_tensor_release(hmath_tensor *tensor)` + +**Parameters:** an owned reference or NULL. **Returns:** nothing; final release +frees the handle and, when no storage owners remain, its data/deleter. NULL is +allowed; releasing the same non-NULL reference twice is invalid. Reset your +variable to NULL after release to avoid accidental reuse. + +### `hmath_tensor_rank` + +`size_t hmath_tensor_rank(const hmath_tensor *tensor)` + +**Parameters:** a live tensor or NULL. **Returns:** its dimension count; NULL +returns zero. A real rank-zero scalar also returns zero: this is not an error +check. No initialization or ownership transfer occurs. + +### `hmath_tensor_count` -## Native backend providers +`size_t hmath_tensor_count(const hmath_tensor *tensor)` -The native backend header defines provider selection, integer-width contracts, -and the BLAS/LAPACK bridge. It is an internal adapter contract used by Haskell's -backend integration, separate from the public ABI-1 tensor API above. +**Parameters:** a live tensor or NULL. **Returns:** its logical element count; +NULL returns zero. Scalars count as one; empty tensors count as zero. The count +can differ from the storage span for strided input. + +### `hmath_tensor_metadata` + +`hmath_status hmath_tensor_metadata(const hmath_tensor *tensor, size_t *shape, size_t *strides, size_t capacity)` + +**Parameters:** live tensor, two caller-owned output arrays, and capacity in +entries (at least rank). Both arrays may be NULL for rank zero. +**Returns:** `HMATH_OK` after writing dimensions and element strides. +**Errors:** invalid tensor/arrays or `HMATH_BOUNDS_ERROR` for insufficient capacity. +Example: use `size_t shape[HMATH_MAX_RANK], strides[HMATH_MAX_RANK];`. + +### `hmath_tensor_copy_to` + +`hmath_status hmath_tensor_copy_to(const hmath_tensor *tensor, double *out, size_t capacity)` + +**Parameters:** live tensor and aligned destination with at least `count` +entries. The output must not overlap input storage; NULL is allowed for empty +output. **Returns:** a logical row-major copy in the caller's buffer. +**Errors:** invalid/overlapping buffer or insufficient capacity. No ownership +transfer occurs. Example: copy a six-element tensor into `double out[6]`. + +### `hmath_tensor_data` + +`hmath_status hmath_tensor_data(const hmath_tensor *tensor, const double **data, size_t *storage_count)` + +**Parameters:** live tensor and two non-NULL output slots. +**Returns:** a **borrowed read-only** storage pointer and underlying storage +size. Use metadata strides for logical indexing; the storage need not be compact. +The pointer is valid only while storage ownership is retained. Do not free it. +**Errors:** NULL tensor or output slots. No allocation or copying occurs. + +### `hmath_tensor_reshape` + +`hmath_status hmath_tensor_reshape(const hmath_tensor *tensor, const size_t *shape, size_t rank, hmath_tensor **out)` + +**Parameters:** live contiguous tensor, new dimensions, and output slot. +**Returns:** a new owned handle sharing storage with the original. +**Errors:** invalid shape, changed element count, non-contiguous input, or +allocation failure. No `-1` dimension inference. Example: reshape a length-six +vector to shape `{2, 3}`; both handles require independent release. + +## Raw allocation + +### `hmath_buffer_alloc` + +`hmath_status hmath_buffer_alloc(size_t bytes, size_t alignment, void **out)` + +**Parameters:** requested byte count, power-of-two alignment in +`[sizeof(void *), 4096]`, and non-NULL output slot. Zero bytes is valid. +**Returns:** one owned aligned allocation; release **only** with +`hmath_buffer_free`. **Errors:** invalid alignment, size exceeding +`HMATH_MAX_ELEMENTS * sizeof(double)`, arithmetic overflow, or allocation failure. +Example: `hmath_buffer_alloc(3 * sizeof(double), 64, &buffer)`. + +### `hmath_buffer_free` + +`void hmath_buffer_free(void *buffer)` + +**Parameters:** a pointer returned by `hmath_buffer_alloc`, or NULL. +**Returns:** nothing; frees that allocation. Never pass a tensor's borrowed data +pointer or an allocation from another allocator. Free each non-NULL allocation once. + +## Checked numerical kernels + +### `hmath_scalar_add` + +`hmath_status hmath_scalar_add(hmath_context *context, double a, double b, double *out)` + +**Parameters:** optional context, two finite scalars, and aligned output pointer. +**Returns:** `HMATH_OK` with their sum in `*out`. +**Errors:** invalid/non-finite input, non-finite result, or common kernel failures. +Example: `hmath_scalar_add(NULL, 2.0, 3.0, &result)` writes `5.0` on success. + +### `hmath_tensor_sum` + +`hmath_status hmath_tensor_sum(hmath_context *context, const hmath_tensor *tensor, double *out)` + +**Parameters:** optional context, live tensor, aligned scalar output. +**Returns:** sum of all logical elements; empty sum is zero. +**Errors:** invalid arguments, non-finite arithmetic, or common kernel failures. +Neither input nor ownership is modified. See the example below. + +### `hmath_tensor_dot` + +`hmath_status hmath_tensor_dot(hmath_context *context, const hmath_tensor *a, const hmath_tensor *b, double *out)` + +**Parameters:** optional context, two live identically shaped tensors, scalar output. +**Returns:** sum of corresponding products across all dimensions, zero for +matching empty tensors. **Errors:** invalid arguments, unequal shapes, +non-finite arithmetic, or common kernel failures. This is not matrix multiplication. + +### `hmath_tensor_add` + +`hmath_status hmath_tensor_add(hmath_context *context, const hmath_tensor *a, const hmath_tensor *b, hmath_tensor **out)` + +**Parameters:** optional context, identically shaped live tensors, output slot. +**Returns:** a new owned elementwise sum; inputs unchanged. No broadcasting. +**Errors:** invalid arguments, shape mismatch, allocation/arithmetic or common +kernel failures. For `[1, 2]` and `[3, 4]`, the result contains `[4, 6]`. + +### `hmath_tensor_matmul` + +`hmath_status hmath_tensor_matmul(hmath_context *context, const hmath_tensor *a, const hmath_tensor *b, hmath_tensor **out)` + +**Parameters:** optional context, rank-two `(m,k)` and `(k,n)` tensors, output slot. +**Returns:** a new owned `(m,n)` matrix product. Work must not exceed +16,777,216 scalar multiply-add steps. +**Errors:** invalid arguments, rank/inner-dimension mismatch, work/size bound, +allocation/arithmetic, or common kernel failures. Inputs remain unchanged. + +### `hmath_tensor_map` + +`hmath_status hmath_tensor_map(hmath_context *context, const hmath_tensor *tensor, hmath_map_callback callback, void *userdata, hmath_tensor **out)` + +**Parameters:** optional context, live input, callback, borrowed userdata, output. +The callback receives `(double value, size_t index, void *userdata, double *result)` +in logical row-major order, writes one finite result, and returns a status. +**Returns:** a new owned tensor of the original shape only if every callback +succeeds. **Errors:** callback status, invalid callback/input, cancellation, +non-finite output, allocation, or runtime failure. Partial results are discarded. +Callbacks are synchronous, may reenter checked calls, must not throw across C, +and must not shut down the runtime. Userdata need only outlive this call. + +### `hmath_batch_sum` + +`hmath_status hmath_batch_sum(hmath_context *context, const hmath_tensor *const *inputs, size_t count, double *out, size_t *completed)` + +**Parameters:** optional context, arrays of `count` live tensor pointers and +scalar output slots, and aligned non-NULL progress pointer. `count <= 4096`. +**Returns:** `HMATH_OK` after all reductions; `*completed == count`. +**Errors:** invalid arrays/bounds or a reduction failure. Unlike atomic tensor +kernels, entries `out[0 .. *completed)` remain valid after failure; later output +slots are untouched. Count zero permits NULL input/output arrays. Initialize +progress storage even for an empty batch: `size_t completed = 0;`. + +## Legacy numerical interface + +Prefer checked functions when available. Legacy numerical calls still require +successful initialization. Invalid lifecycle returns NaN (`-1` for factorial). +All nonempty buffers must contain the declared readable number of doubles; +counts must fit Haskell `Int`. + +### `hmath_add_f64` + +`double hmath_add_f64(double a, double b)` + +**Parameters:** two doubles. **Returns:** their legacy scalar sum. Invalid +lifecycle returns NaN. Unlike the checked interface, this retains legacy +floating-point behavior without a status result. Example: `hmath_add_f64(2, 3)`. + +### `hmath_factorial` + +`long long hmath_factorial(int n)` + +**Parameters:** integer `n` in `[0,20]`. +**Returns:** `n!`, including `0! == 1`; `-1` outside the range or with invalid +lifecycle. Example: `hmath_factorial(5)` returns 120. + +### `hmath_mean_f64` + +`double hmath_mean_f64(const double *values, size_t count)` + +**Parameters:** a readable double array and count. **Returns:** arithmetic mean; +empty or NULL input, or invalid lifecycle, returns NaN. Example: `{2,4}` gives 3. +No handle ownership is transferred. + +### `hmath_dot_f64` + +`double hmath_dot_f64(const double *a, const double *b, size_t count)` + +**Parameters:** two readable double arrays of equal declared count. +**Returns:** sum of products; empty input gives zero, nonempty NULL input or +invalid lifecycle gives NaN. Example: `{1,2}` dotted with `{3,4}` gives 11. + +## DLPack exchange + +Include `hmath_dlpack.h` and the producer's official `dlpack/dlpack.h` for the +managed tensor structs. Only CPU device 0, native-endian binary64, one lane, +and rank at most 8 are supported. Negative strides, unsupported devices/dtypes, +and unknown versioned flags are rejected. Imported storage must remain immutable. + +### `hmath_dlpack_export` + +`hmath_status hmath_dlpack_export(const hmath_tensor *tensor, struct DLManagedTensor **out)` + +**Parameters:** live input and non-NULL managed-tensor output slot. +**Returns:** an owned legacy DLPack **copy**, because legacy DLPack cannot express +read-only storage. The recipient must invoke its deleter exactly once. The +HMath input can then be released independently. +**Errors:** invalid input/output, size/layout, or allocation failure. + +### `hmath_dlpack_import` + +`hmath_status hmath_dlpack_import(struct DLManagedTensor *tensor, size_t storage_elements, hmath_tensor **out)` + +**Parameters:** producer-owned managed tensor, count of readable double elements +**after `byte_offset`**, and output slot. The caller guarantees this count; +DLPack itself carries no allocation size. +**Returns:** one owned HMath tensor and consumes managed-tensor ownership **only +on success**; final HMath storage release calls the producer's deleter. +**Errors:** invalid/unsupported metadata, insufficient storage span, non-finite +data, bounds, or allocation failure. On failure the caller still owns the managed tensor. + +### `hmath_dlpack_export_versioned` + +`hmath_status hmath_dlpack_export_versioned(const hmath_tensor *tensor, struct DLManagedTensorVersioned **out)` + +**Parameters:** live input and output slot. +**Returns:** an owned versioned zero-copy DLPack view with the read-only flag set. +It retains storage independently of the original HMath handle; invoke the +managed view's deleter exactly once. **Errors:** invalid arguments or allocation failure. + +### `hmath_dlpack_import_versioned` + +`hmath_status hmath_dlpack_import_versioned(struct DLManagedTensorVersioned *tensor, size_t storage_elements, hmath_tensor **out)` + +**Parameters:** versioned managed tensor, readable element count after byte offset, +and output slot. **Returns:** one owned HMath tensor, consuming producer ownership +only on success. **Errors:** legacy import validation failures plus unsupported +DLPack version or flags. Do not mutate the imported storage through any alias +while the resulting storage is retained. + +## Complete checked example ```c ---8<-- "include/hmath_backend.h" +#include +#include + +int main(void) { + hmath_tensor *tensor = NULL; + const double values[] = {1.0, 2.0, 3.0}; + const size_t shape[] = {3}; + double total = 0.0; + hmath_status status; + if (hmath_abi_version() != HMATH_ABI_VERSION || hmath_init() != 0) return 1; + status = hmath_tensor_copy(values, 3, shape, 1, &tensor); + if (status == HMATH_OK) status = hmath_tensor_sum(NULL, tensor, &total); + if (status != HMATH_OK) fprintf(stderr, "%s\n", hmath_last_error_message()); + hmath_tensor_release(tensor); + if (status != HMATH_OK) return 1; + printf("%.1f\n", total); /* 6.0 */ + return hmath_runtime_shutdown() == HMATH_OK ? 0 : 1; +} ``` + +## Backend adapter boundary + +`hmath_backend.h` defines the **internal** BLAS/LAPACK provider bridge used by +Haskell. Its `hmath_backend_*` adapter entry points are not part of this stable +public tensor ABI. The supported Haskell provider API is documented under +`HMath.Backend` in the [Haskell reference](haskell.md). diff --git a/docs/reference/haskell.md b/docs/reference/haskell.md index 7d6d8ed..5362d59 100644 --- a/docs/reference/haskell.md +++ b/docs/reference/haskell.md @@ -1,9 +1,10 @@ # Haskell modules -Haskell exposes the full HMath numerical API. The -[generated Haddock reference](https://wavefnd.github.io/hmath/haskell/index.html) -contains public signatures, types, and module documentation, generated from -the same source revision as this site. +Select a module below or in the sidebar to read its public types, function +signatures, input requirements, results, and failure conditions. Search accepts +function names as well as descriptive terms. Module pages are generated from +the same source revision as this site, including function, method, and record +field documentation. | Area | Representative modules | | --- | --- | @@ -24,10 +25,38 @@ modules explicitly for other numerical domains. Checked APIs generally return `Either MathError`; consult the function signature for the exact error and result types. -Build the local API documentation with: +## Read a checked result + +The Haskell API covers more numerical domains than the C, Wave, and Python +bindings. Those bindings currently expose the native scalar/tensor interface; +a Haskell-only function is not automatically available in Python. + +```haskell +import qualified HMath.Scalar as Scalar +import qualified HMath.Matrix as Matrix +import qualified HMath.Matrix.LU as LU + +main :: IO () +main = do + print (Scalar.divide (6 :: Double) 2) -- Right 3.0 + print (Scalar.divide (1 :: Double) 0) -- Left (DomainError ...) + let solution = do + a <- Matrix.fromListChecked 2 2 [2, 0, 0, 4 :: Double] + LU.solve a [6, 8] + print solution -- Right [3.0,2.0] +``` + +An `Either` result distinguishes input/numerical failure (`Left`) from an +accepted result (`Right`). Solver report fields additionally distinguish a +budget stop from convergence. Pure legacy functions such as `HMath.Basic.factorial` +and `HMath.Statistics.mean` can raise errors on invalid input; their entries +state those preconditions. IEEE/generic arithmetic APIs can retain host-type +overflow or NaN behavior when their contract does not add finite checks. + +Build the complete local site with: ```sh -cabal haddock lib:hmath --haddock-html --haddock-hyperlink-source +python tools/build_docs.py ``` The [dense linear algebra guide](../linear-algebra.md) describes matrix shapes, diff --git a/docs/reference/python.md b/docs/reference/python.md index a67a427..b444684 100644 --- a/docs/reference/python.md +++ b/docs/reference/python.md @@ -1,70 +1,373 @@ # Python API -Import the primary interface with `import hmath`. Values are finite IEEE 754 -binary64 numbers. Tensors are immutable; operations return new owned tensors. +`hmath` is the primary interface. Calculations use finite IEEE 754 binary64 +values. Tensors are immutable and do not broadcast implicitly. NumPy is needed +only for the conversion methods. All examples below run in documentation checks. -## Functions and exceptions +## Common contracts -| API | Result and contract | -| --- | --- | -| `add(a, b) -> float` | Add two finite scalar values; initialize the runtime automatically. | -| `initialize() -> None` | Idempotent initialization; ordinary tensor operations already call it. | -| `shutdown() -> None` | Final process-owner operation; join workers first. Cannot reinitialize afterward. | -| `HMathError(status)` | Native checked-operation failure; `.status` contains the integer C status code and the message describes the failure. | +- Shapes contain at most **8** nonnegative Python integers (not booleans). + Each dimension and the total size are bounded by **1,048,576**. Empty + dimensions are supported. Shape `()` is a scalar with exactly one value. +- Use `with` or `close()` to release each owned tensor. Closing one handle + preserves independent retained handles and NumPy views. +- Native failures raise `HMathError`. Shape validation raises `ValueError`; + use after close raises `RuntimeError`. Numeric conversion can also raise + Python `TypeError`, `ValueError`, or `OverflowError`. +- Primary-interface methods synchronize access to tensor handles. Prevent + concurrent close/use yourself when using the optional cffi interface. -Python shape validation raises `ValueError`. Native validation and arithmetic -failures raise `HMathError`; use-after-close and final shutdown errors raise -`RuntimeError`. Numeric conversion can raise ordinary Python conversion errors. +## Module functions -## Tensor construction +### `hmath.initialize()` -| Signature | Result and constraints | -| --- | --- | -| `Tensor(values, shape=None)` | Copy an iterable into native storage; default shape is `(len(values),)`. Explicit shape must have exactly the supplied number of elements. | -| `Tensor.scalar(value)` | Scalar with rank zero and shape `()`. | -| `Tensor.matrix(values, rows, columns)` | Rank-two matrix, with values in row-major order. | -| `Tensor.from_numpy(array, copy=True)` | Preserve shape and copy values into binary64 storage. With `copy=False`, borrow suitable read-only NumPy storage. | +**Parameters:** none. Initialize the process-wide runtime; repeated calls are +allowed. Constructors and `add()` already do this automatically. +**Returns:** `None`. **Raises:** `RuntimeError` for ABI incompatibility or +an irreversibly shut down runtime. -Native limits are rank **8** and **1,048,576** elements. Each dimension must -be a nonnegative integer; zero-length dimensions are allowed. A scalar has -one value. Non-finite input is rejected. See the [NumPy guide](../guides/numpy.md) -for borrowing constraints and alias ownership. +```python +from hmath import initialize +initialize() +initialize() +``` + +### `hmath.add(a, b)` + +**Parameters:** two finite real scalars convertible to C `double`. +**Returns:** their sum as a Python `float`, initializing the runtime if needed. +**Raises:** `HMathError` for non-finite input/result, or runtime/conversion errors. + +```python +from hmath import add +assert add(2, 3.5) == 5.5 +``` + +### `hmath.shutdown()` + +**Parameters:** none. Only the process owner should call this after joining +all numerical users and releasing their resources. Applications can instead +allow process exit to clean up the runtime. +**Returns:** `None`. **Raises:** `HMathError` with status 9 while work is active; +join workers and retry. Successful shutdown is **irreversible**. + +Example, as the last operation of a dedicated process (not run in shared tests): + +```text +from hmath import shutdown +shutdown() +``` + +### `hmath.HMathError(status)` + +**Parameters:** the integer status from a failed checked C call. +**Returns:** a `RuntimeError` subclass instance with `.status` and a snapshot +of the calling thread's native diagnostic in `str(error)`. Catch exceptions +raised by operations rather than constructing this manually. + +```python +from hmath import HMathError, Tensor +try: + Tensor([1, 2], (3,)) +except HMathError as error: + assert error.status == 2 +``` + +## Construction + +### `hmath.Tensor(values, shape=None)` + +**Parameters:** `values`: finite numeric iterable in flat row-major order; +`shape`: optional iterable of dimensions, defaulting to `(len(values),)`. +Values are copied, so later changes to the input do not affect the tensor. +At most 1,048,577 entries are consumed before oversized input is rejected. +**Returns:** a new owned tensor. **Raises:** `ValueError` for Python shape/size +bounds; `HMathError` for mismatched element count, non-finite input, or allocation +failure; ordinary numeric conversion errors may also occur. + +```python +with Tensor([1, 2, 3, 4], (2, 2)) as matrix: + assert matrix.shape == (2, 2) + assert matrix.values() == [1., 2., 3., 4.] +``` + +### `hmath.Tensor.scalar(value)` + +**Parameters:** one finite real value. **Returns:** a new owned rank-zero tensor +with shape `()`. **Raises:** the constructor's conversion and native errors. + +```python +with Tensor.scalar(7) as scalar: + assert scalar.shape == () + assert scalar.values() == [7.0] +``` + +### `hmath.Tensor.matrix(values, rows, columns)` -## Tensor operations +**Parameters:** flat row-major values and two nonnegative integer dimensions; +exactly `rows * columns` values are required. +**Returns:** a new owned rank-two tensor. **Raises:** constructor errors. -| API | Return value and behavior | -| --- | --- | -| `tensor.shape` | Tuple of dimensions. | -| `tensor.values()` | Independent Python list of floats in row-major traversal order. | -| `tensor.numpy(copy=True)` | NumPy array of the same shape; an independent copy by default. With `copy=False`, a read-only native view retaining storage ownership. | -| `tensor.sum()` | Scalar sum of elements. | -| `tensor.dot(other)` | Scalar sum of elementwise products; inputs require identical shapes. | -| `tensor + other` | Elementwise addition; inputs require identical shapes. No broadcasting. | -| `tensor @ other` | Rank-two dense matrix multiplication, with matching inner dimensions. Work is limited to 16,777,216 scalar multiply-add steps. | -| `tensor.reshape(shape)` | New handle sharing the same storage; requires contiguous input and unchanged element count. | -| `tensor.close()` | Release this handle. Repeated calls are allowed. Other retained owners remain valid. | +```python +with Tensor.matrix([1, 2, 3, 4, 5, 6], 2, 3) as matrix: + assert matrix.shape == (2, 3) +``` -Use context managers for deterministic cleanup: +### `hmath.Tensor.from_numpy(array, copy=True)` + +**Parameters:** `array`: NumPy array or array-like input; `copy`: whether to copy. +With `True`, convert to `float64` and copy in row-major order. With `False`, +borrow aligned, native-endian, **read-only** `float64` storage with nonnegative +strides divisible by eight bytes. The tensor keeps the array alive. The caller +must prevent writes through every alias until all borrowed tensors/views die. +**Returns:** an owned tensor preserving shape. **Raises:** `ImportError` without +NumPy, `ValueError` for borrowing/rank/size violations, or `HMathError` for native +storage validation, non-finite data, or allocation failures. ```python -from hmath import Tensor +import numpy as np +array = np.array([[1., 2.], [3., 4.]]) +array.setflags(write=False) +with Tensor.from_numpy(array, copy=False) as tensor: + assert tensor.sum() == 10.0 +``` + +## Inspection and conversion + +### `hmath.Tensor.shape` + +**Parameters:** none; read-only property. **Returns:** a tuple of dimensions, +including `()` for scalars. **Raises:** `RuntimeError` after close or +`HMathError` if native metadata retrieval fails. + +```python +with Tensor([], (0, 3)) as empty: + assert empty.shape == (0, 3) +``` + +### `hmath.Tensor.values()` + +**Parameters:** none. **Returns:** an independent flat `list[float]` in logical +row-major order, including for strided input; `[]` for empty tensors. +**Raises:** closed-handle or native copy errors. + +```python +with Tensor([2, 4]) as tensor: + values = tensor.values() +values[0] = 99 # Independent list remains usable after close. +``` +### `hmath.Tensor.numpy(copy=True)` + +**Parameters:** `copy`: `True` for a writable independent copy, `False` for a +read-only native view with the tensor's shape and strides. Views retain storage +and borrowed owners even after this tensor closes. Do not mutate borrowed aliases. +**Returns:** `numpy.ndarray` of `float64`. **Raises:** `ImportError` without NumPy, +closed-handle errors, or native metadata/data errors. + +```python +with Tensor([1, 2, 3]) as tensor: + view = tensor.numpy(copy=False) +assert view.tolist() == [1., 2., 3.] +assert not view.flags.writeable +del view +``` + +## Calculations + +### `hmath.Tensor.sum()` + +**Parameters:** none. Sum every logical element, regardless of rank. +**Returns:** a `float`, or `0.0` for an empty tensor. +**Raises:** closed-handle errors or native arithmetic/runtime errors, including +non-finite results. + +```python +with Tensor([1, 2, 3]) as tensor: + assert tensor.sum() == 6.0 +``` + +### `hmath.Tensor.dot(other)` + +**Parameters:** a live tensor with exactly the same shape. Sum corresponding +products over the entire tensor; this is a scalar reduction at every rank. +**Returns:** a `float`, or `0.0` for matching empty tensors. +**Raises:** `HMathError` for shape/arithmetic/runtime errors; closed operands +raise `RuntimeError`. + +```python with Tensor([1, 2, 3]) as a, Tensor([4, 5, 6]) as b: assert a.dot(b) == 32.0 +``` + +### `hmath.Tensor.__add__(other)` — `a + b` + +**Parameters:** another live tensor with identical shape; no broadcasting. +**Returns:** a new owned tensor of elementwise sums. Inputs are unchanged. +**Raises:** native shape/allocation/arithmetic/runtime or closed-handle errors. + +```python +with Tensor([1, 2]) as a, Tensor([3, 4]) as b: with a + b as result: - assert result.values() == [5.0, 7.0, 9.0] + assert result.values() == [4., 6.] +``` + +### `hmath.Tensor.__matmul__(other)` — `a @ b` + +**Parameters:** a live rank-two tensor. Shapes `(m, k)` and `(k, n)` produce +`(m, n)`. Work is bounded by **16,777,216** scalar multiply-add steps (`m*k*n`). +This binding does not expose batched multiplication. +**Returns:** a new owned matrix. **Raises:** native rank/inner-dimension, +size/work budget, allocation, arithmetic/runtime, or closed-handle errors. + +```python +with Tensor.matrix([1, 2, 3, 4], 2, 2) as a: + with a @ a as squared: + assert squared.values() == [7., 10., 15., 22.] +``` + +### `hmath.Tensor.reshape(shape)` + +**Parameters:** new dimensions with unchanged element count. Storage must be +contiguous. Negative dimensions, including `-1` for inference, are unsupported. +**Returns:** a new owned handle sharing storage; both handles can close independently. +**Raises:** `ValueError` for invalid dimensions, `HMathError` for incompatible +count or non-contiguous input, or `RuntimeError` after close. + +```python +with Tensor([1, 2, 3, 4]) as flat: + reshaped = flat.reshape((2, 2)) +with reshaped: + assert reshaped.shape == (2, 2) +``` + +## Lifetime protocol + +### `hmath.Tensor.close()` + +**Parameters:** none. Release this handle's native reference and borrowed owner. +**Returns:** `None`; repeated calls are harmless. Other retained handles/views +remain valid. Using this closed handle raises `RuntimeError`. + +```python +tensor = Tensor([1]) +tensor.close() +tensor.close() +``` + +### `hmath.Tensor.__enter__()` + +**Parameters:** none. **Returns:** the same live tensor for a `with` block; +this creates no additional reference. **Raises:** `RuntimeError` after close. +See the context-manager examples above. + +### `hmath.Tensor.__exit__(*args)` + +**Parameters:** Python's context-manager exception triple. +**Returns:** `None`, closing the tensor on normal or exceptional block exit +without suppressing the exception. See the context-manager examples above. + +### `hmath.Tensor.__del__()` + +**Parameters:** none. **Returns:** `None`, calling `close()` as a finalization +fallback. Collection timing is unspecified; use `with` for deterministic cleanup. + +## Optional cffi interface + +Install `hmath-python[cffi]` to use `hmath_cffi`. Both wrappers share the native +runtime. Prevent concurrent close/use of a cffi tensor. NumPy conversion, +`reshape`, `scalar`, and `matrix` constructors belong to the primary interface. + +### `hmath_cffi.add(a, b)` + +**Parameters:** two finite real scalars. **Returns:** their binary64 sum as a +Python float. **Raises:** `hmath_cffi.HMathError` for native failures or ordinary +conversion errors. Import initializes the runtime and checks ABI 1. + +```python +import hmath_cffi as hc +assert hc.add(2, 3) == 5.0 ``` -## cffi interface +### `hmath_cffi.HMathError(status)` + +**Parameters:** native status integer. **Returns:** an exception with `.status` +and a snapshot of the current native error message. Catch this class for cffi +errors; it is a separate class from `hmath.HMathError`. + +### `hmath_cffi.check(status)` + +**Parameters:** status from a raw checked C call. **Returns:** `None` for zero. +**Raises:** `hmath_cffi.HMathError` for nonzero. Call immediately after the raw +call so its thread-local error message has not been replaced. + +### `hmath_cffi.Tensor(values, shape=None)` + +**Parameters:** flat finite numeric iterable and optional dimensions, following +primary constructor limits. **Returns:** an owned cffi tensor with `.shape` +stored as a tuple. **Raises:** `ValueError` for Python bounds, +`hmath_cffi.HMathError` for native input/allocation errors, or conversion errors. + +```python +with hc.Tensor([1, 2, 3, 4], (2, 2)) as a: + assert a.shape == (2, 2) + with a @ a as result: + assert result.values() == [7., 10., 15., 22.] +``` + +### `hmath_cffi.Tensor.values()` + +**Parameters:** none. **Returns:** an independent row-major `list[float]`. +**Raises:** `RuntimeError` after close or `hmath_cffi.HMathError` on copy failure. +Use `.values()` inside the context-manager example above. + +### `hmath_cffi.Tensor.sum()` + +**Parameters:** none. **Returns:** scalar sum, or `0.0` for an empty tensor. +**Raises:** native arithmetic/runtime or closed-handle errors. For example, +`hc.Tensor([1, 2])` sums to `3.0`; close the owner after use. + +### `hmath_cffi.Tensor.dot(other)` + +**Parameters:** a live cffi tensor with identical shape. **Returns:** scalar sum +of elementwise products. **Raises:** native shape/arithmetic/runtime or +closed-handle errors. The primary interface's dot example also applies to cffi. + +### `hmath_cffi.Tensor.__add__(other)` — `a + b` + +**Parameters:** a live cffi tensor of identical shape. **Returns:** a new owned +elementwise sum without broadcasting. **Raises:** native shape/allocation/ +arithmetic/runtime or closed-handle errors. Use with `with a + b as result:`. + +### `hmath_cffi.Tensor.__matmul__(other)` — `a @ b` + +**Parameters:** a live cffi tensor with compatible rank-two dimensions. +**Returns:** a new owned matrix. **Raises:** the same shape/work-bound and +native/lifecycle errors as primary `@`. See the executable cffi example above. + +### `hmath_cffi.Tensor.close()` + +**Parameters:** none. **Returns:** `None`, releasing its cffi-managed reference. +Repeated calls are harmless. Do not close concurrently with an operation on +this tensor. Other independent owners remain valid. + +### `hmath_cffi.Tensor.__enter__()` + +**Parameters:** none. **Returns:** the same live tensor in `with`. +**Raises:** `RuntimeError` after close. No new native owner is created. + +### `hmath_cffi.Tensor.__exit__(*args)` + +**Parameters:** Python's exception triple. **Returns:** `None`, closing this +tensor on block exit without suppressing exceptions. -The optional `hmath_cffi` module provides `add`, `HMathError`, and `Tensor`. -Its tensor API includes the iterable constructor, `values`, `sum`, `dot`, -`+`, `@`, `close`, and context-manager cleanup. Its `.shape` is the stored -shape tuple. NumPy conversion, `reshape`, and the convenience `scalar` and -`matrix` constructors belong to the primary ctypes interface. +### Low-level cffi attributes -Do not close a cffi tensor concurrently with an operation on that tensor. -Both wrappers load the same bundled C library and share its runtime. +`hmath_cffi.ffi` is the configured `cffi.FFI` object; `hmath_cffi.lib` is the +loaded native handle exposing the declarations used by this wrapper. Raw calls +follow the [C ABI](c.md), including status and ownership rules. `tensor.ptr` is +borrowed: do not release it separately or use it after close. `tensor.shape` +is the construction/result shape tuple and must not be reassigned by callers. ## Native status codes diff --git a/docs/reference/wave.md b/docs/reference/wave.md index 6b8261f..1df28b4 100644 --- a/docs/reference/wave.md +++ b/docs/reference/wave.md @@ -1,40 +1,174 @@ # Wave API -The binding lives in `bindings/wave/hmath.wave` and mirrors the checked C ABI. -Operations return integer status codes: zero is success. Output arguments -are valid only when the status reports success. - -| Function | Purpose | -| --- | --- | -| `Tensor` | Wrapper owning one native tensor reference in its `handle` field. | -| `initialize` | Verify ABI 1 and initialize the runtime; returns 10 for an unsupported ABI or 5 after final runtime shutdown. | -| `error_message` | Pointer to the thread-local error message; valid until the next checked C call. | -| `scalar_add` | Add two `f64` values through an output pointer. | -| `tensor_empty` | Construct an empty wrapper before using an output argument. | -| `tensor_copy` | Copy values with explicit dimensions and rank. | -| `vector_copy` | Copy a vector. | -| `matrix_copy` | Copy a row-major matrix. | -| `tensor_values` | Copy values to a caller-provided output buffer. | -| `tensor_sum`, `tensor_dot` | Scalar reductions. | -| `tensor_add`, `tensor_matmul` | Create a new tensor result. | -| `tensor_clone` | Retain an independent native reference. | -| `tensor_close` | Release the wrapper's reference and reset it. | - -Native rank, size, and arithmetic limits are shared with the -[C ABI](c.md). Use `tensor_clone` when creating another owner: assigning a -wrapper by value does not automatically retain its handle. - -Tensor output arguments must point to an empty wrapper created with -`tensor_empty()`. A successful constructor or tensor operation transfers one -owned reference to the output. Close every owned result, including those -created before a later operation fails. - -## Binding source - -The maintained declarations and wrappers are included directly: - -```text ---8<-- "bindings/wave/hmath.wave" +The Wave 0.2.1 binding targets **64-bit systems** where C `size_t` matches Wave +`u64`. Import `bindings/wave/hmath.wave` beside your source as shown in the +[Wave integration guide](../guides/wave.md). All numerical values are `f64`. + +## Shared rules + +`Tensor { handle: ptr }` owns one native reference. Treat owners linearly: +plain struct assignment does **not** retain a second reference. Use +`tensor_clone`, and close every owner, including those created before a later +failure. Keep all input handles live throughout a call. + +Status-returning wrappers return `i32`: zero means success. The C +[status table](python.md#native-status-codes) defines the other values. Read +`error_message()` immediately after a failed native checked call. Wrapper-only +validation (such as an occupied output slot or ABI mismatch) returns its code +without replacing the native diagnostic, so the message may describe an earlier +call. Do not use that stale message as the reason for wrapper validation failure. + +Every tensor output must be a non-NULL pointer to a wrapper initialized with +`tensor_empty()`. Success transfers one owned reference; failure leaves that +empty wrapper unchanged. Scalar outputs are valid only on success. Inputs +must obey the C ABI's rank 8, 1,048,576-element, finite-data, and storage bounds. + +## Initialization and diagnostics + +### `initialize() -> i32` + +**Parameters:** none. Check ABI 1 and initialize the shared runtime. +**Returns:** 0 on success, 10 for unsupported ABI, 5 after irreversible shutdown. +Repeated initialization is allowed. Constructors and `scalar_add` call this +automatically. It does not create a tensor or an ownership obligation. + +### `error_message() -> ptr` + +**Parameters:** none. **Returns:** a borrowed, NUL-terminated thread-local +native error string. It remains valid until the next checked C call on this +thread. Copy it before that call if it must survive; never free it. +Wrapper-only validation does not set a fresh message; see the shared rules. + +### `scalar_add(a: f64, b: f64, output: ptr) -> i32` + +**Parameters:** two finite scalars and a valid aligned scalar output pointer. +**Returns:** status 0 and their sum in `output` after automatic initialization. +**Errors:** invalid/non-finite input or result, initialization or native runtime +failure. Example: `scalar_add(2.0, 3.0, &value)` writes 5.0 on success. + +## Construction and ownership + +### `tensor_empty() -> Tensor` + +**Parameters:** none. **Returns:** `Tensor { handle: null }`, with no native +reference to release. Use this to initialize every result slot before passing +its address to a constructor, clone, add, or matrix multiplication. + +### `tensor_copy(data: ptr, count: u64, shape: ptr, rank: u64, output: ptr) -> i32` + +**Parameters:** `count` readable finite doubles, `rank` dimensions, and empty +output wrapper. Count must equal the dimension product. Rank zero contains one +value; zero dimensions allow an empty tensor. Data must remain readable during +this synchronous call. +**Returns:** status 0 and a new owned row-major copy; input ownership is unchanged. +**Errors:** occupied/NULL output, invalid storage/dimensions, count mismatch, +size bound, initialization, or allocation failure. + +### `vector_copy(data: ptr, count: u64, output: ptr) -> i32` + +**Parameters:** readable values and their count, plus empty output wrapper. +**Returns:** status 0 and a new owned rank-one tensor of length `count`. +**Errors:** the same construction errors as `tensor_copy`. +The values are copied, so the source can be reused once the call returns. + +### `matrix_copy(data: ptr, count: u64, rows: u64, columns: u64, output: ptr) -> i32` + +**Parameters:** row-major values, count, two dimensions, empty output wrapper. +**Returns:** status 0 and a new owned rank-two matrix. +**Errors:** construction errors, including `count != rows * columns`. +For `{1,2,3,4}`, dimensions 2 by 2 create rows `[1,2]` and `[3,4]`. + +### `tensor_clone(source: Tensor, output: ptr) -> i32` + +**Parameters:** a live source and non-NULL empty result wrapper. +**Returns:** 0 and a second owned reference to the same immutable native tensor. +No values are copied. Both owners must be closed independently. +**Errors:** 1 for an empty source, NULL output, or occupied output slot. + +### `tensor_close(tensor: ptr)` + +**Parameters:** pointer to an owned or empty wrapper; NULL is also allowed. +**Returns:** nothing. Release its native reference and set the handle to NULL. +Repeated close is safe. Do not close the last owner concurrently with use. +Cloned owners remain valid. Call this on all success and error cleanup paths. + +## Inspection + +### `tensor_count(tensor: Tensor) -> u64` + +**Parameters:** live or empty wrapper. +**Returns:** logical element count; empty/closed wrapper returns zero. A +rank-zero scalar counts as one. This is a query, not a status result; a zero +count cannot distinguish an empty tensor from an empty wrapper. + +### `tensor_values(tensor: Tensor, output: ptr, count: u64) -> i32` + +**Parameters:** live wrapper and aligned caller-owned output buffer; `count` +is capacity in doubles, at least `tensor_count(tensor)`. It must not overlap +native input storage. A NULL buffer is allowed for zero elements. +**Returns:** 0 after copying flat logical row-major values. +**Errors:** invalid handle/buffer, overlap, or insufficient capacity (8). +It neither consumes the tensor nor transfers storage ownership. + +## Calculations + +These wrappers use the existing runtime and disable cancellation (NULL C +context). Construct an input or call `initialize()` first. Common native failures +include unavailable runtime, allocation, and non-finite arithmetic. + +### `tensor_sum(tensor: Tensor, output: ptr) -> i32` + +**Parameters:** live input and aligned scalar output pointer. +**Returns:** 0 with the sum of every logical element, or zero for an empty tensor. +**Errors:** invalid pointers/handle or common native failures. +The input owner remains unchanged. + +### `tensor_dot(a: Tensor, b: Tensor, output: ptr) -> i32` + +**Parameters:** live tensors with identical shapes and scalar output pointer. +**Returns:** 0 with the sum of elementwise products; matching empty tensors give +zero. **Errors:** shape mismatch, invalid pointers/handles, or common native +failures. This is a scalar reduction, not matrix multiplication. + +### `tensor_add(a: Tensor, b: Tensor, output: ptr) -> i32` + +**Parameters:** live tensors of identical shape and empty result wrapper. +**Returns:** 0 with a new owned elementwise sum. Inputs remain unchanged; there +is no broadcasting. **Errors:** occupied/NULL output, shape mismatch, invalid +handles, or common native failures. Close the result independently of its inputs. + +### `tensor_matmul(a: Tensor, b: Tensor, output: ptr) -> i32` + +**Parameters:** live rank-two matrices of shapes `(m,k)` and `(k,n)`, and empty +result wrapper. **Returns:** 0 with a new owned `(m,n)` dense product. +**Errors:** invalid/occupied output, rank/inner-dimension mismatch, element/work +bounds (at most 16,777,216 scalar multiply-add steps), or common native failures. +Batched and broadcasted matrix products are not exposed by this wrapper. + +## Example with cleanup + +Place this file beside the binding, then use the compiler/linker setup in the +[Wave guide](../guides/wave.md). + +```wave +import("./hmath")::{Tensor, tensor_empty, vector_copy, tensor_sum, tensor_close}; + +fun main() -> i32 { + var samples: array = [1.0, 2.0, 3.0]; + var tensor: Tensor = tensor_empty(); + var total: f64 = 0.0; + var status: i32 = vector_copy(&samples[0], 3, &tensor); + if (status == 0) { + status = tensor_sum(tensor, &total); + } + tensor_close(&tensor); + if (status != 0 || total != 6.0) { + return 1; + } + return 0; +} ``` -See [Wave integration](../guides/wave.md) for compiler and linking instructions. +The lower-level `extern(c, ...)` declarations support these wrappers. Their +contracts are the corresponding [C ABI functions](c.md). The process owner, +rather than each Wave tensor, controls final runtime shutdown. diff --git a/docs/stylesheets/api.css b/docs/stylesheets/api.css new file mode 100644 index 0000000..49048ee --- /dev/null +++ b/docs/stylesheets/api.css @@ -0,0 +1,26 @@ +.haskell-reference .top { + margin: 1.5em 0 2em; + padding-top: .5em; + border-top: 1px solid var(--md-default-fg-color--lightest); +} +.haskell-reference .src { + font-family: var(--md-code-font-family); + font-size: .85em; + overflow-wrap: anywhere; +} +.haskell-reference .link, +.haskell-reference .selflink { + margin-left: .6em; + font-size: .8em; +} +.haskell-reference .subs { + margin-left: 1em; +} +.haskell-reference .caption { + font-weight: bold; +} +.haskell-reference table { + display: block; + overflow-x: auto; + width: 100%; +} diff --git a/mkdocs.yml b/mkdocs.yml index 55f04d3..c9fd90b 100644 --- a/mkdocs.yml +++ b/mkdocs.yml @@ -25,6 +25,8 @@ theme: toggle: icon: material/brightness-4 name: Switch to light mode +extra_css: + - stylesheets/api.css plugins: - search markdown_extensions: diff --git a/src/HMath/API/Algebra.hs b/src/HMath/API/Algebra.hs index d02c986..30604f7 100644 --- a/src/HMath/API/Algebra.hs +++ b/src/HMath/API/Algebra.hs @@ -37,25 +37,51 @@ import qualified HMath.Vector as V embedding. No ordering or approximate division is imposed on exact rings. -} class (Eq a) => Ring a where + -- | Additive identity of this ring. zero :: a + + -- | Multiplicative identity of this ring. one :: a + + -- | Add two ring elements; exact instances obey ring laws and IEEE instances retain host rounding. plus :: a -> a -> a + + -- | Multiply two ring elements using the instance arithmetic. times :: a -> a -> a + + -- | Return the additive inverse of a ring element. negative :: a -> a + + -- | Embed an unbounded Integer into the domain; instance representation/rounding rules apply. integer :: Integer -> a +{- | Ring supporting checked multiplicative inversion. Invalid zero/domain or +unrepresentable inverse returns MathError. +-} class (Ring a) => Field a where + -- | Return multiplicative inverse of a nonzero domain element, or Left MathError for zero/invalid/nonrepresentable inverse. invert :: a -> Either MathError a + +-- | Ring with conjugation,used by Hermitian inner-product algorithms. class (Ring a) => Scalar a where + -- | Return scalar conjugate; real/exact instances use identity and complex instances conjugate imaginary components. conjugateScalar :: a -> a + +{- | Scalar domain exposing precision epsilon and finite-value classification,including +complex component checks. +-} class (Scalar a) => FloatingPoint a where + -- | Given a type proxy, return floating precision epsilon as Double (2^-52 for Double,2^-23 for Float). machineEpsilon :: proxy a -> Double + + -- | Test whether all real/complex components are finite for this instance. finiteScalar :: a -> Bool {- | A numeric domain's conversion from a rational may fail, for example when an exact ring cannot represent a non-integral value. -} class (Ring a) => Numeric a where + -- | Convert exact Rational into the domain, returning Left MathError if it cannot be represented under the instance contract. rational :: Rational -> Either MathError a instance Ring Integer where @@ -146,7 +172,11 @@ instance Numeric (Complex Double) where {- | An example user-definable domain, exact rationals with the explicit algebra contracts. It deliberately does not need a Num or RealFloat instance. -} -newtype Exact = Exact {getExact :: Rational} deriving (Eq, Ord, Show) +newtype Exact = Exact + { getExact :: Rational + -- ^ Extract the exact Rational stored in the example Exact algebra domain. + } + deriving (Eq, Ord, Show) instance Ring Exact where zero = Exact 0 @@ -163,35 +193,65 @@ instance Numeric Exact where rational = Right . Exact horner :: (Ring a) => [a] -> a -> a horner coefficients x = foldl (\value coefficient -> plus (times value x) coefficient) zero coefficients +{- | Return sum(conjugate a[i] * b[i]) using the Scalar and Ring operations. Equal list +lengths are required; mismatch returns VectorLengthMismatch. Empty lists give the ring +zero; instance arithmetic controls precision/overflow. +-} innerProduct :: (Scalar a) => [a] -> [a] -> Either MathError a innerProduct a b | length a /= length b = Left (VectorLengthMismatch (length a) (length b)) | otherwise = Right (foldl plus zero (zipWith (\x y -> times (conjugateScalar x) y) a b)) + +-- | Container interface for matrix dimensions,row-major elements,and checked construction. class MatrixLike m where + -- | Return logical (rows,columns) of a matrix-like container. matrixDimensions :: m a -> (Int, Int) + + -- | Return matrix elements in logical row-major order. matrixElements :: m a -> [a] + + -- | Given rows,columns,flat row-major elements, construct a matrix-like value or return checked shape/count failure. matrixConstruct :: Int -> Int -> [a] -> Either MathError (m a) + instance MatrixLike M.Matrix where matrixDimensions = M.shape matrixElements = M.toList matrixConstruct = M.fromListChecked + +{- | Container interface for tensor dimensions,row-major logical elements,and checked +construction. +-} class TensorLike t where + -- | Return tensor-like dimensions in axis order; [] denotes scalar. tensorDimensions :: t a -> [Int] + + -- | Return tensor-like elements in logical row-major coordinate order. tensorElements :: t a -> [a] + + -- | Given dimensions then flat values, construct a tensor-like value or return shape/count failure. tensorConstruct :: [Int] -> [a] -> Either MathError (t a) + instance TensorLike T.Tensor where tensorDimensions = T.tensorShape tensorElements = T.tensorValues tensorConstruct = T.tensor + +-- | Container interface for checked shape-compatible addition and scalar multiplication. class VectorSpace v where + -- | Add identically shaped vector-space values, returning checked dimension errors on mismatch. vectorPlus :: (Num a) => v a -> v a -> Either MathError (v a) + + -- | Given scalar then vector-space value, return its coordinatewise scalar multiple. vectorScale :: (Num a) => a -> v a -> v a + instance VectorSpace V.Vector where vectorPlus = V.vectorAdd; vectorScale = V.vectorScale instance VectorSpace M.Matrix where vectorPlus = M.addMatrixChecked; vectorScale = M.scaleMatrix -- | Differential extraction reuses the existing nested forward-mode Dual type. class Differentiable a where type Differential a + + -- | Extract associated differential; the Dual instance returns its tangent component. differential :: a -> Differential a instance Differentiable (AD.Dual a) where diff --git a/src/HMath/API/Buffer.hs b/src/HMath/API/Buffer.hs index dbced22..e06d732 100644 --- a/src/HMath/API/Buffer.hs +++ b/src/HMath/API/Buffer.hs @@ -53,48 +53,109 @@ import Foreign.Ptr (Ptr) import Foreign.Storable (Storable, peekElemOff, pokeElemOff, sizeOf) import HMath.Error +{- | Immutable boxed array preserving element laziness unless built with strictBoxed; +conversions preserve logical order. +-} newtype Boxed a = Boxed (Array Int a) deriving (Eq, Show, Functor, Foldable, Traversable) -- | Finite lists only. The list spine is consumed; elements remain lazy. lazyBoxed :: [a] -> Boxed a lazyBoxed xs = Boxed (listArray (0, length xs - 1) xs) +{- | Construct a boxed container from a finite list, forcing every element to weak head +normal form (not deep normal form). Preserve order; element evaluation exceptions +propagate. +-} strictBoxed :: [a] -> Boxed a strictBoxed xs = foldr seq () xs `seq` lazyBoxed xs + +{- | Return boxed elements in zero-based array order as a list. Elements retain the +laziness/strictness chosen at construction. +-} boxedValues :: Boxed a -> [a] boxedValues (Boxed a) = elems a + +-- | Return the number of elements in a boxed container; empty storage has length zero. boxedLength :: Boxed a -> Int boxedLength = length . boxedValues + +{- | Given element transformation then boxed input, return a boxed result with every mapped +element forced to WHNF. Preserve length/order; evaluation exceptions propagate. +-} mapStrict :: (a -> b) -> Boxed a -> Boxed b mapStrict f = strictBoxed . map f . boxedValues + +-- | Immutable unboxed Double storage. Construct with unboxedDouble; boxed conversions copy. newtype UnboxedDouble = UnboxedDouble (U.UArray Int Double) deriving (Eq, Show) + +{- | Copy a finite Double list into an immutable unboxed array in list order. Values are +evaluated by unboxing; no finiteness validation is added. +-} unboxedDouble :: [Double] -> UnboxedDouble unboxedDouble xs = UnboxedDouble (U.listArray (0, length xs - 1) xs) + +-- | Copy/expand unboxed Doubles into a list in array order, preserving length. unboxedValues :: UnboxedDouble -> [Double] unboxedValues (UnboxedDouble a) = U.elems a + +{- | Convert unboxed Double storage to a new strict boxed container, preserving order and +values. +-} unboxedToBoxed :: UnboxedDouble -> Boxed Double unboxedToBoxed = strictBoxed . unboxedValues + +{- | Convert boxed Double values to a new unboxed array, forcing values during copying. +Preserve order and length. +-} boxedToUnboxed :: Boxed Double -> UnboxedDouble boxedToUnboxed = unboxedDouble . boxedValues + +{- | Mutable boxed storage confined by the ST state parameter. Freeze/thaw copy; use +runSTBuffer to prevent region escape. +-} data STBuffer s a = STBuffer !Int !(STArray s Int a) -- | The rank-2 state parameter prevents a mutable region from escaping. runSTBuffer :: Boxed a -> (forall s. STBuffer s a -> ST s b) -> b runSTBuffer boxed action = runST (thawSTBuffer boxed >>= action) +{- | Copy immutable boxed values into new mutable storage in the current ST region. The +input remains unchanged; storage cannot escape the region. +-} thawSTBuffer :: Boxed a -> ST s (STBuffer s a) thawSTBuffer boxed = let xs = boxedValues boxed; n = length xs in STBuffer n <$> newListArray (0, n - 1) xs + +{- | Copy current mutable ST values into an immutable boxed container; later writes do not +modify the frozen result. +-} freezeSTBuffer :: STBuffer s a -> ST s (Boxed a) freezeSTBuffer (STBuffer _ array) = lazyBoxed <$> getElems array + indexCheck :: Int -> Int -> Either MathError () indexCheck n i | i < 0 || i >= n = Left (InvalidArgument "buffer index out of bounds") | otherwise = Right () + +{- | Given ST buffer then zero-based index, read the element. Negative/out-of-range indices +return Left InvalidArgument within ST, rather than indexing the array. +-} readSTBuffer :: STBuffer s a -> Int -> ST s (Either MathError a) readSTBuffer (STBuffer n array) i = case indexCheck n i of Left e -> pure (Left e); Right () -> Right <$> readArray array i + +{- | Given ST buffer, zero-based index, then value, update one element and return Right (). +Invalid index returns Left InvalidArgument without writing. +-} writeSTBuffer :: STBuffer s a -> Int -> a -> ST s (Either MathError ()) writeSTBuffer (STBuffer n array) i x = case indexCheck n i of Left e -> pure (Left e); Right () -> Right <$> writeArray array i x + +{- | Pinned garbage-collected Storable buffer with synchronized IO access. Pointer callbacks +borrow storage only for their dynamic lifetime. +-} data IOBuffer a = IOBuffer !Int !(ForeignPtr a) !(MVar ()) + +{- | Return the immutable element count of a pinned IO buffer. This query neither borrows +its pointer nor takes ownership. +-} ioBufferLength :: IOBuffer a -> Int ioBufferLength (IOBuffer n _ _) = n @@ -111,6 +172,9 @@ newIOBuffer n x lock <- newMVar () pure (Right (IOBuffer n fp lock)) +{- | Copy boxed Storable values into new pinned IO storage. Return Left InvalidArgument for +byte-size overflow; allocation/OS/evaluation failures remain IO exceptions. +-} thawIOBuffer :: forall a. (Storable a) => Boxed a -> IO (Either MathError (IOBuffer a)) thawIOBuffer boxed | toInteger (max 1 n) * toInteger (sizeOf (undefined :: a)) > toInteger (maxBound :: Int) = @@ -122,14 +186,31 @@ thawIOBuffer boxed pure (Right (IOBuffer n fp lock)) where xs = boxedValues boxed; n = length xs + +{- | Given IO buffer then callback, hold its lock and lend a Ptr plus element count for the +callback duration. Do not retain the pointer or reenter locking operations on this same +buffer. Callback exceptions propagate while releasing the lock. +-} withIOBuffer :: (Storable a) => IOBuffer a -> (Ptr a -> Int -> IO b) -> IO b withIOBuffer (IOBuffer n fp lock) action = withMVar lock (\() -> withForeignPtr fp (\p -> action p n)) + +{- | Lock and copy pinned IO values to a strict immutable boxed container. The result is +independent of later buffer writes; allocation/IO exceptions propagate. +-} freezeIOBuffer :: (Storable a) => IOBuffer a -> IO (Boxed a) freezeIOBuffer buffer = withIOBuffer buffer (\p n -> strictBoxed <$> peekArray n p) + +{- | Given IO buffer then zero-based index, read under the buffer lock. Invalid index +returns Left InvalidArgument; IO exceptions propagate. +-} readIOBuffer :: (Storable a) => IOBuffer a -> Int -> IO (Either MathError a) readIOBuffer buffer i = case indexCheck (ioBufferLength buffer) i of Left e -> pure (Left e) Right () -> withIOBuffer buffer (\p _ -> Right <$> peekElemOff p i) + +{- | Given IO buffer, zero-based index, then value, write under its lock and return Right +(). Invalid index returns Left InvalidArgument without modification. +-} writeIOBuffer :: (Storable a) => IOBuffer a -> Int -> a -> IO (Either MathError ()) writeIOBuffer buffer i x = case indexCheck (ioBufferLength buffer) i of Left e -> pure (Left e) diff --git a/src/HMath/API/Convergence.hs b/src/HMath/API/Convergence.hs index ea1adb2..ab606df 100644 --- a/src/HMath/API/Convergence.hs +++ b/src/HMath/API/Convergence.hs @@ -29,12 +29,38 @@ not reinterpret a small update as proof of a small residual. -} data StopReason = ResidualSatisfied | IterationLimit | Stagnation deriving (Eq, Show) +{- | Iteration report retaining the estimate and residual even on a budget/stagnation stop. +Inspect stopReason before assuming convergence. +-} data Convergence a = Convergence - {estimate :: a, iterationCount :: !Int, finalResidual :: !Double, stopReason :: !StopReason} + { estimate :: a + -- ^ Best current estimate, retained even when the iteration budget is exhausted. + , iterationCount :: !Int + -- ^ Number of completed updates; the initial estimate is iteration zero. + , finalResidual :: !Double + -- ^ Finite nonnegative absolute residual at the returned estimate. + , stopReason :: !StopReason + -- ^ ResidualSatisfied,IterationLimit,or Stagnation; successful execution does not itself imply convergence. + } deriving (Eq, Show, Functor, Foldable, Traversable) + +{- | Caller-controlled iteration count and absolute/relative stopping tolerances, validated +by iterateUntil. +-} data IterationOptions = IterationOptions - {maximumIterations :: !Int, absoluteTolerance :: !Double, relativeTolerance :: !Double} + { maximumIterations :: !Int + -- ^ Nonnegative maximum number of updates permitted by iterateUntil. + , absoluteTolerance :: !Double + -- ^ Finite nonnegative absolute stopping threshold. + , relativeTolerance :: !Double + -- ^ Finite nonnegative tolerance scaled by the initial residual. + } deriving (Eq, Show) + +{- | Default iteration budget 1000, absolute tolerance 1e-12, relative tolerance 1e-10. Use +record updates to configure a solver; iterateUntil validates nonnegative finite +tolerances. +-} defaultIterationOptions :: IterationOptions defaultIterationOptions = IterationOptions 1000 1e-12 1e-10 @@ -80,6 +106,10 @@ iterateUntil options step residual stagnant initial = do then Right (Convergence y (n + 1) ry Stagnation) else loop initialResidual (n + 1) y ry +{- | Given operation name then convergence report, return its estimate only for +ResidualSatisfied. IterationLimit or Stagnation becomes Left (NonConvergence name +iterationCount), preserving the distinction between execution and convergence. +-} requireConvergence :: String -> Convergence a -> Either MathError a requireConvergence name r | stopReason r == ResidualSatisfied = Right (estimate r) @@ -89,5 +119,8 @@ requireConvergence name r resultMaybe :: Either e a -> Maybe a resultMaybe = either (const Nothing) Just +{- | Given error value then Maybe result, convert Nothing to Left error and Just x to Right +x. Example: fromMaybeError "missing" (Just 3) == Right 3. +-} fromMaybeError :: e -> Maybe a -> Either e a fromMaybeError e = maybe (Left e) Right diff --git a/src/HMath/API/Shape.hs b/src/HMath/API/Shape.hs index c62207a..67a09f8 100644 --- a/src/HMath/API/Shape.hs +++ b/src/HMath/API/Shape.hs @@ -49,10 +49,22 @@ import qualified HMath.Vector as V -- | Scalars have shape [] and one element. Zero axes are allowed. data Shape = Shape ![Int] !Int deriving (Eq, Ord, Show) +{- | Return runtime dimensions in axis order. Scalars have []; zero-length axes are +retained. +-} shapeDimensions :: Shape -> [Int] shapeDimensions (Shape ds _) = ds + +{- | Return the validated shape product, including one for scalar [] and zero when an axis +is zero. +-} shapeElements :: Shape -> Int shapeElements (Shape _ n) = n + +{- | Validate nonnegative dimensions and an Int-representable element product, returning an +immutable shape witness. Invalid dimensions/overflow return Left MathError. Example: +shapeElements \<$> makeShape [2,3] == Right 6. +-} makeShape :: [Int] -> Either MathError Shape makeShape ds = Shape ds <$> T.shapeSize ds @@ -64,21 +76,44 @@ pattern VectorShape :: Int -> Shape pattern VectorShape n <- (shapeDimensions -> [n]) pattern MatrixShape :: Int -> Int -> Shape pattern MatrixShape m n <- (shapeDimensions -> [m, n]) + +{- | Nominal type-indexed matrix dimensions,validated by staticMatrix. Compatible +multiplication is expressed by shared type indices. +-} newtype StaticMatrix (m :: Nat) (n :: Nat) a = StaticMatrix (M.Matrix a) deriving (Eq, Show) + type role StaticMatrix nominal nominal representational + +{- | Given a dynamic matrix, compare its dimensions against type-level m and n, returning a +nominally indexed witness. Reject type-level Int overflow or runtime mismatch. +-} staticMatrix :: forall m n a. (KnownNat m, KnownNat n) => M.Matrix a -> Either MathError (StaticMatrix m n a) staticMatrix a = do r <- natInt (Proxy :: Proxy m) c <- natInt (Proxy :: Proxy n) if M.shape a == (r, c) then Right (StaticMatrix a) else Left (ShapeMismatch (r, c) (M.shape a)) + +{- | Forget the nominal type-level dimensions of a StaticMatrix, returning the same +immutable dynamic matrix without changing its values. +-} dynamicMatrix :: StaticMatrix m n a -> M.Matrix a dynamicMatrix (StaticMatrix a) = a + +{- | Multiply statically compatible m-by-k and k-by-n matrices. Return an m-by-n witness; +checked dynamic size errors can still return Left MathError. Num arithmetic follows the +element instance. +-} staticMultiply :: (Num a) => StaticMatrix m k a -> StaticMatrix k n a -> Either MathError (StaticMatrix m n a) staticMultiply (StaticMatrix a) (StaticMatrix b) = StaticMatrix <$> M.multiplyChecked a b + +{- | Transpose a StaticMatrix m n to StaticMatrix n m, preserving values with axes +exchanged. +-} staticTranspose :: StaticMatrix m n a -> StaticMatrix n m a staticTranspose (StaticMatrix a) = StaticMatrix (M.transposeMatrix a) + instance Functor (StaticMatrix m n) where fmap f (StaticMatrix a) = StaticMatrix (either (error . show) id (uncurry M.fromListChecked (M.shape a) (map f (M.toList a)))) @@ -89,17 +124,34 @@ instance Traversable (StaticMatrix m n) where <$> traverse f (M.toList a) -- | Type-level list of natural dimensions, reflected without Int truncation. -class KnownShape (ds :: [Nat]) where reflectedShape :: proxy ds -> [Integer] +class KnownShape (ds :: [Nat]) where + {- | Given a type-level shape proxy, reflect exact Integer dimensions + without truncation to Int. + -} + reflectedShape :: proxy ds -> [Integer] instance KnownShape '[] where reflectedShape _ = [] instance (KnownNat n, KnownShape ns) => KnownShape (n ': ns) where reflectedShape _ = toInteger (natVal (Proxy :: Proxy n)) : reflectedShape (Proxy :: Proxy ns) + +{- | Nominal type-indexed tensor shape,validated against reflected runtime dimensions by +staticTensor. +-} newtype StaticTensor (ds :: [Nat]) a = StaticTensor (T.Tensor a) deriving (Eq, Show) + type role StaticTensor nominal representational + +{- | Given dynamic tensor and type-level shape ds, return a nominal witness only if runtime +dimensions match reflectedShape exactly. A mismatch returns Left InvalidArgument. +-} staticTensor :: forall ds a. (KnownShape ds) => T.Tensor a -> Either MathError (StaticTensor ds a) staticTensor t | map toInteger (T.tensorShape t) == reflectedShape (Proxy :: Proxy ds) = Right (StaticTensor t) | otherwise = Left (InvalidArgument "staticTensor: type-level shape differs from runtime shape") + +{- | Forget a StaticTensor shape witness, returning its underlying immutable dynamic tensor +without numerical conversion. +-} dynamicTensor :: StaticTensor ds a -> T.Tensor a dynamicTensor (StaticTensor t) = t @@ -111,17 +163,31 @@ newtype Coordinates (n :: Nat) a = Coordinates [a] deriving (Eq, Show, Functor, Foldable, Traversable) type role Coordinates nominal representational + +{- | Construct a type-indexed coordinate list only when list length equals the KnownNat +index. A mismatch returns Left InvalidArgument; values remain lazy. +-} coordinates :: forall n a. (KnownNat n) => [a] -> Either MathError (Coordinates n a) coordinates xs | toInteger (length xs) == toInteger (natVal (Proxy :: Proxy n)) = Right (Coordinates xs) | otherwise = Left (InvalidArgument "coordinates: type-level length mismatch") + +{- | Extract the ordered list of a Coordinates n value. The nominal length invariant is +preserved by its public constructors. +-} coordinateValues :: Coordinates n a -> [a] coordinateValues (Coordinates xs) = xs + instance (KnownNat n) => Applicative (Coordinates n) where pure x = Coordinates [x | _ <- [1 .. toInteger (natVal (Proxy :: Proxy n))]] Coordinates fs <*> Coordinates xs = Coordinates (zipWith ($) fs xs) + +{- | Convert Coordinates n to a dynamic Vector. Reject a type-level length exceeding Int +before traversing the coordinate list; otherwise preserve all values. +-} coordinatesToVector :: forall n a. (KnownNat n) => Coordinates n a -> Either MathError (V.Vector a) coordinatesToVector xs = natInt (Proxy :: Proxy n) >> Right (V.vector (coordinateValues xs)) + natInt :: (KnownNat n) => Proxy n -> Either MathError Int natInt p | value > toInteger (maxBound :: Int) = Left (InvalidArgument "static dimension exceeds Int") diff --git a/src/HMath/Algorithms.hs b/src/HMath/Algorithms.hs index 21ff548..26c4ff8 100644 --- a/src/HMath/Algorithms.hs +++ b/src/HMath/Algorithms.hs @@ -65,11 +65,29 @@ bound cmp x xs = go 0 (length xs) where mid = lo + (hi - lo) `div` 2 lowerBound, upperBound :: (Ord a) => a -> [a] -> Either MathError Int + +{- | Given a target and ascending list, return the first zero-based insertion index whose +value is >= target, or length at the end. Reject unsorted input. Validation is O(n). +Example: lowerBound 2 [1,2,2,4] == Right 1. +-} lowerBound x xs = ordered xs >> pure (bound (<) x xs) + +{- | Given a target and ascending list, return the first insertion index whose value is > +target. Reject unsorted input. Example: upperBound 2 [1,2,2,4] == Right 3. +-} upperBound x xs = ordered xs >> pure (bound (<=) x xs) + +{- | Given target and ascending list, return Just the first matching zero-based index or +Nothing if absent. Reject unsorted input. Example: binarySearch 2 [1,2,2] == Right +(Just 1). +-} binarySearch :: (Ord a) => a -> [a] -> Either MathError (Maybe Int) binarySearch x xs = do i <- lowerBound x xs; pure (if i < length xs && xs !! i == x then Just i else Nothing) +{- | Search ascending Integer values using value-based interpolation, returning the first +matching index or Nothing. Reject unsorted input. Example: interpolationSearch 20 +[10,20,30] == Right (Just 1). +-} interpolationSearch :: Integer -> [Integer] -> Either MathError (Maybe Int) interpolationSearch x xs = do ordered xs; pure (go 0 (length xs - 1)) where @@ -82,6 +100,11 @@ interpolationSearch x xs = do ordered xs; pure (go 0 (length xs - 1)) | otherwise = go lo (p - 1) where p = lo + fromInteger ((x - a ! lo) * toInteger (hi - lo) `div` (a ! hi - a ! lo)) + +{- | Given a target and ascending finite list, grow a search range then find a matching +index or Nothing. Reject unsorted input. The implementation returns a matching index +without a general first-duplicate guarantee. +-} exponentialSearch :: (Ord a) => a -> [a] -> Either MathError (Maybe Int) exponentialSearch x xs = do ordered xs @@ -120,14 +143,28 @@ select depth k xs where p = xs !! (length xs `div` 2); lo = filter (< p) xs; eq = filter (== p) xs; hi = filter (> p) xs quickselect, introselect :: (Ord a) => Int -> [a] -> Either MathError a + +{- | Given a zero-based order-statistic index and list, return the element at that position +in ascending order without returning a sorted list. Reject negative/out-of-range +indices. Example: quickselect 1 [9,1,5] == Right 5. +-} quickselect k xs | k < 0 || k >= length xs = Left (InvalidArgument "selection index out of bounds") | otherwise = Right (select (length xs) k xs) + +{- | Like quickselect, but bound pivot depth and fall back to heap sorting. Index must lie +in [0,length). Example: introselect 0 [3,2,1] == Right 1. +-} introselect k xs | k < 0 || k >= length xs = Left (InvalidArgument "selection index out of bounds") | otherwise = Right (select (2 * log2 (length xs)) k xs) + log2 :: Int -> Int log2 n | n <= 1 = 0 | otherwise = 1 + log2 (n `div` 2) + +{- | Given k in [0,length] and a list, return the k smallest values in ascending order, +retaining duplicates. Invalid k fails. Example: partialSort 2 [5,1,3] == Right [1,3]. +-} partialSort :: (Ord a) => Int -> [a] -> Either MathError [a] partialSort k xs | k < 0 || k > length xs = Left (InvalidArgument "partial-sort size out of bounds") @@ -136,6 +173,10 @@ partialSort k xs p <- introselect (k - 1) xs let lo = filter (< p) xs pure (mergeSort lo ++ take (k - length lo) (filter (== p) xs)) + +{- | Stable ascending merge sort under a lawful total Ord; accepts empty lists. Return a new +sorted list. Example: mergeSort [3,1,2] == [1,2,3]. +-} mergeSort :: (Ord a) => [a] -> [a] mergeSort [] = [] mergeSort [x] = [x] @@ -145,6 +186,10 @@ mergeSort xs = merge (mergeSort a) (mergeSort b) merge [] ys = ys merge ys [] = ys merge aa@(u : us) bb@(v : vs) | u <= v = u : merge us bb | otherwise = v : merge aa vs + +{- | Ascending reference quicksort preserving equal values, using the head as pivot. +Worst-case quadratic work; accepts empty lists. Example: quicksort [2,1,2] == [1,2,2]. +-} quicksort :: (Ord a) => [a] -> [a] quicksort [] = [] quicksort (p : xs) = quicksort (filter (< p) xs) ++ (p : filter (== p) xs) ++ quicksort (filter (> p) xs) @@ -169,6 +214,10 @@ heapsort xs = elems (extract (n - 1) built) built = Foldable.foldl' (\ar i -> sift ar n i) a [n `div` 2 - 1, n `div` 2 - 2 .. 0] extract i ar | i <= 0 = ar | otherwise = extract (i - 1) (sift (swap ar 0 i) i 0) +{- | Ascending comparison sort with bounded quickselect-style partition depth and heap-sort +fallback. Return a new sorted list; requires a lawful total Ord. Example: introsort +[3,1,2] == [1,2,3]. +-} introsort :: (Ord a) => [a] -> [a] introsort xs = go (2 * log2 (length xs)) xs where @@ -177,6 +226,11 @@ introsort xs = go (2 * log2 (length xs)) xs go d ys = let p = ys !! (length ys `div` 2) in go (d - 1) (filter (< p) ys) ++ filter (== p) ys ++ go (d - 1) (filter (> p) ys) + +{- | Given a nonnegative value-range budget then an Int list, return ascending counting +sort. Reject a negative budget or a range max-min+1 exceeding it (NonConvergence); +empty input succeeds. Example: countingSort 5 [3,1,3] == Right [1,3,3]. +-} countingSort :: Int -> [Int] -> Either MathError [Int] countingSort budget xs | budget < 0 = Left (InvalidArgument "negative counting-sort range budget") @@ -186,6 +240,10 @@ countingSort budget xs | otherwise = Right (concat [replicate (M.findWithDefault 0 x counts) x | x <- [lo .. hi]]) where lo = minimum xs; hi = maximum xs; counts = M.fromListWith (+) [(x, 1) | x <- xs] + +{- | Sort unbounded Integers in ascending order by radix digits, separating negative and +nonnegative magnitudes. Accepts empty input. Example: radixSort [2,-3,0] == [-3,0,2]. +-} radixSort :: [Integer] -> [Integer] radixSort [] = [] radixSort xs = map (+ lo) (go 1 shifted) @@ -196,6 +254,11 @@ radixSort xs = map (+ lo) (go 1 shifted) go p ys | p > hi = ys | otherwise = go (p * 256) (concat [[x | x <- ys, (x `div` p) `mod` 256 == d] | d <- [0 .. 255]]) + +{- | Given bucket count in [1,65536] and finite Doubles in [0,1], sort ascending using +buckets and merge sort. Invalid count/data fail. Example: bucketSort 4 [1,0.5,0] == +Right [0,0.5,1]. +-} bucketSort :: Int -> [Double] -> Either MathError [Double] bucketSort buckets xs | buckets <= 0 || buckets > 65536 = Left (InvalidArgument "bucket count must be in [1,65536]") @@ -204,10 +267,23 @@ bucketSort buckets xs | otherwise = Right (concat [mergeSort [x | x <- xs, index x == i] | i <- [0 .. buckets - 1]]) where index x = min (buckets - 1) (floor (x * fromIntegral buckets)) + +{- | Return original zero-based indices in stable ascending value order. Example: argsort +[3,1,1] == [1,2,0]. No values are discarded. +-} argsort :: (Ord a) => [a] -> [Int] argsort = map snd . mergeSort . flip zip [0 ..] + +{- | Alias of partialSort: return the k smallest values in ascending order, not the k +largest. k outside [0,length] fails. Example: topK 2 [5,1,3] == Right [1,3]. +-} topK :: (Ord a) => Int -> [a] -> Either MathError [a] topK = partialSort + +{- | Given finite q in [0,1] and a nonempty finite Double list, linearly interpolate the +ascending order statistics at q*(n-1). Invalid data fail. Example: quantileSelect 0.5 +[1,3] == Right 2. +-} quantileSelect :: Double -> [Double] -> Either MathError Double quantileSelect q xs | null xs || q < 0 || q > 1 || any (\x -> isNaN x || isInfinite x) (q : xs) = @@ -215,23 +291,61 @@ quantileSelect q xs | otherwise = do a <- introselect lo xs; b <- introselect hi xs; pure ((1 - t) * a + t * b) where p = q * fromIntegral (length xs - 1); lo = floor p; hi = ceiling p; t = p - fromIntegral lo + +{- | Sort ascending and keep one representative of each equal value. Input order is not +preserved. Example: deduplicate [3,1,3] == [1,3]. +-} deduplicate :: (Ord a) => [a] -> [a] deduplicate xs = [x | x : _ <- group (mergeSort xs)] + +{- | Sort ascending and return each distinct value paired with its frequency. Example: +numericGroups [2,1,2] == [(1,1),(2,2)]. +-} numericGroups :: (Ord a) => [a] -> [(a, Int)] numericGroups xs = [(x, length g) | g@(x : _) <- group (mergeSort xs)] + +{- | Encode adjacent equal runs as (value,count), preserving run order without sorting. +Example: runLengthEncode [1,1,2,1] == [(1,2),(2,1),(1,1)]. +-} runLengthEncode :: (Eq a) => [a] -> [(a, Int)] runLengthEncode xs = [(x, length g) | g@(x : _) <- group xs] + +{- | Given maximum output length then (value,count) runs, expand runs. Negative budget/count +fails; output beyond the budget returns NonConvergence before allocation. Zero-length +runs are allowed. +-} runLengthDecode :: Int -> [(a, Int)] -> Either MathError [a] runLengthDecode b runs | b < 0 || any ((< 0) . snd) runs = Left (InvalidArgument "negative RLE size") | sum (map (toInteger . snd) runs) > toInteger b = Left (NonConvergence "RLE output" b) | otherwise = Right (concatMap (uncurry (flip replicate)) runs) + prefixSums, suffixSums, differenceArray, applyDifferences :: (Num a) => [a] -> [a] + +{- | Return cumulative sums including a leading zero; output length is n+1. Arithmetic +follows Num. Example: prefixSums [1,2] == [0,1,3]. +-} prefixSums = scanl (+) 0 + +{- | Return suffix sums including a final zero; output length is n+1. Example: suffixSums +[1,2] == [3,2,0]. +-} suffixSums = scanr (+) 0 + +{- | Return first differences relative to a leading zero, preserving length. Empty input +gives empty output. Example: differenceArray [2,5,9] == [2,3,4]. +-} differenceArray [] = [] differenceArray xs = zipWith (-) xs (0 : xs) + +{- | Reconstruct values from first differences by inclusive cumulative sum. Example: +applyDifferences [2,3,4] == [2,5,9]. +-} applyDifferences = drop 1 . prefixSums + +{- | Return sorted unique keys and zero-based ranks for the original input order. Example: +coordinateCompression [8,2,8] == ([2,8],[1,0,1]). +-} coordinateCompression :: (Ord a) => [a] -> ([a], [Int]) coordinateCompression xs = (keys, map (\x -> table M.! x) xs) where @@ -318,6 +432,10 @@ binaryLift next steps start where go _ 0 x = x; go table k x = go (map (table !!) table) (k `div` 2) (if odd k then table !! x else x) +{- | Given square Integer rows and a nonnegative exponent, return exact matrix +exponentiation by squaring; exponent zero returns identity. Reject ragged/non-square +matrices, order >128, or negative exponent. +-} integerMatrixPower :: [[Integer]] -> Integer -> Either MathError [[Integer]] integerMatrixPower a powerIndex | powerIndex < 0 || length a > 128 || any ((/= n) . length) a = @@ -329,6 +447,10 @@ integerMatrixPower a powerIndex mul x y = [[sum [x !! i !! k * y !! k !! j | k <- [0 .. n - 1]] | j <- [0 .. n - 1]] | i <- [0 .. n - 1]] go _ 0 r = r go x k r = go (mul x x) (k `div` 2) (if odd k then mul r x else r) + +{- | Given base, modulus >1, then Integer sequence, fold h=(h*base+x) mod modulus from zero. +Invalid modulus fails. This is noncryptographic and collisions are possible. +-} polynomialHash :: Integer -> Integer -> [Integer] -> Either MathError Integer polynomialHash base modulus xs | modulus <= 1 = Left (InvalidArgument "hash modulus must exceed one") diff --git a/src/HMath/Autodiff.hs b/src/HMath/Autodiff.hs index 11a48be..959f8fd 100644 --- a/src/HMath/Autodiff.hs +++ b/src/HMath/Autodiff.hs @@ -68,8 +68,17 @@ import qualified HMath.Tensor as T data Dual a = Dual a a deriving (Eq, Show) primal, tangent :: Dual a -> a + +{- | Extract the primal value from Dual value tangent without evaluating a derivative. +Example: primal (Dual 3 1) == 3. +-} primal (Dual a _) = a + +{- | Extract the directional derivative seed/result from a Dual value. Example: tangent +(Dual 3 1) == 1. +-} tangent (Dual _ a) = a + instance (Ord a) => Ord (Dual a) where compare (Dual x _) (Dual y _) = compare x y instance (Num a) => Num (Dual a) where Dual x dx + Dual y dy = Dual (x + y) (dx + dy) @@ -138,6 +147,10 @@ data Unary | Abs | Sign deriving (Eq, Show) + +{- | Opaque reverse-mode differentiable scalar expression,composed from explicit inputs and +operations. Compile/evaluate through the checked autodiff graph API. +-} data Expr = C Double | V Int @@ -149,6 +162,7 @@ data Expr | Stop Expr | Custom ([Double] -> Either MathError (Double, [Double])) [Expr] | Checkpoint ([Expr] -> Expr) [Expr] + instance Show Expr where show (C x) = show x show (V i) = "x" ++ show i @@ -230,7 +244,12 @@ data Node | StopNode Int | CustomNode ([Double] -> Either MathError (Double, [Double])) [Int] | RecomputeNode ([Expr] -> Expr) [Int] + +{- | Opaque reusable automatic-differentiation computation graph with explicit input/output +structure. +-} data CompiledGraph = CompiledGraph Int Int [(Int, Node)] + data Pullback = Partials [(Int, Double)] | Deferred ([Expr] -> Expr) [Int] [Double] -- | Compile an immutable reusable graph with n inputs and a hard limit of one million scalar nodes. @@ -468,7 +487,14 @@ hvp f xs ds = do finite values Right values -newtype GradientState = GradientState {accumulatedGradient :: [Double]} deriving (Eq, Show) +{- | Explicit gradient accumulation owner; evaluation does not mutate it implicitly. Use the +accumulation API to retain/reset gradients. +-} +newtype GradientState = GradientState + { accumulatedGradient :: [Double] + -- ^ Gradient components currently retained by explicit GradientState accumulation; reverse evaluation alone does not mutate it. + } + deriving (Eq, Show) -- | Create an explicit zero accumulation buffer for a nonnegative input count. zeroGradients :: Int -> Either MathError GradientState diff --git a/src/HMath/Backend.hs b/src/HMath/Backend.hs index 940fe93..c14ce3a 100644 --- a/src/HMath/Backend.hs +++ b/src/HMath/Backend.hs @@ -90,17 +90,33 @@ unsuffixed and 64_ suffixed builds are recognized. data BackendRequest = AutoBackend | RequireBackend Provider IntegerABI (Maybe FilePath) deriving (Eq, Show) -data BackendInfo = BackendInfo {selectedProvider :: Provider, selectedIntegerABI :: IntegerABI} +-- | Actual selected BLAS provider and integer-width ABI, available through backendInfo. +data BackendInfo = BackendInfo + { selectedProvider :: Provider + -- ^ Provider actually selected, including Pure when reference fallback is used. + , selectedIntegerABI :: IntegerABI + -- ^ Selected BLAS integer width: LP64 uses 32-bit indices and ILP64 uses 64-bit indices. + } deriving (Eq, Show) + data NativeBackend + +{- | Opaque selected reference/native backend owner. Retain the value while using its +dynamically loaded provider. +-} data Backend = Backend !BackendInfo !(Maybe (ForeignPtr NativeBackend)) -- | Provider identity is immutable for the lifetime of a handle. backendInfo :: Backend -> BackendInfo backendInfo (Backend info _) = info +{- | Construct the deterministic reference backend without dynamically loading BLAS. Its +lifetime is garbage-collected; selected numeric reference decomposition limits still +apply. +-} pureBackend :: Backend pureBackend = Backend (BackendInfo Pure ILP64) Nothing + foreign import ccall safe "hmath_backend_open" cOpen :: CInt -> CInt -> CString -> Ptr CInt -> IO (Ptr NativeBackend) foreign import ccall unsafe "&hmath_backend_close" cClose :: FinalizerPtr NativeBackend @@ -144,6 +160,11 @@ foreign import ccall safe "hmath_lapack_available" cLapackAvailable :: IO CInt lapackAvailable :: IO Bool lapackAvailable = (/= 0) <$> cLapackAvailable +{- | Given AutoBackend or explicit provider/integer-ABI/library request, select a reference +or native BLAS backend in IO. Auto honors HMATH_BACKEND, HMATH_BLAS_PROVIDER, +HMATH_BLAS_INTEGER_BITS and HMATH_BLAS_LIBRARY; unknown settings or unavailable +explicit providers fail. Keep the Backend alive while calling it. +-} selectBackend :: BackendRequest -> IO (Either MathError Backend) selectBackend AutoBackend = do mode <- lookupEnv "HMATH_BACKEND" @@ -220,7 +241,12 @@ lapackStatus name n | n < 0 = Left (InvalidArgument (name ++ ": argument " ++ show (negate (toInteger n)))) | otherwise = Left (NonConvergence name n) +{- | Physical matrix storage order: RowMajor or ColumnMajor, independent of mathematical +transpose. +-} data BackendLayout = RowMajor | ColumnMajor deriving (Eq, Show) + +-- | BLAS operand transformation: unchanged,transposed,or conjugate-transposed. data Transpose = NoTranspose | Transpose | ConjugateTranspose deriving (Eq, Show) -- | Layout conversion is a checked, explicit copy; zero shapes retain rank. @@ -228,9 +254,13 @@ matrixFromLayout :: BackendLayout -> Int -> Int -> [a] -> Either MathError (M.Ma matrixFromLayout RowMajor m n = M.fromListChecked m n matrixFromLayout ColumnMajor m n = fmap M.transposeMatrix . M.fromListChecked n m +{- | Given RowMajor/ColumnMajor layout then Matrix, return values in that physical order +without changing the logical matrix. +-} matrixToLayout :: BackendLayout -> M.Matrix a -> [a] matrixToLayout RowMajor = M.toList matrixToLayout ColumnMajor = M.toList . M.transposeMatrix + transCode :: Transpose -> CInt transCode NoTranspose = 111 transCode Transpose = 112 @@ -283,6 +313,11 @@ vectorOperation b kind alpha xs ys = case validate of reference 0 = checkedList (zipWith (\x y -> alpha * x + y) xs ys) reference 1 = checkedList [sum (zipWith (*) xs ys)] reference _ = checkedList [I.stableNorm xs] + +{- | Given backend,alpha,x,y, return alpha*x+y as a new Double list. Require equal lengths, +finite inputs/result and provider-supported integer extents; validation/provider +failures return Left MathError in IO. +-} axpy :: Backend -> Double -> [Double] -> [Double] -> IO (Either MathError [Double]) axpy b = vectorOperation b 0 @@ -292,6 +327,10 @@ when exact cancellation would produce a finite mathematical result. dot :: Backend -> [Double] -> [Double] -> IO (Either MathError Double) dot b x y = fmap (fmap (!! 0)) (vectorOperation b 1 0 x y) +{- | Given backend then finite Double vector, return Euclidean norm through the selected +provider or reference path. Empty input gives zero; invalid/non-finite output or +provider bounds fail in IO. +-} nrm2 :: Backend -> [Double] -> IO (Either MathError Double) nrm2 b x = fmap (fmap (!! 0)) (vectorOperation b 2 0 x (replicate (length x) 0)) @@ -343,6 +382,11 @@ gemm = gemmWith 0 id finite aComplex :: Complex Double -> [Double] aComplex z = [realPart z, imagPart z] + +{- | Given backend,transpose A,transpose B,alpha,A,B,beta,C, return alpha*op(A)*op(B)+beta*C +as a new complex matrix. Validate compatible dimensions, finite components and provider +integer/allocation bounds. +-} complexGemm :: Backend -> Transpose -> @@ -354,6 +398,7 @@ complexGemm :: M.Matrix (Complex Double) -> IO (Either MathError (M.Matrix (Complex Double))) complexGemm = gemmWith 1 conjugate finiteC + gemmWith :: forall a. (Num a, Storable a) => @@ -409,6 +454,11 @@ gemmWith complexValues conj check b ta tb alpha a bb beta c = case validate of [length (M.toList a), length (M.toList bb), length (M.toList c)] check (alpha : beta : M.toList a ++ M.toList bb ++ M.toList c) Right (aa, bbb, m, n, k) + +{- | Given backend,complex alpha,x,y, compute alpha*x+y, requiring equal lengths and finite +real/imaginary components. Return a new list or checked shape/provider/numeric error in +IO. +-} complexAxpy :: Backend -> Complex Double -> @@ -430,8 +480,17 @@ complexDot b hermitian x y = case sameLength x y >>= \n -> Left e -> pure (Left e) Right (a, bb, c) -> fmap (fmap ((!! 0) . M.toList)) (complexGemm b NoTranspose NoTranspose 1 a bb 0 c) +{- | Given backend then complex vector, return real Euclidean norm of all real/imaginary +components. Non-finite input/output or provider extent errors return Left MathError in +IO. +-} complexNrm2 :: Backend -> [Complex Double] -> IO (Either MathError Double) complexNrm2 b = nrm2 b . concatMap aComplex + +{- | Given backend,transpose selector,alpha,A,x,beta,y, return alpha*op(A)*x+beta*y as a new +complex list. ConjugateTranspose conjugates matrix values; dimensions, finite values +and provider bounds are checked. +-} complexGemv :: Backend -> Transpose -> @@ -496,13 +555,27 @@ stridedBatchedGemm b batches m n k strideA as strideB bs = case prepare of ) [0 .. batches - 1] +{- | Given backend then real matrix, compute checked column-independent LU using the +reference pivoted LU implementation. The backend argument does not change this +routine's provider. Shape/pivot/numeric failures propagate. +-} backendLU :: Backend -> M.Matrix Double -> Either MathError (LU.LU Double) backendLU _ = LU.luDecompose + +{- | Given backend then real matrix, compute reference column-pivoted Householder QR; +selection does not change this routine's provider. Validation/numeric errors propagate. +-} backendQR :: Backend -> M.Matrix Double -> Either MathError (QR.QR Double) backendQR _ = QR.qrDecompose + +{- | Given backend,square real matrix,then RHS list, solve via reference LU for Pure or the +independent LAPACKE solve bridge for a native backend. Invalid dimensions, unavailable +solver, singularity or non-finite arithmetic returns Left MathError. +-} backendSolve :: Backend -> M.Matrix Double -> [Double] -> Either MathError [Double] backendSolve (Backend _ Nothing) = LU.solve backendSolve _ = nativeSolve + {-# NOINLINE nativeSolve #-} nativeSolve :: M.Matrix Double -> [Double] -> Either MathError [Double] nativeSolve a rhs = do @@ -529,13 +602,32 @@ nativeSolve a rhs = do if code > 0 then Left (SingularMatrix (fromIntegral code - 1)) else lapackStatus "LAPACKE solve" (fromIntegral code) >> checkedList output + +{- | Given backend then finite symmetric positive-definite matrix, return reference lower +Cholesky factor. Invalid shape/symmetry/pivots/numeric results fail; provider selection +is not used by this wrapper. +-} backendCholesky :: Backend -> M.Matrix Double -> Either MathError (M.Matrix Double) backendCholesky _ = D.cholesky + +{- | Given backend,design matrix,then RHS list, solve using reference pivoted QR. Require +compatible overdetermined/full-rank input; shape/rank/numeric failures propagate. +-} backendLeastSquares :: Backend -> M.Matrix Double -> [Double] -> Either MathError [Double] backendLeastSquares _ = QR.leastSquares + +{- | Given backend then finite real matrix, use bounded pure reference SVD for Pure or +LAPACK thin SVD for native selection. Return factors or checked +shape/budget/provider/convergence errors. +-} backendSVD :: Backend -> M.Matrix Double -> Either MathError L.SVD backendSVD (Backend _ Nothing) = pureSVD backendSVD _ = L.svd + +{- | Given backend then finite symmetric square matrix, use bounded cyclic-Jacobi reference +solver for Pure or LAPACK otherwise. Return eigenvalues/vectors or +input/provider/convergence errors. +-} backendSymmetricEigen :: Backend -> M.Matrix Double -> Either MathError L.Eigen backendSymmetricEigen (Backend _ Nothing) = pureSymmetricEigen backendSymmetricEigen _ = L.symmetricEigen diff --git a/src/HMath/Basic.hs b/src/HMath/Basic.hs index 01fcb7a..8768482 100644 --- a/src/HMath/Basic.hs +++ b/src/HMath/Basic.hs @@ -8,11 +8,19 @@ module HMath.Basic ( lerp, ) where +{- | Return n! using unbounded Integer arithmetic; 0! is 1. Negative n raises a pure error. +For a checked Either result use HMath.Scalar.factorialChecked. Example: factorial 5 == +120. +-} factorial :: Integer -> Integer factorial n | n < 0 = error "factorial: negative input" | otherwise = product [1 .. n] +{- | Return the zero-based Fibonacci number (F0=0, F1=1). Negative indices raise a pure +error; use HMath.Scalar.fibonacciChecked for checked input. Example: fibonacci 10 == +55. +-} fibonacci :: Integer -> Integer fibonacci n | n < 0 = error "fibonacci: negative input" @@ -21,6 +29,10 @@ fibonacci n go 0 a _ = a go k a b = go (k - 1) b (a + b) +{- | Test an Integer by trial division through its square root. All n below 2 return False; +2 returns True. Example: isPrime 17 == True. This is a reference primality test for +modest inputs. +-} isPrime :: Integer -> Bool isPrime n | n < 2 = False @@ -33,8 +45,16 @@ isPrime n | n `mod` d == 0 = False | otherwise = check (d + 2) +{- | Given lower bound, upper bound, then value, return max lower (min upper value). Bounds +must be ordered by the caller; reversed bounds are not rejected. Example: clamp 0 1 2 +== 1. Use clampChecked for validation. +-} clamp :: (Ord a) => a -> a -> a -> a clamp low high value = max low (min high value) +{- | Given endpoints a and b then parameter t, return a+(b-a)*t. Values outside [0,1] +extrapolate; arithmetic follows the chosen Fractional type without validation. Example: +lerp 10 20 0.5 == 15. +-} lerp :: (Fractional a) => a -> a -> a -> a lerp a b t = a + (b - a) * t diff --git a/src/HMath/Calculus.hs b/src/HMath/Calculus.hs index 266038b..3030be0 100644 --- a/src/HMath/Calculus.hs +++ b/src/HMath/Calculus.hs @@ -55,11 +55,25 @@ import HMath.Error (MathError (..)) import HMath.Matrix (Matrix, fromListChecked) -- | Estimated value, absolute error estimate and callback evaluation count. -data Estimate a = Estimate {estimateValue :: a, estimateError :: Double, evaluations :: Int} +data Estimate a = Estimate + { estimateValue :: a + -- ^ Returned numerical derivative/integral estimate. + , estimateError :: Double + -- ^ Absolute error estimate from the selected approximation/refinement rule; not a universal rigorous bound. + , evaluations :: Int + -- ^ Number of function evaluations used by the calculation. + } deriving (Eq, Show) -- | Positive absolute tolerance, nonnegative relative tolerance and positive budget. -data Tolerance = Tolerance {absoluteTolerance :: Double, relativeTolerance :: Double, maximumEvaluations :: Int} +data Tolerance = Tolerance + { absoluteTolerance :: Double + -- ^ Requested finite nonnegative absolute error threshold. + , relativeTolerance :: Double + -- ^ Requested finite nonnegative error threshold relative to estimate magnitude. + , maximumEvaluations :: Int + -- ^ Positive caller-supplied function-evaluation budget. + } deriving (Eq, Show) -- | Default adaptive tolerance: 1e-10 absolute, 1e-8 relative, 100000 evaluations. diff --git a/src/HMath/Combinatorics.hs b/src/HMath/Combinatorics.hs index 4376fc3..44930f3 100644 --- a/src/HMath/Combinatorics.hs +++ b/src/HMath/Combinatorics.hs @@ -64,15 +64,25 @@ choose n k where r = min k (n - k) +{- | Given n,k in [0,4096], return n!/(n-k)! exactly, or zero when k>n. Invalid orders fail. +Example: permutationsCount 4 2 == Right 12. +-} permutationsCount :: Int -> Int -> Either MathError Integer permutationsCount n k = do order n order k pure (if k > n then 0 else fact n `div` fact (n - k)) +{- | Given n,k in [0,4096], return the exact binomial coefficient, or zero when k>n. Invalid +orders fail. Example: combinationsCount 4 2 == Right 6. +-} combinationsCount :: Int -> Int -> Either MathError Integer combinationsCount n k = do order n; order k; pure (choose n k) +{- | Given nonnegative group sizes whose sum is \<=4096, return +factorial(total)/product(factorial sizes). Invalid sizes/total fail. Example: +multinomial [2,1] == Right 3. +-} multinomial :: [Int] -> Either MathError Integer multinomial ks = do mapM_ order ks @@ -91,6 +101,10 @@ permutationsOf b k xs = do perm 0 _ = [[]] perm j ys = [v : zs | (i, v) <- zip [0 :: Int ..] ys, zs <- perm (j - 1) (take i ys ++ drop (i + 1) ys)] +{- | Given output budget, selection length k, then list, enumerate position-distinct +k-element combinations in source order. Invalid order or insufficient budget fails +before output construction. +-} combinationsOf :: Int -> Int -> [a] -> Either MathError [[a]] combinationsOf b k xs = do n <- combinationsCount (length xs) k; budget b n; pure (comb k xs) @@ -110,6 +124,9 @@ rankPermutation p = do go [] _ = 0 go (x : xs) ys = toInteger (length (takeWhile (< x) ys)) * fact (length xs) + go xs (delete x ys) +{- | Given size n in [0,4096] then zero-based rank in [0,n!), return the lexicographic +permutation of [0..n-1]. Invalid size/rank fails. +-} unrankPermutation :: Int -> Integer -> Either MathError [Int] unrankPermutation n r = do order n @@ -122,6 +139,9 @@ unrankPermutation n r = do let (i, t) = q `divMod` fact (length xs - 1); v = xs !! fromInteger i in v : go t (delete v xs) +{- | Given universe size n then strictly increasing distinct indices in [0,n), return the +zero-based lexicographic combination rank. Invalid order/indices fail. +-} rankCombination :: Int -> [Int] -> Either MathError Integer rankCombination n xs = do order n @@ -132,6 +152,10 @@ rankCombination n xs = do go _ [] = 0 go lo (x : rest) = sum [choose (n - v - 1) (length rest) | v <- [lo .. x - 1]] + go (x + 1) rest +{- | Given universe size n, selection size k, then zero-based rank, return the increasing +index list. Orders must be in [0,4096] and rank must be below choose(n,k); otherwise +fail. +-} unrankCombination :: Int -> Int -> Integer -> Either MathError [Int] unrankCombination n k r = do order n @@ -149,6 +173,9 @@ unrankCombination n k r = do where count = choose (n - x - 1) (j - 1) +{- | Return exact number of permutations of n elements having no fixed points. Require n in +[0,4096]; invalid orders fail. D0=1, D1=0. Example: derangementCount 3 == Right 2. +-} derangementCount :: Int -> Either MathError Integer derangementCount n = do order n @@ -211,15 +238,27 @@ triangle f n k = do stirlingFirst :: Int -> Int -> Either MathError Integer stirlingFirst = triangle (\n _ a b -> a - toInteger (n - 1) * b) +{- | Given n,k, return the exact number of partitions into k nonempty unlabeled blocks. +Require n\<=512 and nonnegative bounded orders; k>n gives zero. +-} stirlingSecond :: Int -> Int -> Either MathError Integer stirlingSecond = triangle (\_ k a b -> a + toInteger k * b) +{- | Return the exact number of set partitions of n labeled objects, summing second-kind +Stirling numbers. The triangular recurrence requires n in [0,512]. +-} bellNumber :: Int -> Either MathError Integer bellNumber n = sum <$> mapM (stirlingSecond n) [0 .. n] +{- | Given n,k, return the Eulerian recurrence counting permutations by ascents. Require +n\<=512 and bounded nonnegative orders; k>n gives zero. +-} eulerianNumber :: Int -> Int -> Either MathError Integer eulerianNumber = triangle (\n k a b -> toInteger (n - k) * a + toInteger (k + 1) * b) +{- | Given n,k in [0,4096], return unsigned Lah number n!/k!*choose(n-1,k-1), with (0,0)=1 +and impossible positive-size partitions giving zero. Invalid orders fail. +-} lahNumber :: Int -> Int -> Either MathError Integer lahNumber n k = do order n @@ -230,9 +269,15 @@ lahNumber n k = do else if k == 0 || k > n then 0 else choose (n - 1) (k - 1) * fact n `div` fact k ) +{- | Return exact Catalan number choose(2*n,n)/(n+1), requiring n in [0,4096]. Example: +catalanNumber 3 == Right 5. +-} catalanNumber :: Int -> Either MathError Integer catalanNumber n = do order n; pure (choose (2 * n) n `div` toInteger (n + 1)) +{- | Return exact zero-based Fibonacci number by fast doubling for n in [0,4096]. Invalid +index fails. Example: fibonacci 10 == Right 55. +-} fibonacci :: Int -> Either MathError Integer fibonacci n = do order n; pure (fst (pair n)) where @@ -241,9 +286,15 @@ fibonacci n = do order n; pure (fst (pair n)) let (a, b) = pair (k `div` 2); c = a * (2 * b - a); d = a * a + b * b in if even k then (c, d) else (d, c + d) +{- | Return zero-based Lucas number using neighboring Fibonacci numbers. n and n+1 must both +satisfy the [0,4096] bound, so n\<=4095. Invalid index fails. +-} lucas :: Int -> Either MathError Integer lucas n = do a <- fibonacci n; b <- fibonacci (n + 1); pure (2 * b - a) +{- | Return Pascal rows zero through n inclusive, starting [[1]]. n must lie in [0,512]; +invalid orders fail. +-} pascalTriangle :: Int -> Either MathError [[Integer]] pascalTriangle n = do order n @@ -262,19 +313,35 @@ inclusionExclusion n sizes where ones 0 = 0 :: Int; ones k = k `mod` 2 + ones (k `div` 2) +{- | Given maximum output count then list, enumerate its position-based powerset. Reject +input order >4096 or a budget smaller than 2^length. Equal input values can yield +equal-valued subsets. +-} subsets :: Int -> [a] -> Either MathError [[a]] subsets b xs = do order (length xs) budget b (2 ^ length xs) pure (foldr (\x ps -> ps ++ map (x :) ps) [[]] xs) +{- | Given output budget then a list of lists, return all ordered choices using sequence. +Reject negative/insufficient budget before constructing results. Empty outer list +yields one empty choice. +-} cartesianProduct :: Int -> [[a]] -> Either MathError [[a]] cartesianProduct b xs = do budget b (product (map (toInteger . length) xs)); pure (sequence xs) +{- | Return the multinomial count of distinct permutations of a list, grouping equal values +in sorted order. Group sizes and total must satisfy the 4096-element combinatorial +bound. +-} multisetCount :: (Ord a) => [a] -> Either MathError Integer multisetCount xs = multinomial (map length (group (sort xs))) +{- | Given budget then ordered values, enumerate distinct multiset permutations in ascending +lexicographic order. Invalid size or insufficient output budget fails before +enumeration. +-} multisetPermutations :: (Ord a) => Int -> [a] -> Either MathError [[a]] multisetPermutations b xs = do count <- multisetCount xs; budget b count; pure (go (sort xs)) @@ -313,15 +380,25 @@ generatingCoefficients n ps qs = do let v = (get ps i - sum [get qs j * (acc !! (i - j)) | j <- [1 .. min i (length qs - 1)]]) / get qs 0 in go (acc ++ [v]) (i + 1) +{- | Given output length n then two coefficient lists, return the first n exact Integer +convolution coefficients, treating absent coefficients as zero. n must lie in [0,4096]. +-} convolveSeries :: Int -> [Integer] -> [Integer] -> Either MathError [Integer] convolveSeries n a b = do order n pure [sum [a !! j * b !! (i - j) | j <- [0 .. i], j < length a, i - j < length b] | i <- [0 .. n - 1]] +{- | Return successive forward-difference rows beginning with the original list and ending +at the last singleton. Empty input yields no rows. Example: finiteDifferences [1,4,9] +== [[1,4,9],[3,5],[2]]. +-} finiteDifferences :: (Num a) => [a] -> [[a]] finiteDifferences [] = [] finiteDifferences xs = xs : finiteDifferences (zipWith (-) (drop 1 xs) xs) +{- | Sum a finite list using its Num arithmetic. Empty input returns zero. Example: +finiteSum [1,2,3] == 6. +-} finiteSum :: (Num a) => [a] -> a finiteSum = sum diff --git a/src/HMath/Constants.hs b/src/HMath/Constants.hs index edb0d1e..e318199 100644 --- a/src/HMath/Constants.hs +++ b/src/HMath/Constants.hs @@ -50,35 +50,92 @@ piConstant , ln2 , ln10 :: (Floating a) => a + +{- | The circle constant pi at the target Floating precision. Example: piConstant :: Double. +For decimal provenance and an approximation bound, use mathematicalConstants. +-} piConstant = pi + +{- | Euler number exp(1) at the target Floating precision. Use mathematicalConstants for +rational decimal provenance. +-} eConstant = exp 1 + +-- | One full turn in radians, 2*pi, at target Floating precision. tau = 2 * pi + +-- | Golden ratio (1+sqrt 5)/2 at the target Floating precision. goldenRatio = (1 + sqrt 5) / 2 + +{- | Euler-Mascheroni constant from the stored 50-decimal-place literal, rounded to the +chosen Floating type. Provenance is in mathematicalConstants. +-} eulerMascheroni = 0.57721566490153286060651209008240243104215933593992 + +{- | Catalan constant from a 50-decimal-place literal, rounded to the target Floating type; +distinct from the integer Catalan-number sequence. +-} catalanConstant = 0.91596559417721901505460351493238411077414937428167 + +{- | Apery constant zeta(3), from a 50-decimal-place literal rounded to the chosen Floating +type. +-} aperyConstant = 1.20205690315959428539973816151144999076498629234049 + +-- | Positive square root of two in the target Floating type. sqrt2 = sqrt 2 + +-- | Positive square root of three in the target Floating type. sqrt3 = sqrt 3 + +-- | Natural logarithm of two in the target Floating type. ln2 = log 2 + +-- | Natural logarithm of ten in the target Floating type. ln10 = log 10 + infinity, nan :: (RealFloat a) => a + +{- | Positive IEEE infinity (1/0) for a RealFloat type. This value is intentionally +non-finite and is rejected by checked finite-input APIs. +-} infinity = 1 / 0 + +{- | IEEE not-a-number (0/0) for a RealFloat type. NaN is not equal to itself; use isNaN to +inspect it. +-} nan = 0 / 0 +{- | Exact stored decimal Rational with name,unit,provenance,measurement uncertainty,and +separate approximation bound. constantAs converts the value without its metadata. +-} data Constant = Constant { constantName :: String + -- ^ Human-readable name of this mathematical or physical constant. , constantValue :: Rational + -- ^ Exact Rational representation of the stored decimal value; measurement/approximation uncertainties are separate fields. , standardUncertainty :: Rational -- ^ Absolute one-standard-deviation measurement uncertainty; zero for definitions. , approximationBound :: Rational -- ^ Absolute decimal truncation bound, separate from measurement uncertainty. , constantUnit :: String + -- ^ Display unit string; mathematical dimensionless constants use 1. , constantSource :: String + -- ^ Provenance URL and adjustment/definition identifier for the stored value. } deriving (Eq, Show) + +{- | Convert a Constant record's exact stored Rational decimal to the target Fractional +type. The result omits its uncertainty metadata; retain the record when reporting +measurements. +-} constantAs :: (Fractional a) => Constant -> a constantAs = fromRational . constantValue +{- | Catalog of mathematical constants with names, Rational decimal values, source URLs, and +absolute decimal truncation bounds of 10^-50. Measurement uncertainties are zero; +target Float/Double conversion adds rounding error. +-} mathematicalConstants :: [Constant] mathematicalConstants = [ math "pi" 3.14159265358979323846264338327950288419716939937510 "https://dlmf.nist.gov/4.19" @@ -111,13 +168,52 @@ speedOfLight , electronMass , astronomicalUnit :: Constant + +{- | Speed of light in vacuum: stored value 299792458 m s^-1, absolute standard uncertainty +0, from CODATA 2022. Returns a Constant metadata record; use constantAs for a numeric +conversion. +-} speedOfLight = physical "speed of light in vacuum" 299792458 0 "m s^-1" + +{- | Planck constant: stored value 6.62607015e-34 J s, absolute standard uncertainty 0, from +CODATA 2022. Returns a Constant metadata record; use constantAs for a numeric +conversion. +-} planckConstant = physical "Planck constant" 6.62607015e-34 0 "J s" + +{- | Elementary charge: stored value 1.602176634e-19 C, absolute standard uncertainty 0, +from CODATA 2022. Returns a Constant metadata record; use constantAs for a numeric +conversion. +-} elementaryCharge = physical "elementary charge" 1.602176634e-19 0 "C" + +{- | Boltzmann constant: stored value 1.380649e-23 J K^-1, absolute standard uncertainty 0, +from CODATA 2022. Returns a Constant metadata record; use constantAs for a numeric +conversion. +-} boltzmannConstant = physical "Boltzmann constant" 1.380649e-23 0 "J K^-1" + +{- | Avogadro constant: stored value 6.02214076e23 mol^-1, absolute standard uncertainty 0, +from CODATA 2022. Returns a Constant metadata record; use constantAs for a numeric +conversion. +-} avogadroConstant = physical "Avogadro constant" 6.02214076e23 0 "mol^-1" + +{- | Newtonian constant of gravitation: stored value 6.67430e-11 m^3 kg^-1 s^-2, absolute +standard uncertainty 0.00015e-11, from CODATA 2022. Returns a Constant metadata record; +use constantAs for a numeric conversion. +-} gravitationalConstant = physical "Newtonian constant of gravitation" 6.67430e-11 0.00015e-11 "m^3 kg^-1 s^-2" + +{- | Electron mass: stored value 9.1093837139e-31 kg, absolute standard uncertainty +0.0000000028e-31, from CODATA 2022. Returns a Constant metadata record; use constantAs +for a numeric conversion. +-} electronMass = physical "electron mass" 9.1093837139e-31 0.0000000028e-31 "kg" + +{- | IAU 2012 exact astronomical unit: 149597870700 metres, with zero measurement +uncertainty and approximation bound. Returns a Constant record with its source URL. +-} astronomicalUnit = Constant "astronomical unit" @@ -126,6 +222,7 @@ astronomicalUnit = 0 "m" "https://www.iau.org/static/resolutions/IAU2012_English.pdf (Resolution B2)" + physical :: String -> Rational -> Rational -> String -> Constant physical name value uncertainty unit = Constant @@ -135,6 +232,11 @@ physical name value uncertainty unit = 0 unit "https://physics.nist.gov/cuu/Constants/Table/allascii.txt (CODATA 2022)" + +{- | Catalog of supported physical constants, retaining unit, source, standard measurement +uncertainty, and approximation-bound metadata. Values use CODATA 2022 except the +IAU-defined astronomical unit. +-} physicalConstants :: [Constant] physicalConstants = [ speedOfLight diff --git a/src/HMath/DataStructure.hs b/src/HMath/DataStructure.hs index 1041fe4..67e4280 100644 --- a/src/HMath/DataStructure.hs +++ b/src/HMath/DataStructure.hs @@ -79,7 +79,14 @@ checkSize n checkRange :: Int -> Int -> Int -> Either MathError () checkRange n lo hi | lo < 0 || hi < lo || hi > n = Left (InvalidArgument "range out of bounds") | otherwise = Right () +{- | Persistent exact-Integer prefix-sum tree with zero-based updates and half-open queries. +Construct with fenwick. +-} data Fenwick = Fenwick Int (Array Int Integer) deriving (Eq, Show) + +{- | Build an immutable Fenwick prefix-sum tree from at most 1048576 Integers. Oversized +input fails; indices in public operations are zero based. +-} fenwick :: [Integer] -> Either MathError Fenwick fenwick xs = do checkSize (length xs) @@ -87,6 +94,10 @@ fenwick xs = do (\p (i, x) -> p >>= fenwickAdd i x) (Right (Fenwick (length xs) (listArray (1, length xs) (replicate (length xs) 0)))) (zip [0 ..] xs) + +{- | Given zero-based index,delta,then Fenwick tree, return a new tree with that value +incremented. Invalid index returns Left InvalidArgument. +-} fenwickAdd :: Int -> Integer -> Fenwick -> Either MathError Fenwick fenwickAdd i delta (Fenwick n a) | i < 0 || i >= n = Left (InvalidArgument "Fenwick update index out of bounds") @@ -96,18 +107,33 @@ fenwickAdd i delta (Fenwick n a) n (a // [(j, a ! j + delta) | j <- takeWhile (<= n) (iterate (\k -> k + (k .&. (-k))) (i + 1))]) ) + +{- | Given exclusive end then tree, return exact sum over [0,end). Require 0\<=end\<=length; +invalid bounds fail. +-} fenwickPrefix :: Int -> Fenwick -> Either MathError Integer fenwickPrefix end (Fenwick n a) = do checkRange n 0 end; pure (sum [a ! j | j <- takeWhile (> 0) (iterate (\k -> k - (k .&. (-k))) end)]) + +{- | Given lo,hi,then tree, return exact half-open sum over [lo,hi). Invalid/reversed bounds +fail; empty range gives zero. +-} fenwickRange :: Int -> Int -> Fenwick -> Either MathError Integer fenwickRange lo hi t@(Fenwick n _) = do checkRange n lo hi; (-) <$> fenwickPrefix hi t <*> fenwickPrefix lo t +{- | Persistent exact-Integer range-sum tree. Construct with segmentTree; segmentSet returns +a new version. +-} data SegmentTree = SegmentTree Int Int (Array Int Integer) deriving (Eq, Show) + powerTwo :: Int -> Int powerTwo n = go 1 where go p | p >= n = p | otherwise = go (p * 2) +{- | Build an immutable Integer sum segment tree from at most 1048576 values. Invalid size +fails; later queries use half-open bounds. +-} segmentTree :: [Integer] -> Either MathError SegmentTree segmentTree xs = do checkSize (length xs) @@ -118,6 +144,10 @@ segmentTree xs = do | i >= size = if i - size < n then xs !! (i - size) else 0 | otherwise = a ! (2 * i) + a ! (2 * i + 1) pure (SegmentTree n size a) + +{- | Given zero-based index,new Integer,then segment tree, return an updated tree. Invalid +index fails; the original remains unchanged. +-} segmentSet :: Int -> Integer -> SegmentTree -> Either MathError SegmentTree segmentSet i x (SegmentTree n size a) | i < 0 || i >= n = Left (InvalidArgument "segment update index out of bounds") @@ -126,6 +156,10 @@ segmentSet i x (SegmentTree n size a) go j ar | j <= 1 = ar | otherwise = let p = j `div` 2 in go p (ar // [(p, ar ! (2 * p) + ar ! (2 * p + 1))]) + +{- | Given lo,hi,then segment tree, return Integer sum over [lo,hi). Invalid bounds fail; an +empty range gives zero. +-} segmentRange :: Int -> Int -> SegmentTree -> Either MathError Integer segmentRange lo hi (SegmentTree n size a) = do checkRange n lo hi; pure (go (lo + size) (hi + size) 0) where @@ -136,7 +170,14 @@ segmentRange lo hi (SegmentTree n size a) = do checkRange n lo hi; pure (go (lo `addRight` (if odd r then a ! (r - 1) else 0) addRight x y = x + y +{- | Immutable precomputed range-minimum table for nonempty half-open queries. Construct +with sparseTable. +-} data SparseTable = SparseTable Int [Array Int Integer] deriving (Eq, Show) + +{- | Precompute range minima for at most 1048576 Integers. Return immutable sparse table; +oversized input fails. +-} sparseTable :: [Integer] -> Either MathError SparseTable sparseTable xs = do checkSize (length xs) @@ -152,6 +193,9 @@ sparseTable xs = do in table : build (width * 2) table pure (SparseTable n (if n == 0 then [] else firstLevel : build 2 firstLevel)) +{- | Given lo,hi,then sparse table, return minimum over nonempty [lo,hi). +Out-of-range/reversed or empty bounds fail. +-} sparseMinimum :: Int -> Int -> SparseTable -> Either MathError Integer sparseMinimum lo hi (SparseTable n tables) = do checkRange n lo hi @@ -160,9 +204,13 @@ sparseMinimum lo hi (SparseTable n tables) = do else let k = integerLog (hi - lo); width = 2 ^ k in pure (min ((tables !! k) ! lo) ((tables !! k) ! (hi - width))) + integerLog :: Int -> Int integerLog n | n <= 1 = 0 | otherwise = 1 + integerLog (n `div` 2) +{- | Immutable disjoint range-sum table supporting constant-query arithmetic. Construct with +disjointSparseTable. +-} data DisjointSparseTable = DisjointSparseTable [Integer] [Array Int Integer] deriving (Eq, Show) {- | Suffix/prefix blocks for associative integer addition, O(n log n) build and @@ -180,6 +228,9 @@ disjointSparseTable xs = do scanr1Safe [] = []; scanr1Safe ys = scanr1 (+) ys pure (DisjointSparseTable xs [level k | k <- [0 .. integerLog (max 1 n)]]) +{- | Given lo,hi,then disjoint sparse sum table, return exact sum over [lo,hi). Invalid +bounds fail; empty range yields zero. +-} disjointRange :: Int -> Int -> DisjointSparseTable -> Either MathError Integer disjointRange lo hi (DisjointSparseTable xs tables) = do checkRange (length xs) lo hi @@ -204,6 +255,9 @@ monotonicMinima width xs q' = reverse (dropWhile ((>= x) . snd) (reverse q)) ++ [(i, x)] in (if i >= width - 1 then [snd (q' !! 0)] else []) ++ go q' rest +{- | For each list position, return Maybe index of its first strictly greater element to the +right, using a monotone stack. Preserve input length; absent successors yield Nothing. +-} nextGreater :: (Ord a) => [a] -> [Maybe Int] nextGreater xs = map (\i -> M.lookup i result) [0 .. length xs - 1] where @@ -215,8 +269,12 @@ nextGreater xs = map (\i -> M.lookup i result) [0 .. length xs - 1] -- | Leftist binary min heap, O(log n) merge/insert/delete-min comparisons. data Heap a = Empty | Node Int a (Heap a) (Heap a) deriving (Eq, Show) +{- | Construct an empty persistent leftist min-heap. heapPop returns Nothing until values +are inserted. +-} emptyHeap :: Heap a emptyHeap = Empty + rank :: Heap a -> Int rank Empty = 0; rank (Node r _ _ _) = r mergeHeap :: (Ord a) => Heap a -> Heap a -> Heap a @@ -228,11 +286,23 @@ mergeHeap a@(Node _ x l r) b@(Node _ y _ _) | otherwise = Node (rank l + 1) x z l where z = mergeHeap r b + +{- | Given value then persistent min-heap, return a new heap containing it. Duplicate values +are retained; original heap remains valid. +-} heapInsert :: (Ord a) => a -> Heap a -> Heap a heapInsert x = mergeHeap (Node 1 x Empty Empty) + +{- | Return Nothing for empty heap, otherwise Just (smallest value,remaining heap). Ties +follow lawful Ord without discarding duplicates. +-} heapPop :: (Ord a) => Heap a -> Maybe (a, Heap a) heapPop Empty = Nothing heapPop (Node _ x l r) = Just (x, mergeHeap l r) + +{- | Build a persistent min-heap from a finite list, retaining all elements including +duplicates. +-} heapFromList :: (Ord a) => [a] -> Heap a heapFromList = Foldable.foldl' (flip heapInsert) Empty @@ -241,10 +311,17 @@ array; sift operations make O(log n) comparisons. -} newtype BinaryHeap = BinaryHeap (Array Int Integer) deriving (Eq, Show) +{- | Build an array-backed Integer min-heap from at most 1048576 values. Oversized input +fails. +-} binaryHeap :: [Integer] -> Either MathError BinaryHeap binaryHeap xs = do checkSize (length xs) pure (Foldable.foldl' (flip binaryInsert) (BinaryHeap (listArray (0, -1) [])) xs) + +{- | Given Integer then binary heap, return a persistent updated min-heap. The insert +operation itself has no Either size check. +-} binaryInsert :: Integer -> BinaryHeap -> BinaryHeap binaryInsert value (BinaryHeap old) = BinaryHeap (bubble (length values) (listArray (0, length values) (values ++ [value]))) where @@ -255,6 +332,10 @@ binaryInsert value (BinaryHeap old) = BinaryHeap (bubble (length values) (listAr | otherwise = bubble parent (a // [(parent, a ! i), (i, a ! parent)]) where parent = (i - 1) `div` 2 + +{- | Return Nothing if empty, otherwise the smallest Integer and a new binary heap +containing the remaining values. +-} binaryPop :: BinaryHeap -> Maybe (Integer, BinaryHeap) binaryPop (BinaryHeap old) = case elems old of [] -> Nothing @@ -277,10 +358,21 @@ Updates lazily invalidate old heap entries; pop discards stale entries. -} data IndexedHeap = IndexedHeap (M.Map Int Integer) (Heap (Integer, Int)) deriving (Eq, Show) +{- | Construct an empty indexed priority queue. Each Int key has at most one Integer +priority. +-} indexedHeap :: IndexedHeap indexedHeap = IndexedHeap M.empty Empty + +{- | Given Int key,Integer priority,then indexed heap, set or replace that key's priority. +Return a new queue; an existing key is updated, not duplicated. +-} indexedSet :: Int -> Integer -> IndexedHeap -> IndexedHeap indexedSet key value (IndexedHeap entries h) = IndexedHeap (M.insert key value entries) (heapInsert (value, key) h) + +{- | Return Just ((key,priority),remaining queue) for the minimum (priority,key) pair, or +Nothing if empty. +-} indexedPop :: IndexedHeap -> Maybe ((Int, Integer), IndexedHeap) indexedPop (IndexedHeap entries h) = case heapPop h of Nothing -> Nothing @@ -288,17 +380,33 @@ indexedPop (IndexedHeap entries h) = case heapPop h of | M.lookup k entries == Just v -> Just ((k, v), IndexedHeap (M.delete k entries) rest) | otherwise -> indexedPop (IndexedHeap entries rest) +{- | Persistent disjoint-set partition of zero-based indices, constructed with unionFind and +updated by union. +-} data UnionFind = UnionFind (Array Int Int) (Array Int Int) deriving (Eq, Show) + +{- | Construct disjoint singleton sets for n zero-based elements, requiring n in +[0,1048576]. Invalid size fails. +-} unionFind :: Int -> Either MathError UnionFind unionFind n = do checkSize n pure (UnionFind (listArray (0, n - 1) [0 .. n - 1]) (listArray (0, n - 1) (replicate n 1))) + +{- | Given element index then union-find structure, return representative root. Invalid +index fails; this pure query does not mutate/compress the stored structure. +-} findRoot :: Int -> UnionFind -> Either MathError Int findRoot i (UnionFind parent _) | i < 0 || i >= length (elems parent) = Left (InvalidArgument "union-find index out of bounds") | otherwise = Right (go i) where go j | parent ! j == j = j | otherwise = go (parent ! j) + +{- | Given two valid indices then union-find, return a new structure merging their +components by size. Invalid indices fail; already connected inputs leave connectivity +unchanged. +-} union :: Int -> Int -> UnionFind -> Either MathError UnionFind union a b uf@(UnionFind parent sizes) = do u <- findRoot a uf @@ -309,8 +417,16 @@ union a b uf@(UnionFind parent sizes) = do then uf else UnionFind (parent // [(small, large)]) (sizes // [(large, sizes ! large + sizes ! small)]) ) + +{- | Given two indices then union-find, return whether their roots match. Invalid indices +return Left InvalidArgument. +-} connected :: Int -> Int -> UnionFind -> Either MathError Bool connected a b uf = (==) <$> findRoot a uf <*> findRoot b uf + +{- | Return all disjoint components as lists of zero-based element indices, including +singleton sets. +-} components :: UnionFind -> [[Int]] components uf@(UnionFind parent _) = M.elems @@ -329,13 +445,29 @@ mix x = hashes :: Int -> Int -> Word64 -> [Int] hashes k m x = [fromIntegral (mix (x + fromIntegral i * 0x9e3779b97f4a7c15) `mod` fromIntegral m) | i <- [1 .. k]] + +{- | Immutable probabilistic membership filter; False is definitive and True may be a false +positive. Construct with bloom. +-} data Bloom = Bloom Int Int Integer Integer deriving (Eq, Show) + +{- | Given bit count m in [1,1048576] then hash count k in [1,64], construct an empty Bloom +filter. Invalid dimensions fail. +-} bloom :: Int -> Int -> Either MathError Bloom bloom m k | m <= 0 || m > 1048576 || k <= 0 || k > 64 = Left (InvalidArgument "invalid Bloom dimensions") | otherwise = Right (Bloom m k 0 0) + +{- | Given Word64 key then Bloom filter, set its k hash positions and return updated filter. +Reinsertions are permitted; false positives remain possible. +-} bloomInsert :: Word64 -> Bloom -> Bloom bloomInsert x (Bloom m k bits count) = Bloom m k (Foldable.foldl' setBit bits (hashes k m x)) (count + 1) + +{- | Test a Word64 key against all Bloom hash positions. False means definitely absent; True +may be a false positive under the documented hash model. +-} bloomMember :: Word64 -> Bloom -> Bool bloomMember x (Bloom m k bits _) = all (testBit bits) (hashes k m x) @@ -346,12 +478,23 @@ than the common exponential occupancy approximation. bloomFalsePositiveBound :: Bloom -> Double bloomFalsePositiveBound (Bloom m k _ count) = min 1 (fromIntegral k * fromInteger count / fromIntegral m) ^ k +{- | Immutable frequency sketch with nonnegative updates and possible collision +overestimation. Construct with countMin. +-} data CountMin = CountMin Int Int (M.Map (Int, Int) Integer) Integer deriving (Eq, Show) + +{- | Given positive width and depth with product\<=1048576, construct an empty count-min +sketch. Invalid dimensions fail. +-} countMin :: Int -> Int -> Either MathError CountMin countMin width depth | width <= 0 || depth <= 0 || toInteger width * toInteger depth > 1048576 = Left (InvalidArgument "invalid sketch dimensions") | otherwise = Right (CountMin width depth M.empty 0) + +{- | Given Word64 key,nonnegative Integer increment,then sketch, increment its hash +counters. Negative updates fail; return a persistent updated sketch. +-} countMinAdd :: Word64 -> Integer -> CountMin -> Either MathError CountMin countMinAdd x delta (CountMin w d counts total) | delta < 0 = Left (InvalidArgument "count-min requires nonnegative updates") @@ -363,6 +506,11 @@ countMinAdd x delta (CountMin w d counts total) (Foldable.foldl' (\m key -> M.insertWith (+) key delta m) counts (zip [0 ..] (hashes d w x))) (total + delta) ) + +{- | Given Word64 key then sketch, return minimum associated counter as an Integer frequency +estimate. It may overestimate through collisions; use countMinErrorBound for the +documented model. +-} countMinEstimate :: Word64 -> CountMin -> Integer countMinEstimate x (CountMin w d counts _) = minimum [M.findWithDefault 0 (i, j) counts | (i, j) <- zip [0 ..] (hashes d w x)] @@ -370,11 +518,20 @@ countMinEstimate x (CountMin w d counts _) = minimum [M.findWithDefault 0 (i, j) countMinErrorBound :: CountMin -> (Double, Double) countMinErrorBound (CountMin w d _ total) = (exp 1 * fromInteger total / fromIntegral w, exp (-fromIntegral d)) +-- | Immutable probabilistic distinct-cardinality sketch, constructed with hyperLogLog. data HyperLogLog = HyperLogLog Int (M.Map Int Int) deriving (Eq, Show) + +{- | Construct an empty cardinality sketch from precision p in [4,16], using 2^p registers. +Invalid precision fails; hllEstimate returns its probabilistic estimate. +-} hyperLogLog :: Int -> Either MathError HyperLogLog hyperLogLog precision | precision < 4 || precision > 16 = Left (InvalidArgument "HLL precision must be in [4,16]") | otherwise = Right (HyperLogLog precision M.empty) + +{- | Given Word64 item then HyperLogLog sketch, hash and update its register maximum. Return +persistent updated sketch; repeated items do not add a new exact count. +-} hllAdd :: Word64 -> HyperLogLog -> HyperLogLog hllAdd x (HyperLogLog p registers) = HyperLogLog p (M.insertWith max bucket rho registers) where @@ -397,7 +554,14 @@ hllEstimate (HyperLogLog p registers) zeros = count - M.size registers raw = alpha * m * m / (fromIntegral zeros + sum [2 ** (-fromIntegral r) | r <- M.elems registers]) +{- | Seeded bounded Algorithm-R stream sample state. Construct with reservoir and update +with reservoirAdd. +-} data Reservoir a = Reservoir Int Integer Word64 [a] deriving (Eq, Show) + +{- | Given sample capacity in [0,1048576] then Word64 seed, construct an empty deterministic +Algorithm-R reservoir. Invalid capacity fails. +-} reservoir :: Int -> Word64 -> Either MathError (Reservoir a) reservoir k seed | k < 0 || k > 1048576 = Left (InvalidArgument "invalid reservoir size") @@ -430,6 +594,9 @@ reservoirAdd x (Reservoir k count seed values) limit = 2 ^ (64 :: Int) - (2 ^ (64 :: Int) `mod` bound) in if r < limit then (r `mod` bound, next) else draw bound next +{- | Return retained reservoir sample values. Their count never exceeds capacity; output +order is storage order, not a sorted or arrival-order guarantee. +-} reservoirValues :: Reservoir a -> [a] reservoirValues (Reservoir _ _ _ xs) = xs @@ -439,13 +606,25 @@ O(n), queries O(1) after insertion. Exceeding the cap fails without eviction. -} data OnlineQuantiles = OnlineQuantiles Int [Double] deriving (Eq, Show) +{- | Given exact-storage cap in [0,1048576], create an empty online order-statistics +container. Invalid capacity fails; this retains exact values rather than a +bounded-memory approximate sketch. +-} onlineQuantiles :: Int -> Either MathError OnlineQuantiles onlineQuantiles cap = do checkSize cap; pure (OnlineQuantiles cap []) + +{- | Given finite Double then quantile container, insert in sorted order. Non-finite values +or a full cap fail without eviction; original container is unchanged. +-} quantileAdd :: Double -> OnlineQuantiles -> Either MathError OnlineQuantiles quantileAdd x (OnlineQuantiles cap xs) | isNaN x || isInfinite x = Left NonFiniteResult | length xs >= cap = Left (NonConvergence "online quantile memory" cap) | otherwise = let (a, b) = span (<= x) xs in Right (OnlineQuantiles cap (a ++ [x] ++ b)) + +{- | Given finite q in [0,1] then nonempty quantile container, linearly interpolate order +statistics at q*(n-1). Invalid q or empty state returns Left InvalidArgument. +-} onlineQuantile :: Double -> OnlineQuantiles -> Either MathError Double onlineQuantile q (OnlineQuantiles _ xs) | null xs || isNaN q || isInfinite q || q < 0 || q > 1 = diff --git a/src/HMath/DeepLearning/Core.hs b/src/HMath/DeepLearning/Core.hs index 238c3ae..6b223bf 100644 --- a/src/HMath/DeepLearning/Core.hs +++ b/src/HMath/DeepLearning/Core.hs @@ -39,6 +39,9 @@ import Data.List (sortBy) import qualified HMath.Autodiff as AD import HMath.Error +{- | Scalar activation selector. LeakyReLU/PReLU carry negative-side slope and ELU carries +positive alpha; other constructors select the named standard activation. +-} data Activation = Sigmoid | Tanh @@ -55,6 +58,7 @@ data Activation | HardSigmoid | HardSwish deriving (Eq, Show) + finite :: [Double] -> Either MathError () finite xs = if all (\x -> not (isNaN x || isInfinite x)) xs then Right () else Left NonFiniteResult sigmoid :: Double -> Double @@ -63,6 +67,11 @@ softplus :: Double -> Double softplus x = max x 0 + log (1 + exp (-abs x)) -- GELU uses the explicit tanh approximation from Hendrycks/Gimpel (2016). + +{- | Given Activation selector then finite scalar, evaluate the selected activation. +Parameterized LeakyReLU/PReLU slopes must be finite and ELU alpha positive. Invalid +input/parameters or non-finite output returns Left MathError. +-} activation :: Activation -> Double -> Either MathError Double activation kind x = do finite [x] @@ -173,7 +182,15 @@ gatedLinearUnit values gate = do then Left (VectorLengthMismatch (length values) (length gate)) else Right (zipWith (\x g -> x * sigmoid g) values gate) +{- | Loss aggregation: Sum adds elementwise losses and Mean divides by their count; +vector-level loss exceptions are documented by loss. +-} data Reduction = Sum | Mean deriving (Eq, Show) + +{- | Checked loss selector,including squared/absolute error,cross +entropy,KL,hinge,cosine,and parameterized Huber/smooth losses. Target/prediction domain +rules belong to loss. +-} data Loss = MeanSquaredError | MeanAbsoluteError @@ -186,6 +203,7 @@ data Loss | CosineLoss | Hinge Double deriving (Eq, Show) + validatePair :: [Double] -> [Double] -> Either MathError () validatePair target prediction = do finite (target ++ prediction) @@ -374,6 +392,11 @@ log-softmax chain rule. Impossible alignments return DomainError. ctcLoss :: Int -> [Int] -> [[Double]] -> Either MathError Double ctcLoss blank labels logs = fst <$> ctcLossGradient blank labels logs +{- | Given blank class index, target labels, then rectangular time-by-class log +probabilities, return CTC negative log likelihood and gradient rows. Validate class +indices, finite/log-probability constraints and alignment feasibility. Empty time +permits only empty labels; invalid/impossible inputs return Left MathError. +-} ctcLossGradient :: Int -> [Int] -> [[Double]] -> Either MathError (Double, [[Double]]) ctcLossGradient blank labels logs = do case logs of diff --git a/src/HMath/DeepLearning/Layers.hs b/src/HMath/DeepLearning/Layers.hs index 64e84ab..607c8c7 100644 --- a/src/HMath/DeepLearning/Layers.hs +++ b/src/HMath/DeepLearning/Layers.hs @@ -56,7 +56,11 @@ import HMath.Error import HMath.Random (RNG, normal, sampleN, uniform) import qualified HMath.Tensor as T +{- | Layer mode: Training updates/uses batch statistics; Inference uses retained running +statistics. +-} data Training = Training | Inference deriving (Eq, Show) + finite :: [Double] -> Either MathError () finite xs = if all (\x -> not (isNaN x || isInfinite x)) xs then Right () else Left NonFiniteResult validTensor :: T.Tensor Double -> Either MathError () @@ -114,7 +118,17 @@ spatialDropout mode probability rng input = case T.tensorShape input of Right (output, expanded, state) _ -> Left (InvalidArgument "spatial dropout requires N,C,spatial") -data BatchNormState = BatchNormState {runningMean :: [Double], runningVariance :: [Double], batchesSeen :: Int} +{- | Per-channel running mean/variance and incorporated training-batch count for batch +normalization. +-} +data BatchNormState = BatchNormState + { runningMean :: [Double] + -- ^ Per-channel running mean used during inference. + , runningVariance :: [Double] + -- ^ Per-channel running variance used during inference. + , batchesSeen :: Int + -- ^ Number of training batches incorporated into running statistics. + } deriving (Eq, Show) {- | Population variance normalizes a training batch; unbiased sample variance @@ -255,6 +269,10 @@ weightNorm axis magnitudes input = do shape [get input ix * (magnitudes !! (ix !! axis)) / (norms !! (ix !! axis)) | ix <- allIx] +{- | Weight initializer selector: Xavier/Kaiming uniform/normal,Orthogonal gain,or +TruncatedNormal mean sigma cutoff. initializeWeights also takes explicit fan counts and +RNG. +-} data Initializer = XavierUniform | XavierNormal @@ -363,13 +381,19 @@ denseAD input weights bias = do y <- denseGeneric x w bias AD.adTensor (T.tensorShape y) (T.tensorValues y) +-- | Per-axis stride,padding,dilation,and channel-group settings for checked convolution. data ConvOptions = ConvOptions { convolutionStride :: [Int] + -- ^ Positive spatial stride per convolution axis. , convolutionPadding :: [Int] + -- ^ Nonnegative symmetric padding per spatial axis. , convolutionDilation :: [Int] + -- ^ Positive spacing between kernel elements per spatial axis. , convolutionGroups :: Int + -- ^ Positive group count dividing input/output channels for grouped convolution. } deriving (Eq, Show) + convGeneric :: (Num a) => Bool -> [Int] -> ConvOptions -> T.Tensor a -> T.Tensor a -> [a] -> Either MathError (T.Tensor a) @@ -524,6 +548,7 @@ convolutionAD options input weights bias = do output <- convGeneric False [] options x w bias AD.adTensor (T.tensorShape output) (T.tensorValues output) +-- | Pooling reduction selector: MaxPool or AveragePool over each checked window. data PoolMode = MaxPool | AveragePool deriving (Eq, Show) -- | Windowed max/average pooling. Padded elements are excluded from the average; entirely padded windows fail. @@ -734,6 +759,9 @@ alibiBias slope queryLength keyLength offset = do finite (concat values) Right values +{- | Opaque retained attention keys/values for incremental decoding; use checked cache +append/attention operations. +-} data KVCache = KVCache Int Int Int (T.Tensor Double) (T.Tensor Double) deriving (Eq, Show) -- | Create an owned immutable key/value cache with fixed positive capacity and feature widths. diff --git a/src/HMath/DeepLearning/Metrics.hs b/src/HMath/DeepLearning/Metrics.hs index 2115327..1e7b1ef 100644 --- a/src/HMath/DeepLearning/Metrics.hs +++ b/src/HMath/DeepLearning/Metrics.hs @@ -22,13 +22,19 @@ import Data.List (groupBy, sortBy) import HMath.Error import qualified HMath.Tensor as T +-- | Accuracy and per-class precision,recall,and F1 values ordered by class index. data ClassificationMetrics = ClassificationMetrics { accuracy :: Double + -- ^ Fraction of correctly predicted samples. , precisionByClass :: [Double] + -- ^ Per-class true positives divided by predicted positives; ordering follows class indices. , recallByClass :: [Double] + -- ^ Per-class true positives divided by actual positives. , f1ByClass :: [Double] + -- ^ Per-class harmonic mean of precision and recall, following the metric function's zero-denominator convention. } deriving (Eq, Show) + finite :: [Double] -> Either MathError () finite xs = if all (\x -> not (isNaN x || isInfinite x)) xs then Right () else Left NonFiniteResult diff --git a/src/HMath/DeepLearning/Precision.hs b/src/HMath/DeepLearning/Precision.hs index d8cf993..8d4dcb8 100644 --- a/src/HMath/DeepLearning/Precision.hs +++ b/src/HMath/DeepLearning/Precision.hs @@ -33,7 +33,14 @@ import HMath.Error import qualified HMath.Numeric as N import qualified HMath.Tensor as T +{- | Integer quantization policy: Symmetric around zero or Asymmetric with a learned zero +point. +-} data Quantization = Symmetric | Asymmetric deriving (Eq, Show) + +{- | Opaque Int8 tensor with shape,optional channel axis,scales,and zero points. Construct +through the checked quantization API. +-} data QuantizedTensor = QuantizedTensor [Int] (Maybe Int) [Double] [Int] [Int8] deriving (Eq, Show) -- | Return signed INT8 storage in logical row-major order. @@ -120,6 +127,9 @@ int8Gemm (QuantizedTensor [m, k] aa as az av) (QuantizedTensor [inner, n] ba bs T.tensor [m, n] vals int8Gemm _ _ = Left (InvalidArgument "INT8 GEMM expects matrices") +{- | Mixed-precision storage/rounding selector FP16 or BF16; operations report +finite/overflow conditions through the checked precision API. +-} data Precision = FP16 | BF16 deriving (Eq, Show) -- | Round operands to the chosen 16-bit format, accumulate in Float32, and return checked Double values. @@ -144,7 +154,15 @@ reducedGemm precision a b = do T.tensor [m, n] vals _ -> Left (InvalidArgument "reduced GEMM expects conformable matrices") -data LossScaler = LossScaler {lossScale :: Double, scaleGrowthInterval :: Int, finiteSteps :: Int} +-- | Dynamic mixed-precision loss-scale state with finite-step growth tracking. +data LossScaler = LossScaler + { lossScale :: Double + -- ^ Positive scaling factor applied to loss/gradients in mixed-precision training. + , scaleGrowthInterval :: Int + -- ^ Number of consecutive finite updates before loss-scale growth. + , finiteSteps :: Int + -- ^ Current count of consecutive finite updates since the last reset/growth. + } deriving (Eq, Show) -- | Create a positive finite loss scale and positive growth interval; zero accumulated finite steps. diff --git a/src/HMath/Discrete.hs b/src/HMath/Discrete.hs index cba6960..0f75cf4 100644 --- a/src/HMath/Discrete.hs +++ b/src/HMath/Discrete.hs @@ -60,35 +60,63 @@ multiplicities; intersection takes minima and difference truncates at zero. -} newtype MultiSet a = MultiSet (M.Map a Integer) deriving (Eq, Show) +{- | Construct a finite multiset by counting equal ordered values with exact nonnegative +Integer multiplicities. +-} multiset :: (Ord a) => [a] -> MultiSet a multiset xs = MultiSet (M.fromListWith (+) [(x, 1) | x <- xs]) + +-- | Given value then multiset, return its Integer frequency, or zero when absent. multiplicity :: (Ord a) => a -> MultiSet a -> Integer multiplicity x (MultiSet m) = M.findWithDefault 0 x m + +-- | Return (value,positive multiplicity) pairs in ascending value order. multisetEntries :: MultiSet a -> [(a, Integer)] multisetEntries (MultiSet m) = M.toAscList m + +-- | Given value then multiset, increment its multiplicity by one and return a new multiset. multisetInsert :: (Ord a) => a -> MultiSet a -> MultiSet a multisetInsert x (MultiSet m) = MultiSet (M.insertWith (+) x 1 m) + +{- | Given value then multiset, remove one occurrence, deleting its entry at zero. Absent +values are a no-op. +-} multisetDelete :: (Ord a) => a -> MultiSet a -> MultiSet a multisetDelete x (MultiSet m) = MultiSet (M.update (\n -> if n <= 1 then Nothing else Just (n - 1)) x m) + multisetUnion , multisetIntersection , multisetDifference :: (Ord a) => MultiSet a -> MultiSet a -> MultiSet a + +{- | Add multiplicities of two multisets, retaining all distinct values. This is multiset +sum rather than maximum-multiplicity union. +-} multisetUnion (MultiSet a) (MultiSet b) = MultiSet (M.unionWith (+) a b) + +-- | Return shared values with minimum of the two multiplicities. multisetIntersection (MultiSet a) (MultiSet b) = MultiSet (M.intersectionWith min a b) + +-- | Subtract right multiplicities from left, truncating at zero and removing empty entries. multisetDifference (MultiSet a) (MultiSet b) = MultiSet (M.filter (> 0) (M.mapWithKey (\x n -> n - M.findWithDefault 0 x b) a)) -- | Opaque arbitrary-size dynamic bitset; bits outside its width are zero. data BitSet = BitSet Int Integer deriving (Eq, Show) +{- | Given width in [0,1048576] then nonnegative Integer less than 2^width, construct an +opaque bitset. Invalid width/value fails; bit zero is least significant. +-} bitSet :: Int -> Integer -> Either MathError BitSet bitSet w v | w < 0 || w > 1048576 || v < 0 || v >= 2 ^ w = Left (InvalidArgument "bitset width/value out of range") | otherwise = Right (BitSet w v) +-- | Return declared number of bits, including leading zeros. bitWidth :: BitSet -> Int bitWidth (BitSet w _) = w + +-- | Return unsigned Integer value of all bits within the declared width. bitValue :: BitSet -> Integer bitValue (BitSet _ v) = v @@ -96,10 +124,22 @@ bitIndex :: BitSet -> Int -> Either MathError () bitIndex (BitSet w _) i | i < 0 || i >= w = Left (InvalidArgument "bit index out of bounds") | otherwise = Right () + +{- | Given bitset then zero-based bit index, return membership. Out-of-width or negative +indices return Left InvalidArgument. +-} bitMember :: BitSet -> Int -> Either MathError Bool bitMember b i = do bitIndex b i; pure (testBit (bitValue b) i) + +{- | Given bitset then valid bit index, return a new bitset with that bit set. Invalid index +fails. +-} bitInsert :: BitSet -> Int -> Either MathError BitSet bitInsert b@(BitSet w v) i = do bitIndex b i; pure (BitSet w (setBit v i)) + +{- | Given bitset then valid bit index, return a new bitset with that bit cleared. Invalid +index fails. +-} bitDelete :: BitSet -> Int -> Either MathError BitSet bitDelete b@(BitSet w v) i = do bitIndex b i; pure (BitSet w (clearBit v i)) @@ -108,42 +148,81 @@ bitCombine f (BitSet w a) (BitSet v b) | w /= v = Left (InvalidArgument "bit widths differ") | otherwise = Right (BitSet w (f a b .&. (2 ^ w - 1))) bitUnion, bitIntersection, bitDifference :: BitSet -> BitSet -> Either MathError BitSet + +{- | Return bitwise OR of equal-width bitsets. Different widths fail; no implicit resize +occurs. +-} bitUnion = bitCombine (.|.) + +-- | Return bitwise AND of equal-width bitsets; mismatched widths fail. bitIntersection = bitCombine (.&.) + +-- | Return left bits with right bits cleared, requiring equal widths. Width mismatch fails. bitDifference = bitCombine (\a b -> a .&. complement b) -- | Shrinking explicitly discards high bits. resizeBitSet :: Int -> BitSet -> Either MathError BitSet resizeBitSet w (BitSet _ v) = bitSet w (v .&. (2 ^ max 0 w - 1)) +-- | Count set bits within declared width, returning Int. populationCount :: BitSet -> Int populationCount = popCount . bitValue + +-- | Count high-end zero bits within declared width. All-zero bitset returns its full width. leadingZeros :: BitSet -> Int leadingZeros (BitSet w v) = w - go v where go 0 = 0; go x = 1 + go (shiftR x 1) + +-- | Count low-end zero bits; an all-zero bitset returns its declared width. trailingZeros :: BitSet -> Int trailingZeros (BitSet w v) = if v == 0 then w else go v where go x | odd x = 0 | otherwise = 1 + go (shiftR x 1) + +{- | Given signed rotation count then bitset, rotate left modulo width (negative counts +rotate right). Width-zero input is unchanged. +-} rotateBits :: Int -> BitSet -> BitSet rotateBits _ b@(BitSet 0 _) = b rotateBits k (BitSet w v) = let j = k `mod` w in BitSet w ((shiftL v j .|. shiftR v (w - j)) .&. (2 ^ w - 1)) + +{- | Reverse exactly the declared width of bits, preserving width and leading/trailing zero +positions. +-} reverseBits :: BitSet -> BitSet reverseBits (BitSet w v) = BitSet w (sum [if testBit v i then bit (w - i - 1) else 0 | i <- [0 .. w - 1]]) + +-- | Return width-preserving reflected Gray code v xor (v shifted right one). grayEncode :: BitSet -> BitSet grayEncode (BitSet w v) = BitSet w (v `xor` shiftR v 1) + +-- | Decode reflected Gray bits to the corresponding width-preserving binary value. grayDecode :: BitSet -> BitSet grayDecode (BitSet w v) = BitSet w (go v 0) where go 0 r = r; go x r = go (shiftR x 1) (r `xor` x) + +{- | Count differing bit positions between equal-width bitsets. Different widths return Left +InvalidArgument. +-} hammingDistance :: BitSet -> BitSet -> Either MathError Int hammingDistance a b = populationCount <$> bitCombine xor a b setUnion, setIntersection, setDifference, symmetricDifference :: (Ord a) => [a] -> [a] -> [a] + +{- | Treat lists as finite sets and return their sorted unique union; input order and +multiplicity are discarded. +-} setUnion a b = S.toAscList (S.union (S.fromList a) (S.fromList b)) + +-- | Return sorted unique values present in both input lists. setIntersection a b = S.toAscList (S.intersection (S.fromList a) (S.fromList b)) + +-- | Return sorted unique left values absent from the right list. setDifference a b = S.toAscList (S.difference (S.fromList a) (S.fromList b)) + +-- | Return sorted unique values present in exactly one input list. symmetricDifference a b = setUnion (setDifference a b) (setDifference b a) square :: [[a]] -> Either MathError Int @@ -165,12 +244,23 @@ transitiveClosure a = do [0 .. n - 1] ) +{- | Given square Bool relation matrix, add reflexivity and symmetry then compute transitive +closure. Reject nonsquare or oversized (>512) relations. +-} equivalenceClosure :: [[Bool]] -> Either MathError [[Bool]] equivalenceClosure a = do n <- square a transitiveClosure [[i == j || a !! i !! j || a !! j !! i | j <- [0 .. n - 1]] | i <- [0 .. n - 1]] + +{- | Return whether a bounded square Bool relation is already reflexive, symmetric and +transitive. Invalid matrix shape/size fails. +-} isEquivalence :: [[Bool]] -> Either MathError Bool isEquivalence a = (== a) <$> equivalenceClosure a + +{- | Multiply compatible square Bool relation matrices over OR/AND, representing relational +composition. Invalid dimensions or size bounds fail. +-} booleanMultiply :: [[Bool]] -> [[Bool]] -> Either MathError [[Bool]] booleanMultiply a b = do n <- square a @@ -180,6 +270,10 @@ booleanMultiply a b = do else pure [[or [a !! i !! k && b !! k !! j | k <- [0 .. n - 1]] | j <- [0 .. n - 1]] | i <- [0 .. n - 1]] +{- | Boolean proposition tree. Literal and Variable leaves combine through +Not,And,Or,Xor,Implies,Iff; Variable indices address the assignment list passed to +evaluateProp. +-} data Prop = Literal Bool | Variable Int @@ -191,6 +285,10 @@ data Prop | Iff Prop Prop deriving (Eq, Show) +{- | Given variable Bool assignment list then proposition, evaluate +literals/variables/connectives. Invalid variable index or excessive expression depth +returns Left MathError. +-} evaluateProp :: [Bool] -> Prop -> Either MathError Bool evaluateProp values = go (0 :: Int) where @@ -219,9 +317,17 @@ truthTable n p {- | Value bits and a don't-care mask. Both fields are bounded by the supplied input width when returned by 'quineMcCluskey'. -} -data Implicant = Implicant {implicantValue :: Integer, implicantMask :: Integer} +data Implicant = Implicant + { implicantValue :: Integer + -- ^ Fixed bit values of a Boolean implicant; positions masked by implicantMask are ignored. + , implicantMask :: Integer + -- ^ Bit mask whose set bits denote don't-care positions in an implicant. + } deriving (Eq, Ord, Show) +{- | Given implicant then Integer minterm, compare bits where implicantMask is clear. True +means this Boolean cube covers the minterm. +-} implicantCovers :: Implicant -> Integer -> Bool implicantCovers (Implicant v m) x = (x .&. complement m) == v diff --git a/src/HMath/Expression.hs b/src/HMath/Expression.hs index 00593cb..d9191d4 100644 --- a/src/HMath/Expression.hs +++ b/src/HMath/Expression.hs @@ -1,6 +1,6 @@ -- SPDX-License-Identifier: MPL-2.0 -{- | A pure, bounded real expression language shared with 'HMath.Symbolic'. +{- | A pure, bounded real expression language shared with "HMath.Symbolic". Grammar: @let name = expression in expression@; left-associative @+ - * /@; right-associative @^@; unary @+ -@ binds below powers (@-2^2 = -(2^2)@). @@ -86,16 +86,50 @@ import Data.Word (Word64) import Numeric (showEFloat, showIntAtBase) -- | Zero-based offset and one-based line/column. Generated expressions use 0/0/0. -data SourcePos = SourcePos {sourceOffset :: Int, sourceLine :: Int, sourceColumn :: Int} +data SourcePos = SourcePos + { sourceOffset :: Int + -- ^ Zero-based source character offset; generated nodes use zero. + , sourceLine :: Int + -- ^ One-based source line, or zero for generated unknown positions. + , sourceColumn :: Int + -- ^ One-based source column, or zero for generated unknown positions. + } deriving (Eq, Ord, Show) +{- | Source position sentinel (offset,line,column)=(0,0,0), used by programmatically +constructed nodes rather than parsed source positions. +-} unknownPosition :: SourcePos unknownPosition = SourcePos 0 0 0 +-- | Unary expression operator; Negate changes the operand sign. data UnaryOp = Negate deriving (Eq, Ord, Show) + +{- | Arithmetic expression operator: addition,subtraction,multiplication,division,or +exponentiation. Evaluation enforces the selected numeric/domain limits. +-} data BinaryOp = Add | Subtract | Multiply | Divide | Power deriving (Eq, Ord, Show) + +{- | Symbolic pi,Euler number e,or tau=2*pi. Precision mode determines how a constant is +evaluated. +-} data NamedConstant = Pi | Euler | Tau deriving (Eq, Ord, Show) -data Expr = Expr {expressionPosition :: SourcePos, expressionNode :: ExprNode} deriving (Show) + +{- | Positioned expression syntax tree. Smart builders use unknownPosition; parsed nodes +retain source locations. Validation/evaluation returns structured ExprError rather than +executing host code. +-} +data Expr = Expr + { expressionPosition :: SourcePos + -- ^ Source location carried by this Expr for positioned errors. + , expressionNode :: ExprNode + -- ^ Literal/variable/operator/call/let structure of this expression. + } + deriving (Show) + +{- | Expression syntax: exact literal,named variable/constant,unary/binary +operation,registered call,or lexically scoped let binding. +-} data ExprNode = Literal Rational | Variable String @@ -105,35 +139,79 @@ data ExprNode | Call String [Expr] | Let String Expr Expr deriving (Eq, Ord, Show) + instance Eq Expr where Expr _ a == Expr _ b = a == b instance Ord Expr where compare (Expr _ a) (Expr _ b) = compare a b + +{- | Construct an exact Rational literal Expr at unknownPosition. This builder does not +validate resource limits; evaluation/serialization performs checked validation. +-} literal :: Rational -> Expr literal = Expr unknownPosition . Literal + +{- | Construct a named variable Expr at unknownPosition; lookup and limit validation occur +during checked processing. +-} variable :: String -> Expr variable = Expr unknownPosition . Variable + +{- | Construct a Pi/Euler/Tau named-constant Expr at unknownPosition, without numeric +evaluation. +-} constant :: NamedConstant -> Expr constant = Expr unknownPosition . Constant + +-- | Given UnaryOp then child Expr, construct an unevaluated unary node at unknownPosition. unary :: UnaryOp -> Expr -> Expr unary op = Expr unknownPosition . Unary op + +{- | Given BinaryOp,left Expr,right Expr, construct an unevaluated binary node at +unknownPosition. Domain and resource checks occur when evaluated. +-} binary :: BinaryOp -> Expr -> Expr -> Expr binary op a b = Expr unknownPosition (Binary op a b) + +{- | Given function name then argument Expr list, construct a call node at unknownPosition. +Evaluation resolves the supplied registry; construction does not execute a function. +-} call :: String -> [Expr] -> Expr call name = Expr unknownPosition . Call name + +{- | Given binding name,value Expr,body Expr, construct a lexically scoped let node at +unknownPosition. The binding applies in the body, not its own value expression. +-} letIn :: String -> Expr -> Expr -> Expr letIn name a b = Expr unknownPosition (Let name a b) +{- | Explicit resource budgets checked before parsing,evaluation,serialization,and cache +growth; start from defaultLimits. +-} data Limits = Limits { maximumSteps :: Int + -- ^ Maximum checked evaluation/rewrite instruction steps. , maximumDepth :: Int + -- ^ Maximum permitted parser/expression recursion depth. , maximumNodes :: Int + -- ^ Maximum expression or compiled-node storage budget. , maximumInputChars :: Int + -- ^ Maximum accepted input/serialized text characters. , maximumIntegerBits :: Int + -- ^ Maximum exact-integer bit length in checked arithmetic. , maximumCacheEntries :: Int + -- ^ Maximum retained compiled-expression cache entries; zero disables retention. } deriving (Eq, Show) + +{- | Default expression budgets: 100000 steps, depth 128, 20000 nodes, 100000 input +characters, 1024 integer bits and 64 cache entries. Use record updates; validateLimits +checks hard implementation bounds. +-} defaultLimits :: Limits defaultLimits = Limits 100000 128 20000 100000 1024 64 +{- | Expression error category distinguishing syntax/name/type/domain/nonfinite failures +from bounded-resource exhaustion and unsupported operations. +-} data ErrorKind = SyntaxError | UnknownName @@ -146,10 +224,25 @@ data ErrorKind | InvalidLimits | Unsupported deriving (Eq, Ord, Show) -data ExprError = ExprError {errorKind :: ErrorKind, errorPosition :: SourcePos, errorMessage :: String} + +-- | Structured expression failure with category,source position,and human-readable detail. +data ExprError = ExprError + { errorKind :: ErrorKind + -- ^ Structured syntax,name,domain,type,nonfinite,unsupported,or resource-error category. + , errorPosition :: SourcePos + -- ^ Source position attached to the failed operation. + , errorMessage :: String + -- ^ Human-readable detail for this expression failure. + } deriving (Eq, Show) + err :: ErrorKind -> SourcePos -> String -> Either ExprError a err k p = Left . ExprError k p + +{- | Return Right () if all resource budgets fit implementation bounds: steps 1..10000000, +depth 1..256, nodes 1..100000, input chars 1..1000000, integer bits 2..8192, cache +entries 0..1024. Otherwise return ExprError InvalidLimits. +-} validateLimits :: Limits -> Either ExprError () validateLimits l | or @@ -168,6 +261,7 @@ validateLimits l ] = err InvalidLimits unknownPosition "limits exceed positive reference implementation bounds" | otherwise = Right () + data Budget = Budget !Int !Int start :: Limits -> Budget start l = Budget (maximumSteps l) (maximumNodes l) @@ -410,6 +504,10 @@ operator Subtract = "-" operator Multiply = "*" operator Divide = "/" operator Power = "^" + +{- | Return sorted distinct variable names free in an Expr, respecting lexical let bindings. +No evaluation or name lookup occurs. +-} freeVariables :: Expr -> [String] freeVariables = Set.toAscList . go where @@ -422,9 +520,25 @@ freeVariables = Set.toAscList . go Call _ xs -> Set.unions (map go xs) Let s a b -> Set.union (go a) (Set.delete s (go b)) +{- | Expression numeric mode: ExactRational retains exact supported rational arithmetic; +Float64 uses checked binary64 evaluation. Unsupported exact transcendental operations +return structured errors. +-} data Precision = ExactRational | Float64 deriving (Eq, Ord, Show) + +{- | Evaluation result tagged ExactValue Rational or FloatValue Double. The selected +Precision controls permitted operations and conversions. +-} data Value = ExactValue Rational | FloatValue Double deriving (Eq, Show) + +{- | Map from variable names to tagged expression Values. Lexical let bindings extend the +environment inside their body. +-} type Bindings = Map.Map String Value + +{- | Finite whitelist of supported scalar operations; Registry maps valid names/aliases to +these selectors, never arbitrary host code. +-} data Builtin = Sin | Cos @@ -445,9 +559,22 @@ data Builtin | Cosh | Tanh deriving (Eq, Ord, Show, Enum, Bounded) + +{- | Immutable safe builtin-name registry, initialized with emptyRegistry or defaultRegistry +and extended with registerFunction. +-} newtype Registry = Registry (Map.Map String Builtin) deriving (Eq, Show) + +{- | Construct a registry containing no builtins; callers may add permitted names with +registerFunction. +-} emptyRegistry :: Registry emptyRegistry = Registry Map.empty + +{- | Registry of supported safe scalar builtins (trigonometric/hyperbolic functions, +exp/log/sqrt, abs/signum, rounding and min/max). Evaluation dispatches known Builtin +values, never arbitrary source code. +-} defaultRegistry :: Registry defaultRegistry = Registry @@ -475,6 +602,11 @@ defaultRegistry = [minBound .. maxBound] ) ) + +{- | Given valid identifier name,Builtin selector,then registry, insert or replace an alias. +Reject invalid names (including length>1024) or more than 256 distinct entries with +structured ExprError. +-} registerFunction :: String -> Builtin -> Registry -> Either ExprError Registry registerFunction n f (Registry m) | length (take 1025 n) > 1024 || not (identifier n) = @@ -482,8 +614,11 @@ registerFunction n f (Registry m) | Map.size m >= 256 && Map.notMember n m = err MemoryLimit unknownPosition "registry supports at most 256 names" | otherwise = Right (Registry (Map.insert n f m)) + +-- | Sorted function and alias names accepted by a registry; no evaluation occurs. allowedFunctions :: Registry -> [String] allowedFunctions (Registry m) = Map.keys m + arity :: Builtin -> Int arity f = if f `elem` [Min, Max] then 2 else 1 finite :: Double -> Bool @@ -661,6 +796,10 @@ evaluateExpression l mode registry env expression = do Right (v, b2) Let n a c -> do (x, b2) <- go (d + 1) b1 vars a; b3 <- charge p 1 1 b2; go (d + 1) b3 (Map.insert n x vars) c +{- | Given limits,precision,registry,bindings,then source text, parse and evaluate under the +checked expression budgets. Return exact Rational or Float64 Value according to mode; +syntax/name/domain/resource failures return positioned ExprError. +-} evaluateText :: Limits -> Precision -> Registry -> Bindings -> String -> Either ExprError Value evaluateText l mode registry env source = parseExpression l source >>= evaluateExpression l mode registry env @@ -676,7 +815,12 @@ data Key | KStrictLet Int Int deriving (Eq, Ord, Show) data Instruction = Instruction SourcePos Key deriving (Eq, Show) + +{- | Opaque validated expression DAG with common-subexpression sharing and source locations. +Use compileExpression/evaluateCompiled. +-} data Compiled = Compiled Expr Int (Map.Map Int Instruction) deriving (Eq, Show) + data Build = Build !Int (Map.Map Key Int) (Map.Map Int Instruction) Budget {- | Compile to a hash-consed DAG. Strict lets are retained, including unused @@ -713,6 +857,7 @@ compileExpression l expression = do b1 <- charge p 1 1 b Right (n, Build (n + 1) (Map.insert key n keys) (Map.insert n (Instruction p key) instructions) b1) +-- | Number of unique DAG instructions after common-subexpression sharing. compiledNodeCount :: Compiled -> Int compiledNodeCount (Compiled _ _ nodes) = Map.size nodes @@ -792,10 +937,22 @@ or results. Keys include exact source; eviction occurs at the caller's limit. -} newtype ExpressionCache = ExpressionCache [(String, Compiled)] deriving (Eq, Show) +{- | Construct an empty immutable compiled-expression cache. cachedExpression returns an +updated cache explicitly. +-} emptyExpressionCache :: ExpressionCache emptyExpressionCache = ExpressionCache [] + +{- | Return number of retained compiled-source entries; does not compile or evaluate +anything. +-} cacheSize :: ExpressionCache -> Int cacheSize (ExpressionCache xs) = length xs + +{- | Given limits,source text,then cache, return (compiled expression,updated cache), +reusing a matching entry when permitted. Enforce entry and aggregate source/instruction +budgets; parse/compile/resource failures return ExprError. +-} cachedExpression :: Limits -> String -> ExpressionCache -> Either ExprError (Compiled, ExpressionCache) cachedExpression l source (ExpressionCache entries) = do @@ -850,6 +1007,11 @@ formatRadix base value -- Serialization uses a reserved constructor vocabulary, not Read: input cannot -- manufacture a Ratio with denominator zero or bypass parser resource limits. + +{- | Given limits then Expr, validate its structure and produce versioned safe textual +encoding, retaining expression structure. Exceeded character/structure limits return +ExprError. +-} serializeExpression :: Limits -> Expr -> Either ExprError String serializeExpression l e = do validateExpression l e @@ -866,6 +1028,11 @@ serializeExpression l e = do Binary op a b -> "__" ++ show op ++ "(" ++ encode a ++ "," ++ encode b ++ ")" Call name xs -> "__call(" ++ name ++ concatMap ((", " ++) . encode) xs ++ ")" Let name a b -> "__let(" ++ name ++ "," ++ encode a ++ "," ++ encode b ++ ")" + +{- | Given limits then encoded text, parse the supported serialization and revalidate its +structure. Malformed/unsupported nodes or exceeded limits return ExprError; no host +code evaluation is used. +-} deserializeExpression :: Limits -> String -> Either ExprError Expr deserializeExpression l source = do encoded <- parseExpression l source diff --git a/src/HMath/Geometry/Collision.hs b/src/HMath/Geometry/Collision.hs index a2a119d..f00e384 100644 --- a/src/HMath/Geometry/Collision.hs +++ b/src/HMath/Geometry/Collision.hs @@ -102,9 +102,13 @@ A zero-depth touch may have the deterministic normal (1,0). -} data Penetration = Penetration { penetrationDepth :: Double + -- ^ Estimated overlap depth along penetrationNormal, in coordinate units. , penetrationNormal :: Point2 + -- ^ Separating direction of the returned EPA penetration estimate. , penetrationError :: Double + -- ^ Remaining absolute support gap at the stopping iteration. , penetrationIterations :: Int + -- ^ Completed expanding-polytope iterations. } deriving (Eq, Show) diff --git a/src/HMath/Geometry/Internal.hs b/src/HMath/Geometry/Internal.hs index 7e534a0..bf08f09 100644 --- a/src/HMath/Geometry/Internal.hs +++ b/src/HMath/Geometry/Internal.hs @@ -71,80 +71,189 @@ data Orientation = Clockwise | Collinear | Counterclockwise deriving (Eq, Ord, S -- | Point position with boundary reported separately. data Location = Outside | Boundary | Inside deriving (Eq, Ord, Show) +{- | Test whether a Double is neither NaN nor infinite. This alone does not impose the +geometry coordinate magnitude cap. +-} finite :: Double -> Bool finite x = not (isNaN x || isInfinite x) + +{- | Given predicate then diagnostic text, return Right () if satisfied or Left (DomainError +text). +-} require :: Bool -> String -> Either MathError () require condition message = if condition then Right () else Left (DomainError message) + +{- | Accept a finite geometry coordinate only when its absolute value is \<=1e50, bounding +downstream Double products. +-} coord :: Double -> Bool coord x = finite x && abs x <= 1e50 + +-- | Extract [x,y] from a Point2 without validation. coords2 :: Point2 -> [Double] coords2 (P2 x y) = [x, y] + +-- | Extract [x,y,z] from a Point3 without validation. coords3 :: Point3 -> [Double] coords3 (P3 x y z) = [x, y, z] + +-- | Extract ordered coordinate list from a PointND without validation. coordsND :: PointND -> [Double] coordsND (PointND xs) = xs + +{- | Validate both Point2 coordinates as finite with absolute magnitude \<=1e50; invalid data +returns DomainError. +-} check2 :: Point2 -> Either MathError () check2 p = require (all coord (coords2 p)) "invalid 2D coordinates (finite, |x|<=1e50)" + +{- | Validate all Point3 coordinates as finite with absolute magnitude \<=1e50; invalid data +returns DomainError. +-} check3 :: Point3 -> Either MathError () check3 p = require (all coord (coords3 p)) "invalid 3D coordinates (finite, |x|<=1e50)" + +{- | Require 1..16 coordinates, all finite and bounded by 1e50 in magnitude. Invalid PointND +returns DomainError. +-} checkND :: PointND -> Either MathError () checkND (PointND xs) = require (not (null xs) && length xs <= 16 && all coord xs) "invalid ND point (dimension 1..16, |x|<=1e50)" + +{- | Validate both ND points and require equal dimensions. Invalid coordinates/rank/mismatch +return DomainError. +-} checkPair :: PointND -> PointND -> Either MathError () checkPair a b = checkND a >> checkND b >> require (length (coordsND a) == length (coordsND b)) "point dimensions differ" + +{- | Return the supplied list if every Double is finite, otherwise Left NonFiniteResult. +This checks numerical results without the coordinate magnitude cap. +-} checked :: [Double] -> Either MathError [Double] checked xs = if all finite xs then Right xs else Left NonFiniteResult + +{- | Given x,y, construct Point2 after bounded finite-coordinate validation. Invalid values +return DomainError. +-} point2 :: Double -> Double -> Either MathError Point2 point2 x y = let p = P2 x y in check2 p >> Right p + +{- | Given x,y,z, construct Point3 after bounded finite-coordinate validation. Invalid +values return DomainError. +-} point3 :: Double -> Double -> Double -> Either MathError Point3 point3 x y z = let p = P3 x y z in check3 p >> Right p + +{- | Construct a checked ND point from 1..16 bounded finite coordinates. Invalid +dimension/value returns DomainError. +-} pointND :: [Double] -> Either MathError PointND pointND xs = let p = PointND xs in checkND p >> Right p + +{- | Unchecked sum of pairwise list products using zipWith; unequal lists truncate to the +shorter length. Checked geometry callers must validate matching dimensions first. +-} dot :: [Double] -> [Double] -> Double dot a b = sum (zipWith (*) a b) + +{- | Return scaled Euclidean list norm to reduce intermediate overflow; empty/all-zero list +yields zero. No finiteness check is added. +-} norm :: [Double] -> Double norm xs = let size = maximum (0 : map abs xs) in if size == 0 then 0 else size * sqrt (sum [(x / size) ^ (2 :: Int) | x <- xs]) + +{- | Unchecked coordinatewise left-minus-right list subtraction, truncating to the shorter +list on mismatch. +-} sub :: [Double] -> [Double] -> [Double] sub = zipWith (-) + +-- | Unchecked coordinatewise list addition, truncating to the shorter list on mismatch. plus :: [Double] -> [Double] -> [Double] plus = zipWith (+) + +{- | Given Double scalar then coordinate list, return all coordinates multiplied by it +without validation. +-} scale :: Double -> [Double] -> [Double] scale a = map (* a) + +{- | Return right-handed cross product of two Point3 vectors. Coordinates/results are +unchecked at this helper boundary. +-} cross :: Point3 -> Point3 -> Point3 cross (P3 a b c) (P3 x y z) = P3 (b * z - c * y) (c * x - a * z) (a * y - b * x) + +-- | Add Point2 coordinates componentwise without validation. add2 :: Point2 -> Point2 -> Point2 add2 (P2 x y) (P2 a b) = P2 (x + a) (y + b) + +-- | Subtract right Point2 coordinates from left, without validation. sub2 :: Point2 -> Point2 -> Point2 sub2 (P2 x y) (P2 a b) = P2 (x - a) (y - b) + +-- | Given scalar then Point2, scale both coordinates without validation. scale2 :: Double -> Point2 -> Point2 scale2 t (P2 x y) = P2 (t * x) (t * y) + +-- | Return 2D determinant ax*by-ay*bx as Double without validation. cross2 :: Point2 -> Point2 -> Double cross2 (P2 x y) (P2 a b) = x * b - y * a + +-- | Return 2D dot product ax*bx+ay*by without validation. dot2 :: Point2 -> Point2 -> Double dot2 a b = dot (coords2 a) (coords2 b) + +-- | Return scaled Euclidean length of a Point2 without checked finite validation. norm2 :: Point2 -> Double norm2 = norm . coords2 + +{- | Convert a list of exactly three Doubles to Point3; all other lengths return origin P3 0 +0 0. This helper does not validate finite coordinates. +-} from3 :: [Double] -> Point3 from3 [x, y, z] = P3 x y z from3 _ = P3 0 0 0 + +{- | Pair each polygon-list element with its cyclic successor, including the last-to-first +edge. Empty list returns []; singleton returns one self-pair. +-} edges :: [a] -> [(a, a)] edges [] = [] edges xs@(first : rest) = zip xs (rest ++ [first]) + +{- | Given finite points a,b,c, compute exact Rational determinant of their represented +Double coordinates. Positive is counterclockwise, zero collinear; non-finite inputs +violate this unchecked helper's precondition. +-} orientExact :: Point2 -> Point2 -> Point2 -> Rational orientExact (P2 ax ay) (P2 bx by) (P2 cx cy) = (toRational bx - toRational ax) * (toRational cy - toRational ay) - (toRational by - toRational ay) * (toRational cx - toRational ax) + +{- | Compare orientExact determinant with zero, returning GT for counterclockwise, EQ for +collinear, LT for clockwise. Inputs must already be finite. +-} orient :: Point2 -> Point2 -> Point2 -> Ordering orient a b c = compare (orientExact a b c) 0 + +{- | Given endpoints a,b then point p, test exact collinearity and inclusive coordinate +bounds. Finite input validation belongs to the checked caller. +-} onSegment :: Point2 -> Point2 -> Point2 -> Bool onSegment a@(P2 ax ay) b@(P2 bx by) p@(P2 x y) = orient a b p == EQ && x >= min ax bx && x <= max ax bx && y >= min ay by && y <= max ay by + +{- | Validate a simple polygon with 3..256 bounded finite vertices, no adjacent duplicates, +nonzero area and no nonadjacent edge intersection. Return validated vertices or +DomainError. +-} checkPolygon :: Polygon -> Either MathError [Point2] checkPolygon (Polygon ps) = do require (length ps >= 3 && length ps <= 256) "polygon requires 3..256 vertices" @@ -163,6 +272,11 @@ checkPolygon (Polygon ps) = do "polygon self-intersects" require (signedArea ps /= 0) "polygon has zero area" Right ps + +{- | Return oriented shoelace area using exact Rational intermediate arithmetic on finite +Double coordinates. Positive means counterclockwise. This helper does not validate +polygon simplicity. +-} signedArea :: [Point2] -> Double signedArea ps = fromRational @@ -170,8 +284,17 @@ signedArea ps = [toRational ax * toRational by - toRational ay * toRational bx | (P2 ax ay, P2 bx by) <- edges ps] / 2 ) + +{- | Return polygon vertices in counterclockwise order by reversing negative signed area; +zero-area input remains unchanged. Validation is the caller's responsibility. +-} ccw :: [Point2] -> [Point2] ccw ps = if signedArea ps < 0 then reverse ps else ps + +{- | Given valid simple polygon vertices then finite Point2, return Boundary for an edge +point, otherwise Inside/Outside by ray parity. This helper performs no constructor +validation. +-} locateUnchecked :: [Point2] -> Point2 -> Location locateUnchecked ps p@(P2 x y) | any (\(a, b) -> onSegment a b p) (edges ps) = Boundary @@ -186,6 +309,9 @@ locateUnchecked ps p@(P2 x y) Inside | otherwise = Outside +{- | Given fallback then list, return its first element or the fallback for empty input. +Example: firstOr 0 [] == 0. +-} firstOr :: a -> [a] -> a firstOr fallback [] = fallback firstOr _ (x : _) = x diff --git a/src/HMath/Geometry/Primitives.hs b/src/HMath/Geometry/Primitives.hs index 7d134d7..ee95fe1 100644 --- a/src/HMath/Geometry/Primitives.hs +++ b/src/HMath/Geometry/Primitives.hs @@ -469,6 +469,10 @@ raySphere ray@(Ray o d) sphere@(Sphere center radius) = do data CircleIntersection = DisjointCircles | CoincidentCircles | CirclePoints [Point2] deriving (Eq, Show) +{- | Given two circles, return DisjointCircles, CoincidentCircles, or CirclePoints for their +intersection. Require valid finite centers and nonnegative bounded radii. Tangency +yields one point; identical zero-radius circles yield their single center. +-} circleIntersection :: Circle -> Circle -> Either MathError CircleIntersection circleIntersection (Circle a r) (Circle b s) = do mapM_ check2 [a, b] diff --git a/src/HMath/Geometry/Spatial.hs b/src/HMath/Geometry/Spatial.hs index bed7a4c..a7e19f8 100644 --- a/src/HMath/Geometry/Spatial.hs +++ b/src/HMath/Geometry/Spatial.hs @@ -35,6 +35,10 @@ newtype PointCloud = Cloud [PointND] deriving (Eq, Show) data Node = Leaf AABB [(Int, PointND)] | Branch AABB [Node] | Ball AABB [Double] Double [Node] deriving (Eq, Show) + +{- | Opaque checked spatial-search tree/hash index. Construction and query functions +document dimension/work limits and exactness flags. +-} data SpatialIndex = Tree Int Node | Hash Int Double (Map.Map [Integer] [(Int, PointND)]) deriving (Eq, Show) @@ -162,9 +166,21 @@ boxDistance p (AABB a b) = {- | A budgeted nearest-neighbor answer; False means unexplored leaves may improve the answer. Returned distances are exact Double Euclidean distances. -} -data NeighborQuery = NeighborQuery {queryNeighbors :: [(Int, Double)], queryLeaves :: Int, queryExhaustive :: Bool} +data NeighborQuery = NeighborQuery + { queryNeighbors :: [(Int, Double)] + -- ^ Nearest candidate IDs paired with Euclidean distances, in increasing distance order. + , queryLeaves :: Int + -- ^ Number of visited spatial-index leaves charged to the query budget. + , queryExhaustive :: Bool + -- ^ True only when unexplored nodes cannot improve the returned neighbors; False marks a budget-limited approximation. + } deriving (Eq, Show) +{- | Given neighbor count k, positive leaf budget, index, then query point, search for +nearest neighbors. Require matching finite coordinate dimension and 1\<=k\<=65536. The +result reports neighbors, visited leaves and whether search was exhaustive; an +exhausted budget is not an exact-neighbor guarantee. +-} nearestQuery :: Int -> Int -> SpatialIndex -> PointND -> Either MathError NeighborQuery nearestQuery k budget index p = do checkND p diff --git a/src/HMath/Graph/Analysis.hs b/src/HMath/Graph/Analysis.hs index 8a39cbe..84c4442 100644 --- a/src/HMath/Graph/Analysis.hs +++ b/src/HMath/Graph/Analysis.hs @@ -49,6 +49,10 @@ weakNeighbors g v = ( S.fromList ([edgeTo e | e <- edges g, edgeFrom e == v] ++ [edgeFrom e | e <- edges g, edgeTo e == v]) ) + +{- | Return Just Bool colors for every vertex if the underlying undirected adjacency is +bipartite, including disconnected components; conflicting edges/loops yield Nothing. +-} bipartiteColors :: Graph -> Maybe [Bool] bipartiteColors g = mapM (`M.lookup` final) (allVertices g) where @@ -70,6 +74,10 @@ bipartiteColors g = mapM (`M.lookup` final) (allVertices g) (allVertices g) final = maybe M.empty id result +{- | Return zero-based greedy colors in vertex order using underlying undirected adjacency. +A self-loop makes proper coloring impossible and returns Left DomainError. Minimal +color count is not guaranteed. +-} greedyColoring :: Graph -> Either MathError [Int] greedyColoring g | any (\e -> edgeFrom e == edgeTo e) (edges g) = @@ -85,6 +93,11 @@ greedyColoring g ) M.empty (allVertices g) + +{- | Given work budget then graph with at most 24 vertices, search for a minimum proper +coloring. Invalid budget/size or self-loops fail; exhausted search returns +NonConvergence. +-} exactColoring :: Int -> Graph -> Either MathError [Int] exactColoring fuel g = do initial <- greedyColoring g @@ -146,6 +159,10 @@ eulerianPath g ((u, i) : _) -> walk ((u, Just i) : stack) (S.insert i used) vertices ids [] -> walk rest used (v : vertices) (maybe ids (: ids) incoming) +{- | Given search budget then graph, find a path visiting every vertex once, returning Maybe +vertex list. Invalid options/exhausted budget fail; Nothing means exhaustive search +found no path. +-} hamiltonianPath :: Int -> Graph -> Either MathError (Maybe [Int]) hamiltonianPath fuel g | fuel < 0 || vertexCount g > 24 = @@ -183,6 +200,10 @@ nearestNeighborTour g start = do answer = if vertexCount g == 1 then Just (0, [start, start]) else go [start] if maybe False (not . finite . fst) answer then Left NonFiniteResult else pure answer +{- | Given improvement-step budget,graph,then closed Hamiltonian tour, improve via pairwise +segment reversals. Validate the tour permutation/edges and finite cost. Return +(cost,tour); invalid input or missing edges fails. +-} twoOptTour :: Int -> Graph -> [Int] -> Either MathError (Double, [Int]) twoOptTour steps g tour | steps < 0 @@ -226,6 +247,11 @@ iterateVector name steps tol update = go steps if maximum (0 : zipWith (\a b -> abs (a - b)) x y) <= tol then Right y else if remaining <= 1 then Left (NonConvergence name steps) else go (remaining - 1) y + +{- | Given iteration budget,tolerance,damping,then graph, return vertex PageRank scores with +dangling-node redistribution. Require nonnegative weights, finite damping in [0,1), +valid tolerance/budget; nonconvergence/numeric failure returns Left MathError. +-} pageRank :: Int -> Double -> Double -> Graph -> Either MathError [Double] pageRank steps tol damping g = do validateIteration steps tol @@ -256,6 +282,11 @@ pageRank steps tol damping g = do ) | v <- allVertices g ] + +{- | Return outgoing traversal degree divided by n-1 for each vertex; n\<=1 yields zeros. +Undirected loops contribute twice and parallel edges are retained, so values can exceed +one. +-} degreeCentrality :: Graph -> [Double] degreeCentrality g = [ if n <= 1 then 0 else fromIntegral (length (neighbors g v)) / fromIntegral (n - 1) @@ -266,6 +297,10 @@ degreeCentrality g = -- Brandes' unweighted accumulation; parallel arcs count as distinct shortest -- edge paths, consistent with the graph's multigraph interpretation. + +{- | Return unweighted shortest-path betweenness by vertex, accounting for shortest-path +multiplicities. Undirected scores are halved; edge weights are not path lengths here. +-} betweennessCentrality :: Graph -> [Double] betweennessCentrality g = map (/ if directed g then 1 else 2) (Foldable.foldl' source (replicate n 0) (allVertices g)) where @@ -308,6 +343,10 @@ unweightedDistances g start = go (M.singleton start 0) [start] let fresh = S.toAscList (S.fromList [u | (u, _, _) <- neighbors g v, M.notMember u dist]) next = Foldable.foldl' (\m u -> M.insert u (dist M.! v + 1) m) dist fresh in go next (vs ++ fresh) + +{- | Return unweighted closeness with reachable-component correction: +reachable^2/((n-1)*sumDistances). Isolated/singleton vertices yield zero. +-} closenessCentrality :: Graph -> [Double] closenessCentrality g = [ let ds = M.elems (unweightedDistances g v); reachable = length ds - 1; total = sum ds @@ -318,6 +357,7 @@ closenessCentrality g = ] where n = vertexCount g + weightedMultiply :: Graph -> [Double] -> [Double] weightedMultiply g x = [sum [edgeWeight e * x !! edgeFrom e | e <- arcs g, edgeTo e == v] | v <- allVertices g] @@ -345,6 +385,10 @@ eigenvectorCentrality steps tol g = do let y = zipWith (+) x (weightedMultiply g x); norm = sqrt (sum (map (\v -> v * v) y)) in map (/ norm) y +{- | Given iterations,tolerance,alpha,beta,then graph, iterate weighted Katz scores. Require +finite alpha>=0 and alpha times maximum absolute incoming weight sum \<1. Invalid input +or nonconvergence fails. +-} katzCentrality :: Int -> Double -> Double -> Double -> Graph -> Either MathError [Double] katzCentrality steps tol alpha beta g = do validateIteration steps tol @@ -358,6 +402,10 @@ katzCentrality steps tol alpha beta g = do tol (map (\v -> beta + alpha * v) . weightedMultiply g) (replicate (vertexCount g) beta) + +{- | Return local undirected clustering coefficients from distinct non-self neighbor sets. +Degree below two yields zero. Directed graphs fail. +-} clusteringCoefficients :: Graph -> Either MathError [Double] clusteringCoefficients g = do requireUndirected g @@ -397,6 +445,10 @@ diameterRadius g where distances = map (unweightedDistances g) (allVertices g) +{- | Given normalized Bool then nonnegative-weight undirected graph, return dense +combinatorial or normalized Laplacian rows. Directed/negative-weight graphs or +non-finite arithmetic fail. +-} graphLaplacian :: Bool -> Graph -> Either MathError [[Double]] graphLaplacian normalized g = do requireUndirected g @@ -482,6 +534,11 @@ communityInput g = do if any ((< 0) . edgeWeight) (edges g) then Left (DomainError "nonnegative community weights required") else Right () + +{- | Given undirected nonnegative-weight graph then one community label per vertex, return +weighted modularity. Invalid graph/label length or arithmetic fails; loops follow the +module degree convention. +-} modularity :: Graph -> [Int] -> Either MathError Double modularity g labels = do communityInput g diff --git a/src/HMath/Graph/Core.hs b/src/HMath/Graph/Core.hs index df4eb26..dfe4d7c 100644 --- a/src/HMath/Graph/Core.hs +++ b/src/HMath/Graph/Core.hs @@ -62,35 +62,93 @@ import qualified HMath.DataStructure as U import HMath.Error (MathError (..)) import Text.Read (readMaybe) -data Edge = Edge {edgeId :: Int, edgeFrom :: Int, edgeTo :: Int, edgeWeight :: Double} +{- | Finite weighted multigraph edge with stable identity and zero-based endpoints. Parallel +edges and loops retain separate IDs. +-} +data Edge = Edge + { edgeId :: Int + -- ^ Stable zero-based identity assigned by original input edge order. + , edgeFrom :: Int + -- ^ Zero-based source endpoint of the original edge. + , edgeTo :: Int + -- ^ Zero-based destination endpoint of the original edge. + , edgeWeight :: Double + -- ^ Finite Double edge weight, retaining loops/parallel-edge identity. + } deriving (Eq, Ord, Show, Read) + +{- | Opaque validated directed/undirected finite multigraph, constructed with graph or +checked conversion functions. +-} data Graph = Graph Bool Int [Edge] deriving (Eq, Show) + +{- | Return whether the graph is directed. Undirected edges are represented once in edges +and twice in arcs, including loops. +-} directed :: Graph -> Bool directed (Graph d _ _) = d + +{- | Return graph vertex count. Valid vertex labels are zero-based integers below this +count. +-} vertexCount :: Graph -> Int vertexCount (Graph _ n _) = n + +{- | Return original labeled edges in input order, preserving loops, multiplicity and stable +edge IDs. +-} edges :: Graph -> [Edge] edges (Graph _ _ es) = es + +{- | Test whether a Double is neither NaN nor infinite; used by checked graph +weight/arithmetic validation. +-} finite :: Double -> Bool finite x = not (isNaN x || isInfinite x) + +{- | Given directed flag,vertex count,then (from,to,weight) triples, construct a multigraph +with stable input-order edge IDs. Require 0\<=vertices\<=512, \<=65536 edges, valid +endpoints and finite weights; otherwise return Left InvalidArgument. +-} graph :: Bool -> Int -> [(Int, Int, Double)] -> Either MathError Graph graph d n es | n < 0 || n > 512 || length es > 65536 = Left (InvalidArgument "graph size limit exceeded") | any (\(u, v, w) -> u < 0 || v < 0 || u >= n || v >= n || not (finite w)) es = Left (InvalidArgument "invalid graph endpoint/weight") | otherwise = Right (Graph d n [Edge i u v w | (i, (u, v, w)) <- zip [0 ..] es]) + +{- | Given graph then vertex index, return Right () only for a label in [0,vertexCount). +Invalid labels return Left InvalidArgument. +-} checkVertex :: Graph -> Int -> Either MathError () checkVertex g v | v < 0 || v >= vertexCount g = Left (InvalidArgument "graph vertex out of bounds") | otherwise = Right () + +{- | Return Right () for an undirected graph; directed input returns Left InvalidArgument. +No graph conversion occurs. +-} requireUndirected :: Graph -> Either MathError () requireUndirected g | directed g = Left (InvalidArgument "undirected graph required") | otherwise = Right () + +{- | Return directed traversal arcs. An undirected edge yields forward and reverse arcs +sharing one original ID; a loop therefore yields two arcs. +-} arcs :: Graph -> [Edge] arcs g | directed g = edges g | otherwise = concat [[e, e{edgeFrom = edgeTo e, edgeTo = edgeFrom e}] | e <- edges g] + +{- | Given graph then vertex, return sorted (destination,weight,edge ID) traversal entries +leaving that vertex. Parallel edges/loops are preserved. This query does not itself +reject invalid vertex labels. +-} neighbors :: Graph -> Int -> [(Int, Double, Int)] neighbors g v = sort [(edgeTo e, edgeWeight e, edgeId e) | e <- arcs g, edgeFrom e == v] + +{- | Return one sorted neighbors row per zero-based vertex, retaining weight and edge +identity for every traversal arc. +-} adjacencyList :: Graph -> [[(Int, Double, Int)]] adjacencyList g = [neighbors g v | v <- [0 .. vertexCount g - 1]] @@ -121,6 +179,10 @@ fromAdjacencyList d rows orientations = orientations ) +{- | Given directed flag,square cells of (edge ID,weight) lists,then original edge +orientations, reconstruct a lossless graph. Validate square shape, canonical IDs/arcs +and graph bounds through fromCSR; malformed input fails. +-} fromLabeledAdjacencyMatrix :: Bool -> [[[(Int, Double)]]] -> [(Int, Int)] -> Either MathError Graph fromLabeledAdjacencyMatrix d cells orientations | any ((/= length cells) . length) cells = Left (InvalidArgument "adjacency matrix must be square") @@ -143,16 +205,30 @@ fromAdjacencyMatrix d matrix where n = length matrix +{- | Lossless labeled compressed adjacency storage. Offsets index target/weight/ID arrays; +orientations preserve original undirected edge direction. +-} data CSR = CSR { csrDirected :: Bool + -- ^ Whether CSR traversal represents a directed graph. , csrVertices :: Int + -- ^ Number of graph vertices, including isolated rows. , csrOffsets :: [Int] + -- ^ Row pointer array of length vertices+1, starting at zero and ending at traversal entry count. , csrTargets :: [Int] + -- ^ Destination vertex for each compressed traversal entry. , csrWeights :: [Double] + -- ^ Finite edge weight for each traversal entry. , csrIds :: [Int] + -- ^ Original edge ID for each traversal entry; an undirected edge contributes two arcs sharing its ID. , csrOrientations :: [(Int, Int)] + -- ^ Original endpoint orientation for each edge ID, required for lossless undirected round-trip. } deriving (Eq, Show, Read) + +{- | Convert a graph to lossless CSR rows with offsets, targets, weights, IDs and original +edge orientations. Preserve loops and multiedge identity. +-} toCSR :: Graph -> CSR toCSR g = let rows = adjacencyList g; entries = concat rows @@ -164,6 +240,11 @@ toCSR g = [w | (_, w, _) <- entries] [i | (_, _, i) <- entries] [(edgeFrom e, edgeTo e) | e <- edges g] + +{- | Validate CSR sizes, offsets, endpoint/weight/ID arrays and original orientations, then +reconstruct a canonical graph. Malformed or noncanonical data returns Left +InvalidArgument. +-} fromCSR :: CSR -> Either MathError Graph fromCSR input@(CSR d n offsets targets weights ids orientations) | n < 0 @@ -205,19 +286,41 @@ fromCSR input@(CSR d n offsets targets weights ids orientations) Right (u, v, w) | otherwise -> Left (InvalidArgument "CSR edge identity/orientation mismatch") +{- | Validated graph with explicit left/right vertex partition. Construct from part-local +endpoints using bipartiteGraph. +-} data BipartiteGraph = BipartiteGraph Int Graph deriving (Eq, Show) + +{- | Given left count,right count,then (left-local,right-local,weight) triples, construct an +undirected bipartite graph. Right vertices are offset by left count internally. +Negative/out-of-range endpoints, non-finite weights or graph size bounds fail. +-} bipartiteGraph :: Int -> Int -> [(Int, Int, Double)] -> Either MathError BipartiteGraph bipartiteGraph left right es | left < 0 || right < 0 || any (\(u, v, _) -> u < 0 || u >= left || v < 0 || v >= right) es = Left (InvalidArgument "bipartite endpoints out of bounds") | otherwise = BipartiteGraph left <$> graph False (left + right) [(u, left + v, w) | (u, v, w) <- es] + +-- | Return (left vertex count,right vertex count) of a bipartite graph. bipartiteParts :: BipartiteGraph -> (Int, Int) bipartiteParts (BipartiteGraph l g) = (l, vertexCount g - l) + +{- | Return underlying undirected graph, whose right-part global labels start at the +left-part count. +-} bipartiteBase :: BipartiteGraph -> Graph bipartiteBase (BipartiteGraph _ g) = g +{- | Validated finite vertex set with canonical sorted distinct vertices per hyperedge. +Construct with hypergraph. +-} data Hypergraph = Hypergraph Int [[Int]] deriving (Eq, Show) + +{- | Given vertex count then hyperedge vertex lists, validate bounded size/endpoints and +construct a hypergraph. Canonicalize vertices within each hyperedge by +sorting/deduplicating. Invalid bounds fail. +-} hypergraph :: Int -> [[Int]] -> Either MathError Hypergraph hypergraph n es | n < 0 @@ -227,14 +330,24 @@ hypergraph n es || any (\e -> length (nub e) /= length e) es = Left (InvalidArgument "invalid hypergraph") | otherwise = Right (Hypergraph n (map sort es)) + +-- | Return the number of zero-based vertices in a hypergraph. hyperVertices :: Hypergraph -> Int hyperVertices (Hypergraph n _) = n + +{- | Return canonical hyperedge lists with sorted distinct member vertices, preserving +hyperedge list order. +-} hyperedges :: Hypergraph -> [[Int]] hyperedges (Hypergraph _ es) = es {- | Versioned Haskell tuple grammar. Deserialization validates all invariants, requires full-input parsing and limits input text to 16 MiB. -} + +{- | Serialize a bipartite graph with HMath.BipartiteGraph/1 version marker and local part +labels. Pair with deserializeBipartiteGraph for checked round-trip. +-} serializeBipartiteGraph :: BipartiteGraph -> String serializeBipartiteGraph bip = let (left, right) = bipartiteParts bip @@ -245,6 +358,9 @@ serializeBipartiteGraph bip = , [(edgeFrom e, edgeTo e - left, edgeWeight e) | e <- edges (bipartiteBase bip)] ) +{- | Read a versioned bipartite serialization, then validate part counts, endpoints and +weights. Reject unknown/malformed encoding or input longer than 16777216 characters. +-} deserializeBipartiteGraph :: String -> Either MathError BipartiteGraph deserializeBipartiteGraph text | length text > 16777216 = Left (InvalidArgument "serialized bipartite graph too large") @@ -252,19 +368,32 @@ deserializeBipartiteGraph text Just (version, left, right, es) | version == ("HMath.BipartiteGraph/1" :: String) -> bipartiteGraph left right es _ -> Left (InvalidArgument "invalid bipartite serialization/version") +{- | Serialize graph direction, vertex count and input-ordered edges with HMath.Graph/1 +marker; stable IDs reconstruct from edge order. +-} serializeGraph :: Graph -> String serializeGraph g = show ("HMath.Graph/1", directed g, vertexCount g, [(edgeFrom e, edgeTo e, edgeWeight e) | e <- edges g]) +{- | Read complete HMath.Graph/1 encoding and reconstruct via checked graph constructor. +Unknown version, malformed text, input over 16777216 characters or invalid graph data +fails. +-} deserializeGraph :: String -> Either MathError Graph deserializeGraph text | length text > 16777216 = Left (InvalidArgument "serialized graph too large") | otherwise = case readMaybe text of Just (version, d, n, es) | version == ("HMath.Graph/1" :: String) -> graph d n es _ -> Left (InvalidArgument "invalid graph serialization/version") + +-- | Serialize vertex count and canonical hyperedges with HMath.Hypergraph/1 version marker. serializeHypergraph :: Hypergraph -> String serializeHypergraph h = show ("HMath.Hypergraph/1", hyperVertices h, hyperedges h) + +{- | Read versioned hypergraph encoding and validate through hypergraph. Reject +unknown/malformed input, more than 16777216 characters or invalid graph bounds. +-} deserializeHypergraph :: String -> Either MathError Hypergraph deserializeHypergraph text | length text > 16777216 = Left (InvalidArgument "serialized hypergraph too large") @@ -272,6 +401,10 @@ deserializeHypergraph text Just (version, n, es) | version == ("HMath.Hypergraph/1" :: String) -> hypergraph n es _ -> Left (InvalidArgument "invalid hypergraph serialization/version") +{- | Given graph then valid start vertex, return breadth-first reachable-vertex order with +sorted neighbor tie-breaking. Invalid start fails; disconnected unreachable vertices +are omitted. +-} bfs :: Graph -> Int -> Either MathError [Int] bfs g start = do checkVertex g start; pure (go S.empty [start]) where @@ -279,6 +412,10 @@ bfs g start = do checkVertex g start; pure (go S.empty [start]) go seen (v : rest) | S.member v seen = go seen rest | otherwise = v : go (S.insert v seen) (rest ++ [u | (u, _, _) <- neighbors g v]) + +{- | Given graph then valid start vertex, return depth-first reachable-vertex order with +deterministic sorted neighbors. Invalid start fails; each reached vertex appears once. +-} dfs :: Graph -> Int -> Either MathError [Int] dfs g start = do checkVertex g start; pure (go S.empty [start]) where @@ -311,6 +448,9 @@ iterativeDeepening b g source target = do (Right (Nothing, fuel - 1)) [v | (v, _, _) <- neighbors g (last path), v `notElem` path] +{- | Return a deterministic topological order of all vertices of a directed acyclic graph. +Undirected graphs or directed cycles return Left MathError. +-} topologicalSort :: Graph -> Either MathError [Int] topologicalSort g | not (directed g) = Left (InvalidArgument "topological sort requires directed graph") @@ -320,6 +460,10 @@ topologicalSort g go out remaining = case [v | v <- remaining, not (any (\e -> edgeTo e == v && edgeFrom e `elem` remaining) (edges g))] of [] -> Left (DomainError "directed cycle") (v : _) -> go (out ++ [v]) (filter (/= v) remaining) + +{- | Test for a directed or undirected cycle, respecting original edge identities. Loops and +parallel undirected edges can form cycles. +-} hasCycle :: Graph -> Bool hasCycle g | directed g = either (const True) (const False) (topologicalSort g) @@ -332,6 +476,10 @@ hasCycle g same <- U.connected (edgeFrom e) (edgeTo e) uf next <- U.union (edgeFrom e) (edgeTo e) uf pure (found || same, next) + +{- | Return weak connected components as sorted vertex lists, ignoring edge direction and +retaining isolated vertices. +-} connectedComponents :: Graph -> [[Int]] connectedComponents g = go S.empty [0 .. vertexCount g - 1] where @@ -369,6 +517,9 @@ tarjanSCC g = sort (map sort output) let (c, i, l, s, o, cs) = state in (c, i, M.insert v (min (l M.! v) (idx M.! u)) l, s, o, cs) | otherwise = state +{- | Return sorted strongly connected components via Kosaraju traversal; undirected graphs +reduce to ordinary connected components. +-} kosarajuSCC :: Graph -> [[Int]] kosarajuSCC g = sort (map sort (snd (Foldable.foldl' second (S.empty, []) order))) where @@ -406,6 +557,9 @@ articulationPoints g = do (S.insert v seen) ([u | (u, _, i) <- neighbors g v, Just u /= removed, Just i /= edgeRemoved] ++ vs) +{- | Return original IDs of bridges in an undirected multigraph; parallel edges are treated +distinctly. Directed input returns Left InvalidArgument. +-} bridges :: Graph -> Either MathError [Int] bridges g = do requireUndirected g @@ -417,6 +571,9 @@ bridges g = do > length (connectedComponents g) ] +{- | Return a minimum spanning forest of an undirected weighted graph by Kruskal, breaking +ties by stable edge ID. Disconnected graphs return a forest; directed input fails. +-} kruskal :: Graph -> Either MathError [Edge] kruskal g = do requireUndirected g @@ -446,6 +603,9 @@ prim g = do requireUndirected g; pure (go S.empty []) (e : _) -> go (S.insert (edgeFrom e) (S.insert (edgeTo e) seen)) (out ++ [e]) [] -> go (S.insert (([v | v <- [0 .. vertexCount g - 1], S.notMember v seen] !! 0)) seen) out +{- | Return an undirected minimum spanning forest by repeatedly merging components along +cheapest outgoing edges. Preserve original edge identity; directed input fails. +-} boruvka :: Graph -> Either MathError [Edge] boruvka g = do requireUndirected g diff --git a/src/HMath/Graph/Flow.hs b/src/HMath/Graph/Flow.hs index 6b0a61b..a0d9670 100644 --- a/src/HMath/Graph/Flow.hs +++ b/src/HMath/Graph/Flow.hs @@ -27,15 +27,32 @@ import qualified Data.Set as S import HMath.Error (MathError (..)) import HMath.Graph.Core +{- | Directed integral-capacity/unit-cost edge with stable identity. Capacities are +nonnegative; costs may be negative. +-} data NetworkEdge = NetworkEdge { networkEdgeId :: Int + -- ^ Stable original edge identity in network input order. , networkFrom :: Int + -- ^ Source vertex of this directed network edge. , networkTo :: Int + -- ^ Destination vertex of this directed network edge. , networkCapacity :: Integer + -- ^ Exact nonnegative Integer capacity of this edge. , networkCost :: Integer + -- ^ Exact Integer cost per unit flow; may be negative. } deriving (Eq, Show) + +{- | Opaque exact network-flow input with stable parallel/antiparallel edges, constructed +with network. +-} data Network = Network Int [NetworkEdge] deriving (Eq, Show) + +{- | Given vertex count then (from,to,capacity,cost) edges, construct an exact integral +network with stable edge IDs. Require \<=512 vertices, \<=65536 edges, valid endpoints +and nonnegative capacities. Costs may be negative. +-} network :: Int -> [(Int, Int, Integer, Integer)] -> Either MathError Network network n es | n < 0 @@ -44,11 +61,24 @@ network n es || any (\(u, v, c, _) -> u < 0 || v < 0 || u >= n || v >= n || c < 0) es = Left (InvalidArgument "invalid network size/endpoints/capacity") | otherwise = Right (Network n [NetworkEdge i u v c w | (i, (u, v, c, w)) <- zip [0 ..] es]) + +-- | Return original network edges in input/ID order, retaining capacities and costs. networkEdges :: Network -> [NetworkEdge] networkEdges (Network _ es) = es -data FlowResult = FlowResult {flowValue :: Integer, edgeFlows :: [Integer], flowCost :: Integer} +{- | Exact net flow,total edge cost,and original-edge-order flows. A maximum-flow result +alone does not certify minimum cost. +-} +data FlowResult = FlowResult + { flowValue :: Integer + -- ^ Exact net flow leaving the chosen source. + , edgeFlows :: [Integer] + -- ^ Exact edge flows in original network edge order, preserving parallel and antiparallel identity. + , flowCost :: Integer + -- ^ Sum of edge flow times edge unit cost; maximum-flow methods do not necessarily minimize this cost. + } deriving (Eq, Show) + type Residual = M.Map Int Integer arcData :: Network -> Int -> (Int, Int, Integer) arcData (Network _ es) i = @@ -106,9 +136,23 @@ augmenting breadth b net s t = do valid b net s t; go b (initial net) | fuel <= 0 -> Left (NonConvergence "augmenting maximum flow" b) | otherwise -> go (fuel - 1) (augment (minimum [r M.! i | i <- path]) path r) fordFulkerson, edmondsKarp :: Int -> Network -> Int -> Int -> Either MathError FlowResult + +{- | Given augmentation budget,network,source,sink, compute exact maximum flow using +depth-first augmenting paths. Invalid/non-distinct endpoints or negative budget fails; +exhausted budget returns NonConvergence. Result retains per-edge flows and total cost. +-} fordFulkerson = augmenting False + +{- | Given augmentation budget,network,source,sink, compute exact maximum flow using +breadth-first shortest augmenting paths. Invalid input or exhausted budget fails; +parallel/antiparallel edge flows retain identity. +-} edmondsKarp = augmenting True +{- | Given work budget,network,source,sink, compute maximum flow with level graphs and +blocking-flow augmentation. Invalid source/sink/budget or exhausted work returns Left +MathError; result includes flows in original edge order. +-} dinic :: Int -> Network -> Int -> Int -> Either MathError FlowResult dinic b net s t = do valid b net s t; phase b (initial net) where @@ -136,6 +180,10 @@ dinic b net s t = do valid b net s t; phase b (initial net) | fuel <= 0 -> Left (NonConvergence "Dinic maximum flow" b) | otherwise -> block (fuel - 1) (augment (minimum [r M.! i | i <- path]) path r) dist +{- | Given push/relabel work budget,network,source,sink, compute exact maximum flow by +preflow and relabel operations. Reject invalid endpoints/budget; work exhaustion +returns NonConvergence. +-} pushRelabel :: Int -> Network -> Int -> Int -> Either MathError FlowResult pushRelabel b net@(Network n _) s t = do valid b net s t diff --git a/src/HMath/Graph/Paths.hs b/src/HMath/Graph/Paths.hs index da90954..f181327 100644 --- a/src/HMath/Graph/Paths.hs +++ b/src/HMath/Graph/Paths.hs @@ -39,6 +39,10 @@ nonnegative g checkedSum :: Double -> Double -> Either MathError Double checkedSum a b = let c = a + b in if finite c then Right c else Left NonFiniteResult +{- | Given graph then source list, return distance to the nearest supplied source, each +seeded at zero. Invalid sources, negative weights or non-finite arithmetic fail. Empty +sources give all Nothing. +-} multiSourceDijkstra :: Graph -> [Int] -> Either MathError [Maybe Double] multiSourceDijkstra g sources = do mapM_ (checkVertex g) sources @@ -57,6 +61,10 @@ multiSourceDijkstra g sources = do (neighbors g v) go (S.insert v visited) next +{- | Given graph then source, return minimum distances in vertex order, with Nothing for +unreachable vertices. Require valid source and nonnegative weights; invalid input or +non-finite arithmetic fails. +-} dijkstra :: Graph -> Int -> Either MathError [Maybe Double] dijkstra g source = multiSourceDijkstra g [source] @@ -69,6 +77,10 @@ relax es initial = foldM step initial es repeatRelax :: Int -> [Edge] -> Distances -> Either MathError Distances repeatRelax count es initial = foldM (\m _ -> relax es m) initial [1 .. count] +{- | Given graph then source, return minimum distances including negative weights. Invalid +source, reachable negative cycle or non-finite arithmetic returns Left MathError; +unreachable vertices are Nothing. +-} bellmanFord :: Graph -> Int -> Either MathError [Maybe Double] bellmanFord g source = do checkVertex g source @@ -76,6 +88,9 @@ bellmanFord g source = do next <- relax (arcs g) dist if next /= dist then Left (DomainError "reachable negative cycle") else finish g dist +{- | Return all-pairs minimum-distance rows, with Nothing for unreachable pairs. Negative +edges are allowed; any negative cycle or non-finite arithmetic fails. +-} floydWarshall :: Graph -> Either MathError [[Maybe Double]] floydWarshall g = do let n = vertexCount g @@ -238,6 +253,10 @@ kShortestPaths fuel count g source target = do [(u, w, i) | (u, w, i) <- neighbors g v, u `notElem` path] go (b - 1) (rest ++ added) out +{- | Given directed acyclic graph then source, return maximum path-weight distance to each +vertex, Nothing for unreachable vertices. Invalid source, cycles/undirected input or +non-finite arithmetic fails. +-} longestDAGPaths :: Graph -> Int -> Either MathError [Maybe Double] longestDAGPaths g source = do checkVertex g source diff --git a/src/HMath/Image/Color.hs b/src/HMath/Image/Color.hs index da6b6b7..6b192e0 100644 --- a/src/HMath/Image/Color.hs +++ b/src/HMath/Image/Color.hs @@ -13,6 +13,9 @@ module HMath.Image.Color (ColorSpace (..), convertColor, grayscale, srgbToLinear import HMath.Error import HMath.Image.Core +{- | Color coordinate convention,including sRGB,linear RGB,HSV,HSL,XYZ,Lab,and YCbCr. +convertColor validates each source convention's ranges. +-} data ColorSpace = SRGB | LinearRGB | HSV | HSL | XYZ | Lab | YCbCr deriving (Eq, Show) {- | Transfer functions extend linearly below their positive breakpoints; @@ -21,8 +24,13 @@ finite negative/out-of-gamut channels are retained. srgbToLinear :: Double -> Either MathError Double srgbToLinear x = do require (finite x) "nonfinite sRGB channel"; scalar (decode x) +{- | Encode a finite linear-light channel with the sRGB piecewise transfer function (linear +branch through 0.0031308). No automatic clipping is performed. Non-finite input/result +returns Left MathError. +-} linearToSrgb :: Double -> Either MathError Double linearToSrgb x = do require (finite x) "nonfinite linear RGB channel"; scalar (encode x) + scalar :: Double -> Either MathError Double scalar x = do _ <- checked [x]; Right x decode, encode :: Double -> Double diff --git a/src/HMath/Image/Core.hs b/src/HMath/Image/Core.hs index d1e696a..fdf305e 100644 --- a/src/HMath/Image/Core.hs +++ b/src/HMath/Image/Core.hs @@ -38,11 +38,24 @@ import Data.Array (Array, elems, listArray, (!)) import HMath.Error import qualified HMath.Tensor as T +{- | Opaque finite CPU image with row-major spatial axes and interleaved channels. Construct +with image; shape/channel/storage limits are checked. +-} data Image = Image [Int] Int (Array Int Double) deriving (Eq, Show) + +-- | Test whether Double is neither NaN nor infinite. finite :: Double -> Bool finite x = not (isNaN x || isInfinite x) + +{- | Given predicate then diagnostic, return Right () or image-prefixed Left +InvalidArgument. +-} require :: Bool -> String -> Either MathError () require p message = if p then Right () else Left (InvalidArgument ("image: " ++ message)) + +{- | Return finite Double values unchanged, or Left NonFiniteResult when any sample is +non-finite. +-} checked :: [Double] -> Either MathError [Double] checked values = if all finite values then Right values else Left NonFiniteResult @@ -66,34 +79,66 @@ fromTensor tensor = do require (length dims >= 2) "tensor needs spatial and channel axes" image (init dims) (last dims) (T.tensorValues tensor) +{- | Copy an image to Tensor Double with shape spatial dimensions followed by channel count. +Values remain row-major with interleaved channels; checked tensor size errors +propagate. +-} toTensor :: Image -> Either MathError (T.Tensor Double) toTensor img = T.tensor (imageShape img ++ [imageChannels img]) (imageValues img) + +-- | Return spatial dimensions only, excluding the last implicit channel axis. imageShape :: Image -> [Int] imageShape (Image dims _ _) = dims + +-- | Return channel count, between one and sixteen for validated images. imageChannels :: Image -> Int imageChannels (Image _ channels _) = channels + +-- | Return flat row-major samples with channels interleaved at each spatial coordinate. imageValues :: Image -> [Double] imageValues (Image _ _ values) = elems values + +-- | Return number of spatial pixels (shape product), excluding channel multiplicity. spatialSize :: Image -> Int spatialSize = product . imageShape + +{- | Enumerate zero-based row-major coordinates of a dimension list. [] yields [[]]; +zero/negative extents yield no coordinates. This helper performs no image validation. +-} coordinates :: [Int] -> [[Int]] coordinates [] = [[]] coordinates (d : ds) = [i : is | i <- [0 .. d - 1], is <- coordinates ds] -- Internal indexing kernel: callers must have checked rank/range and channel. + +{- | Unchecked image access: given image,complete spatial coordinates,then channel, return +one sample. Checked callers must validate rank/ranges; invalid indices can raise an +array error. +-} at :: Image -> [Int] -> Int -> Double at (Image dims channels values) ix c = values ! (foldl (\acc (i, d) -> acc * d + i) 0 (zip ix dims) * channels + c) +{- | Given image then complete spatial coordinates, return all channel values in order. +Invalid coordinate rank/range returns Left InvalidArgument. +-} pixel :: Image -> [Int] -> Either MathError [Double] pixel img ix = do require (length ix == length (imageShape img) && and (zipWith (\i d -> i >= 0 && i < d) ix (imageShape img))) "pixel index out of range" Right [at img ix c | c <- [0 .. imageChannels img - 1]] + +{- | Given zero-based channel index then image, return a copied one-channel image of the +same spatial shape. Invalid channel index fails. +-} channel :: Int -> Image -> Either MathError Image channel c img = do require (c >= 0 && c < imageChannels img) "channel index out of range" image (imageShape img) 1 [at img ix c | ix <- coordinates (imageShape img)] + +{- | Concatenate channels of a nonempty same-spatial-shape image list in input order. +Require total channels\<=16; shape/count or checked storage limits fail. +-} combineChannels :: [Image] -> Either MathError Image combineChannels images = do require (not (null images)) "no channels to combine" @@ -108,6 +153,9 @@ combineChannels images = do mapImage :: (Double -> Double) -> Image -> Either MathError Image mapImage f img = image (imageShape img) (imageChannels img) (map f (imageValues img)) +{- | Given binary sample function then equally shaped/channel-count images, return a new +validated image. Mismatched shape/channels or non-finite output returns Left MathError. +-} zipImage :: (Double -> Double -> Double) -> Image -> Image -> Either MathError Image zipImage f a b = do require (imageShape a == imageShape b && imageChannels a == imageChannels b) "image shape mismatch" @@ -141,6 +189,9 @@ gamma power img = do "gamma needs positive exponent/nonnegative data" mapImage (** power) img +{- | Image sampling policy: Constant fill,edge Clamp,half-sample symmetric Reflect,or +periodic Wrap. +-} data Boundary = Constant Double | Clamp | Reflect | Wrap deriving (Eq, Show) {- | Reflect is half-sample symmetric (... b a | a b c | c b ...). diff --git a/src/HMath/Image/Filter.hs b/src/HMath/Image/Filter.hs index ff2bff2..35ba335 100644 --- a/src/HMath/Image/Filter.hs +++ b/src/HMath/Image/Filter.hs @@ -31,9 +31,16 @@ import qualified Data.Set as Set import HMath.Error import HMath.Image.Core +{- | Validate Constant boundary value as finite; Clamp,Reflect,Wrap are always valid. +Non-finite constant returns Left InvalidArgument. +-} validateBoundary :: Boundary -> Either MathError () validateBoundary (Constant value) = require (finite value) "nonfinite boundary constant" validateBoundary _ = Right () + +{- | Require a two-dimensional one-channel image and return (height,width). Other +spatial/channel layouts return Left InvalidArgument. +-} scalar2D :: Image -> Either MathError (Int, Int) scalar2D img = do require (length (imageShape img) == 2 && imageChannels img == 1) "one-channel 2D image required" @@ -60,6 +67,11 @@ correlate boundary dims weights img = do apply ix c = sum [w * sample boundary img (zipWith (+) ix offset) c | (offset, w) <- zip offsets weights] build (imageShape img) (imageChannels img) apply +{- | Given boundary,kernel dimensions,flat weights,then image, reverse all kernel axes and +correlate. Channels are filtered independently; require odd extents\<=65, matching +rank/count, \<=4096 weights and \<=20000000 sample operations. Invalid/non-finite +input/result fails. +-} convolve :: Boundary -> [Int] -> [Double] -> Image -> Either MathError Image convolve boundary dims weights = correlate boundary dims (reverse weights) @@ -77,6 +89,9 @@ gaussianBlur boundary sigma radius img = do img [0 .. rank - 1] +{- | Given radius then image, enumerate centered neighborhood offsets. Require radius in +[0,16], \<=4096 neighbors and \<=20000000 sample operations; otherwise fail. +-} windowOffsets :: Int -> Image -> Either MathError [[Int]] windowOffsets radius img = do let rank = length (imageShape img); count = (2 * toInteger radius + 1) ^ rank @@ -88,6 +103,11 @@ windowOffsets radius img = do ) "neighborhood/work limit" Right (map (map (subtract radius)) (coordinates (replicate rank (2 * radius + 1)))) + +{- | Given boundary,radius,then image, average a centered full-dimensional box neighborhood +independently per channel. Neighborhood/work bounds and boundary finiteness are +checked; invalid/non-finite output fails. +-} boxBlur :: Boundary -> Int -> Image -> Either MathError Image boxBlur boundary radius img = do validateBoundary boundary @@ -99,6 +119,10 @@ boxBlur boundary radius img = do sum [sample boundary img (zipWith (+) ix offset) c / fromIntegral (length offsets) | offset <- offsets] ) + +{- | Given boundary,radius,then image, choose the median of each centered odd-sized +neighborhood independently per channel. Invalid boundary/neighborhood/work bounds fail. +-} medianBlur :: Boundary -> Int -> Image -> Either MathError Image medianBlur boundary radius img = do validateBoundary boundary @@ -145,6 +169,7 @@ sharpen boundary amount sigma radius img = do blurred <- gaussianBlur boundary sigma radius img zipImage (\x y -> x + amount * (x - y)) img blurred +-- | Image gradient stencil selector, choosing Sobel,Prewitt,or Scharr. data GradientOperator = Sobel | Prewitt | Scharr deriving (Eq, Show) {- | Returns row derivative, column derivative, magnitude, and atan2(row,col) @@ -171,6 +196,9 @@ gradient operator boundary img = do angle <- zipImage atan2 dr dc Right (dr, dc, mag, angle) +{- | Given boundary then one-channel 2D image, apply the four-neighbor 3-by-3 Laplacian +[0,1,0;1,-4,1;0,1,0]. Invalid image/boundary or non-finite output fails. +-} laplacian :: Boundary -> Image -> Either MathError Image laplacian boundary img = do _ <- scalar2D img; correlate boundary [3, 3] [0, 1, 0, 1, -4, 1, 0, 1, 0] img @@ -209,6 +237,7 @@ canny boundary sigma radius low high img = do edges = flood (Set.toList strong) strong build [height, width] 1 (\ix _ -> if Set.member (ix !! 0, ix !! 1) edges then 1 else 0) +-- | Grayscale footprint operation selector: erosion,dilation,opening,or closing. data Morphology = Erosion | Dilation | Opening | Closing deriving (Eq, Show) {- | Flat grayscale morphology with an explicit odd-rank Boolean footprint. @@ -248,6 +277,10 @@ morphology operation boundary dims footprint img = do Opening -> erode img >>= dilate Closing -> dilate img >>= erode +{- | Given boundary,footprint dimensions,Bool footprint,then image, return dilation minus +erosion. Shape/footprint/work/boundary validation and finite output checks propagate +from morphology. +-} morphologicalGradient :: Boundary -> [Int] -> [Bool] -> Image -> Either MathError Image morphologicalGradient boundary dims footprint img = do dilated <- morphology Dilation boundary dims footprint img diff --git a/src/HMath/Image/Histogram.hs b/src/HMath/Image/Histogram.hs index 5c36a7a..e229dfa 100644 --- a/src/HMath/Image/Histogram.hs +++ b/src/HMath/Image/Histogram.hs @@ -20,6 +20,10 @@ bin :: Int -> Double -> Int bin bins x = min (bins - 1) (floor (x * fromIntegral bins)) counts :: Int -> [Double] -> [Int] counts bins values = elems (accumArray (+) 0 (0, bins - 1) [(bin bins x, 1) | x <- values] :: Array Int Int) + +{- | Given bin count in [2,4096] then image with every sample in [0,1], return one Int count +list per channel. Values at 1 enter the final bin. Invalid count/range fails. +-} histogram :: Int -> Image -> Either MathError [[Int]] histogram bins img = do unit bins img diff --git a/src/HMath/Image/Measure.hs b/src/HMath/Image/Measure.hs index ad56380..e7718ed 100644 --- a/src/HMath/Image/Measure.hs +++ b/src/HMath/Image/Measure.hs @@ -21,6 +21,9 @@ import HMath.Error import HMath.Image.Core import HMath.Image.Filter (scalar2D) +{- | Template matching score: squared difference or normalized correlation. Interpret +whether smaller/larger values are better according to the metric. +-} data TemplateMetric = SquaredDifference | NormalizedCorrelation deriving (Eq, Show) {- | Valid 2D, one-channel matching. Each output is one template origin. @@ -77,6 +80,10 @@ imageCentroid img = do col <- rawMoment 0 1 img >>= single . (/ mass) Right (row, col) +{- | Given row exponent p,column exponent q,then scalar 2D image, compute the unnormalized +intensity-weighted central moment around its centroid. Require orders in [0,8]; invalid +image/zero mass or non-finite result fails. +-} centralMoment :: Int -> Int -> Image -> Either MathError Double centralMoment p q img = do (height, width) <- scalar2D img @@ -119,6 +126,10 @@ integralImage img = do ] build [height + 1, width + 1] nc (\ix c -> values ! (ix !! 0, ix !! 1, c)) +{- | Given (row,column) origin,(height,width) extent,then padded integralImage output, +return per-channel sum of the half-open rectangle. Reject invalid/out-of-range bounds; +zero extents are allowed. +-} rectangleSum :: (Int, Int) -> (Int, Int) -> Image -> Either MathError [Double] rectangleSum (row, col) (height, width) summed = do require @@ -144,6 +155,10 @@ same a b = require (imageShape a == imageShape b && imageChannels a == imageChannels b) "comparison shape mismatch" + +{- | Given two images of equal spatial shape and channels, return average squared sample +difference. Shape mismatch or non-finite arithmetic returns Left MathError. +-} meanSquaredError :: Image -> Image -> Either MathError Double meanSquaredError a b = do same a b diff --git a/src/HMath/Image/Spatial.hs b/src/HMath/Image/Spatial.hs index 13ced2a..4d0dfe8 100644 --- a/src/HMath/Image/Spatial.hs +++ b/src/HMath/Image/Spatial.hs @@ -20,6 +20,9 @@ import HMath.Image.Filter (validateBoundary) import qualified HMath.Matrix as M import qualified HMath.Matrix.LU as LU +{- | Image resampling interpolation mode, choosing nearest,bilinear,bicubic,or Lanczos +kernels. +-} data Interpolation = Nearest | Bilinear | Bicubic | Lanczos deriving (Eq, Show) {- | 2D resize uses pixel-center mapping (i+0.5)*old/new-0.5, independently @@ -137,6 +140,7 @@ interpolate method boundary img y x c = total = sum (map snd wy) * sum (map snd wx) in sum [a * b / total * sample boundary img [i, j] c | (i, a) <- wy, (j, b) <- wx] +-- | Spatial connected-component adjacency: axis neighbors or all surrounding neighbors. data Connectivity = AxisConnected | FullyConnected deriving (Eq, Show) {- | Nonzero is foreground. Label zero is background; component labels start diff --git a/src/HMath/Interchange/Array.hs b/src/HMath/Interchange/Array.hs index 8028aa5..34a7eef 100644 --- a/src/HMath/Interchange/Array.hs +++ b/src/HMath/Interchange/Array.hs @@ -76,10 +76,15 @@ archive budget applies to the SUM of uncompressed members, preventing bombs. -} data Limits = Limits { maxBytes :: Int + -- ^ Maximum aggregate encoded/input/backing bytes, including relevant format overhead. , maxElements :: Int + -- ^ Maximum logical scalar element count. , maxRank :: Int + -- ^ Maximum array dimension count (implementation cap 255). , maxMetadata :: Int + -- ^ Maximum descriptive metadata/header byte budget. , maxArchiveEntries :: Int + -- ^ Maximum archive member count; aggregate uncompressed bytes are also bounded. } deriving (Eq, Show) @@ -98,23 +103,51 @@ data InterchangeError -- | Opaque validated bytes and descriptive UTF-8 metadata (key/value strings). data Array = Array DType Endian [Int] [Int] Int B.ByteString [(String, String)] deriving (Eq, Show) +{- | Return the fixed-width wire dtype of an Array; this is independent of Haskell host +Int/Double defaults. +-} arrayDType :: Array -> DType arrayDType (Array x _ _ _ _ _ _) = x + +-- | Return explicit payload byte order; single-byte dtypes are endian-independent. arrayEndian :: Array -> Endian arrayEndian (Array _ x _ _ _ _ _) = x + +-- | Return logical dimensions in axis order; [] is scalar and zero axes are valid. arrayShape :: Array -> [Int] arrayShape (Array _ _ x _ _ _ _) = x + +{- | Return signed byte strides for each axis. Unlike HMath.Tensor strides, these are bytes, +not elements. +-} arrayStrides :: Array -> [Int] arrayStrides (Array _ _ _ x _ _ _) = x + +-- | Return byte offset of logical origin within arrayBytes backing storage. arrayOffset :: Array -> Int arrayOffset (Array _ _ _ _ x _ _) = x + +{- | Return immutable backing bytes, which may include padding or data not reached by the +logical strided view. Use toValues or repack for logical contents. +-} arrayBytes :: Array -> B.ByteString arrayBytes (Array _ _ _ _ _ x _) = x + +{- | Return descriptive UTF-8-compatible key/value metadata strings in stored order; +metadata is not executable. +-} arrayMetadata :: Array -> [(String, String)] arrayMetadata (Array _ _ _ _ _ _ x) = x +{- | Given condition then InterchangeError, return Right () when True and Left that error +otherwise. This helper performs no IO. +-} guardI :: Bool -> InterchangeError -> Either InterchangeError () guardI p e = unless p (Left e) + +{- | Validate nonnegative finite resource caps, rank\<=255 and Int-safe +byte/element/metadata/archive budgets. Invalid settings return InvalidData. +-} checkLimits :: Limits -> Either InterchangeError () checkLimits lim = guardI @@ -130,10 +163,18 @@ checkLimits lim = && maxArchiveEntries lim < maxBound ) (InvalidData "invalid resource limits") + +{- | Given diagnostic name,nonnegative upper bound,then Integer value, convert only if value +lies in [0,upper] and fits Int. Otherwise return LimitExceeded with that name. +-} boundedInt :: String -> Integer -> Integer -> Either InterchangeError Int boundedInt name upper x = do guardI (x >= 0 && x <= upper && x <= toInteger (maxBound :: Int)) (LimitExceeded name) Right (fromInteger x) + +{- | Return fixed byte width of a DType, including complex pairs (C64=8,C128=16) and +Bool8=1. +-} elementBytes :: DType -> Int elementBytes dt = case dt of Bool8 -> 1 @@ -149,12 +190,18 @@ elementBytes dt = case dt of F64 -> 8 C64 -> 8 C128 -> 16 + +{- | Given limits then dimensions, validate rank, nonnegative axes and element product, +returning Int element count. Invalid data or exceeded limits return InterchangeError. +-} validateShape :: Limits -> [Int] -> Either InterchangeError Int validateShape lim sh = do checkLimits lim guardI (length (take (maxRank lim + 1) sh) <= maxRank lim) (LimitExceeded "array rank") guardI (all (>= 0) sh) (InvalidData "negative dimension") boundedInt "array element count" (toInteger (maxElements lim)) (product (map toInteger sh)) + +-- | Return logical shape product; scalar arrays have one element and empty axes have zero. elementCount :: Array -> Int elementCount = product . arrayShape @@ -190,6 +237,9 @@ array lim dt en sh st off bs = do (InvalidData "noncanonical boolean") Right a +{- | Given limits,dtype,endian,physical order,shape,then exact packed bytes, construct a +canonical byte-strided array. Require exact byte count; invalid shape/data/limits fail. +-} contiguousArray :: Limits -> DType -> Endian -> Order -> [Int] -> B.ByteString -> Either InterchangeError Array contiguousArray lim dt en order sh bs = do @@ -219,6 +269,9 @@ withMetadata lim meta (Array dt en sh st off bs _) = do (InvalidData "surrogate in metadata") Right (Array dt en sh st off bs meta) +{- | Return backing byte offsets for each logical element in row-major coordinate order, +honoring signed strides and offset. +-} byteOffsets :: Array -> [Int] -- An inner zero axis must short-circuit before traversing outer dimensions. -- Those outer dimensions can be huge even when the logical size is zero. @@ -234,8 +287,13 @@ Custom instances must write exactly elementBytes bytes and use a bounded decoder. Built-in instances preserve floating-point bit representations. -} class Element a where + -- | Given a Haskell Element type proxy, return its exact fixed-width wire DType. elementType :: proxy a -> DType + + -- | Given byte order then one typed Element, emit its binary representation with Data.Binary.Put. putElement :: Endian -> a -> Put + + -- | Given byte order, decode one typed Element with Data.Binary.Get; surrounding array decoders enforce byte/storage budgets. getElement :: Endian -> Get a put16 :: Endian -> Word16 -> Put @@ -314,6 +372,11 @@ instance Element (Complex Double) where elementType _ = C128 putElement en (a :+ b) = putElement en a >> putElement en b getElement en = (:+) <$> getElement en <*> getElement en + +{- | Given limits,endian,shape,then typed Element list, encode to a contiguous array with +that Element dtype. Require exact shape/count match and resource bounds; failures +return InterchangeError. +-} fromValues :: forall a. (Element a) => Limits -> Endian -> [Int] -> [a] -> Either InterchangeError Array fromValues lim en sh xs = do @@ -324,6 +387,10 @@ fromValues lim en sh xs = do (LimitExceeded "encoded values") guardI (length (take (n + 1) xs) == n) (InvalidData "value count does not match shape") contiguousArray lim dt en COrder sh (L.toStrict (runPut (mapM_ (putElement en) xs))) + +{- | Decode logical row-major values as the requested Element type, requiring an exact dtype +match. No silent numeric cast occurs; mismatch returns Unsupported/InvalidData. +-} toValues :: forall a. (Element a) => Array -> Either InterchangeError [a] toValues a = do guardI @@ -337,13 +404,30 @@ toValues a = do Left (_, _, err) -> Left (InvalidData err) Right (rest, _, x) | L.null rest -> Right x _ -> Left (InvalidData "element decoder size mismatch") + +{- | Given limits,endian,then typed Haskell Tensor, encode logical row-major values and +preserve shape. The Element instance determines wire dtype; resource bounds can fail. +-} fromTensor :: (Element a) => Limits -> Endian -> T.Tensor a -> Either InterchangeError Array fromTensor lim en t = fromValues lim en (T.tensorShape t) (if T.numel t == 0 then [] else T.tensorValues t) + +{- | Decode an Array of matching Element dtype to a contiguous Haskell Tensor, preserving +logical shape/order. Dtype or checked tensor-construction failure returns +InterchangeError. +-} toTensor :: (Element a) => Array -> Either InterchangeError (T.Tensor a) toTensor a = toValues a >>= either (Left . InvalidData . show) Right . T.tensor (arrayShape a) + +{- | Given limits,endian,then typed Matrix, encode its row-major values as a rank-two Array. +Dtype comes from Element; resource limits can fail. +-} fromMatrix :: (Element a) => Limits -> Endian -> M.Matrix a -> Either InterchangeError Array fromMatrix lim en m = let (r, c) = M.shape m in fromValues lim en [r, c] (M.toList m) + +{- | Decode a matching typed rank-two Array to Matrix. Rank/dtype or checked shape +conversion failures return InterchangeError. +-} toMatrix :: (Element a) => Array -> Either InterchangeError (M.Matrix a) toMatrix a = case arrayShape a of [r, c] -> toValues a >>= either (Left . InvalidData . show) Right . M.fromListChecked r c @@ -388,8 +472,16 @@ repack lim en order a = do (B.concat [swap (B.take width (B.drop i (arrayBytes a))) | i <- offsets]) withMetadata lim (arrayMetadata a) b +{- | Given limits,destination endian,physical order,then Array, repack its logical payload +and return raw bytes without shape/header metadata. Checked resource/layout failures +propagate. +-} rawEncode :: Limits -> Endian -> Order -> Array -> Either InterchangeError B.ByteString rawEncode lim en order = fmap arrayBytes . repack lim en order + +{- | Given limits,dtype,endian,order,shape,then bytes, construct a packed Array. Caller +supplies all metadata; exact byte-count and shape/resource validation is enforced. +-} rawDecode :: Limits -> DType -> Endian -> Order -> [Int] -> B.ByteString -> Either InterchangeError Array rawDecode = contiguousArray diff --git a/src/HMath/Interchange/Binary.hs b/src/HMath/Interchange/Binary.hs index 6fd12c9..926e7fb 100644 --- a/src/HMath/Interchange/Binary.hs +++ b/src/HMath/Interchange/Binary.hs @@ -49,6 +49,11 @@ putMeta meta = do mapM_ (\(k, v) -> putString k >> putString v) meta where putString s = let b = E.encodeUtf8 (T.pack s) in putWord32le (fromIntegral (B.length b)) >> putByteString b + +{- | Given limits then Array, encode HMath wire-format v1 including +shape/strides/offset/metadata/backing storage and CRC-32. Invalid metadata/layout or +exceeded aggregate byte budget fails. +-} encodeBinary :: Limits -> Array -> Either InterchangeError B.ByteString encodeBinary lim a = do _ <- @@ -90,6 +95,11 @@ encodeBinary lim a = do putByteString (arrayBytes a) ) Right (content <> L.toStrict (runPut (putWord32le (crc32 content)))) + +{- | Given limits then bytes, validate HMath v1 magic/header/flags/CRC and exact framing, +returning an Array. Truncation, corruption, unsupported metadata or exceeded budgets +return InterchangeError. +-} decodeBinary :: Limits -> B.ByteString -> Either InterchangeError Array decodeBinary lim input = do checkLimits lim diff --git a/src/HMath/Interchange/Compression.hs b/src/HMath/Interchange/Compression.hs index a2c5f3c..0278dfd 100644 --- a/src/HMath/Interchange/Compression.hs +++ b/src/HMath/Interchange/Compression.hs @@ -20,8 +20,17 @@ data Compression = RawDeflate | Zlib | Gzip deriving (Eq, Show, Enum) foreign import ccall unsafe "hmath_interchange_has_zlib" c_available :: IO CInt foreign import ccall safe "hmath_interchange_compress" c_compress :: CInt -> CInt -> Ptr Word8 -> CSize -> Ptr Word8 -> CSize -> Ptr CSize -> IO CInt + +{- | Probe whether the optional native zlib adapter is available, returning IO Bool. False +means compressed operations cannot run; no payload is processed. +-} compressionAvailable :: IO Bool compressionAvailable = (/= 0) <$> c_available + +{- | Given limits,RawDeflate/Zlib/Gzip wrapper,then bytes, compress within a bounded output +allocation. Return InterchangeError for unavailable provider, invalid limits, +byte-budget excess or compression failure in IO. +-} compress :: Limits -> Compression -> B.ByteString -> IO (Either InterchangeError B.ByteString) compress lim wrapper input = -- zlib's conservative deflate bound plus wrapper slack, capped by the diff --git a/src/HMath/Interchange/IO.hs b/src/HMath/Interchange/IO.hs index 1e00eaa..49a9b1f 100644 --- a/src/HMath/Interchange/IO.hs +++ b/src/HMath/Interchange/IO.hs @@ -181,8 +181,17 @@ foreign import ccall safe "hmath_interchange_map_read" -- | Scope-bound mapping; no pointer or borrowed ByteString is exposed. data MappedArray s = MappedArray RawSpec Int (MVar (Maybe (Ptr ()))) +{- | Return dimensions of a callback-scoped read-only mapped array. The region token +prevents its raw view escaping withMappedArray. +-} mappedShape :: MappedArray s -> [Int] mappedShape (MappedArray (RawSpec _ _ _ sh) _ _) = sh + +{- | Given limits,RawSpec,path,then rank-2 callback, map read-only raw data for that +callback's lifetime and unmap on exit. Validate exact file size/spec/budgets; +path/IO/format failures return InterchangeError. Do not retain borrowed pointers beyond +the callback. +-} withMappedArray :: Limits -> RawSpec -> FilePath -> (forall s. MappedArray s -> IO a) -> IO (Either InterchangeError a) withMappedArray lim spec path action = ioErrors $ case rawSize lim spec of diff --git a/src/HMath/Interchange/Numpy.hs b/src/HMath/Interchange/Numpy.hs index d4d61cc..db49518 100644 --- a/src/HMath/Interchange/Numpy.hs +++ b/src/HMath/Interchange/Numpy.hs @@ -42,6 +42,11 @@ descriptor dt = case dt of F64 -> "f8" C64 -> "c8" C128 -> "c16" + +{- | Given limits,physical C/F order,then Array, repack and write a NumPy NPY v1 payload +with explicit dtype/endian/shape. Oversized header/output or unsupported layout +conversion fails. +-} encodeNpy :: Limits -> Order -> Array -> Either InterchangeError B.ByteString encodeNpy lim order a = do packed <- repack lim (arrayEndian a) order a @@ -108,6 +113,11 @@ headerParser = lexeme (char '{') *> sepEndBy field (lexeme (char ',')) <* lexeme pure (x : xs) ) <++ pure [] + +{- | Given limits then NPY bytes, decode supported v1/v2/v3 fixed-width scalar dtype arrays. +Reject pickle/object/record/string dtypes, malformed headers, unknown endian/layout, +trailing bytes or exceeded budgets. +-} decodeNpy :: Limits -> B.ByteString -> Either InterchangeError Array decodeNpy lim input = do checkLimits lim diff --git a/src/HMath/Interchange/Text.hs b/src/HMath/Interchange/Text.hs index b8c4df8..078754d 100644 --- a/src/HMath/Interchange/Text.hs +++ b/src/HMath/Interchange/Text.hs @@ -140,6 +140,10 @@ parseValues lim dt en sh ss = do then Left (InvalidData "float32 overflow") else Right y complexChecked (a :+ b) = (:+) <$> floatChecked a <*> floatChecked b + +{- | Given limits then Array, encode self-describing HMath text with dtype/shape and scalar +tokens. Invalid/unsupported values or output exceeding limits returns InterchangeError. +-} encodeText :: Limits -> Array -> Either InterchangeError B.ByteString encodeText lim a = do values <- valueTokens a @@ -158,6 +162,10 @@ encodeText lim a = do ++ "\n" ++ unlines values ) + +{- | Given limits then HMath text bytes, parse dtype/shape/tokens and return a checked +Array. Invalid ASCII/header/value counts or exceeded budgets fail. +-} decodeText :: Limits -> B.ByteString -> Either InterchangeError Array decodeText lim bs = do s <- ascii lim bs @@ -181,6 +189,11 @@ decodeText lim bs = do _ -> Left (InvalidData "empty text") where (>=>) f g x = f x >>= g + +{- | Given limits,comma or tab separator,then rank-two noncomplex Array, encode CSV/TSV +numeric cells. No shape/dtype metadata is embedded; unsupported input/separator or +output bounds fail. +-} encodeDelimited :: Limits -> Char -> Array -> Either InterchangeError B.ByteString encodeDelimited lim separator a = do guardI (separator == ',' || separator == '\t') (InvalidData "separator must be comma or tab") @@ -197,6 +210,11 @@ encodeDelimited lim separator a = do rows xs = let (row, rest) = splitAt c xs in row : rows rest output lim (concatMap ((++ "\n") . intercalate [separator]) (rows values)) _ -> Left (InvalidData "CSV requires rank two") + +{- | Given limits,comma/tab separator,target DType,then CSV/TSV bytes, parse rectangular +real numeric cells to a rank-two Array. Complex dtype, malformed rows/tokens or +exceeded budgets fail. +-} decodeDelimited :: Limits -> Char -> DType -> B.ByteString -> Either InterchangeError Array decodeDelimited lim separator dt bs = do guardI (separator == ',' || separator == '\t') (InvalidData "separator must be comma or tab") diff --git a/src/HMath/Interpolation.hs b/src/HMath/Interpolation.hs index e5002fa..d032f37 100644 --- a/src/HMath/Interpolation.hs +++ b/src/HMath/Interpolation.hs @@ -91,8 +91,11 @@ data RBF = RBF RadialKernel [[Double]] [Double] [Double] deriving (Eq, Show) -- | Coefficients or parameters, observed absolute residual, and iteration/evaluation count; error is an estimate. data Approximation = Approximation { approximationCoefficients :: [Double] + -- ^ Fitted coefficients in the approximation routine's documented basis/order. , approximationError :: Double + -- ^ Reported approximation residual/error measure, not a general analytic bound. , approximationIterations :: Int + -- ^ Number of fitting/refinement iterations performed. } deriving (Eq, Show) diff --git a/src/HMath/MachineLearning/Clustering.hs b/src/HMath/MachineLearning/Clustering.hs index e7e5b49..a42fb6d 100644 --- a/src/HMath/MachineLearning/Clustering.hs +++ b/src/HMath/MachineLearning/Clustering.hs @@ -37,7 +37,14 @@ import HMath.Error import HMath.MachineLearning.Internal import qualified HMath.Random as R -newtype ClusterModel = Clusters {clusterCenters :: Dataset} deriving (Eq, Show) +{- | Fitted cluster centroids as cluster-by-feature observations; prediction assigns new +queries to the learned centers. +-} +newtype ClusterModel = Clusters + { clusterCenters :: Dataset + -- ^ Cluster centroids as cluster-by-feature rows. + } + deriving (Eq, Show) -- | Assign each row to its closest squared-Euclidean center; ties use the first center. predictClusters :: ClusterModel -> Dataset -> Either MathError [Int] @@ -143,8 +150,19 @@ kMedoids c k xs = do Right (candidates !! argmin costs) iterateFit c step (\a b -> abs (cost a - cost b)) [0 .. k - 1] -data GaussianMixture = GMM {mixtureWeights :: [Double], mixtureMeans :: Dataset, mixtureCovariances :: [Dataset]} +{- | Fitted component probabilities,mean vectors,and covariance matrices in shared component +order. +-} +data GaussianMixture = GMM + { mixtureWeights :: [Double] + -- ^ Gaussian-mixture component probabilities in component order. + , mixtureMeans :: Dataset + -- ^ Component mean vectors, matching mixtureWeights order. + , mixtureCovariances :: [Dataset] + -- ^ One feature-by-feature covariance matrix per Gaussian component. + } deriving (Eq, Show) + logsumexp :: [Double] -> Double logsumexp xs = let m = maximum xs in m + log (sum (map (exp . subtract m) xs)) @@ -323,7 +341,19 @@ meanShift c bandwidth xs = do -- | Single, complete, average Euclidean distance or Ward variance-increase linkage. data Linkage = Single | Complete | Average | Ward deriving (Eq, Show) -data Merge = Merge {leftCluster :: Int, rightCluster :: Int, mergeDistance :: Double, mergedSize :: Int} +{- | One hierarchical-clustering merge, retaining child IDs,linkage distance,and merged +observation count. +-} +data Merge = Merge + { leftCluster :: Int + -- ^ Left child cluster ID in a hierarchical merge. + , rightCluster :: Int + -- ^ Right child cluster ID in a hierarchical merge. + , mergeDistance :: Double + -- ^ Linkage distance at which the two child clusters merge. + , mergedSize :: Int + -- ^ Number of original observations in the merged cluster. + } deriving (Eq, Show) -- | Agglomerate the closest active clusters to produce all n-1 linkage rows. diff --git a/src/HMath/MachineLearning/Decomposition.hs b/src/HMath/MachineLearning/Decomposition.hs index 1cff9aa..ebe7f9f 100644 --- a/src/HMath/MachineLearning/Decomposition.hs +++ b/src/HMath/MachineLearning/Decomposition.hs @@ -53,7 +53,17 @@ import HMath.MachineLearning.Regression (Kernel, kernel) import qualified HMath.Matrix.LAPACK as L import qualified HMath.Random as R -data PCA = PCA {pcaMean :: [Double], pcaComponents :: Dataset, pcaVariances :: [Double]} +{- | Fitted feature center,principal-component directions,and their explained variances; use +transform functions for new observations. +-} +data PCA = PCA + { pcaMean :: [Double] + -- ^ Training feature means subtracted before projection. + , pcaComponents :: Dataset + -- ^ Principal component loading vectors in component order. + , pcaVariances :: [Double] + -- ^ Explained variances associated with the retained principal components. + } deriving (Eq, Show) -- | Fit count principal axes from at least two observations; uses sample covariance (denominator n-1). @@ -236,7 +246,14 @@ normalMatrix seed n d = do (values, _) <- R.sampleN (n * d) (R.normal 0 1) (R.seedRNG R.PCG32 (fromIntegral seed)) Right [take d (drop (i * d) values) | i <- [0 .. n - 1]] -data FactorAnalysis = FA {factorCenter :: [Double], factorLoadings :: Dataset, factorNoise :: [Double]} +-- | Fitted feature center,latent factor loadings,and diagonal feature-noise variances. +data FactorAnalysis = FA + { factorCenter :: [Double] + , factorLoadings :: Dataset + -- ^ Fitted feature-by-factor loading matrix. + , factorNoise :: [Double] + -- ^ Per-feature residual noise variances in the factor model. + } deriving (Eq, Show) {- | Gaussian factor-analysis EM with diagonal noise floor. Unlike PCA, each diff --git a/src/HMath/MachineLearning/Internal.hs b/src/HMath/MachineLearning/Internal.hs index a6bf010..4c92095 100644 --- a/src/HMath/MachineLearning/Internal.hs +++ b/src/HMath/MachineLearning/Internal.hs @@ -36,21 +36,36 @@ defaultMLConfig = MLConfig 500 1e-8 0.05 42 -- | A finite budget is a valid stopping point, distinct from convergence. data Fit a = Fit { fitted :: a + -- ^ Best fitted model retained when fitting stops. , fitIterations :: Int + -- ^ Completed fitting iterations. , fitResidual :: Double + -- ^ Algorithm-specific finite stopping residual at the returned model. , fitConverged :: Bool + -- ^ Whether the selected stopping residual met tolerance; a budget stop may return False. } deriving (Eq, Show) +-- | Test whether Double is neither NaN nor infinite. finite :: Double -> Bool finite x = not (isNaN x || isInfinite x) + +-- | Validate a list of finite numerical values, returning Right () or Left NonFiniteResult. checked :: [Double] -> Either MathError () checked xs | all finite xs = Right () | otherwise = Left NonFiniteResult + +{- | Given condition then diagnostic, return Right () or Left InvalidArgument prefixed with +ML context. +-} require :: Bool -> String -> Either MathError () require True _ = Right () require False s = Left (InvalidArgument ("ML: " ++ s)) + +{- | Validate positive iteration count and positive finite tolerance/learning rate of +MLConfig. Invalid settings return Left InvalidArgument. +-} config :: MLConfig -> Either MathError () config c = require @@ -61,6 +76,10 @@ config c = && mlRate c > 0 ) "invalid iteration/tolerance/rate configuration" + +{- | Validate a nonempty finite rectangular observation-by-feature list with positive +feature count and Int-safe size. Return (observations,features) or Left MathError. +-} dataset :: Dataset -> Either MathError (Int, Int) dataset [] = Left (InvalidArgument "ML: nonempty dataset required") dataset xs@(r : _) = do @@ -69,45 +88,108 @@ dataset xs@(r : _) = do require (toInteger n * toInteger d <= toInteger (maxBound :: Int)) "shape overflow" checked (concat xs) Right (n, d) + +{- | Given dataset then finite response list, validate dataset and equal +observation/response count. Return dataset dimensions; mismatch/non-finite data fails. +-} responses :: Dataset -> [Double] -> Either MathError (Int, Int) responses xs ys = do dims@(n, _) <- dataset xs require (n == length ys) "response count mismatch" checked ys Right dims + +{- | Given expected feature dimension then query rows, validate every row width and finite +values. Empty queries are allowed; mismatch/non-finite values fail. +-} queries :: Int -> Dataset -> Either MathError () queries d xs = do require (all ((== d) . length) xs) "query feature count mismatch" checked (concat xs) + +{- | Unchecked list inner product using zipWith; unequal lengths truncate. Estimator callers +validate feature shapes first. +-} dot :: [Double] -> [Double] -> Double dot x y = sum (zipWith (*) x y) + add, sub :: [Double] -> [Double] -> [Double] + +{- | Unchecked coordinatewise list addition, truncating to shorter length; checked estimator +callers validate dimensions. +-} add = zipWith (+) + +{- | Unchecked coordinatewise left-minus-right list subtraction, truncating to shorter +length. +-} sub = zipWith (-) + +{- | Given scalar then coordinate list, multiply each coordinate without checked finiteness +validation. +-} scale :: Double -> [Double] -> [Double] scale s = map (s *) + +{- | Return scaled Euclidean norm of a coordinate list, zero for empty/all-zero input. +Caller validates finite inputs/results when required. +-} norm :: [Double] -> Double norm xs | s == 0 = 0 | otherwise = s * sqrt (sum [(x / s) ^ (2 :: Int) | x <- xs]) where s = maximum (0 : map abs xs) + +{- | Return squared Euclidean distance using sub and dot. Require matching dimensions +externally; this unchecked helper truncates mismatched lists. +-} dist2 :: [Double] -> [Double] -> Double dist2 x y = dot z z where z = sub x y + +{- | Return per-feature means for a nonempty equal-width dataset. Empty outer input raises a +pure foldl1 error; use dataset validation before calling. +-} meanV :: Dataset -> [Double] meanV xs = foldl1 add (map (scale (1 / fromIntegral (length xs))) xs) + +{- | Unchecked dense row-list matrix multiplication via row/column dot products. Caller must +validate rectangular compatible dimensions; zip-based dot otherwise truncates. +-} matmul :: Dataset -> Dataset -> Dataset matmul x y = [[dot r c | c <- transpose y] | r <- x] + +{- | Return n-by-n Double identity rows for a nonnegative dimension; nonpositive n gives []. +No allocation budget is checked here. +-} ident :: Int -> Dataset ident n = [[if i == j then 1 else 0 | j <- [0 .. n - 1]] | i <- [0 .. n - 1]] + +{- | Given index,new value,then list, replace by take/drop reconstruction. The checked +caller must ensure an in-range index; this helper does not reject invalid bounds. +-} replace :: Int -> a -> [a] -> [a] replace i x xs = take i xs ++ [x] ++ drop (i + 1) xs + +{- | Validate dataset then construct row-major Matrix Double with matching dimensions. +Empty/ragged/non-finite input fails. +-} matrix :: Dataset -> Either MathError (M.Matrix Double) matrix xs = do (n, d) <- dataset xs; M.fromListChecked n d (concat xs) + +-- | Convert Matrix to dense row lists, preserving explicit zero-column row count. rows :: M.Matrix a -> [[a]] rows m | d == 0 = replicate n [] | otherwise = [take d (drop (i * d) (M.toList m)) | i <- [0 .. n - 1]] where (n, d) = M.shape m + +{- | Compute a validated dataset pseudoinverse using relative singular-value tolerance 1e-12 +and return dense rows. Decomposition/backend failures propagate. +-} pinv :: Dataset -> Either MathError Dataset pinv x = matrix x >>= A.pseudoinverse 1e-12 >>= pure . rows + +{- | Given dataset then response list, solve least squares through the pseudoinverse. +Validate counts/finite data/result; checked failures propagate. +-} solveLS :: Dataset -> [Double] -> Either MathError [Double] solveLS x y = do _ <- responses x y @@ -115,6 +197,10 @@ solveLS x y = do let answer = map (`dot` y) p checked answer Right answer + +{- | Validate a square dataset, compute pseudoinverse and require inverse reconstruction +residual below 1e-6*n. Reject singular/invalid matrices or decomposition failures. +-} inverse :: Dataset -> Either MathError Dataset inverse x = do (n, d) <- dataset x @@ -123,6 +209,11 @@ inverse x = do let residual = norm (concat (zipWith sub (matmul x p) (ident n))) require (residual < 1e-6 * fromIntegral n) "singular matrix" Right p + +{- | Validate finite square approximately symmetric dataset, symmetrize and eigendecompose. +Return descending real eigenvalues and corresponding eigenvector columns as rows; +invalid spectrum/backend failures propagate. +-} symmetricEigen :: Dataset -> Either MathError ([Double], Dataset) symmetricEigen x = do (n, d) <- dataset x @@ -142,8 +233,17 @@ symmetricEigen x = do let order = map fst (sortOn (negate . snd) (zip [0 ..] (map realPart vals))) Right ([realPart (vals !! j) | j <- order], [[realPart (vs !! i !! j) | j <- order] | i <- [0 .. n - 1]]) + argmin, argmax :: (Ord a) => [a] -> Int + +{- | Return zero-based first index of a minimum in a nonempty list. Empty list raises a pure +minimum error; callers must validate nonempty input. +-} argmin xs = snd (minimum (zip xs [0 ..])) + +{- | Return zero-based index selected by maximumBy on a nonempty list, with later equal +maxima preferred. Empty list raises a pure error. +-} argmax xs = snd (maximumBy (comparing fst) (zip xs [0 ..])) -- | Deterministic reference iteration; residual is supplied by each estimator. @@ -164,9 +264,13 @@ iterateFit c step difference start = do then Right (Fit new (k + 1) r False) else go (k + 1) new +{- | Monadic left fold: given checked step,initial accumulator,then list, stop at first Left +MathError and otherwise return final accumulator. +-} foldEither :: (a -> b -> Either MathError a) -> a -> [b] -> Either MathError a foldEither = foldM +-- | Return the first row of nested lists, or [] for an empty outer list. firstRow :: [[a]] -> [a] firstRow [] = [] firstRow (x : _) = x diff --git a/src/HMath/MachineLearning/Neighbors.hs b/src/HMath/MachineLearning/Neighbors.hs index 92dfd2b..18dc811 100644 --- a/src/HMath/MachineLearning/Neighbors.hs +++ b/src/HMath/MachineLearning/Neighbors.hs @@ -76,7 +76,17 @@ buildIndex kind leafSize xs = do transposeLocal [] = [] transposeLocal rows' = let d = length (firstRow rows') in [[r !! j | r <- rows'] | j <- [0 .. d - 1]] -data NeighborResult = NeighborResult {neighbors :: [(Int, Double)], visitedLeaves :: Int, exhaustive :: Bool} +{- | Neighbor indices/distances plus visited-leaf and exhaustive-search diagnostics. +Budget-limited candidates are explicitly marked approximate. +-} +data NeighborResult = NeighborResult + { neighbors :: [(Int, Double)] + -- ^ Training-row indices paired with returned Euclidean distances, ordered by distance and then index. + , visitedLeaves :: Int + -- ^ Number of leaves visited against the explicit query budget. + , exhaustive :: Bool + -- ^ True if the neighbor search completed its exact stopping condition; False if unexplored nodes may improve candidates. + } deriving (Eq, Show) {- | maxLeaves is a query work budget. A False exhaustive flag means unexplored diff --git a/src/HMath/MachineLearning/Preprocessing.hs b/src/HMath/MachineLearning/Preprocessing.hs index 13edcf3..eb440e0 100644 --- a/src/HMath/MachineLearning/Preprocessing.hs +++ b/src/HMath/MachineLearning/Preprocessing.hs @@ -233,7 +233,13 @@ oneHotEncode policy (Encoder levels) xs = do Right [[if x == c then 1 else 0 | c <- levels] | x <- xs] -- | Disjoint indices into the original dataset. No estimator is fitted here. -data Fold = Fold {trainingIndices :: [Int], validationIndices :: [Int]} deriving (Eq, Show) +data Fold = Fold + { trainingIndices :: [Int] + -- ^ Zero-based original row indices assigned to training in this fold. + , validationIndices :: [Int] + -- ^ Zero-based original row indices held out for validation in this fold. + } + deriving (Eq, Show) permutation :: Word64 -> Int -> [Int] permutation seed n = map snd (sortOn fst (zip (take n (stream (R.seedRNG R.PCG32 seed))) [0 .. n - 1])) diff --git a/src/HMath/MachineLearning/Regression.hs b/src/HMath/MachineLearning/Regression.hs index 82af8d4..9af291c 100644 --- a/src/HMath/MachineLearning/Regression.hs +++ b/src/HMath/MachineLearning/Regression.hs @@ -154,7 +154,15 @@ fitRobust c delta xs ys = do (\a b -> norm (sub (coefficients a) (coefficients b))) start -data BayesianLinear = BayesianLinear {bayesianMean :: LinearModel, bayesianCovariance :: Dataset} +{- | Posterior-mean linear model together with coefficient covariance, returned by Bayesian +regression fitting. +-} +data BayesianLinear = BayesianLinear + { bayesianMean :: LinearModel + -- ^ Posterior-mean fitted linear model. + , bayesianCovariance :: Dataset + -- ^ Posterior covariance matrix of linear coefficients. + } deriving (Eq, Show) {- | Isotropic zero-mean Gaussian prior, observation precision beta. Unlike diff --git a/src/HMath/Matrix/Advanced.hs b/src/HMath/Matrix/Advanced.hs index 6f9e56e..a6dbc85 100644 --- a/src/HMath/Matrix/Advanced.hs +++ b/src/HMath/Matrix/Advanced.hs @@ -52,30 +52,56 @@ import HMath.Matrix.LU (inverse, solve) import Prelude hiding (log, sqrt) import qualified Prelude as P +{- | Given row count, column count, then zero-based (row,column) generator, construct a +row-major matrix. Negative dimensions or Int-size element product overflow return Left +MathError. +-} generateMatrix :: Int -> Int -> (Int -> Int -> a) -> Either MathError (Matrix a) generateMatrix = build + +{- | Given lower flag then matrix, preserve entries on/below the diagonal if True, on/above +if False, and zero the rest. Rectangular matrices are allowed; return checked +construction result. +-} triangularMatrix :: (Num a) => Bool -> Matrix a -> Either MathError (Matrix a) triangularMatrix lower a = build r c (\i j -> if (lower && j <= i) || (not lower && j >= i) then get a i j else 0) where (r, c) = shape a + +{- | Return (A+transpose(A))/2 for a square matrix. Non-square input returns +NonSquareMatrix; arithmetic follows Fractional. +-} symmetricMatrix :: (Fractional a) => Matrix a -> Either MathError (Matrix a) symmetricMatrix a | r /= c = Left (NonSquareMatrix (r, c)) | otherwise = build r c (\i j -> (get a i j + get a j i) / 2) where (r, c) = shape a + +{- | Return (A+conjugateTranspose(A))/2 for a square complex matrix. Non-square input fails; +this symmetrizes rather than merely asserting the original is Hermitian. +-} hermitianMatrix :: (RealFloat a) => Matrix (Complex a) -> Either MathError (Matrix (Complex a)) hermitianMatrix a | r /= c = Left (NonSquareMatrix (r, c)) | otherwise = build r c (\i j -> (get a i j + conjugate (get a j i)) / 2) where (r, c) = shape a + +{- | Given a permutation p of [0..n-1], construct n-by-n P with P[i,p[i]]=1. Duplicate, +missing, or out-of-range indices return Left InvalidArgument. +-} permutationMatrix :: (Num a) => [Int] -> Either MathError (Matrix a) permutationMatrix p | sort p /= [0 .. n - 1] = Left (InvalidArgument "permutationMatrix: indices must be a permutation") | otherwise = build n n (\i j -> if p !! i == j then 1 else 0) where n = length p + +{- | Assemble a rectangular grid of matrix blocks. Require equal heights within each block +row and equal widths within each block column. Ragged grids or total-size overflow +fail; empty grids yield a 0-by-0 matrix. +-} blockMatrix :: [[Matrix a]] -> Either MathError (Matrix a) blockMatrix [] = fromListChecked 0 0 [] blockMatrix blocks @@ -100,6 +126,11 @@ blockMatrix blocks n = length (blocks !! 0) totalR = sum [toInteger (fst (shape (row !! 0))) | row <- blocks] totalC = sum [toInteger (snd (shape b)) | b <- blocks !! 0] + +{- | Given rows, columns, then (diagonal offset,values) pairs, construct a matrix with zeros +elsewhere. Offset k means column-row=k. Each list must match that diagonal's length; +duplicates add. Invalid dimensions/counts fail. +-} bandedMatrix :: (Num a) => Int -> Int -> [(Int, [a])] -> Either MathError (Matrix a) bandedMatrix r c diagonals | r < 0 || c < 0 = Left (NegativeDimensions (r, c)) @@ -115,18 +146,33 @@ bandedMatrix r c diagonals where diagonalLength k = max 0 (min (toInteger r) (toInteger c - toInteger k) - max 0 (-toInteger k)) +{- | Transpose a complex matrix and conjugate every entry, exchanging its row/column +dimensions. +-} conjugateTranspose :: (RealFloat a) => Matrix (Complex a) -> Matrix (Complex a) conjugateTranspose = mapEntries conjugate . transposeMatrix + +{- | Given elementwise function and two identically shaped matrices, apply it to +corresponding entries and return a new matrix. Mismatched shapes return ShapeMismatch. +-} zipMatrixWith :: (a -> b -> c) -> Matrix a -> Matrix b -> Either MathError (Matrix c) zipMatrixWith f a b | shape a /= shape b = Left (ShapeMismatch (shape a) (shape b)) | otherwise = fromListChecked r c (zipWith f (toList a) (toList b)) where (r, c) = shape a + +{- | Multiply pairs of matrices from equally long lists, preserving batch order. Different +batch lengths or any checked multiplication failure return Left MathError. +-} batchedMultiply :: (Num a) => [Matrix a] -> [Matrix a] -> Either MathError [Matrix a] batchedMultiply as bs | length as /= length bs = Left (VectorLengthMismatch (length as) (length bs)) | otherwise = sequence (zipWith multiplyChecked as bs) + +{- | Return the block Kronecker product of matrices A and B, of shape +(Arows*Brows,Acols*Bcols). Reject dimension/element-count overflow. +-} kronecker :: (Num a) => Matrix a -> Matrix a -> Either MathError (Matrix a) kronecker a b | rows > toInteger (maxBound :: Int) || cols > toInteger (maxBound :: Int) = @@ -141,6 +187,10 @@ kronecker a b (br, bc) = shape b rows = toInteger ar * toInteger br cols = toInteger ac * toInteger bc + +{- | Return columnwise Kronecker product, requiring equal column counts. Shape is +(Arows*Brows,columns); mismatched columns or dimension overflow fail. +-} khatriRao :: (Num a) => Matrix a -> Matrix a -> Either MathError (Matrix a) khatriRao a b | ac /= bc = Left (InnerDimensionMismatch ac bc) @@ -149,6 +199,11 @@ khatriRao a b | otherwise = build (ar * br) ac (\i j -> get a (i `div` br) j * get b (i `mod` br) j) where (ar, ac) = shape a; (br, bc) = shape b + +{- | Given Integer exponent then square real matrix, compute power by squaring. Zero yields +identity; negative exponent inverts first. Non-square/singular input or multiplication +errors propagate. +-} matrixPower :: (RealFloat a) => Integer -> Matrix a -> Either MathError (Matrix a) matrixPower power a | r /= c = Left (NonSquareMatrix (r, c)) @@ -160,34 +215,65 @@ matrixPower power a go k base result = do next <- if odd k then multiplyChecked result base else Right result if k == 1 then Right next else do squared <- multiplyChecked base base; go (k `div` 2) squared next + +{- | Return sum of main diagonal of a square matrix; non-square input returns +NonSquareMatrix. A 0-by-0 matrix has trace zero. +-} trace :: (Num a) => Matrix a -> Either MathError a trace a | r /= c = Left (NonSquareMatrix (r, c)) | otherwise = Right (sum [get a i i | i <- [0 .. r - 1]]) where (r, c) = shape a + +{- | Return maximum absolute column sum (induced one norm). Empty dimensions give zero; no +finiteness check is added. +-} matrixNorm1 :: (Ord a, Num a) => Matrix a -> a matrixNorm1 a = maximum (0 : [sum [abs (get a i j) | i <- [0 .. r - 1]] | j <- [0 .. c - 1]]) where (r, c) = shape a + +{- | Return maximum absolute row sum (induced infinity norm). A matrix with no elements +gives zero. +-} matrixNormInfinity :: (Ord a, Num a) => Matrix a -> a matrixNormInfinity a | null (toList a) = 0 | otherwise = maximum (0 : map (sum . map abs) (entries a)) + +{- | Return scaled Euclidean norm of all entries, reducing intermediate overflow; empty +matrix norm is zero. No Either result is added. +-} frobeniusNorm :: (RealFloat a) => Matrix a -> a frobeniusNorm = stableNorm . toList + +{- | Return largest singular value via SVD, or zero for an empty singular spectrum. Invalid +input/backend decomposition failures return Left MathError. +-} spectralNorm :: Matrix Double -> Either MathError Double spectralNorm a = maximum . (0 :) . singularValues <$> svd a + validTol :: Double -> Either MathError () validTol t | t < 0 || isNaN t || isInfinite t = Left InvalidTolerance | otherwise = Right () + +{- | Given finite nonnegative relative tolerance then matrix, count positive singular values +whose ratio to the largest exceeds tolerance. Zero tolerance counts all positive +singular values. Invalid tolerance or SVD failure propagates. +-} matrixRank :: Double -> Matrix Double -> Either MathError Int matrixRank tol a = do validTol tol f <- svd a let s = singularValues f; biggest = maximum (0 : s) Right (length [x | x <- s, x > 0, tol == 0 || x / biggest > tol]) + +{- | Given relative singular-value tolerance then m-by-n matrix, return n-by-m Moore-Penrose +pseudoinverse via thresholded SVD. Rectangular/rank-deficient inputs are supported; +invalid tolerance or numeric/decomposition failures propagate. +-} pseudoinverse :: Double -> Matrix Double -> Either MathError (Matrix Double) pseudoinverse tol a = do validTol tol @@ -199,16 +285,33 @@ pseudoinverse tol a = do if k == 0 then zeroMatrixChecked (snd (shape a)) (fst (shape a)) else finiteMatrix result >> Right result + +{- | Return largest/smallest singular-value ratio; singular matrices yield positive +infinity, empty spectrum yields 1. Input/SVD failures return Left MathError. +-} conditionNumber :: Matrix Double -> Either MathError Double conditionNumber a = do f <- svd a case singularValues f of [] -> Right 1 xs -> Right (if minimum xs == 0 then 1 / 0 else maximum xs / minimum xs) + +{- | Given relative SVD rank tolerance then matrix, return columns of left singular vectors +spanning its numerical column space. Invalid tolerance/decomposition errors propagate. +-} columnSpace :: Double -> Matrix Double -> Either MathError (Matrix Double) columnSpace tol a = do rank <- matrixRank tol a; f <- svd a; sliceMatrixChecked (0, 0) (fst (shape a), rank) (svdU f) + +{- | Given relative rank tolerance then matrix, return a column basis for its row space by +applying columnSpace to its transpose. +-} rowSpace :: Double -> Matrix Double -> Either MathError (Matrix Double) rowSpace tol a = columnSpace tol (transposeMatrix a) + +{- | Given relative singular-value tolerance then m-by-n matrix, return an n-by-(n-rank) +basis for its numerical right null space using full SVD. Invalid +tolerance/decomposition failures propagate. +-} nullSpace :: Double -> Matrix Double -> Either MathError (Matrix Double) nullSpace tol a = do validTol tol @@ -216,11 +319,21 @@ nullSpace tol a = do rank <- matrixRank tol a let n = snd (shape a) sliceMatrixChecked (0, rank) (n, n - rank) (transposeMatrix (svdVT f)) + +{- | Given source basis matrix, target square basis matrix, then source coordinate list, map +to physical coordinates and solve in target basis. Shape mismatch, singular target, and +checked solve errors propagate. +-} changeCoordinates :: (RealFloat a) => Matrix a -> Matrix a -> [a] -> Either MathError [a] changeCoordinates source target coordinates = do rhs <- fromListChecked (length coordinates) 1 coordinates physical <- multiplyChecked source rhs solve target (toList physical) + +{- | Given positive finite tolerance, positive iteration budget, then square finite matrix, +approximate exp(A) by scaling, Taylor series and squaring. Return NonConvergence on +exhausted series budget; input/shape/numerical failures propagate. +-} matrixExp :: (RealFloat a) => a -> Int -> Matrix a -> Either MathError (Matrix a) matrixExp tol budget a | r /= c = Left (NonSquareMatrix (r, c)) @@ -249,6 +362,7 @@ matrixExp tol budget a if matrixNorm1 next <= tol * max 1 (matrixNorm1 totalNext) then Right totalNext else series small (k + 1) next totalNext + symmetricSpectral :: (Double -> Either MathError Double) -> Matrix Double -> Either MathError (Matrix Double) symmetricSpectral f a @@ -270,6 +384,11 @@ symmetricSpectral f a finiteMatrix result >> Right result where (r, c) = shape a + +{- | Compute principal real matrix logarithm of a symmetric positive-definite Double matrix +using symmetric eigendecomposition. Reject non-square/asymmetric matrices, nonpositive +spectrum, non-real decomposition, or numeric failure. +-} matrixLog :: Matrix Double -> Either MathError (Matrix Double) matrixLog = symmetricSpectral @@ -278,6 +397,11 @@ matrixLog = then Left (DomainError "matrixLog: positive definite matrix required") else Right (P.log x) ) + +{- | Compute symmetric positive-semidefinite matrix square root by spectral decomposition; +tolerate eigenvalues down to -1e-12 and clamp them to zero. Invalid +shape/symmetry/spectrum or decomposition failure returns Left MathError. +-} matrixSqrt :: Matrix Double -> Either MathError (Matrix Double) matrixSqrt = symmetricSpectral @@ -286,6 +410,10 @@ matrixSqrt = then Left (DomainError "matrixSqrt: positive semidefinite matrix required") else Right (P.sqrt (max 0 x)) ) + +{- | Return (U,P) from SVD so A=U*P, with P positive semidefinite; rectangular input uses +the thin polar factors. Validation/decomposition/multiplication errors propagate. +-} polar :: Matrix Double -> Either MathError (Matrix Double, Matrix Double) polar a = do f <- svd a diff --git a/src/HMath/Matrix/Decomposition.hs b/src/HMath/Matrix/Decomposition.hs index 4704c45..b0598cb 100644 --- a/src/HMath/Matrix/Decomposition.hs +++ b/src/HMath/Matrix/Decomposition.hs @@ -34,10 +34,20 @@ import HMath.Matrix.Internal import HMath.Matrix.LAPACK (Hessenberg (..), hessenberg) import HMath.Matrix.LU (inverse, luDecomposeWithTolerance, solve, solveLU) +{- | Given finite nonnegative relative tolerance then finite matrix, return normalized +row-echelon form and zero-based pivot columns. Partial row pivoting skips pivots below +tolerance times the global entry scale. Invalid tolerance/non-finite arithmetic fails. +-} gaussianElimination :: (RealFloat a) => a -> Matrix a -> Either MathError (Matrix a, [Int]) gaussianElimination tol a = eliminate False tol a + +{- | Given relative tolerance then finite matrix, return reduced row-echelon form and +zero-based pivot columns using row pivoting. Invalid tolerance/non-finite arithmetic +fails. +-} gaussJordan :: (RealFloat a) => a -> Matrix a -> Either MathError (Matrix a, [Int]) gaussJordan tol a = eliminate True tol a + eliminate :: (RealFloat a) => Bool -> a -> Matrix a -> Either MathError (Matrix a, [Int]) eliminate reduced tol a | tol < 0 || isNaN tol || isInfinite tol = Left InvalidTolerance @@ -77,6 +87,11 @@ checkSymmetric a | otherwise = finiteMatrix a >> Right n where (n, m) = shape a + +{- | Factor a finite symmetric positive-definite matrix as L*transpose(L), returning +lower-triangular L. Non-square/asymmetric/non-finite input or a nonpositive diagonal +pivot returns Left MathError. +-} cholesky :: (RealFloat a) => Matrix a -> Either MathError (Matrix a) cholesky a = do n <- checkSymmetric a @@ -94,6 +109,11 @@ cholesky a = do let result = if i == j then sqrt value else value / (rows !! j !! j) finiteValues [result] Right (xs ++ [result]) + +{- | Factor a finite symmetric matrix as L*diag(d)*transpose(L), returning unit lower L and +diagonal list d. This unpivoted method requires nonzero scalar pivots; it can reject +invertible indefinite matrices needing block pivots. +-} ldlt :: (RealFloat a) => Matrix a -> Either MathError (Matrix a, [a]) ldlt a = do n <- checkSymmetric a @@ -117,6 +137,10 @@ ldlt a = do else do finiteValues [d] Right (rows ++ [prefix ++ 1 : replicate (n - i - 1) 0], ds ++ [d]) + +{- | Factor finite m-by-n matrix as Q*R using Givens rotations, returning square m-by-m Q +and m-by-n R without column pivoting. Non-finite input/intermediate results fail. +-} givensQR :: (RealFloat a) => Matrix a -> Either MathError (Matrix a, Matrix a) givensQR a = do finiteMatrix a @@ -150,8 +174,21 @@ givensQR a = do where (m, n) = shape a -data Bidiagonal a = Bidiagonal {bidiagonalU :: Matrix a, bidiagonalB :: Matrix a, bidiagonalV :: Matrix a} +-- | Orthogonal factors A=U*B*transpose(V), retaining a rectangular bidiagonal B. +data Bidiagonal a = Bidiagonal + { bidiagonalU :: Matrix a + -- ^ Left orthogonal factor in A=U*B*transpose(V). + , bidiagonalB :: Matrix a + -- ^ Bidiagonal matrix in the factorization, retaining input shape. + , bidiagonalV :: Matrix a + -- ^ Right orthogonal factor in A=U*B*transpose(V). + } deriving (Eq, Show) + +{- | Reduce a finite rectangular matrix to bidiagonal form with orthogonal factors, +returning Bidiagonal fields. Input/numeric validation errors propagate; inspect the +factor types and module reconstruction example. +-} bidiagonalize :: (RealFloat a) => Matrix a -> Either MathError (Bidiagonal a) bidiagonalize a = do finiteMatrix a @@ -185,15 +222,32 @@ bidiagonalize a = do v1 <- multiplyChecked v g finiteValues (toList b2 ++ toList v1) Right (u1, b2, v1) + +{- | Reduce a symmetric finite square matrix to @(Q,T)@, satisfying +@A = Q * T * transpose Q@ with tridiagonal @T@. Non-square/asymmetric input +or numerical failure returns Left MathError. +-} tridiagonalize :: Matrix Double -> Either MathError (Matrix Double, Matrix Double) tridiagonalize a = do _ <- checkSymmetric a f <- hessenberg a Right (hessenbergQ f, hessenbergH f) +{- | Accepted eigenpair estimate with residual and iteration count. See the iterative +solver's tolerance and failure contract. +-} data Iteration a = Iteration - {iterationValue :: a, iterationVector :: [a], iterationResidual :: a, iterationCount :: Int} + { iterationValue :: a + -- ^ Returned real eigenvalue estimate. + , iterationVector :: [a] + -- ^ Returned normalized eigenvector estimate. + , iterationResidual :: a + -- ^ Eigenpair residual norm used to assess convergence. + , iterationCount :: Int + -- ^ Number of eigen-iteration updates performed. + } deriving (Eq, Show) + iterateEigen :: (RealFloat a) => String -> @@ -238,8 +292,19 @@ iterateEigen name tol budget action a initial else if norm == 0 then Left (DomainError (name ++ ": zero iterate")) else go (k + 1) (map (/ norm) y) matrixScale = maximum (0 : map (sum . map abs) (entries a)) + +{- | Given positive finite tolerance,positive budget,square finite matrix,then nonzero +starting vector, estimate a dominant eigenpair. Return Iteration with +value/vector/residual/count; invalid dimensions/options, non-finite arithmetic or +exhausted budget fails. +-} powerIteration :: (RealFloat a) => a -> Int -> Matrix a -> [a] -> Either MathError (Iteration a) powerIteration tol budget a = iterateEigen "powerIteration" tol budget (\_ x -> Right [dotV row x | row <- entries a]) a + +{- | Given tolerance,budget,shift,square matrix,then starting vector, estimate an eigenpair +near shift by repeated shifted solves. Require valid finite inputs and nonzero start; +singular shifted systems or convergence/numerical failures return Left MathError. +-} inverseIteration :: (RealFloat a) => a -> Int -> a -> Matrix a -> [a] -> Either MathError (Iteration a) inverseIteration tol budget shift a initial = do @@ -247,6 +312,11 @@ inverseIteration tol budget shift a initial = do iterateEigen "inverseIteration" tol budget (\_ -> solve shifted) a initial where n = fst (shape a) + +{- | Given tolerance,budget,square matrix,then nonzero initial vector, refine an eigenpair +with Rayleigh-quotient shifts. Shape/options, singular shifted solves or +convergence/numerical failures return Left MathError. +-} rayleighIteration :: (RealFloat a) => a -> Int -> Matrix a -> [a] -> Either MathError (Iteration a) rayleighIteration tol budget a = iterateEigen "rayleighIteration" tol budget action a where @@ -263,8 +333,22 @@ rayleighIteration tol budget a = iterateEigen "rayleighIteration" tol budget act luDecomposeWithTolerance 0 regular >>= (`solveLU` x) result -> result -data Arnoldi a = Arnoldi {arnoldiBasis :: Matrix a, arnoldiHessenberg :: Matrix a} +{- | Krylov basis columns and upper-Hessenberg projection returned by arnoldi; exact +breakdown may shorten the basis. +-} +data Arnoldi a = Arnoldi + { arnoldiBasis :: Matrix a + -- ^ Orthonormal Krylov basis vectors as matrix columns. + , arnoldiHessenberg :: Matrix a + -- ^ Hessenberg projection relating the matrix action to the Arnoldi basis. + } deriving (Eq, Show) + +{- | Given positive finite tolerance,requested basis size,square matrix,then nonzero initial +vector, build Arnoldi basis/projection. Require 1\<=requested\<=matrix order. Invalid +input or numerical failures return Left MathError; exact Krylov breakdown terminates +the basis. +-} arnoldi :: (RealFloat a) => a -> Int -> Matrix a -> [a] -> Either MathError (Arnoldi a) arnoldi tol requested a initial | m /= n = Left (NonSquareMatrix (m, n)) @@ -358,6 +442,10 @@ lanczos tol requested a initial = do Right (Arnoldi qmat hmat) else go next (columns ++ [column]) beta (k + 1) +{- | Given positive finite tolerance,positive budget,then finite square matrix, iterate QR +to return @(Q,T)@: accumulated orthogonal vectors and the resulting iterate. Invalid +options/shape or failure to converge within budget returns Left MathError. +-} qrIteration :: (RealFloat a) => a -> Int -> Matrix a -> Either MathError (Matrix a, Matrix a) qrIteration tol budget a | m /= n = Left (NonSquareMatrix (m, n)) diff --git a/src/HMath/Matrix/LAPACK.hs b/src/HMath/Matrix/LAPACK.hs index a64811d..319c37e 100644 --- a/src/HMath/Matrix/LAPACK.hs +++ b/src/HMath/Matrix/LAPACK.hs @@ -166,9 +166,28 @@ foreign import ccall unsafe "hmath_lapacke_dgebal" cBalance :: CInt -> CChar -> CInt -> Ptr CDouble -> CInt -> Ptr CInt -> Ptr CInt -> Ptr CDouble -> IO CInt -data SVD = SVD {svdU :: Matrix Double, singularValues :: [Double], svdVT :: Matrix Double} +{- | Real singular-value decomposition with U,descending nonnegative singular values,and VT. +Thin/full dimensions follow the selected factorization function. +-} +data SVD = SVD + { svdU :: Matrix Double + -- ^ Left singular vectors as columns of the real thin/full SVD factor. + , singularValues :: [Double] + -- ^ Nonnegative real singular values in descending order. + , svdVT :: Matrix Double + -- ^ Transposed right singular-vector factor in A=U*diag(s)*VT. + } deriving (Eq, Show) -data Eigen = Eigen {eigenvalues :: [Complex Double], eigenvectors :: Matrix (Complex Double)} + +{- | Complex eigenvalues with corresponding right eigenvector columns, including conjugate +pairs from real input. +-} +data Eigen = Eigen + { eigenvalues :: [Complex Double] + -- ^ Complex eigenvalues matching eigenvector column order. + , eigenvectors :: Matrix (Complex Double) + -- ^ Right eigenvectors as complex matrix columns. + } deriving (Eq, Show) {- | Projective eigenvalues alpha/beta preserve infinite eigenvalues and @@ -176,27 +195,60 @@ indeterminate singular pencils without dividing by a zero beta. -} data GeneralizedEigen = GeneralizedEigen { eigenAlpha :: [Complex Double] + -- ^ Generalized-eigenvalue numerators alpha; retain with beta to represent infinite eigenvalues. , eigenBeta :: [Double] + -- ^ Generalized-eigenvalue denominators beta; zero beta can represent an infinite eigenvalue. , generalizedEigenvectors :: Matrix (Complex Double) + -- ^ Right eigenvector columns satisfying beta*A*v=alpha*B*v. } deriving (Eq, Show) -data Schur = Schur {schurQ :: Matrix Double, schurT :: Matrix Double, schurEigenvalues :: [Complex Double]} +-- | Real Schur factors A=Q*T*transpose(Q), with quasi-triangular T and complex eigenvalues. +data Schur = Schur + { schurQ :: Matrix Double + -- ^ Orthogonal basis in A=Q*T*transpose(Q). + , schurT :: Matrix Double + -- ^ Real quasi-upper-triangular Schur form, including 2-by-2 blocks for conjugate pairs. + , schurEigenvalues :: [Complex Double] + -- ^ Complex eigenvalues decoded from the real Schur form. + } deriving (Eq, Show) + +{- | Generalized real Schur factors for a matrix pair, retaining alpha/beta eigenvalue +representation to allow infinite eigenvalues. +-} data QZ = QZ { qzQ :: Matrix Double + -- ^ Left orthogonal QZ transform, with A=Q*S*transpose(Z). , qzZ :: Matrix Double + -- ^ Right orthogonal QZ transform for both matrix factors. , qzS :: Matrix Double + -- ^ First generalized real Schur factor S. , qzT :: Matrix Double + -- ^ Second generalized real Schur factor T. , qzAlpha :: [Complex Double] + -- ^ Generalized Schur eigenvalue numerators alpha. , qzBeta :: [Double] + -- ^ Generalized Schur eigenvalue denominators beta; do not divide blindly when zero. } deriving (Eq, Show) -data Hessenberg = Hessenberg {hessenbergQ :: Matrix Double, hessenbergH :: Matrix Double} + +-- | Orthogonal reduction A=Q*H*transpose(Q), with H upper Hessenberg. +data Hessenberg = Hessenberg + { hessenbergQ :: Matrix Double + -- ^ Orthogonal transform in A=Q*H*transpose(Q). + , hessenbergH :: Matrix Double + -- ^ Upper Hessenberg form with zeros below the first subdiagonal. + } deriving (Eq, Show) -- | D^-1 A D = balancedMatrix. Scale-only balancing preserves index order. -data Balance = Balance {balancedMatrix :: Matrix Double, balanceScales :: [Double]} +data Balance = Balance + { balancedMatrix :: Matrix Double + -- ^ Matrix after LAPACK diagonal balancing. + , balanceScales :: [Double] + -- ^ Diagonal basis scaling factors used by the balancing transformation. + } deriving (Eq, Show) char :: Char -> CChar @@ -246,6 +298,11 @@ square a (m, n) = shape a {-# NOINLINE svd #-} + +{- | Compute thin real SVD A=U*diag(s)*VT via LAPACK, with descending nonnegative singular +values and k=min(m,n). Return m-by-k U and k-by-n VT. Invalid input, unavailable +backend, allocation bounds or LAPACK failure returns Left MathError. +-} svd :: Matrix Double -> Either MathError SVD svd a = do validate a @@ -262,6 +319,7 @@ svd a = do status "SVD" info finiteValues (s ++ u ++ v) SVD <$> fromListChecked m k u <*> pure s <*> fromListChecked k n v + {-# NOINLINE fullSVD #-} -- | Full square U and V^T, including null-space completion. @@ -286,6 +344,10 @@ fullSVD a = do finiteValues (s ++ u ++ v) SVD <$> fromListChecked m m u <*> pure s <*> fromListChecked n n v +{- | Given retained rank k then real matrix, compute thin SVD and retain its first k +components. Reject k outside the available rank dimensions; decomposition failures +propagate. +-} truncatedSVD :: Int -> Matrix Double -> Either MathError SVD truncatedSVD k a | k < 0 || k > min m n = Left (InvalidArgument "truncatedSVD: invalid rank") @@ -345,6 +407,11 @@ complexVectors n imag values = build n n $ \i j -> then values !! (i * n + j) :+ values !! (i * n + j + 1) else values !! (i * n + j - 1) :+ negate (values !! (i * n + j)) {-# NOINLINE eigen #-} + +{- | Compute complex eigenvalues and right eigenvectors of a finite real square matrix via +LAPACK. Complex-conjugate pairs are decoded into complex columns. Invalid +shape/backend/numeric failures return Left MathError. +-} eigen :: Matrix Double -> Either MathError Eigen eigen a = do n <- square a @@ -360,6 +427,7 @@ eigen a = do status "eigen" info finiteValues (re ++ im ++ vs) Eigen (zipWith (:+) re im) <$> complexVectors n im vs + {-# NOINLINE symmetricEigen #-} -- | Real symmetric eigensolver with orthonormal columns, sorted ascending. @@ -384,6 +452,11 @@ symmetricEigen a = do Eigen (map (:+ 0) ws) <$> fromListChecked n n (map (:+ 0) vs) {-# NOINLINE generalizedEigen #-} + +{- | Given equally sized square matrices A,B, compute generalized alpha/beta eigenvalue +representation and right eigenvectors. Retain alpha/beta to represent infinite +eigenvalues safely; invalid input or LAPACK failure propagates. +-} generalizedEigen :: Matrix Double -> Matrix Double -> Either MathError GeneralizedEigen generalizedEigen a b = do n <- square a @@ -404,7 +477,13 @@ generalizedEigen a b = do status "generalizedEigen" info finiteValues (re ++ im ++ be ++ vs) GeneralizedEigen (zipWith (:+) re im) be <$> complexVectors n im vs + {-# NOINLINE schur #-} + +{- | Compute real Schur form A=Q*T*transpose(Q), returning orthogonal Q, +quasi-upper-triangular T and complex eigenvalues. Require finite square input and +available LAPACK; failures return Left MathError. +-} schur :: Matrix Double -> Either MathError Schur schur a = do n <- square a @@ -421,7 +500,12 @@ schur a = do status "Schur" info finiteValues (re ++ im ++ qs ++ ts) Schur <$> fromListChecked n n qs <*> fromListChecked n n ts <*> pure (zipWith (:+) re im) + {-# NOINLINE qz #-} + +{- | Compute generalized real Schur factors for a finite square matrix pair A,B, retaining +Q,Z,S,T and alpha/beta eigenvalues. Shape/backend/LAPACK errors return Left MathError. +-} qz :: Matrix Double -> Matrix Double -> Either MathError QZ qz a b = do n <- square a @@ -470,7 +554,12 @@ qz a b = do <*> fromListChecked n n ts <*> pure (zipWith (:+) re im) <*> pure be + {-# NOINLINE hessenberg #-} + +{- | Reduce finite real square A to upper Hessenberg H with orthogonal Q, satisfying +A=Q*H*transpose(Q). Invalid shape or backend/decomposition failures propagate. +-} hessenberg :: Matrix Double -> Either MathError Hessenberg hessenberg a = do n <- square a @@ -492,7 +581,13 @@ hessenberg a = do n [if i > j + 1 then 0 else hs !! (i * n + j) | i <- [0 .. n - 1], j <- [0 .. n - 1]] Hessenberg <$> fromListChecked n n qs <*> pure h + {-# NOINLINE balance #-} + +{- | Balance a real square matrix by diagonal scaling, returning the balanced matrix and +scales needed to interpret its basis. Invalid finite-input/shape checks or LAPACK +failures return Left MathError. +-} balance :: Matrix Double -> Either MathError Balance balance a = do n <- square a @@ -511,8 +606,11 @@ balance a = do -- | Complex128 thin SVD: A = U diag(s) V*, where complexVT already stores V*. data ComplexSVD = ComplexSVD { complexU :: Matrix (Complex Double) + -- ^ Complex left singular vectors as columns. , complexSingularValues :: [Double] + -- ^ Descending nonnegative real singular values of the complex matrix. , complexVT :: Matrix (Complex Double) + -- ^ Conjugate-transposed right singular vectors in complex SVD. } deriving (Eq, Show) @@ -533,6 +631,11 @@ validateComplex a = do else finiteValues (complexParts (toList a)) {-# NOINLINE complexSVD #-} + +{- | Compute thin complex SVD with conjugate-transposed right factor VT and real nonnegative +singular values. Require finite complex entries and available LAPACK. Invalid storage +sizes/backend/decomposition fails. +-} complexSVD :: Matrix (Complex Double) -> Either MathError ComplexSVD complexSVD a = do validateComplex a @@ -550,7 +653,13 @@ complexSVD a = do status "complex SVD" info finiteValues (ss ++ complexParts us ++ complexParts vs) ComplexSVD <$> fromListChecked m k us <*> pure ss <*> fromListChecked k n vs + {-# NOINLINE complexEigen #-} + +{- | Compute complex eigenvalues and right eigenvectors of a finite complex square matrix +via LAPACK. Invalid shape, backend availability, bounds or decomposition errors return +Left MathError. +-} complexEigen :: Matrix (Complex Double) -> Either MathError Eigen complexEigen a = do validateComplex a diff --git a/src/HMath/Matrix/QR.hs b/src/HMath/Matrix/QR.hs index 024bbc7..5160084 100644 --- a/src/HMath/Matrix/QR.hs +++ b/src/HMath/Matrix/QR.hs @@ -30,17 +30,43 @@ import HMath.Error import HMath.Matrix import HMath.Matrix.Internal +{- | Opaque column-pivoted Householder factors satisfying A[:,p]=Q*R, with numerical-rank +estimate. Construct with qrDecompose. +-} data QR a = QR (Matrix a) (Matrix a) [Int] Int deriving (Eq, Show) + +-- | Extract the square m-by-m orthogonal Q factor from a QR decomposition. qrQ :: QR a -> Matrix a qrQ (QR q _ _ _) = q + +{- | Extract the m-by-n upper trapezoidal R factor. Column ordering corresponds to +qrPermutation. +-} qrR :: QR a -> Matrix a qrR (QR _ r _ _) = r + +-- | Return zero-based original column indices in pivoted order, satisfying A[:,p]=Q*R. qrPermutation :: QR a -> [Int] qrPermutation (QR _ _ p _) = p + +{- | Return estimated numerical rank selected by the factorization's relative diagonal-pivot +tolerance. +-} qrRank :: QR a -> Int qrRank (QR _ _ _ r) = r + +{- | Column-pivoted Householder QR of a finite m-by-n matrix using relative rank tolerance +max(m,n)*machine epsilon. Return factors satisfying A[:,permutation]=Q*R. Numeric/input +failures return Left MathError; rank deficiency is recorded rather than rejected at +factorization. +-} qrDecompose :: (RealFloat a) => Matrix a -> Either MathError (QR a) qrDecompose a = qrDecomposeWithTolerance (defaultTolerance a) a + +{- | Given finite nonnegative relative rank tolerance then finite matrix, compute +column-pivoted Householder QR. Reject invalid tolerance/non-finite arithmetic. Zero +tolerance counts every nonzero diagonal pivot as significant. +-} qrDecomposeWithTolerance :: (RealFloat a) => a -> Matrix a -> Either MathError (QR a) qrDecomposeWithTolerance tol a | tol < 0 || isNaN tol || isInfinite tol = Left InvalidTolerance @@ -77,10 +103,23 @@ qrDecomposeWithTolerance tol a rclean = [[if j == k && i > k then 0 else rnew !! i !! j | j <- [0 .. n - 1]] | i <- [0 .. m - 1]] finiteValues (concat qnew ++ concat rclean) Right (qnew, rclean, swap k pivot p) + +{- | Given QR factorization then a matrix with m rows, return Q times that matrix. +Dimension/size errors return Left MathError; generic Num arithmetic is unchanged. +-} applyQ :: (Num a) => QR a -> Matrix a -> Either MathError (Matrix a) applyQ f = multiplyChecked (qrQ f) + +{- | Given QR factorization then a matrix with m rows, return transpose(Q) times it. Checked +matrix dimension errors propagate. +-} applyQT :: (Num a) => QR a -> Matrix a -> Either MathError (Matrix a) applyQT f = multiplyChecked (transposeMatrix (qrQ f)) + +{- | Given QR factors and an m-by-k RHS, return n-by-k least-squares coefficients, undoing +column pivoting. Require m>=n and full column rank; shape/rank/finiteness failures +return Left MathError. +-} solveMatrixQR :: (RealFloat a) => QR a -> Matrix a -> Either MathError (Matrix a) solveMatrixQR f b | m < n = Left (InvalidArgument "leastSquares: underdetermined system") @@ -107,18 +146,43 @@ solveMatrixQR f b ) where r = qrR f; (m, n) = shape r + +{- | Given full-column-rank QR factors of an m-by-n matrix then m-element right-hand side, +return n least-squares coefficients in original column order. Reject underdetermined +systems, incompatible RHS, deficient rank, or non-finite input/result. +-} solveQR :: (RealFloat a) => QR a -> [a] -> Either MathError [a] solveQR f b = do rhs <- fromListChecked (length b) 1 b toList <$> solveMatrixQR f rhs + +{- | Given finite m-by-n design matrix then m-element RHS, factor with pivoted QR and return +least-squares coefficients. Require m>=n and full column rank; decomposition/solve +errors propagate. +-} leastSquares :: (RealFloat a) => Matrix a -> [a] -> Either MathError [a] leastSquares a b = qrDecompose a >>= (`solveQR` b) + +{- | Given finite m-by-n design and m-by-k RHS matrices, return n-by-k least-squares +solution via QR. Underdetermined/rank-deficient or invalid input returns Left +MathError. +-} leastSquaresMatrix :: (RealFloat a) => Matrix a -> Matrix a -> Either MathError (Matrix a) leastSquaresMatrix a b = qrDecompose a >>= (`solveMatrixQR` b) + +{- | Given finite nonnegative lambda, design matrix, then RHS list, minimize squared +residual plus lambda times squared coefficient norm. Use augmented QR, not normal +equations. Zero lambda delegates to leastSquares; dimension/numeric errors propagate. +-} ridgeSolve :: (RealFloat a) => a -> Matrix a -> [a] -> Either MathError [a] ridgeSolve lambda a b = do rhs <- fromListChecked (length b) 1 b toList <$> ridgeSolveMatrix lambda a rhs + +{- | Given lambda, m-by-n design, then m-by-k RHS, return n-by-k ridge coefficients via +augmented QR. Reject negative/non-finite lambda, RHS mismatch, shape overflow, or +numerical failure. +-} ridgeSolveMatrix :: (RealFloat a) => a -> Matrix a -> Matrix a -> Either MathError (Matrix a) ridgeSolveMatrix lambda a b | lambda < 0 || isNaN lambda || isInfinite lambda = diff --git a/src/HMath/Numeric.hs b/src/HMath/Numeric.hs index 09ebcc2..cb982e3 100644 --- a/src/HMath/Numeric.hs +++ b/src/HMath/Numeric.hs @@ -114,22 +114,48 @@ import Data.Word (Word16, Word32, Word64, Word8) import GHC.Float (castDoubleToWord64) import HMath.Error (MathError (..)) +-- | Alias for Haskell Float (IEEE binary32 on supported targets). type Float32 = Float + +-- | Alias for Haskell Double (IEEE binary64 on supported targets). type Float64 = Double +{- | Software rounding direction: nearest-even,toward zero,toward positive infinity,or +toward negative infinity. Host CPU rounding mode is unchanged. +-} data RoundingMode = NearestEven | TowardZero | TowardPositive | TowardNegative deriving (Eq, Show) + +{- | Software operation flags: invalid operation,division by zero,overflow,underflow,or +inexact conversion. +-} data NumericException = InvalidOperation | DivisionByZero | NumericOverflow | NumericUnderflow | Inexact deriving (Eq, Show) -data Rounded a = Rounded {roundedValue :: a, numericalExceptions :: [NumericException]} + +{- | Rounded numeric result paired with software exception flags. Inspect flags when +intentional precision loss matters. +-} +data Rounded a = Rounded + { roundedValue :: a + -- ^ Value produced by the explicitly selected software rounding operation. + , numericalExceptions :: [NumericException] + -- ^ Software rounding flags; these do not modify the host IEEE exception environment. + } deriving (Eq, Show) +{- | Given software rounding mode then exact Rational, return Integer rounded by +nearest-even, toward zero, toward positive infinity, or toward negative infinity. No +host rounding flags are changed. +-} roundRational :: RoundingMode -> Rational -> Integer roundRational NearestEven = round roundRational TowardZero = truncate roundRational TowardPositive = ceiling roundRational TowardNegative = floor +{- | IEEE classification distinguishing NaN,signed infinity,signed zero,subnormal,and normal +finite values. +-} data IEEEClass = NotANumber | PositiveInfinity @@ -139,6 +165,10 @@ data IEEEClass | Subnormal | Normal deriving (Eq, Show) + +{- | Classify a RealFloat value as NaN, signed infinity, signed zero, subnormal, or normal. +Signed zero is distinguished with isNegativeZero. +-} classify :: (RealFloat a) => a -> IEEEClass classify x | isNaN x = NotANumber @@ -147,14 +177,24 @@ classify x | isDenormalized x = Subnormal | otherwise = Normal +{- | Format limits and precision metadata derived from RealFloat or the explicit 16-bit +format definition. +-} data NumericLimits a = NumericLimits { minimumNormal :: a + -- ^ Smallest positive normal value of the represented floating format. , minimumSubnormal :: a + -- ^ Smallest positive subnormal value of the represented floating format. , maximumFinite :: a + -- ^ Largest finite positive value of the represented floating format. , machineEpsilon :: a + -- ^ Gap between one and its next larger representable value. , significandDigits :: Int + -- ^ Number of radix digits in the floating significand. , minimumExponent :: Int + -- ^ Lower exponent bound returned by RealFloat.floatRange. , maximumExponent :: Int + -- ^ Upper exponent bound returned by RealFloat.floatRange. } deriving (Eq, Show) @@ -177,6 +217,9 @@ float16Limits, bfloat16Limits :: NumericLimits Double float16Limits = NumericLimits (2 ** (-14)) (2 ** (-24)) 65504 (2 ** (-10)) 11 (-13) 16 bfloat16Limits = NumericLimits (2 ** (-126)) (2 ** (-133)) (encodeFloat 255 120) (2 ** (-7)) 8 (-125) 128 +{- | Given a bounded integral type witness, return its exact (minimum,maximum) as Integers. +The witness value is used only to select the type. +-} integerLimits :: (Integral a, Bounded a) => a -> (Integer, Integer) integerLimits x = (toInteger (minBound `asTypeOf` x), toInteger (maxBound `asTypeOf` x)) @@ -206,6 +249,10 @@ frexp x | x == 0 || isNaN x || isInfinite x = (x, 0) | otherwise = let (_, e) = decodeFloat x; k = e + floatDigits x in (scaleFloat (-k) x, k) +{- | Given real value then Int exponent, scale by the numeric radix to that power using +scaleFloat (binary types use powers of two). IEEE overflow/underflow follows the host +type; no Either check is added. +-} ldexp :: (RealFloat a) => a -> Int -> a ldexp x n = scaleFloat n x @@ -219,9 +266,16 @@ ulpDistance a b let bits = castDoubleToWord64 x; mag = toInteger (bits .&. 0x7fffffffffffffff) in if testBit bits 63 then negate mag else mag +{- | Given nonnegative allowed ULP distance then two Doubles, test their binary64 +representable-value distance. Signed zeros compare equal. Negative tolerance or NaN +gives False. +-} withinULPs :: Integer -> Double -> Double -> Bool withinULPs n a b = n >= 0 && either (const False) (<= n) (ulpDistance a b) +{- | Convert an integral value to a bounded integral destination only if in range. Return +Left DomainError rather than wrap or truncate out-of-range input. +-} safeIntegralCast :: (Integral a, Integral b, Bounded b) => a -> Either MathError b safeIntegralCast x = r where @@ -230,12 +284,21 @@ safeIntegralCast x = r if toInteger x < toInteger (minBound `asTypeOf` y) || toInteger x > toInteger (maxBound `asTypeOf` y) then Left (DomainError "integral cast out of range") else Right y + +{- | Convert an integral value to a bounded integral destination, clamping to +minBound/maxBound when out of range. No error result is produced. +-} saturatingCast :: (Integral a, Integral b, Bounded b) => a -> b saturatingCast x = y where y = fromInteger (max (toInteger (minBound `asTypeOf` y)) (min (toInteger (maxBound `asTypeOf` y)) (toInteger x))) + +{- | Given software rounding mode then finite real value, round exactly through Rational +then range-check the bounded integral destination. Non-finite or out-of-range input +returns Left DomainError. +-} realToIntegral :: (RealFloat a, Integral b, Bounded b) => RoundingMode -> a -> Either MathError b realToIntegral mode x | isNaN x || isInfinite x = Left (DomainError "non-finite integral cast") @@ -260,21 +323,56 @@ report inexact, overflow and tininess-after-rounding underflow flags. -} newtype Float16 = Float16 Word16 deriving (Eq, Show) +{- | Opaque bfloat16 storage with 8 exponent and 7 explicit fraction bits. Use bfloat16 for +rounded conversion or bfloat16FromBits for exact storage construction. +-} newtype BFloat16 = BFloat16 Word16 deriving (Eq, Show) + +{- | Return raw IEEE binary16 storage bits, including sign, exponent and fraction, as +Word16. +-} float16Bits :: Float16 -> Word16 float16Bits (Float16 w) = w + +{- | Construct binary16 storage from raw Word16 without validation or rounding; all bit +patterns, including NaNs, are representable. +-} float16FromBits :: Word16 -> Float16 float16FromBits = Float16 + +-- | Return raw bfloat16 storage bits as Word16. bfloat16Bits :: BFloat16 -> Word16 bfloat16Bits (BFloat16 w) = w + +{- | Construct bfloat16 storage from raw Word16 without conversion; all bit patterns are +retained. +-} bfloat16FromBits :: Word16 -> BFloat16 bfloat16FromBits = BFloat16 + +{- | Given rounding mode then Double, round directly to IEEE binary16 and return Rounded +storage plus software flags. Preserve signed zero/infinity; canonicalize NaN. Flags +report inexact, overflow, and tininess-after-rounding underflow. +-} float16 :: RoundingMode -> Double -> Rounded Float16 float16 mode x = let Rounded w flags = encodeSmall 5 10 mode x in Rounded (Float16 w) flags + +{- | Given rounding mode then Double, round directly to bfloat16 without an intermediate +binary32 rounding. Return Rounded storage and software flags, preserving signed +zero/infinity and canonicalizing NaN. +-} bfloat16 :: RoundingMode -> Double -> Rounded BFloat16 bfloat16 mode x = let Rounded w flags = encodeSmall 8 7 mode x in Rounded (BFloat16 w) flags + +{- | Decode binary16 storage to Double, preserving finite values, signed zero, infinity and +NaN classification. Every finite binary16 value is exactly representable as Double. +-} fromFloat16 :: Float16 -> Double fromFloat16 (Float16 w) = decodeSmall 5 10 w + +{- | Decode bfloat16 storage to Double, preserving finite values, signed zero and non-finite +classification. +-} fromBFloat16 :: BFloat16 -> Double fromBFloat16 (BFloat16 w) = decodeSmall 8 7 w @@ -347,10 +445,20 @@ any 'RoundingMode'. Transcendentals use guard bits and rational series. -} data BigFloat = BigFloat Int Rational deriving (Eq, Show) +-- | Return the runtime number of significant binary bits retained by a BigFloat. bigPrecision :: BigFloat -> Int bigPrecision (BigFloat p _) = p + +{- | Return the exact Rational value of the already-rounded BigFloat, without another +conversion or rounding. +-} bigRational :: BigFloat -> Rational bigRational (BigFloat _ x) = x + +{- | Given precision in [2,1000000] bits, rounding mode, then Rational, construct +configurable-precision BigFloat plus Inexact flag if rounded. Invalid precision returns +Left InvalidArgument. Exponents are unbounded; no IEEE NaN/infinity is stored. +-} bigFloat :: Int -> RoundingMode -> Rational -> Either MathError (Rounded BigFloat) bigFloat p mode x | p < 2 || p > 1000000 = Left (InvalidArgument "precision must be 2..1000000 bits") @@ -364,20 +472,49 @@ bigFloat p mode x extended :: Rational -> Either MathError BigFloat extended x = roundedValue <$> bigFloat 64 NearestEven x +{- | Round BigFloat to host Double through fromRational. This may overflow/underflow or lose +precision; it returns no software flags or Either validation. +-} bigToDouble :: BigFloat -> Double bigToDouble = fromRational . bigRational + bigResult :: Int -> Rational -> Either MathError BigFloat bigResult p x = roundedValue <$> bigFloat p NearestEven x bigAdd, bigSubtract, bigMultiply, bigDivide :: BigFloat -> BigFloat -> Either MathError BigFloat + +{- | Add two BigFloats exactly then round once to the larger operand precision, +nearest-even. Return the new BigFloat in Either. +-} bigAdd a b = bigResult (max (bigPrecision a) (bigPrecision b)) (bigRational a + bigRational b) + +{- | Subtract the second BigFloat from the first, rounding once nearest-even at the larger +operand precision. +-} bigSubtract a b = bigResult (max (bigPrecision a) (bigPrecision b)) (bigRational a - bigRational b) + +{- | Multiply two BigFloats exactly then round once nearest-even to the larger operand +precision. +-} bigMultiply a b = bigResult (max (bigPrecision a) (bigPrecision b)) (bigRational a * bigRational b) + +{- | Divide two BigFloats and round once nearest-even to the larger precision. Zero divisor +returns Left DomainError. +-} bigDivide _ (BigFloat _ 0) = Left (DomainError "BigFloat division by zero") bigDivide a b = bigResult (max (bigPrecision a) (bigPrecision b)) (bigRational a / bigRational b) + mixedAdd, mixedMultiply :: BigFloat -> Double -> Either MathError BigFloat + +{- | Given BigFloat then finite Double, add via exact Rational intermediates at max(BigFloat +precision,53) bits, nearest-even. Non-finite Double fails. +-} mixedAdd a x | isNaN x || isInfinite x = Left (DomainError "non-finite mixed operand") | otherwise = bigResult (max 53 (bigPrecision a)) (bigRational a + toRational x) + +{- | Given BigFloat then finite Double, multiply at max(BigFloat precision,53) bits using +exact intermediates and nearest-even. Non-finite Double fails. +-} mixedMultiply a x | isNaN x || isInfinite x = Left (DomainError "non-finite mixed operand") | otherwise = bigResult (max 53 (bigPrecision a)) (bigRational a * toRational x) @@ -388,6 +525,10 @@ integerSqrt n | otherwise = go (2 ^ ((integerBits n + 1) `quot` 2)) where go x = let y = (x + n `quot` x) `quot` 2 in if y >= x then x else go y + +{- | Compute nonnegative BigFloat square root using integer/rational guard precision then +round to the input precision. Negative input returns Left DomainError; zero succeeds. +-} bigSqrt :: BigFloat -> Either MathError BigFloat bigSqrt (BigFloat p x) | x < 0 = Left (DomainError "negative BigFloat square root") @@ -418,6 +559,10 @@ bigExp (BigFloat p x) sq k v = do rounded <- bigResult (p + reductions + 24) (v * v); sq (k - 1) (bigRational rounded) in sq reductions initial >>= bigResult p +{- | Compute natural logarithm at the BigFloat precision using rational series and guard +bits. Require positive input; invalid domain/resource limits return Left MathError. +Final rounding has the module's documented accuracy limits. +-} bigLog :: BigFloat -> Either MathError BigFloat bigLog (BigFloat p x) | x <= 0 = Left (DomainError "BigFloat logarithm needs positive input") @@ -438,37 +583,88 @@ constructors and arithmetic use explicit rounding and report inexactness. -} data Fixed = Fixed Int Integer deriving (Eq, Show) +{- | Return nonnegative decimal scale s of a Fixed value; its exact value is coefficient / +10^s. +-} fixedScale :: Fixed -> Int fixedScale (Fixed s _) = s + +{- | Return exact stored Integer coefficient of a Fixed value, before division by +10^fixedScale. +-} fixedCoefficient :: Fixed -> Integer fixedCoefficient (Fixed _ c) = c + +-- | Return exact coefficient/10^scale represented by a Fixed value, without rounding. fixedRational :: Fixed -> Rational fixedRational (Fixed s n) = n % (10 ^ s) + +{- | Given decimal scale in [0,10000], rounding mode, then Rational, return Rounded Fixed +and Inexact when required. Invalid scale fails. This scale counts decimal fractional +places, not significant digits. +-} fixed :: Int -> RoundingMode -> Rational -> Either MathError (Rounded Fixed) fixed s mode x | s < 0 || s > 10000 = Left (InvalidArgument "fixed scale must be 0..10000") | otherwise = let c = roundRational mode (x * fromInteger (10 ^ s)); v = Fixed s c in Right (Rounded v [Inexact | fixedRational v /= x]) + +{- | Add two Fixed values using the larger decimal scale, nearest-even, returning Rounded +result and software flags. +-} fixedAdd :: Fixed -> Fixed -> Either MathError (Rounded Fixed) fixedAdd a b = fixed (max (fixedScale a) (fixedScale b)) NearestEven (fixedRational a + fixedRational b) + +{- | Given rounding mode then two Fixed values, multiply and round to their larger scale, +returning Rounded result and flags. +-} fixedMultiply :: RoundingMode -> Fixed -> Fixed -> Either MathError (Rounded Fixed) fixedMultiply mode a b = fixed (max (fixedScale a) (fixedScale b)) mode (fixedRational a * fixedRational b) + +{- | Given rounding mode then Fixed numerator and denominator, divide and round to their +larger scale. Zero divisor returns Left DomainError; successful rounding flags are +retained. +-} fixedDivide :: RoundingMode -> Fixed -> Fixed -> Either MathError (Rounded Fixed) fixedDivide mode a b | fixedCoefficient b == 0 = Left (DomainError "fixed division by zero") | otherwise = fixed (max (fixedScale a) (fixedScale b)) mode (fixedRational a / fixedRational b) + +{- | Opaque decimal fixed-point value with fractional-place scale, built through decimal +with explicit rounding. This is not an implicit significant-digit decimal context. +-} newtype Decimal = Decimal Fixed deriving (Eq, Show) + +{- | Given decimal fractional-place scale, rounding mode, then Rational, construct Rounded +Decimal through fixed. Scale must lie in [0,10000]; no significant-digit interpretation +is implied. +-} decimal :: Int -> RoundingMode -> Rational -> Either MathError (Rounded Decimal) decimal p mode x = do Rounded v flags <- fixed p mode x; Right (Rounded (Decimal v) flags) + +-- | Return exact Rational value stored in a Decimal without further rounding. decimalRational :: Decimal -> Rational decimalRational (Decimal f) = fixedRational f + +{- | Add two Decimals at their larger decimal scale, nearest-even, returning Rounded result +and software flags. +-} decimalAdd :: Decimal -> Decimal -> Either MathError (Rounded Decimal) decimalAdd (Decimal a) (Decimal b) = do Rounded v flags <- fixedAdd a b; Right (Rounded (Decimal v) flags) + decimalMultiply , decimalDivide :: RoundingMode -> Decimal -> Decimal -> Either MathError (Rounded Decimal) + +{- | Given rounding mode then two Decimals, multiply at the larger fractional-place scale +and return Rounded result with flags. +-} decimalMultiply mode (Decimal a) (Decimal b) = do Rounded v flags <- fixedMultiply mode a b; Right (Rounded (Decimal v) flags) + +{- | Given rounding mode then two Decimals, divide at their larger scale and return Rounded +result. Zero divisor returns Left DomainError. +-} decimalDivide mode (Decimal a) (Decimal b) = do Rounded v flags <- fixedDivide mode a b; Right (Rounded (Decimal v) flags) {- | Finite closed binary64 intervals. Arithmetic endpoints are rounded outward @@ -477,14 +673,24 @@ output is rejected; division rejects denominators containing zero. -} data Interval = Interval Double Double deriving (Eq, Show) +{- | Given finite lower and upper bounds in increasing order, construct a closed binary64 +Interval. Reversed or non-finite bounds fail. Equal endpoints are valid. +-} interval :: Double -> Double -> Either MathError Interval interval a b | any (\x -> isNaN x || isInfinite x) [a, b] || a > b = Left (DomainError "invalid finite interval") | otherwise = Right (Interval a b) + +-- | Return (lower,upper) binary64 endpoints of a validated closed interval. intervalBounds :: Interval -> (Double, Double) intervalBounds (Interval a b) = (a, b) + +{- | Given interval then Double, test closed-bound membership lower\<=x\<=upper. NaN +comparisons give False. +-} intervalContains :: Interval -> Double -> Bool intervalContains (Interval a b) x = a <= x && x <= b + outward :: Rational -> Rational -> Either MathError Interval outward lo hi = interval (down lo) (up hi) where @@ -499,11 +705,27 @@ intervalAdd , intervalMultiply , intervalDivide :: Interval -> Interval -> Either MathError Interval + +{- | Add finite intervals with exact Rational endpoint arithmetic rounded outward, enclosing +the exact sum. Results requiring unbounded endpoints fail. +-} intervalAdd (Interval a b) (Interval c d) = outward (toRational a + toRational c) (toRational b + toRational d) + +{- | Subtract intervals with endpoints [a-d,b-c], rounding outward. Non-finite/unbounded +resulting endpoints return Left MathError. +-} intervalSubtract (Interval a b) (Interval c d) = outward (toRational a - toRational d) (toRational b - toRational c) + +{- | Multiply intervals using the minimum/maximum of all four endpoint products and outward +rounding. Reject unbounded output. +-} intervalMultiply (Interval a b) (Interval c d) = let xs = [toRational x * toRational y | x <- [a, b], y <- [c, d]] in outward (minimum xs) (maximum xs) + +{- | Divide intervals using endpoint quotients with outward rounding. A divisor interval +containing zero returns Left DomainError; unbounded output also fails. +-} intervalDivide (Interval a b) (Interval c d) | c <= 0 && d >= 0 = Left (DomainError "interval divisor contains zero") | otherwise = @@ -514,7 +736,13 @@ intervalDivide (Interval a b) (Interval c d) Elementary functions follow host IEEE domains; checked algorithms can inspect both components. abs at zero uses derivative zero (a chosen subgradient). -} -data Dual a = Dual {primal :: a, tangent :: a} deriving (Eq, Show) +data Dual a = Dual + { primal :: a + -- ^ Primal component of a forward-mode Dual number. + , tangent :: a + -- ^ Directional derivative component of a forward-mode Dual number. + } + deriving (Eq, Show) instance (Num a) => Num (Dual a) where Dual a b + Dual c d = Dual (a + c) (b + d) @@ -544,6 +772,11 @@ instance (Floating a) => Floating (Dual a) where asinh (Dual a b) = Dual (asinh a) (b / sqrt (1 + a * a)) acosh (Dual a b) = Dual (acosh a) (b / sqrt (a * a - 1)) atanh (Dual a b) = Dual (atanh a) (b / (1 - a * a)) + +{- | Given a function on Dual numbers then primal input x, seed Dual x 1 and extract the +output tangent. Arithmetic/domains follow Dual's Num/Floating instances; no Either +validation is added. +-} derivative :: (Num a) => (Dual a -> Dual a) -> a -> a derivative f x = tangent (f (Dual x 1)) @@ -563,18 +796,31 @@ instance (RealFloat a) => Num (Quaternion a) where fromInteger n = Quaternion (fromInteger n) 0 0 0 abs q = Quaternion (quaternionNorm q) 0 0 0 signum q = let n = quaternionNorm q in if n == 0 then Quaternion 0 0 0 0 else qScale (1 / n) q + +{- | For Quaternion real i j k, negate the three imaginary components and preserve the real +part. +-} quaternionConjugate :: (Num a) => Quaternion a -> Quaternion a quaternionConjugate (Quaternion a b c d) = Quaternion a (-b) (-c) (-d) + +{- | Return scaled Euclidean norm of four quaternion components, reducing avoidable +intermediate overflow. Empty/zero-component quaternion has norm zero. +-} quaternionNorm :: (RealFloat a) => Quaternion a -> a quaternionNorm (Quaternion a b c d) | scale == 0 = 0 | otherwise = scale * sqrt (sum [let v = x / scale in v * v | x <- [a, b, c, d]]) where scale = maximum (map abs [a, b, c, d]) + qScale :: (Num a) => a -> Quaternion a -> Quaternion a qScale s (Quaternion a b c d) = Quaternion (s * a) (s * b) (s * c) (s * d) qDivide :: (Fractional a) => Quaternion a -> a -> Quaternion a qDivide (Quaternion a b c d) s = Quaternion (a / s) (b / s) (c / s) (d / s) + +{- | Invert a finite nonzero quaternion using scaled norm arithmetic. Zero/non-finite input +returns DomainError; non-finite inverse returns NonFiniteResult. +-} quaternionInverse :: (RealFloat a) => Quaternion a -> Either MathError (Quaternion a) quaternionInverse q@(Quaternion a b c d) | any (\x -> isNaN x || isInfinite x) [a, b, c, d] || maximum (map abs [a, b, c, d]) == 0 = @@ -586,8 +832,14 @@ quaternionInverse q@(Quaternion a b c d) denom = e * e + f * f + g * g + h * h out = qDivide (qDivide (quaternionConjugate qs) denom) scale in if qFinite out then Right out else Left NonFiniteResult + qFinite :: (RealFloat a) => Quaternion a -> Bool qFinite (Quaternion a b c d) = all (\x -> not (isNaN x || isInfinite x)) [a, b, c, d] + +{- | Given nonzero finite quaternion q then (x,y,z), return imaginary part of +q*(0,x,y,z)*inverse(q). Normalization of q is implicit in the inverse; invalid +input/result returns Left MathError. +-} rotateVector :: (RealFloat a) => Quaternion a -> (a, a, a) -> Either MathError (a, a, a) rotateVector q (x, y, z) = do qi <- quaternionInverse q @@ -596,9 +848,20 @@ rotateVector q (x, y, z) = do then Right (a, b, c) else Left NonFiniteResult +{- | Real and dual quaternion pair, commonly representing a rigid rotation/translation. +Construct normalized rigid transforms with rigidTransform. +-} data DualQuaternion a = DualQuaternion (Quaternion a) (Quaternion a) deriving (Eq, Show) + +{- | Multiply real/dual quaternion pairs as (a,b)*(c,d)=(a*c,a*d+b*c). Return the product +using host quaternion arithmetic; no validation or normalization is added. +-} dualQuaternionMultiply :: (RealFloat a) => DualQuaternion a -> DualQuaternion a -> DualQuaternion a dualQuaternionMultiply (DualQuaternion a b) (DualQuaternion c d) = DualQuaternion (a * c) (a * d + b * c) + +{- | Invert the real quaternion a, returning (inverse(a), -inverse(a)*b*inverse(a)). Invalid +real part propagates quaternionInverse failure. +-} dualQuaternionInverse :: (RealFloat a) => DualQuaternion a -> Either MathError (DualQuaternion a) dualQuaternionInverse (DualQuaternion a b) = do ai <- quaternionInverse a; Right (DualQuaternion ai (negate (ai * b * ai))) @@ -613,6 +876,10 @@ rigidTransform q (x, y, z) = do dual = Quaternion 0 (x / 2) (y / 2) (z / 2) * r if qFinite r && qFinite dual then Right (DualQuaternion r dual) else Left NonFiniteResult +{- | Given dual-quaternion transform then point tuple, rotate by its real part and add +translation from twice the dual part times the real inverse. Invalid inverse or +non-finite result fails. +-} transformPoint :: (RealFloat a) => DualQuaternion a -> (a, a, a) -> Either MathError (a, a, a) transformPoint (DualQuaternion r d) v = do (a, b, c) <- rotateVector r v @@ -622,16 +889,27 @@ transformPoint (DualQuaternion r d) v = do then Right (a + x, b + y, c + z) else Left NonFiniteResult +{- | Sum a finite list using Kahan compensation; empty input yields zero. Arithmetic follows +Num and compensation does not promise exact rounding or reject non-finite values. +-} kahanSum :: (Num a) => [a] -> a kahanSum xs = fst (L.foldl' step (0, 0) xs) where step (s, c) x = let y = x - c; t = s + y in (t, (t - s) - y) + +{- | Sum a finite list with Neumaier compensation, correcting for differing term magnitudes. +Empty input gives zero; arithmetic follows the chosen ordered Num type. +-} neumaierSum :: (Num a, Ord a) => [a] -> a neumaierSum xs = let (s, c) = L.foldl' step (0, 0) xs in s + c where step (s, c) x = let t = s + x; correction = if abs s >= abs x then (s - t) + x else (x - t) + s in (t, c + correction) + +{- | Recursively split and sum a finite list to reduce sequential rounding accumulation. +Empty input gives zero. Arithmetic remains that of the chosen Num type. +-} pairwiseSum :: (Num a) => [a] -> a pairwiseSum [] = 0 pairwiseSum [x] = x diff --git a/src/HMath/ODE.hs b/src/HMath/ODE.hs index 6fcb365..3591cd4 100644 --- a/src/HMath/ODE.hs +++ b/src/HMath/ODE.hs @@ -68,12 +68,19 @@ rejected attempts, and newtonIterations bounds each implicit correction. -} data ODEOptions = ODEOptions { odeAbsoluteTolerance :: Double + -- ^ Finite positive absolute local error tolerance. , odeRelativeTolerance :: Double + -- ^ Finite nonnegative local error tolerance relative to state scale. , initialStep :: Double + -- ^ Requested positive initial step magnitude; integration direction follows time bounds. , minimumStep :: Double + -- ^ Positive minimum permitted step magnitude before reporting failure. , maximumStep :: Double + -- ^ Positive maximum permitted step magnitude. , maximumSteps :: Int + -- ^ Maximum integration-step work budget. , newtonIterations :: Int + -- ^ Iteration budget for implicit-method nonlinear solves. } deriving (Eq, Show) @@ -85,7 +92,13 @@ defaultODEOptions = ODEOptions 1e-9 1e-7 1e-2 1e-12 0.1 100000 30 constructor is public for inspection; interpolation validates all dimensions. -} data Trajectory = Trajectory - {trajectoryTimes :: [Double], trajectoryStates :: [[Double]], trajectoryDerivatives :: [[Double]]} + { trajectoryTimes :: [Double] + -- ^ Accepted sample times in integration order. + , trajectoryStates :: [[Double]] + -- ^ State vector at each trajectory time. + , trajectoryDerivatives :: [[Double]] + -- ^ ODE derivative vector at each trajectory sample, used by dense output. + } deriving (Eq, Show) finite :: Double -> Bool @@ -473,7 +486,13 @@ zip4 _ _ _ _ = [] data EventDirection = AnyDirection | Rising | Falling deriving (Eq, Show) -- | A located event time and its dense-interpolated state. -data Event = Event {eventTime :: Double, eventState :: [Double]} deriving (Eq, Show) +data Event = Event + { eventTime :: Double + -- ^ Located event crossing time. + , eventState :: [Double] + -- ^ Interpolated state vector at eventTime. + } + deriving (Eq, Show) {- | Locate bracketed sign-changing events by dense-output bisection. Tangential roots and multiple roots inside one sample interval are not guaranteed. diff --git a/src/HMath/Optimization/Common.hs b/src/HMath/Optimization/Common.hs index 3c48b12..057d45c 100644 --- a/src/HMath/Optimization/Common.hs +++ b/src/HMath/Optimization/Common.hs @@ -41,16 +41,38 @@ import HMath.Error import qualified HMath.Matrix as M import qualified HMath.Matrix.LU as LU +-- | Scalar objective function over a parameter vector, supplied by the optimization caller. type Objective = [Double] -> Either MathError Double + +{- | Caller-supplied gradient components in parameter order; dimension/finite checks occur +in the consuming optimizer. +-} type Gradient = [Double] -> Either MathError [Double] + +{- | Caller-supplied second-derivative matrix in parameter order, consumed by checked Newton +methods. +-} type Hessian = [Double] -> Either MathError [[Double]] + +{- | Finite optimization work budgets,tolerance,and method step rate. Start from +defaultOptimizeOptions. +-} data OptimizeOptions = OptimizeOptions { optMaxIterations :: Int + -- ^ Maximum optimization iterations. , optMaxEvaluations :: Int + -- ^ Maximum objective/evaluation work budget. , optTolerance :: Double + -- ^ Positive finite method-specific stopping tolerance. , optLearningRate :: Double + -- ^ Positive finite step-size/rate where used by the method. } deriving (Eq, Show) + +{- | Default optimization options: 1000 iterations, 20000 evaluations, tolerance 1e-8 and +learning rate 0.01. Customize with record updates; algorithms validate the selected +settings. +-} defaultOptimizeOptions :: OptimizeOptions defaultOptimizeOptions = OptimizeOptions 1000 20000 1e-8 0.01 @@ -61,11 +83,17 @@ methods. Stochastic searches cannot certify global optimality. -} data OptimizeResult = OptimizeResult { optPoint :: [Double] + -- ^ Returned parameter vector at the accepted estimate. , optValue :: Double + -- ^ Objective value at optPoint. , optGradientNorm :: Double + -- ^ Gradient,projected/proximal,or geometric stopping residual as defined by the selected method. , optIterations :: Int + -- ^ Completed optimization iterations. , optEvaluations :: Int + -- ^ Recorded objective/evaluation count. , optConverged :: Bool + -- ^ Whether the selected method met its stopping criterion; this does not certify a global optimum. } deriving (Eq, Show) @@ -156,6 +184,9 @@ result k n converged f g x = do checkedPoint [norm gs] Right (OptimizeResult x y (norm gs) k (n + 2) converged) +{- | Selected constant or scheduled learning-rate policy, with method-specific parameters +validated by the schedule function. +-} data LearningRate = ConstantRate Double | StepDecay Double Int Double @@ -189,7 +220,17 @@ learningRate schedule step checkedPoint [value] if value < 0 then Left (InvalidArgument "negative learning rate") else Right value -data EarlyStopping = EarlyStopping {bestScore :: Maybe Double, staleSteps :: Int, stopped :: Bool} +{- | Explicit monitoring state retaining the best score,nonimproving count,and stop flag; it +does not mutate an optimizer automatically. +-} +data EarlyStopping = EarlyStopping + { bestScore :: Maybe Double + -- ^ Best monitored score so far, or Nothing before the first observation. + , staleSteps :: Int + -- ^ Consecutive monitoring updates without sufficient improvement. + , stopped :: Bool + -- ^ Whether early-stopping patience has been exhausted. + } deriving (Eq, Show) -- | Track strict improvement beyond minDelta; stop after patience stale observations. @@ -203,6 +244,7 @@ earlyStopping patience minDelta value state = do stale = if improved then 0 else staleSteps state + 1 Right (EarlyStopping (if improved then Just value else bestScore state) stale (stale >= patience)) +-- | Step selection policy: Armijo backtracking or strong-Wolfe conditions. data LineSearch = Armijo | StrongWolfe deriving (Eq, Show) {- | Backtracking Armijo or bracket-and-zoom strong Wolfe (c1=1e-4,c2=.9). diff --git a/src/HMath/Optimization/Constrained.hs b/src/HMath/Optimization/Constrained.hs index eb53f45..a4dcf33 100644 --- a/src/HMath/Optimization/Constrained.hs +++ b/src/HMath/Optimization/Constrained.hs @@ -27,9 +27,17 @@ import HMath.Error import HMath.Optimization.Common import HMath.Optimization.Local (QuasiNewton (BFGS), minimizeQuasiNewton) +{- | Scalar Equality or LessEqual constraint over the parameter vector; inequality functions +use the solver's \<=0 convention. +-} data Constraint = Equality Objective Gradient | LessEqual Objective Gradient + +{- | Constrained-optimization strategy selecting quadratic penalty,log barrier,augmented +Lagrangian,or interior-point treatment. +-} data PenaltyMethod = QuadraticPenalty | LogBarrier | InteriorPoint | AugmentedLagrangian deriving (Eq, Show) + constraintValues :: [Constraint] -> [Double] -> Either MathError [(Bool, Double, [Double])] constraintValues cs x = mapM value cs where @@ -165,7 +173,19 @@ constrainedMinimize method o f g constraints x0 = do Left e -> Left e _ -> backtrack remaining (k + 1) (rate / 2) y gs x -data LPResult = LPResult {lpPoint :: [Double], lpValue :: Double, lpBasis :: [Int], lpIterations :: Int} +{- | Linear-program primal solution,objective value,retained basis indices,and iteration +count. +-} +data LPResult = LPResult + { lpPoint :: [Double] + -- ^ Returned primal variable vector of the linear program. + , lpValue :: Double + -- ^ Objective value at the returned LP point. + , lpBasis :: [Int] + -- ^ Zero-based basis indices retained by the simplex solution. + , lpIterations :: Int + -- ^ Number of simplex iterations performed. + } deriving (Eq, Show) {- | Primal two-phase simplex with Bland entering/leaving rules. Tolerance is diff --git a/src/HMath/Optimization/FirstOrder.hs b/src/HMath/Optimization/FirstOrder.hs index b3cee19..aad4741 100644 --- a/src/HMath/Optimization/FirstOrder.hs +++ b/src/HMath/Optimization/FirstOrder.hs @@ -24,6 +24,9 @@ import qualified Data.Foldable as Foldable (foldl') import HMath.Error import HMath.Optimization.Common +{- | First-order optimizer selector, including momentum and adaptive-moment variants. +Stateful parameters are validated by the selected optimizer. +-} data GradientMethod = GradientDescent | Momentum @@ -38,6 +41,10 @@ data GradientMethod | Nadam | RAdam deriving (Eq, Show, Enum, Bounded) + +{- | Opaque accumulated first-order optimizer moments/history. Initialize and advance +through the stateful optimizer API. +-} data OptimizerState = OptimizerState Int [Double] [Double] [Double] deriving (Eq, Show) -- | Allocate zero momentum/moment buffers for a nonnegative parameter count. diff --git a/src/HMath/Optimization/Global.hs b/src/HMath/Optimization/Global.hs index 21dcf1b..7959ddb 100644 --- a/src/HMath/Optimization/Global.hs +++ b/src/HMath/Optimization/Global.hs @@ -20,6 +20,9 @@ import HMath.Optimization.Common import HMath.Optimization.Local (nelderMead) import HMath.Random (Generator (PCG32), RNG, normal, sampleN, seedRNG, uniform) +{- | Seeded bounded stochastic search strategy. A successful finite run does not certify +global optimality. +-} data GlobalMethod = SimulatedAnnealing | DifferentialEvolution @@ -27,6 +30,7 @@ data GlobalMethod | ParticleSwarm | CMAES deriving (Eq, Show) + validateBounds :: [(Double, Double)] -> Either MathError () validateBounds bounds = do checkedPoint (concatMap (\(lo, hi) -> [lo, hi, hi - lo]) bounds) diff --git a/src/HMath/Optimization/Local.hs b/src/HMath/Optimization/Local.hs index ee5c195..c6e23f0 100644 --- a/src/HMath/Optimization/Local.hs +++ b/src/HMath/Optimization/Local.hs @@ -27,6 +27,7 @@ import Data.List (sortOn) import HMath.Error import HMath.Optimization.Common +-- | Bounded one-dimensional minimization strategy (golden section,Brent,or ternary search). data ScalarMethod = GoldenSection | TernarySearch | BrentSearch deriving (Eq, Show) -- | Minimize on a finite bracket a Either MathError [Double] + +{- | Caller-supplied residual Jacobian with rows corresponding to residual components and +columns to parameters. +-} type JacobianFunction = [Double] -> Either MathError [[Double]] + +{- | Robust residual penalty selector. Parameterized Huber/Cauchy/SoftL1 choices carry the +selected scale; checked solvers validate it. +-} data LeastSquaresLoss = SquaredLoss | HuberLoss Double | CauchyLoss Double | SoftL1 Double deriving (Eq, Show) diff --git a/src/HMath/PDE.hs b/src/HMath/PDE.hs index 5e14905..9634dae 100644 --- a/src/HMath/PDE.hs +++ b/src/HMath/PDE.hs @@ -74,7 +74,14 @@ data PDEOperator = PDEOperator Grid (S.Sparse Double) (S.Sparse Double) [Double] deriving (Eq, Show) -- | Nodal solution with independently recomputed infinity residual; errorEstimate reports backward residual only. -data PDEResult = PDEResult {pdeValues :: [Double], pdeResidual :: Double, pdeErrorEstimate :: Double} +data PDEResult = PDEResult + { pdeValues :: [Double] + -- ^ Computed grid solution values in the solver's documented spatial order. + , pdeResidual :: Double + -- ^ Residual measure at the returned grid solution. + , pdeErrorEstimate :: Double + -- ^ Solver-specific discretization/error estimate; not a universal certified bound. + } deriving (Eq, Show) -- | Construct a grid with >=3 nodes per axis; reject overflowing counts and rounded-away duplicate coordinates. diff --git a/src/HMath/Probability.hs b/src/HMath/Probability.hs index 8117f06..67b7582 100644 --- a/src/HMath/Probability.hs +++ b/src/HMath/Probability.hs @@ -66,6 +66,19 @@ import HMath.Matrix.LU (determinant, inverse, solve) import qualified HMath.Random as R import qualified HMath.Special as S +{- | Parameterized probability law. Constructors carry: Bernoulli p; Binomial trials p; +NegativeBinomial successes p; Geometric p; Hypergeometric population successes draws; +Poisson rate; Categorical probabilities; DiscreteUniform lo hi; Uniform lo hi; Normal +mean standardDeviation; LogNormal logMean logStandardDeviation; Exponential rate; Gamma +shape scale; Beta alpha beta; ChiSquare degrees; StudentT degrees; FisherF +numeratorDegrees denominatorDegrees; Cauchy/Laplace/Logistic location scale; Weibull +shape scale; Pareto scale shape; Rayleigh/Maxwell scale; Gumbel location scale; +GeneralizedExtremeValue location scale shape; BetaBinomial trials alpha beta; Skellam +rate1 rate2; VonMises meanAngle concentration; Triangular lo mode hi; TruncatedNormal +mean standardDeviation lo hi; Mixture weightedLaws; Empirical samples; GaussianKDE +bandwidth samples. Call validateDistribution to check finite +parameters,support,normalization,and family budgets before numerical use. +-} data Distribution = Bernoulli Double | Binomial Int Double @@ -102,6 +115,7 @@ data Distribution | Empirical [Double] | GaussianKDE Double [Double] deriving (Eq, Show) + finite :: Double -> Bool finite x = not (isNaN x || isInfinite x) positive :: Double -> Bool diff --git a/src/HMath/Root.hs b/src/HMath/Root.hs index 52c443a..811df0a 100644 --- a/src/HMath/Root.hs +++ b/src/HMath/Root.hs @@ -39,35 +39,79 @@ import qualified HMath.Matrix as M import qualified HMath.Matrix.LU as LU import qualified HMath.Polynomial as P +{- | Root-solver iteration/evaluation budgets and residual/step tolerances, initialized with +defaultRootOptions. +-} data RootOptions = RootOptions { rootMaxIterations :: Int + -- ^ Maximum scalar-root iteration count. , rootMaxEvaluations :: Int + -- ^ Maximum scalar function/derivative evaluation budget. , rootTolerance :: Double + -- ^ Requested finite positive residual tolerance. , rootStepTolerance :: Double + -- ^ Requested finite positive parameter-step tolerance. } deriving (Eq, Show) + +{- | Default root-solving limits: 200 iterations, 4000 evaluations, residual tolerance 1e-10 +and step tolerance 1e-12. Solvers validate options and report their own convergence +diagnostics. +-} defaultRootOptions :: RootOptions defaultRootOptions = RootOptions 200 4000 1e-10 1e-12 + +{- | Scalar root estimate with residual,optional certified bracket error bound,and work +counts. +-} data RootResult = RootResult { rootValue :: Double + -- ^ Returned scalar root estimate. , rootResidual :: Double + -- ^ Absolute function residual at rootValue. , rootErrorBound :: Maybe Double + -- ^ Optional bracket-based absolute root error bound; Nothing when the method cannot certify one. , rootIterations :: Int + -- ^ Completed scalar-root iterations. , rootEvaluations :: Int + -- ^ Recorded function/derivative evaluation count. } deriving (Eq, Show) + +{- | Validated scalar bracketing state used by checked bracketed root solvers; construct +through the bracketing API. +-} data Bracket = Bracket Double Double Double Double deriving (Eq, Show) + +{- | Bracket-preserving root strategy such as bisection,Brent,Ridder,or regula falsi +variants. +-} data BracketMethod = Bisection | RegulaFalsi | Illinois | Brent | Ridder deriving (Eq, Show) + +{- | Derivative-based scalar-root strategy, including Newton,Halley,and Householder methods +with their required derivatives. +-} data DerivativeMethod = Newton | Halley | Householder3 deriving (Eq, Show) + +-- | Fixed-point acceleration strategy, selecting Picard,Aitken,or Steffensen iteration. data FixedPointMethod = Picard | Aitken | SteffensenFixed deriving (Eq, Show) + +-- | Multivariate root strategy, selecting checked Newton or Broyden updates. data SystemMethod = MultivariateNewton | NewtonTrustRegion Double | Broyden deriving (Eq, Show) + +-- | Returned multivariate root vector with residual norm and iteration/evaluation counts. data SystemRootResult = SystemRootResult { systemRoot :: [Double] + -- ^ Returned multivariate root parameter vector. , systemResidual :: Double + -- ^ Norm of the residual function at systemRoot. , systemIterations :: Int + -- ^ Completed nonlinear-system iterations. , systemEvaluations :: Int + -- ^ Recorded system function/evaluation count. } deriving (Eq, Show) + finite :: Double -> Bool finite x = not (isNaN x || isInfinite x) valid :: RootOptions -> Either MathError () diff --git a/src/HMath/Scalar.hs b/src/HMath/Scalar.hs index 862dd18..61a56b0 100644 --- a/src/HMath/Scalar.hs +++ b/src/HMath/Scalar.hs @@ -76,8 +76,20 @@ import Data.Ratio ((%)) import HMath.Error (MathError (..)) add, subtractScalar, multiply :: (Num a) => a -> a -> a + +{- | Add two values using their Num instance. No overflow check is added; bounded integral +types retain their usual arithmetic behavior. Example: add 2 3 == 5. +-} add = (+) + +{- | Subtract the second value from the first using Num arithmetic. Example: subtractScalar +5 2 == 3; use checkedSubtract to reject bounded integer overflow. +-} subtractScalar = (-) + +{- | Multiply two values using Num arithmetic. Example: multiply 3 4 == 12; use +checkedMultiply or checkedFloatMultiply for explicit overflow checks. +-} multiply = (*) finite :: (RealFloat a) => a -> Bool @@ -93,12 +105,21 @@ inputs xs | all finite xs = Right () | otherwise = Left (DomainError "non-finite scalar input") +{- | Divide the first finite real value by the second. Return Left DomainError for +non-finite input or a zero divisor, and Left NonFiniteResult for overflow. Example: +divide 6 2 == Right 3. +-} divide :: (RealFloat a) => a -> a -> Either MathError a divide a b = do inputs [a, b] if b == 0 then Left (DomainError "division by zero") else result (a / b) quotientRemainder, euclideanDivision :: Integer -> Integer -> Either MathError (Integer, Integer) + +{- | Return integer quotient and remainder using quotRem (quotient truncates toward zero). A +zero divisor returns Left DomainError. Example: quotientRemainder (-7) 3 == Right +(-2,-1). +-} quotientRemainder _ 0 = Left (DomainError "division by zero") quotientRemainder a b = Right (quotRem a b) @@ -107,12 +128,31 @@ euclideanDivision _ 0 = Left (DomainError "division by zero") euclideanDivision a b = let r = a `mod` abs b in Right ((a - r) `quot` b, r) absolute, sign :: (Num a) => a -> a + +{- | Return abs using the supplied Num instance, including that instance's overflow +behavior. Example: absolute (-3) == 3. +-} absolute = abs + +-- | Return signum using the supplied Num instance. Example: sign (-3) == -1; sign 0 == 0. sign = signum + minimumScalar, maximumScalar :: (Ord a) => a -> a -> a + +{- | Return the smaller of two values under their Ord instance. Example: minimumScalar 2 5 +== 2. +-} minimumScalar = min + +{- | Return the larger of two values under their Ord instance. Example: maximumScalar 2 5 == +5. +-} maximumScalar = max +{- | Given lower bound, upper bound, then value, clamp to the closed interval. Non-finite +inputs or reversed bounds return Left DomainError. Example: clampChecked 0 1 2 == Right +1. +-} clampChecked :: (RealFloat a) => a -> a -> a -> Either MathError a clampChecked lo hi x = do inputs [lo, hi, x] @@ -126,6 +166,10 @@ lerpChecked a b t = do inputs [a, b, t] result (fromRational (toRational a + toRational t * (toRational b - toRational a))) +{- | Given endpoints a,b then value x, return (x-a)/(b-a) using rational intermediates and +one conversion. Equal endpoints/non-finite inputs fail; extrapolation is allowed. +Example: inverseLerp 10 20 15 == Right 0.5. +-} inverseLerp :: (RealFloat a) => a -> a -> a -> Either MathError a inverseLerp a b x = do inputs [a, b, x] @@ -133,28 +177,62 @@ inverseLerp a b x = do then Left (DomainError "equal interpolation endpoints") else result (fromRational ((toRational x - toRational a) / (toRational b - toRational a))) +{- | Given source endpoints a,b, destination endpoints c,d, then x, map x from the source +interval to the destination interval. Extrapolation is allowed. Fails on equal source +endpoints, non-finite input/result. Example: remap 0 10 0 100 5 == Right 50. +-} remap :: (RealFloat a) => a -> a -> a -> a -> a -> Either MathError a remap a b c d x = inverseLerp a b x >>= lerpChecked c d + +{- | Given edge then x, return 0 below the edge and 1 at/above it. Non-finite inputs return +Left DomainError. Example: step 2 2 == Right 1. +-} step :: (RealFloat a) => a -> a -> Either MathError a step edge x = inputs [edge, x] >> Right (if x < edge then 0 else 1) + smoothstep, smootherstep :: (RealFloat a) => a -> a -> a -> Either MathError a + +{- | Given strictly increasing edges then x, clamp t=(x-a)/(b-a) to [0,1] and return +t*t*(3-2*t). Invalid edges/non-finite values fail. Example: smoothstep 0 1 0.5 == Right +0.5. +-} smoothstep a b x = do t <- boundedParameter a b x result (t * t * (3 - 2 * t)) + +{- | Given increasing edges then x, apply the quintic 6t^5-15t^4+10t^3 to the clamped +interpolation parameter. Invalid edges/non-finite values fail. Example: smootherstep 0 +1 0.5 == Right 0.5. +-} smootherstep a b x = do t <- boundedParameter a b x result (t * t * t * (t * (t * 6 - 15) + 10)) + boundedParameter :: (RealFloat a) => a -> a -> a -> Either MathError a boundedParameter a b x | a >= b = Left (DomainError "smoothstep requires increasing edges") | otherwise = inverseLerp a b x >>= clampChecked 0 1 +{- | Raise a finite real base to a finite real exponent using (**). Non-real/domain results +and overflow return Left NonFiniteResult; non-finite input fails. Example: power 2 3 == +Right 8. +-} power :: (RealFloat a) => a -> a -> Either MathError a power a b = inputs [a, b] >> result (a ** b) + +{- | Raise a finite real base to an Integer exponent, allowing negative powers except for a +zero base. Invalid zero reciprocal/non-finite input fails; overflow is NonFiniteResult. +Example: integerPower 2 (-2) == Right 0.25. +-} integerPower :: (RealFloat a) => a -> Integer -> Either MathError a integerPower a n = do inputs [a] if a == 0 && n < 0 then Left (DomainError "negative power of zero") else result (a ^^ n) + +{- | Given base, nonnegative exponent, positive modulus, compute modular exponentiation by +squaring. Invalid exponent/modulus returns Left DomainError. Example: modularPower 2 10 +1000 == Right 24. +-} modularPower :: Integer -> Integer -> Integer -> Either MathError Integer modularPower a n m | n < 0 || m <= 0 = @@ -165,25 +243,56 @@ modularPower a n m go b k acc = go ((b * b) `mod` m) (k `quot` 2) (if odd k then (acc * b) `mod` m else acc) sqrtChecked, cubeRoot, reciprocalSqrt :: (RealFloat a) => a -> Either MathError a + +{- | Return the nonnegative square root of a finite nonnegative input; reject +negatives/non-finite values. Example: sqrtChecked 9 == Right 3. +-} sqrtChecked x = inputs [x] >> if x < 0 then Left (DomainError "negative square root") else result (sqrt x) + +{- | Return the signed real cube root of a finite input, including negative values, through +nthRoot 3. Example: cubeRoot (-8) is approximately Right (-2). +-} cubeRoot x = nthRoot 3 x + +{- | Return 1/sqrt(x) for finite strictly positive x. Zero/negative/non-finite inputs fail, +as does a non-finite result. Example: reciprocalSqrt 4 == Right 0.5. +-} reciprocalSqrt x = inputs [x] >> if x <= 0 then Left (DomainError "reciprocal square root needs positive input") else result (1 / sqrt x) + +{- | Given positive integer degree n then finite x, return its signed real n-th root. Even +roots of negative x and nonpositive degrees fail. Example: nthRoot 3 (-8) is +approximately Right (-2). +-} nthRoot :: (RealFloat a) => Int -> a -> Either MathError a nthRoot n x = do inputs [x] if n <= 0 || (x < 0 && even n) then Left (DomainError "invalid real root") else if x == 0 then Right x else result (signum x * exp (log (abs x) / fromIntegral n)) + expChecked, logChecked :: (RealFloat a) => a -> Either MathError a + +{- | Compute exp of a finite input, reporting non-finite output as Left NonFiniteResult. +Finite underflow to zero is allowed. Example: expChecked 0 == Right 1. +-} expChecked x = inputs [x] >> result (exp x) + +{- | Compute the natural logarithm of finite positive x. Zero/negative/non-finite input +fails. Example: logChecked 1 == Right 0. +-} logChecked x = inputs [x] >> if x <= 0 then Left (DomainError "logarithm needs positive input") else result (log x) expm1, log1p :: (RealFloat a) => a -> Either MathError a + +{- | Compute exp(x)-1, using a convergent series near zero to reduce cancellation. Reject +non-finite input/output; preserve signed zero. Example: expm1 0 == Right 0. This is not +a correct-rounding guarantee. +-} expm1 x = do inputs [x] if x == 0 then Right x else result (if abs x < 0.5 then expSeries 1 x x else exp x - 1) @@ -194,6 +303,10 @@ expm1 x = do where term' = term * x / fromIntegral (k + 1 :: Int) next = acc + term' + +{- | Compute log(1+x), using a series near zero. Require finite x greater than -1; preserve +signed zero and reject non-finite output. Example: log1p 0 == Right 0. +-} log1p x = do inputs [x] if x <= -1 @@ -211,6 +324,9 @@ log1p x = do term' = term * y * y next = acc + term' / fromIntegral (2 * k + 1 :: Int) +{- | Return sqrt(a*a+b*b) with scaling to avoid avoidable intermediate overflow. Require +finite inputs and result. Example: hypot 3 4 == Right 5. +-} hypot :: (RealFloat a) => a -> a -> Either MathError a hypot a b = do inputs [a, b] @@ -223,10 +339,30 @@ floorChecked , truncateChecked , bankersRound :: (RealFloat a) => a -> Either MathError Integer + +{- | Convert a finite real to the greatest Integer no larger than it. Non-finite input +fails. Example: floorChecked (-1.2) == Right (-2). +-} floorChecked x = inputs [x] >> Right (floor x) + +{- | Convert a finite real to the least Integer no smaller than it. Non-finite input fails. +Example: ceilChecked 1.2 == Right 2. +-} ceilChecked x = inputs [x] >> Right (ceiling x) + +{- | Round a finite real to Integer with ties to even, as bankersRound. Non-finite input +fails. Example: roundChecked 2.5 == Right 2. +-} roundChecked = bankersRound + +{- | Convert finite real to Integer toward zero. Non-finite input fails. Example: +truncateChecked (-1.8) == Right (-1). +-} truncateChecked x = inputs [x] >> Right (truncate x) + +{- | Round a finite real to nearest Integer, resolving exact half ties to even. Non-finite +input fails. Example: bankersRound 3.5 == Right 4. +-} bankersRound x = inputs [x] >> Right (round x) {- | Decimal-place rounding with exact rational scaling and ties to even. Negative @@ -241,16 +377,32 @@ roundDigits n x = do let scale = if n >= 0 then fromInteger (10 ^ n) else 1 / fromInteger (10 ^ negate n) in result (fromRational (fromInteger (round (toRational x * scale)) / scale)) +{- | Split finite x into its truncated Integer and signed fractional remainder. Non-finite +input fails. Example: integerFraction (-1.5) == Right (-1,-0.5). +-} integerFraction :: (RealFloat a) => a -> Either MathError (Integer, a) integerFraction x = do inputs [x] let n = truncate x Right (n, if x == 0 then x else x - fromInteger n) + +{- | Given integral value then strictly positive modulus, return the nonnegative remainder. +Nonpositive modulus fails. Example: positiveModulo (-1) 5 == Right 4. +-} positiveModulo :: (Integral a) => a -> a -> Either MathError a positiveModulo _ m | m <= 0 = Left (DomainError "modulus must be positive") positiveModulo a m = Right (a `mod` m) + absoluteError, relativeError :: (RealFloat a) => a -> a -> Either MathError a + +{- | Given actual then expected finite values, return abs(actual-expected); reject +non-finite input/result. Example: absoluteError 3 2 == Right 1. +-} absoluteError actual expected = inputs [actual, expected] >> result (abs (actual - expected)) + +{- | Given actual then expected, return absolute error divided by abs(expected). Expected +must be nonzero and inputs/results finite. Example: relativeError 3 2 == Right 0.5. +-} relativeError actual expected = if expected == 0 then Left (DomainError "zero reference for relative error") @@ -266,37 +418,80 @@ factorialChecked , lucas , catalan :: Integer -> Either MathError Integer + +{- | Return exact n! for nonnegative Integer n; negatives fail with DomainError. Example: +factorialChecked 5 == Right 120. No fixed-size arithmetic overflow occurs. +-} factorialChecked n = nonnegative n >> Right (product [1 .. n]) + +{- | Return n*(n-2)*... exactly for n >= 0; (-1)!! is also 1. Other negative n fail. +Example: doubleFactorial 5 == Right 15. +-} doubleFactorial n | n == -1 = Right 1 | otherwise = nonnegative n >> Right (product [n, n - 2 .. 1]) + risingFactorial, fallingFactorial :: Integer -> Integer -> Either MathError Integer + +{- | Given integer x then nonnegative length n, return x*(x+1)*...*(x+n-1). Negative length +fails; length zero gives 1. Example: risingFactorial 3 2 == Right 12. +-} risingFactorial x n = nonnegative n >> Right (product [x .. x + n - 1]) + +{- | Given integer x then nonnegative length n, return x*(x-1)*...*(x-n+1). Negative length +fails; length zero gives 1. Example: fallingFactorial 3 2 == Right 6. +-} fallingFactorial x n = nonnegative n >> Right (product [x - n + 1 .. x]) + +{- | Return exact zero-based Fibonacci number using fast doubling (F0=0,F1=1). Negative +index fails. Example: fibonacciChecked 10 == Right 55. +-} fibonacciChecked n = nonnegative n >> Right (fst (fibPair n)) + fibPair :: Integer -> (Integer, Integer) fibPair 0 = (0, 1) fibPair n = let (a, b) = fibPair (n `quot` 2); c = a * (2 * b - a); d = a * a + b * b in if even n then (c, d) else (d, c + d) + +{- | Return exact zero-based Lucas number (L0=2,L1=1). Negative index fails. Example: lucas +5 == Right 11. +-} lucas n = nonnegative n >> let (a, b) = fibPair n in Right (2 * b - a) + permutations, combinations :: Integer -> Integer -> Either MathError Integer + +{- | Given nonnegative n,k, return n!/(n-k)!; k>n gives zero. Negative inputs fail. Example: +permutations 4 2 == Right 12. +-} permutations n k = do nonnegative n nonnegative k if k > n then Right 0 else Right (product [n - k + 1 .. n]) + +{- | Given nonnegative n,k, return the exact binomial coefficient; k>n gives zero. Negative +inputs fail. Example: combinations 4 2 == Right 6. +-} combinations n k = do nonnegative n nonnegative k if k > n then Right 0 else let j = min k (n - k) in Right (product [n - j + 1 .. n] `quot` product [1 .. j]) + +{- | Given nonnegative group sizes, return factorial(sum sizes)/product(factorial sizes). +Negative entries fail. Example: multinomial [2,1] == Right 3. +-} multinomial :: [Integer] -> Either MathError Integer multinomial ks = do mapM_ nonnegative ks f <- factorialChecked (sum ks) fs <- mapM factorialChecked ks Right (f `quot` product fs) + +{- | Return exact n-th Catalan number for nonnegative Integer n; negative input fails. +Example: catalan 3 == Right 5. +-} catalan n = nonnegative n >> fmap (`quot` (n + 1)) (combinations (2 * n) n) -- | Bernoulli convention B1 = -1/2. Akiyama-Tanigawa exact rational recurrence. @@ -311,11 +506,27 @@ bernoulli n update xs 0 = xs update xs j = update (take (j - 1) xs ++ [fromIntegral j * (xs !! (j - 1) - xs !! j)] ++ drop j xs) (j - 1) +{- | Return exact Rational sum 1+1/2+...+1/n; n=0 gives 0 and negatives fail. Example: +harmonic 2 == Right (3/2). +-} harmonic :: Integer -> Either MathError Rational harmonic n = nonnegative n >> Right (sum [1 % k | k <- [1 .. n]]) + cumulativeSum, prefixSum, cumulativeProduct :: (Num a) => [a] -> [a] + +{- | Return inclusive running sums without a leading zero; output has input length. +Arithmetic follows Num. Example: cumulativeSum [1,2,3] == [1,3,6]. +-} cumulativeSum = drop 1 . scanl (+) 0 + +{- | Return running sums including a leading zero; output length is input length plus one. +Example: prefixSum [1,2] == [0,1,3]. +-} prefixSum = scanl (+) 0 + +{- | Return inclusive running products without a leading one. Arithmetic follows Num. +Example: cumulativeProduct [2,3,4] == [2,6,24]. +-} cumulativeProduct = drop 1 . scanl (*) 1 {- | Software single-rounding FMA for finite inputs using exact 'Rational'. This @@ -328,9 +539,22 @@ fusedMultiplyAdd a b c = do result (if r == 0 && a * b == 0 && c == 0 then a * b + c else fromRational r) saturatingAdd, saturatingSubtract, saturatingMultiply :: (Integral a, Bounded a) => a -> a -> a + +{- | Add bounded integers through an exact Integer intermediate and clamp to the destination +minBound/maxBound. Example: saturatingAdd (127 :: Int8) 1 == 127. +-} saturatingAdd a b = saturate (toInteger a + toInteger b) + +{- | Subtract bounded integers through Integer and clamp to type bounds instead of wrapping. +Example: saturatingSubtract (0 :: Word8) 1 == 0. +-} saturatingSubtract a b = saturate (toInteger a - toInteger b) + +{- | Multiply bounded integers through Integer and clamp to type bounds instead of wrapping. +Example: saturatingMultiply (100 :: Int8) 2 == 127. +-} saturatingMultiply a b = saturate (toInteger a * toInteger b) + saturate :: (Integral a, Bounded a) => Integer -> a saturate n = x where @@ -339,9 +563,22 @@ checkedAdd , checkedSubtract , checkedMultiply :: (Integral a, Bounded a) => a -> a -> Either MathError a + +{- | Add bounded integers using an exact intermediate. Out-of-range results return Left +DomainError, never wrap. Example: checkedAdd (2 :: Int8) 3 == Right 5. +-} checkedAdd a b = boundedResult (toInteger a + toInteger b) + +{- | Subtract bounded integers using an exact intermediate, returning Left DomainError on +underflow/overflow. Example: checkedSubtract (0 :: Word8) 1 fails. +-} checkedSubtract a b = boundedResult (toInteger a - toInteger b) + +{- | Multiply bounded integers using an exact intermediate and reject out-of-range results. +Example: checkedMultiply (100 :: Int8) 2 fails. +-} checkedMultiply a b = boundedResult (toInteger a * toInteger b) + boundedResult :: (Integral a, Bounded a) => Integer -> Either MathError a boundedResult n = r where diff --git a/src/HMath/Signal.hs b/src/HMath/Signal.hs index 4dca6aa..5adf29f 100644 --- a/src/HMath/Signal.hs +++ b/src/HMath/Signal.hs @@ -528,6 +528,10 @@ window kind n = do result = case kind of DolphChebyshev _ -> let scale = maximum (map abs raw) in map (/ scale) raw; _ -> raw vector result +{- | Given window kind, odd tap count in [1,257], cutoff frequency and positive sample rate, +return normalized low-pass FIR coefficients. Require 0\ Int -> Double -> Double -> Either MathError [Double] windowedSinc kind taps cutoff rate = do require @@ -613,7 +617,16 @@ antiAlias factor taps xs = do localFilter taps (checked . dot kernel) xs -- | Interior peak index, height, topographic prominence and half-prominence width in samples. -data Peak = Peak {peakIndex :: Int, peakHeight :: Double, peakProminence :: Double, peakWidth :: Double} +data Peak = Peak + { peakIndex :: Int + -- ^ Zero-based sample index of the detected peak. + , peakHeight :: Double + -- ^ Sample amplitude at peakIndex. + , peakProminence :: Double + -- ^ Peak height above its reference surrounding contour level. + , peakWidth :: Double + -- ^ Estimated width at the selected prominence height, measured in samples. + } deriving (Eq, Show) {- | Interior local maxima; flat plateaus select the lower middle index. Width diff --git a/src/HMath/Sparse.hs b/src/HMath/Sparse.hs index 00ce1eb..edb6263 100644 --- a/src/HMath/Sparse.hs +++ b/src/HMath/Sparse.hs @@ -63,7 +63,14 @@ import HMath.Matrix import HMath.Matrix.Internal (dotV, finiteValues, stableNorm, swap) import HMath.Matrix.LAPACK (Eigen, SVD, eigen, svd) +{- | Canonical immutable sparse matrix with summed duplicate coordinates and explicit zeros +removed. Construct using sparse or checked format conversions. +-} data Sparse a = Sparse Int Int (M.Map (Int, Int) a) deriving (Eq, Show) + +{- | Interchange representation selector carrying COO,CSR,CSC,DIA,BSR,or ELLPACK arrays; +validate through fromFormat. +-} data SparseFormat a = COO Int Int [(Int, Int, a)] | CSR Int Int [Int] [Int] [a] @@ -72,22 +79,35 @@ data SparseFormat a | BSR Int Int Int Int [Int] [Int] [[a]] | ELLPACK Int Int Int [Int] [a] deriving (Eq, Show) + shapeValid :: Int -> Int -> Either MathError () shapeValid r c | r < 0 || c < 0 = Left (NegativeDimensions (r, c)) | otherwise = Right () + +{- | Given rows,columns,then (row,column,value) entries, validate coordinates, sum +duplicates and remove explicit zeros. Return canonical ordered sparse storage; invalid +shape/indices or size overflow fail. +-} sparse :: (Eq a, Num a) => Int -> Int -> [(Int, Int, a)] -> Either MathError (Sparse a) sparse r c xs = do shapeValid r c if any (\(i, j, _) -> i < 0 || j < 0 || i >= r || j >= c) xs then Left (InvalidArgument "sparse: coordinate out of bounds") else Right (Sparse r c (M.filter (/= 0) (M.fromListWith (+) [((i, j), v) | (i, j, v) <- xs]))) + +-- | Return declared (row count,column count), including empty dimensions. sparseShape :: Sparse a -> (Int, Int) sparseShape (Sparse r c _) = (r, c) + +-- | Return canonical nonzero (row,column,value) triples in ascending coordinate order. sparseEntries :: Sparse a -> [(Int, Int, a)] sparseEntries (Sparse _ _ xs) = [(i, j, v) | ((i, j), v) <- M.toAscList xs] + +-- | Return stored nonzero count after duplicate coalescing and zero removal. nonzeros :: Sparse a -> Int nonzeros (Sparse _ _ xs) = M.size xs + segments :: Int -> Int -> [Int] -> [Int] -> [a] -> Either MathError [[(Int, a)]] segments outer inner ptr indices values | toInteger outer + 1 > toInteger (maxBound :: Int) = bad @@ -100,6 +120,11 @@ segments outer inner ptr indices values where bad = Left (InvalidArgument "sparse compressed format: invalid pointers, indices, or ordering") parts = [take (ptr !! (i + 1) - ptr !! i) (drop (ptr !! i) (zip indices values)) | i <- [0 .. outer - 1]] + +{- | Validate COO/CSR/CSC/DIA/BSR/ELLPACK dimensions, pointers/indices and values, then +construct canonical sparse storage. Invalid layout or coordinates return Left +MathError. +-} fromFormat :: (Eq a, Num a) => SparseFormat a -> Either MathError (Sparse a) fromFormat (COO r c xs) = sparse r c xs fromFormat (CSR r c ptr indices values) = do @@ -158,8 +183,16 @@ fromFormat (ELLPACK r c width indices values) = do if not (all valid rows) then Left (InvalidArgument "ELLPACK: malformed indices or padding") else sparse r c [(i, j, v) | (i, row) <- zip [0 ..] rows, (j, v) <- row, j /= (-1)] + +{- | Return coordinate-list SparseFormat with explicit row/column/value arrays, preserving +canonical nonzeros. +-} toCOO :: Sparse a -> SparseFormat a toCOO a = let (r, c) = sparseShape a in COO r c (sparseEntries a) + +{- | Return compressed sparse row format with row offsets, column indices and nonzero +values. +-} toCSR :: Sparse a -> SparseFormat a toCSR a = let (r, c) = sparseShape a @@ -171,8 +204,14 @@ toCSR a = (scanl (+) 0 [M.findWithDefault 0 i counts | i <- [0 .. r - 1]]) [j | (_, j, _) <- xs] [v | (_, _, v) <- xs] + +-- | Return compressed sparse column format with column offsets, row indices and values. toCSC :: Sparse a -> SparseFormat a toCSC a = case toCSR (sparseTranspose a) of CSR c r p i v -> CSC r c p i v; _ -> error "toCSC invariant" + +{- | Return diagonal sparse format; absent positions in represented diagonals are padded +with zero. +-} toDIA :: (Num a) => Sparse a -> SparseFormat a toDIA a = let (r, c) = sparseShape a @@ -180,6 +219,11 @@ toDIA a = offsets = M.keys (M.fromList [(j - i, ()) | (i, j, _) <- xs]) vals = M.fromList [((i, j), v) | (i, j, v) <- xs] in DIA r c [(k, [M.findWithDefault 0 (i, i + k) vals | i <- [0 .. r - 1]]) | k <- offsets] + +{- | Given positive block rows,block columns,then sparse matrix, build block-sparse-row +format with zero padding within edge blocks. Invalid block dimensions or size overflow +fails. +-} toBSR :: (Num a) => Int -> Int -> Sparse a -> Either MathError (SparseFormat a) toBSR br bc a | br <= 0 || bc <= 0 || toInteger br * toInteger bc > toInteger (maxBound :: Int) = @@ -206,6 +250,10 @@ toBSR br bc a ) where (r, c) = sparseShape a + +{- | Return ELLPACK padded row storage, using row width equal to maximum nonzeros per row. +Invalid/overflowing storage dimensions fail. +-} toELLPACK :: (Num a) => Sparse a -> Either MathError (SparseFormat a) toELLPACK a | toInteger r * toInteger width > toInteger (maxBound :: Int) = @@ -224,6 +272,10 @@ toELLPACK a rows = M.fromListWith (++) [(i, [(j, v)]) | (i, j, v) <- sparseEntries a] row i = sortOn fst (M.findWithDefault [] i rows) width = maximum (0 : map length (M.elems rows)) + +{- | Return a dense Matrix with the same dimensions and zeros for missing entries. Checked +dense element-count overflow can fail. +-} sparseToDense :: (Num a) => Sparse a -> Either MathError (Matrix a) sparseToDense (Sparse r c xs) = fromListChecked @@ -233,18 +285,38 @@ sparseToDense (Sparse r c xs) = then [] else [M.findWithDefault 0 (i, j) xs | i <- [0 .. r - 1], j <- [0 .. c - 1]] ) + +{- | Convert a dense matrix to canonical sparse storage, discarding exact zeros and +preserving dimensions. +-} denseToSparse :: (Eq a, Num a) => Matrix a -> Sparse a denseToSparse a = Sparse r c (M.fromList [((k `div` c, k `mod` c), v) | (k, v) <- zip [0 ..] (toList a), v /= 0]) where (r, c) = shape a + +{- | Exchange row/column coordinates and dimensions without changing values, returning +canonical sparse order. +-} sparseTranspose :: Sparse a -> Sparse a sparseTranspose (Sparse r c xs) = Sparse c r (M.mapKeys (\(i, j) -> (j, i)) xs) + +{- | Add equal-shaped sparse matrices, coalescing entries and dropping resulting zeros. +Shape mismatch or checked construction errors fail. +-} sparseAdd :: (Eq a, Num a) => Sparse a -> Sparse a -> Either MathError (Sparse a) sparseAdd (Sparse r c a) (Sparse s t b) | (r, c) /= (s, t) = Left (ShapeMismatch (r, c) (s, t)) | otherwise = Right (Sparse r c (M.filter (/= 0) (M.unionWith (+) a b))) + +{- | Subtract right sparse values from left for equal shapes; coalesce and remove zeros. +Shape mismatch fails. +-} sparseSubtract :: (Eq a, Num a) => Sparse a -> Sparse a -> Either MathError (Sparse a) sparseSubtract a (Sparse r c b) = sparseAdd a (Sparse r c (M.map negate b)) + +{- | Given sparse matrix then dense vector, return matrix-vector product. Vector length must +equal column count; mismatch returns Left MathError. +-} spmv :: (Num a) => Sparse a -> [a] -> Either MathError [a] spmv (Sparse r c xs) vector | length vector /= c = Left (VectorLengthMismatch c (length vector)) @@ -253,6 +325,10 @@ spmv (Sparse r c xs) vector let input = listArray (0, c - 1) vector sums = accumArray (+) 0 (0, r - 1) [(i, v * (input ! j)) | ((i, j), v) <- M.toAscList xs] in Right (elems sums) + +{- | Multiply compatible sparse matrices using sparse row contributions. Inner-dimension +mismatch or output construction errors return Left MathError. +-} spmm :: (Eq a, Num a) => Sparse a -> Sparse a -> Either MathError (Sparse a) spmm (Sparse r c a) (Sparse s t b) | c /= s = Left (InnerDimensionMismatch c s) @@ -260,6 +336,10 @@ spmm (Sparse r c a) (Sparse s t b) sparse r t [(i, j, x * y) | ((i, k), x) <- M.toAscList a, (j, y) <- M.findWithDefault [] k rowsB] where rowsB = M.fromListWith (++) [(k, [(j, v)]) | ((k, j), v) <- M.toAscList b] + +{- | Return sparse Kronecker product, multiplying row/column dimensions and nonzero pairs. +Dimension/product overflow fails. +-} sparseKronecker :: (Eq a, Num a) => Sparse a -> Sparse a -> Either MathError (Sparse a) sparseKronecker a b | toInteger r * toInteger s > toInteger (maxBound :: Int) @@ -272,6 +352,11 @@ sparseKronecker a b [(i * s + k, j * t + l, x * y) | (i, j, x) <- sparseEntries a, (k, l, y) <- sparseEntries b] where (r, c) = sparseShape a; (s, t) = sparseShape b + +{- | Given lower Bool,square finite sparse matrix,then RHS list, solve by forward/back +substitution. Require correct triangular structure and matching RHS length; zero +diagonal pivots or non-finite arithmetic fail. +-} sparseTriangularSolve :: (RealFloat a) => Bool -> Sparse a -> [a] -> Either MathError [a] sparseTriangularSolve lower a@(Sparse n m values) b | n /= m = Left (NonSquareMatrix (n, m)) @@ -290,19 +375,37 @@ sparseTriangularSolve lower a@(Sparse n m values) b (b !! i - sum [x * M.findWithDefault 0 j xs | (j, x) <- M.findWithDefault [] i rows, j /= i]) / pivot in if pivot == 0 then Left (SingularMatrix i) else finiteValues [v] >> Right (M.insert i v xs) + +{- | Given diagonal square sparse matrix then RHS, divide by each diagonal pivot. +Off-diagonal entries, shape mismatch, zero pivots or non-finite data fail. +-} sparseDiagonalSolve :: (RealFloat a) => Sparse a -> [a] -> Either MathError [a] sparseDiagonalSolve a b | any (\(i, j, _) -> i /= j) (sparseEntries a) = Left (DomainError "sparseDiagonalSolve: diagonal matrix required") | otherwise = sparseTriangularSolve True a b +{- | Opaque sparse row-pivoted LU factors with reconstruction permutation; solve through +sparseSolveLU. +-} data SparseLU a = SparseLU (Sparse a) (Sparse a) [Int] deriving (Eq, Show) + +-- | Extract unit lower-triangular sparse factor from a SparseLU result. sparseLULower :: SparseLU a -> Sparse a sparseLULower (SparseLU l _ _) = l + +-- | Extract upper-triangular sparse factor from a SparseLU result. sparseLUUpper :: SparseLU a -> Sparse a sparseLUUpper (SparseLU _ u _) = u + +-- | Return LU row permutation in pivoted order, for reconstructing P*A=L*U. sparseLUPermutation :: SparseLU a -> [Int] sparseLUPermutation (SparseLU _ _ p) = p + +{- | Given finite nonnegative relative pivot tolerance then square finite sparse matrix, +compute sparse LU with row pivoting. Invalid tolerance/input, zero/near-singular pivots +or numerical failure returns Left MathError. +-} sparseLU :: (RealFloat a) => a -> Sparse a -> Either MathError (SparseLU a) sparseLU tol a@(Sparse n m values) | n /= m = Left (NonSquareMatrix (n, m)) @@ -339,6 +442,10 @@ sparseLU tol a@(Sparse n m values) Right (M.insert i next rs, if multiplier == 0 then ls else M.insert (i, k) multiplier ls) (nextRows, nextL) <- foldl update (Right (swapped, lsw)) [k + 1 .. n - 1] Right (nextRows, nextL, swap k pivot p) + +{- | Given sparse LU factors then RHS list, apply row permutation and triangular solves. +Dimension mismatch, singularity or non-finite input/result fails. +-} sparseSolveLU :: (RealFloat a) => SparseLU a -> [a] -> Either MathError [a] sparseSolveLU f b | length b /= n = Left (VectorLengthMismatch n (length b)) @@ -347,6 +454,10 @@ sparseSolveLU f b >>= sparseTriangularSolve False (sparseLUUpper f) where n = fst (sparseShape (sparseLULower f)) + +{- | Factor a symmetric positive-definite finite sparse matrix into a lower sparse factor. +Invalid shape/symmetry, nonpositive pivots or numerical failure returns Left MathError. +-} sparseCholesky :: (RealFloat a) => Sparse a -> Either MathError (Sparse a) sparseCholesky a@(Sparse n m values) | n /= m = Left (NonSquareMatrix (n, m)) @@ -371,13 +482,22 @@ sparseCholesky a@(Sparse n m values) finiteValues [x] Right (if x == 0 then l else M.insert (i, j) x l) +{- | Opaque sparse QR factors with implicit orthogonal transform; use sparseQRUpper and +sparseQRApplyQT. +-} data SparseQR a = SparseQR (Sparse a) [(Int, [a])] deriving (Eq, Show) + +-- | Extract upper-triangular/trapezoidal sparse R from a sparse QR factorization. sparseQRUpper :: SparseQR a -> Sparse a sparseQRUpper (SparseQR r _) = r {- | Sparse Householder QR retains only the R nonzeros and compact reflectors; fill is retained, never silently dropped. Reflection vectors are dense tails. -} + +{- | Given finite nonnegative tolerance then sparse matrix, compute its checked sparse QR +factors. Invalid tolerance, input or numerical failure returns Left MathError. +-} sparseQR :: (RealFloat a) => Sparse a -> Either MathError (SparseQR a) sparseQR a@(Sparse m n values) = do finiteValues (M.elems values) @@ -408,6 +528,9 @@ sparseQR a@(Sparse m n values) = do finiteValues (M.elems cleaned) Right (Sparse r c cleaned, reflectors ++ [(k, unit)]) +{- | Given sparse QR factors then compatible RHS list, apply transpose(Q) without +constructing dense Q. Invalid length or non-finite arithmetic fails. +-} sparseQRApplyQT :: (RealFloat a) => SparseQR a -> [a] -> Either MathError [a] sparseQRApplyQT (SparseQR r reflectors) b | length b /= fst (sparseShape r) = Left (VectorLengthMismatch (fst (sparseShape r)) (length b)) @@ -417,6 +540,10 @@ sparseQRApplyQT (SparseQR r reflectors) b let coefficient = 2 * dotV v (drop start xs) next = take start xs ++ zipWith (\x y -> x - coefficient * y) (drop start xs) v in finiteValues next >> Right next + +{- | For a square sparse matrix, return one adjacency row per vertex with stored +(column,value) neighbors. Non-square matrix returns Left MathError. +-} sparseGraph :: Sparse a -> Either MathError [(Int, [(Int, a)])] sparseGraph a | n /= m = Left (NonSquareMatrix (n, m)) @@ -438,17 +565,34 @@ sparseStorageBytes scalarBytes a + 2 * toInteger (sizeOf (undefined :: Int)) ) +{- | Canonical sparse multidimensional entries, constructed by sparseTensor with checked +coordinates and duplicate coalescing. +-} data SparseTensor a = SparseTensor [Int] (M.Map [Int] a) deriving (Eq, Show) + +{- | Given dimensions then (coordinate-list,value) entries, validate rank/bounds, sum +duplicate coordinates and remove zeros. Invalid shape/indices return Left MathError. +-} sparseTensor :: (Eq a, Num a) => [Int] -> [([Int], a)] -> Either MathError (SparseTensor a) sparseTensor dims values | any (< 0) dims || any (\(is, _) -> length is /= length dims || or (zipWith (\i d -> i < 0 || i >= d) is dims)) values = Left (InvalidArgument "sparseTensor: shape or index invalid") | otherwise = Right (SparseTensor dims (M.filter (/= 0) (M.fromListWith (+) values))) + +-- | Return axis dimensions of a sparse tensor; [] denotes a scalar. sparseTensorShape :: SparseTensor a -> [Int] sparseTensorShape (SparseTensor dims _) = dims + +{- | Return canonical nonzero (coordinate list,value) pairs in lexicographic coordinate +order. +-} sparseTensorEntries :: SparseTensor a -> [([Int], a)] sparseTensorEntries (SparseTensor _ xs) = M.toAscList xs + +{- | Given sparse tensor then full zero-based coordinates, return stored value or zero. +Wrong rank or out-of-range indices fail. +-} sparseTensorLookup :: (Num a) => SparseTensor a -> [Int] -> Either MathError a sparseTensorLookup (SparseTensor dims xs) is | length is /= length dims || or (zipWith (\i d -> i < 0 || i >= d) is dims) = @@ -462,8 +606,13 @@ This is not a scalable sparse eigensolver/SVD and never silently densifies. sparseEigenReference :: Integer -> Sparse Double -> Either MathError Eigen sparseEigenReference budget a = referenceDense budget a >>= eigen +{- | Given explicit dense-byte budget then sparse Double matrix, densify only if within +budget and run checked dense SVD. This is a reference fallback, not a sparse iterative +SVD; budget/backend/numeric errors fail. +-} sparseSVDReference :: Integer -> Sparse Double -> Either MathError SVD sparseSVDReference budget a = referenceDense budget a >>= svd + referenceDense :: Integer -> Sparse Double -> Either MathError (Matrix Double) referenceDense budget a | budget < 0 || toInteger r * toInteger c > budget = diff --git a/src/HMath/Special.hs b/src/HMath/Special.hs index 46a0e12..eb292eb 100644 --- a/src/HMath/Special.hs +++ b/src/HMath/Special.hs @@ -95,7 +95,13 @@ foreign import ccall unsafe "jn" cJn :: CInt -> CDouble -> CDouble foreign import ccall unsafe "yn" cYn :: CInt -> CDouble -> CDouble -- | Finite value and estimated absolute numerical error. The estimate includes truncation/discretization and a small rounding allowance; it is not a certified enclosure. -data SFResult = SFResult {sfValue :: Double, sfError :: Double} deriving (Eq, Show) +data SFResult = SFResult + { sfValue :: Double + -- ^ Returned special-function numerical estimate. + , sfError :: Double + -- ^ Absolute numerical error estimate accompanying sfValue. + } + deriving (Eq, Show) finite :: Double -> Bool finite x = not (isNaN x || isInfinite x) diff --git a/src/HMath/Statistics.hs b/src/HMath/Statistics.hs index 774f7ab..1a4afc4 100644 --- a/src/HMath/Statistics.hs +++ b/src/HMath/Statistics.hs @@ -9,10 +9,16 @@ module HMath.Statistics ( import Data.List (sort) +{- | Arithmetic mean of a finite nonempty list: sum divided by length. Empty input raises a +pure error; no non-finite-value validation is performed. Example: mean [2,4] == 3. +-} mean :: (Fractional a) => [a] -> a mean [] = error "mean: empty input" mean xs = sum xs / fromIntegral (length xs) +{- | Population variance of a finite nonempty list, dividing squared deviations by n (not +n-1). Empty input raises a pure error. Example: variance [1,3] == 1. +-} variance :: (Fractional a) => [a] -> a variance [] = error "variance: empty input" variance xs = @@ -20,9 +26,15 @@ variance xs = squared = map (\x -> (x - m) * (x - m)) xs in sum squared / fromIntegral (length xs) +{- | Population standard deviation, sqrt of variance. Requires a finite nonempty list; empty +input raises the same error as variance. Example: standardDeviation [1,3] == 1. +-} standardDeviation :: (Floating a) => [a] -> a standardDeviation = sqrt . variance +{- | Sort a finite nonempty list and return its middle value, averaging the central pair for +even length. Empty input raises a pure error. Example: median [4,1,3,2] == 2.5. +-} median :: (Ord a, Fractional a) => [a] -> a median [] = error "median: empty input" median xs diff --git a/src/HMath/Statistics/Advanced.hs b/src/HMath/Statistics/Advanced.hs index a9e0d5f..eceb2c1 100644 --- a/src/HMath/Statistics/Advanced.hs +++ b/src/HMath/Statistics/Advanced.hs @@ -514,7 +514,14 @@ jackknife statistic xs = do in pure (n * theta - (n - 1) * m, sqrt ((n - 1) / n * sum (map (\t -> (t - m) ^ (2 :: Int)) ts))) -- | Test statistic, p value clamped to [0,1] after numerical checks, and applicable degrees of freedom. -data TestResult = TestResult {testStatistic :: Double, pValue :: Double, degreesOfFreedom :: [Double]} +data TestResult = TestResult + { testStatistic :: Double + -- ^ Computed statistic for the selected hypothesis test. + , pValue :: Double + -- ^ Reported tail probability, clamped to [0,1]; interpret using the test's documented alternative hypothesis. + , degreesOfFreedom :: [Double] + -- ^ Distribution degrees-of-freedom parameters in test-specific order (for example numerator then denominator for F tests). + } deriving (Eq, Show) result :: Double -> Double -> [Double] -> Either MathError TestResult diff --git a/src/HMath/Symbolic.hs b/src/HMath/Symbolic.hs index 29cab1e..f27d6db 100644 --- a/src/HMath/Symbolic.hs +++ b/src/HMath/Symbolic.hs @@ -99,9 +99,20 @@ failure k e = Left . ExprError k (expressionPosition e) unsupported :: Expr -> String -> Either ExprError a unsupported = failure Unsupported +{- | Symbolic domain fact such as real,positive,nonzero,or sign restrictions, used to guard +domain-sensitive identities. +-} data Property = Real | NonZero | Positive | NonNegative | Integral | Negative | NonPositive deriving (Eq, Ord, Show) + +{- | Validated variable-property environment. Build through the assumptions API; +noAssumptions proves no additional variable facts. +-} newtype Assumptions = Assumptions (Map.Map String [Property]) deriving (Eq, Show) + +{- | Construct an empty variable-property environment. Simplifications requiring +positivity/nonzero facts remain guarded or unchanged without proof. +-} noAssumptions :: Assumptions noAssumptions = Assumptions Map.empty @@ -122,11 +133,26 @@ assumptions entries = do then failure DomainFailure (variable name) "contradictory assumptions" else Right () -data SymbolicOptions = SymbolicOptions {symbolicLimits :: Limits, symbolicAssumptions :: Assumptions} +{- | Expression budgets together with permitted variable assumptions for checked symbolic +operations. +-} +data SymbolicOptions = SymbolicOptions + { symbolicLimits :: Limits + -- ^ Expression resource/numeric budgets used by symbolic operations. + , symbolicAssumptions :: Assumptions + -- ^ Variable facts permitted when proving domain-sensitive rewrites. + } deriving (Eq, Show) + +{- | Default expression budgets with no assumptions; domain-sensitive rules +require their preconditions to be proved before rewriting. +-} defaultSymbolicOptions :: SymbolicOptions defaultSymbolicOptions = SymbolicOptions defaultLimits noAssumptions +{- | Given assumptions,requested Property,then Expr, conservatively test whether the fact is +established. False means not proved, not a proof of its negation. +-} proves :: Assumptions -> Property -> Expr -> Bool proves a@(Assumptions names) prop e = case expressionNode e of Literal q -> case prop of @@ -246,6 +272,10 @@ rewrites x/x or removes an unproved partial function from a zero product. normalize :: SymbolicOptions -> Expr -> Either ExprError Expr normalize = simplify +{- | Given SymbolicOptions then Expr, simplify within its resource limits and supplied +assumptions, preserving domain-sensitive conditions. Return ExprError for +invalid/budget-exceeding input/output. +-} simplify :: SymbolicOptions -> Expr -> Either ExprError Expr simplify o e = inputs o [e] >> go e >>= checked o where @@ -341,6 +371,10 @@ simplify o e = inputs o [e] >> go e >>= checked o | q == 1 = x | q == (-1) = neg x | otherwise = times (literal q) x + +{- | Alias of simplify, combining supported like terms under the same assumption and budget +checks. +-} collectTerms :: SymbolicOptions -> Expr -> Either ExprError Expr collectTerms = simplify @@ -413,6 +447,9 @@ substitute limits replacements expression = do Let n a b -> n : allNames a ++ allNames b _ -> [] +{- | Symbolic rewrite pattern with literal/variable/operator/call structure and binding +placeholders. +-} data Pattern = Any String | Exactly Expr @@ -459,10 +496,16 @@ matchPattern limits pat expression = do step _ (fuel, Nothing) _ = Right (fuel, Nothing) step d (fuel, Just env) (p, e) = go d fuel env p e +{- | Pattern,replacement expression,and property requirements needed for a valid bounded +symbolic rewrite. +-} data RewriteRule = RewriteRule { rewritePattern :: Pattern + -- ^ Pattern to match before applying this rewrite rule. , rewriteReplacement :: Expr + -- ^ Replacement expression, with matched bindings substituted. , rewriteRequirements :: [(String, Property)] + -- ^ Variable properties required to justify the rewrite. } deriving (Eq, Show) @@ -531,12 +574,26 @@ differentiate o name expression = do _ -> unsupported e "unsupported symbolic derivative" checked o result +{- | Given symbolic options,ordered variable names,then scalar expression, return symbolic +partial derivatives in that order. At most 32 variables are supported; +expression/domain/resource failures return ExprError. +-} gradient :: SymbolicOptions -> [String] -> Expr -> Either ExprError [Expr] gradient o names e = inputs o [e] >> boundedVariables o names >> mapM (\n -> differentiate o n e) names + +{- | Given options,ordered variable names,then output-expression list, return one gradient +row per output. Validate variable/expression budgets; failures return ExprError. +-} jacobian :: SymbolicOptions -> [String] -> [Expr] -> Either ExprError [[Expr]] jacobian o names es = boundedVariables o names >> boundedExpressions o es >> mapM (gradient o names) es + +{- | Given options,ordered variables,then scalar Expr, return derivatives of each gradient +component in the same row/column variable order. Validation/differentiation/resource +failures propagate. +-} hessian :: SymbolicOptions -> [String] -> Expr -> Either ExprError [[Expr]] hessian o names e = gradient o names e >>= mapM (gradient o names) + boundedVariables :: SymbolicOptions -> [String] -> Either ExprError () boundedVariables o names | length (take 33 names) > 32 = failure MemoryLimit (literal 0) "at most 32 symbolic variables" @@ -549,6 +606,11 @@ boundedExpressions o es | otherwise = inputs o es -- Polynomial admission checks size/degree/coefficient bits at every operation. + +{- | Given options,variable name,then Expr, convert a supported univariate exact Rational +polynomial. Other variables/functions, invalid exponents or resource-limit violations +return ExprError. +-} toPolynomial :: SymbolicOptions -> String -> Expr -> Either ExprError (P.Polynomial Rational) toPolynomial o name expression = inputs o [variable name, expression] >> go expression where @@ -574,12 +636,21 @@ toPolynomial o name expression = inputs o [variable name, expression] >> go expr failure MemoryLimit expression "polynomial degree limit 64" | otherwise = mapM_ (\q -> validateExpression (symbolicLimits o) (literal q)) (P.coefficients p) >> Right p + +{- | Given variable name then exact Rational Polynomial, build an Expr in Horner form. This +pure builder does not itself validate SymbolicOptions limits. +-} fromPolynomial :: String -> P.Polynomial Rational -> Expr fromPolynomial name p = foldr (\a acc -> plus (literal a) (times (variable name) acc)) (literal 0) (P.coefficients p) +{- | Exact leading coefficient and symbolic factor/multiplicity pairs; unfactored remainder +behavior follows the factorization function. +-} data PolynomialFactorization = PolynomialFactorization { factorLeading :: Rational + -- ^ Exact scalar leading factor outside the polynomial factors. , factorTerms :: [(Expr, Int)] + -- ^ Symbolic factors paired with positive multiplicities. } deriving (Eq, Show) @@ -609,6 +680,10 @@ rationalSimplify o name e = case expressionNode e of (divide (fromPolynomial name (P.rationalNumerator r)) (fromPolynomial name (P.rationalDenominator r))) _ -> simplify o e +{- | Given options then Expr, apply supported trigonometric identities such as matching +sin-squared plus cos-squared terms, after input validation. This is a bounded rule set, +not a general identity prover. +-} trigonometricSimplify :: SymbolicOptions -> Expr -> Either ExprError Expr trigonometricSimplify o e = do inputs o [e] @@ -621,6 +696,11 @@ trigonometricSimplify o e = do case expressionNode e of Binary Add a b | identity a b || identity b a -> Right (literal 1) _ -> simplify o e + +{- | Given options then Expr, apply log product/quotient/power rules only when the supplied +assumptions establish required real-domain facts. Unproved transformations are left +unchanged; budget errors propagate. +-} logarithmicSimplify :: SymbolicOptions -> Expr -> Either ExprError Expr logarithmicSimplify o e = do inputs o [e] @@ -753,7 +833,12 @@ integrateRational o name numeratorExpr denominatorExpr = do denominatorExpr "partial fraction primitive requires linear or simple positive quadratic denominator" +-- | Limit approach direction: from left,from right,or two-sided. data Direction = FromLeft | FromRight | TwoSided deriving (Eq, Show) + +{- | Symbolic finite/infinite limit classification,including an explicit does-not-exist or +unresolved result. +-} data LimitResult = FiniteLimit Rational | PositiveInfinity | NegativeInfinity | DoesNotExist deriving (Eq, Show) @@ -802,7 +887,17 @@ leadingAt center p = go 0 p where value = P.evaluatePolynomial q center / fromInteger (product [1 .. toInteger k]) -data Series = Series {seriesCenter :: Rational, seriesMinimumPower :: Int, seriesTerms :: [Expr]} +{- | Finite symbolic Taylor/Laurent coefficient list with exact center and starting power; +no analytic convergence is implied by storage alone. +-} +data Series = Series + { seriesCenter :: Rational + -- ^ Exact Rational expansion center. + , seriesMinimumPower :: Int + -- ^ Power corresponding to the first coefficient, including negative powers for Laurent series. + , seriesTerms :: [Expr] + -- ^ Coefficient expressions ordered from seriesMinimumPower upward. + } deriving (Eq, Show) {- | Truncated Taylor coefficients f^(k)(c)/k!, order 0..20. Missing regularity @@ -828,6 +923,10 @@ taylorSeries o name center order e = do more <- go (k + 1) (factorial * toInteger (k + 1)) next Right (c : more) +{- | Given options,variable name,order,then Expr, compute the Taylor series centered at zero +via taylorSeries. Unsupported symbolic derivatives or exceeded order/resource bounds +return ExprError. +-} maclaurinSeries :: SymbolicOptions -> String -> Int -> Expr -> Either ExprError Series maclaurinSeries o name = taylorSeries o name 0 @@ -861,11 +960,21 @@ seriesOrder :: Expr -> Int -> Either ExprError () seriesOrder e n | n < 0 || n > 20 = failure MemoryLimit e "series order must be 0..20" | otherwise = Right () + +{- | Given options then Rational coefficient list, construct a finite formal jet with at +most 64 coefficients, subject to expression numeric budgets. No analytic convergence is +claimed. +-} formalPowerSeries :: SymbolicOptions -> [Rational] -> Either ExprError (P.PowerSeries Rational) formalPowerSeries o coefficients | length (take 65 coefficients) > 64 = failure MemoryLimit (literal 0) "formal jet supports at most 64 coefficients" | otherwise = inputs o (map literal coefficients) >> Right (P.powerSeries coefficients) + +{- | Given options then two formal Rational jets, validate and convolve coefficients under +the 64-coefficient cap. Oversized input/output or numeric-limit failures return +ExprError. +-} multiplyFormalSeries :: SymbolicOptions -> P.PowerSeries Rational -> @@ -875,12 +984,21 @@ multiplyFormalSeries o a b = do _ <- formalPowerSeries o (P.seriesCoefficients a) _ <- formalPowerSeries o (P.seriesCoefficients b) formalPowerSeries o (P.seriesCoefficients (P.multiplySeries a b)) + +{- | Given options then formal Rational series with nonzero constant term, compute its +reciprocal jet. Invalid constant/size or numeric budgets return ExprError. +-} reciprocalFormalSeries :: SymbolicOptions -> P.PowerSeries Rational -> Either ExprError (P.PowerSeries Rational) reciprocalFormalSeries o a = do _ <- formalPowerSeries o (P.seriesCoefficients a) result <- mathResult (literal 0) (P.reciprocalSeries a) formalPowerSeries o (P.seriesCoefficients result) + +{- | Given options,variable name,then polynomial Expr, return rational roots with +multiplicities plus the remaining deflated Expr. Irrational/non-rational roots remain +in the remainder; unsupported conversion or work-budget exhaustion returns ExprError. +-} exactPolynomialRoots :: SymbolicOptions -> String -> Expr -> Either ExprError ([(Rational, Int)], Expr) exactPolynomialRoots o name e = do @@ -912,9 +1030,21 @@ numericalPolynomialRoots o name e = do (P.polynomial [fromRational q :+ 0 | q <- P.coefficients p]) ) +-- | Comparison relation selector: equality,inequality,or ordered less/greater comparisons. data RelationOp = Equal | NotEqual | Less | LessEqual | Greater | GreaterEqual deriving (Eq, Show) + +{- | Symbolic comparison of two expressions; use simplifyRelation to decide or preserve +unresolved conditions. +-} data Relation = Relation RelationOp Expr Expr deriving (Eq, Show) + +-- | Decided truth value or unresolved symbolic relation under the provided assumptions. data RelationResult = Truth Bool | Unresolved Relation deriving (Eq, Show) + +{- | Given options then Relation, simplify both sides and return a Boolean Truth when +decidable, otherwise a symbolic unresolved relation/conditions. Invalid expressions or +resource failures return ExprError. +-} simplifyRelation :: SymbolicOptions -> Relation -> Either ExprError RelationResult simplifyRelation o (Relation op a b) = do x <- simplify o a @@ -925,6 +1055,7 @@ simplifyRelation o (Relation op a b) = do | x == y && defined (symbolicAssumptions o) x -> Right (Truth (op `elem` [Equal, LessEqual, GreaterEqual])) | otherwise -> Right (Unresolved (Relation op x y)) + compareRelation :: (Ord a) => RelationOp -> a -> a -> Bool compareRelation Equal = (==) compareRelation NotEqual = (/=) @@ -953,6 +1084,9 @@ solveLinearInequality o name (Relation op a b) = do flipOp GreaterEqual = LessEqual flipOp x = x +{- | Symbolic linear-system outcome distinguishing a determined/parametric solution from +inconsistency or unresolved computation. +-} data LinearSolution = Inconsistent | ParametricSolution [(String, Expr)] [String] deriving (Eq, Show) @@ -1023,7 +1157,12 @@ solveLinearEquations o names equations = do inputs o (map literal (concat next)) rref (r + 1) (c + 1) next (pivots ++ [(r, c)]) +-- | Checked bounded rectangular expression matrix, constructed with symbolicMatrix. newtype SymbolicMatrix = SymbolicMatrix [[Expr]] deriving (Eq, Show) + +{- | Given options then nonempty rectangular Expr rows, construct a checked symbolic matrix +bounded to 8-by-8. Empty/ragged/oversized or invalid expressions fail. +-} symbolicMatrix :: SymbolicOptions -> [[Expr]] -> Either ExprError SymbolicMatrix symbolicMatrix o rows | null rows @@ -1035,13 +1174,23 @@ symbolicMatrix o rows | otherwise = inputs o (concat rows) >> Right (SymbolicMatrix rows) where width = case rows of r : _ -> length (take 9 r); [] -> 0 + +-- | Extract row-major symbolic expressions without evaluation or simplification. matrixExpressions :: SymbolicMatrix -> [[Expr]] matrixExpressions (SymbolicMatrix rows) = rows + +{- | Given options then equally shaped symbolic matrices, add and simplify corresponding +expressions. Shape mismatch or symbolic resource/domain failure returns ExprError. +-} matrixAdd :: SymbolicOptions -> SymbolicMatrix -> SymbolicMatrix -> Either ExprError SymbolicMatrix matrixAdd o (SymbolicMatrix a) (SymbolicMatrix b) | length a /= length b || map length a /= map length b = failure DomainFailure (literal 0) "matrix addition shape mismatch" | otherwise = mapM (mapM (simplify o) . uncurry (zipWith plus)) (zip a b) >>= symbolicMatrix o + +{- | Given options then compatible symbolic matrices, form simplified dot-product entries. +Inner-dimension mismatch or expression/output limits return ExprError. +-} matrixMultiply :: SymbolicOptions -> SymbolicMatrix -> SymbolicMatrix -> Either ExprError SymbolicMatrix matrixMultiply o (SymbolicMatrix a) (SymbolicMatrix b) @@ -1079,7 +1228,13 @@ symbolicDeterminant o (SymbolicMatrix rows) (zip [0 ..] r) checked o (Foldable.foldl' plus (literal 0) terms) -data Guarded a = Guarded {guardedValue :: a, requiredConditions :: [(Expr, Property)]} +-- | Value paired with mathematical property conditions required for its unconditional use. +data Guarded a = Guarded + { guardedValue :: a + -- ^ Result whose validity depends on requiredConditions. + , requiredConditions :: [(Expr, Property)] + -- ^ Expression/property facts that must hold before using guardedValue unconditionally. + } deriving (Eq, Show) {- | Exact 1x1/2x2 real eigenvalue formulas; an unproved discriminant is returned @@ -1104,6 +1259,10 @@ symbolicEigenvalues o (SymbolicMatrix rows) = case rows of ) _ -> unsupported (literal 0) "symbolic eigenvalues support order 1 or 2" +{- | Given options,precision,bindings list,then Expr, evaluate using the default builtin +registry and symbolic limits. Later duplicate binding names replace earlier ones. +Evaluation/name/domain/resource errors remain ExprError. +-} numericalSubstitution :: SymbolicOptions -> Precision -> [(String, Value)] -> Expr -> Either ExprError Value numericalSubstitution o mode bindings = evaluateExpression (symbolicLimits o) mode defaultRegistry (Map.fromList bindings) diff --git a/src/HMath/Tensor.hs b/src/HMath/Tensor.hs index 33228af..7861140 100644 --- a/src/HMath/Tensor.hs +++ b/src/HMath/Tensor.hs @@ -112,11 +112,28 @@ import Data.Typeable (Typeable, typeRep) import HMath.Error import Prelude hiding (repeat) +{- | Tensor storage classification: canonical row major,column major,or general strided +view. +-} data Layout = RowMajor | ColumnMajor | Strided deriving (Eq, Show, Read) + +-- | Tensor execution/storage device; this release supports CPU. data Device = CPU deriving (Eq, Show, Read) + +{- | Immutable boxed CPU tensor with signed element strides and shared view storage. +Construct through tensor and checked view operations; garbage collection manages +lifetime. +-} data Tensor a = Tensor [Int] [Int] Int (Array Int a) deriving (Show) + instance (Eq a) => Eq (Tensor a) where a == b = tensorShape a == tensorShape b && tensorValues a == tensorValues b + +{- | Validate nonnegative dimensions and return their product as Int. Scalar [] has one +element; a zero axis gives zero. Negative dimensions or an Int-overflowing product +return Left InvalidArgument. Haskell tensors do not inherit the C ABI's smaller +rank/element caps. +-} shapeSize :: [Int] -> Either MathError Int shapeSize dims | any (< 0) dims = Left (InvalidArgument "tensor: negative shape") @@ -124,40 +141,80 @@ shapeSize dims | otherwise = Right (fromInteger size) where size = product (map toInteger dims) + stridesFor :: Layout -> [Int] -> [Int] stridesFor layout dims | 0 `elem` dims = replicate (length dims) 0 | layout == ColumnMajor = take (length dims) (scanl (*) 1 dims) | otherwise = drop 1 (scanr (*) 1 dims) + +{- | Given shape then flat row-major values, construct an immutable CPU tensor. Require +exactly the shape product values; invalid dimensions/count return Left MathError. +Generic values are not validated for finiteness. +-} tensor :: [Int] -> [a] -> Either MathError (Tensor a) tensor dims xs = do n <- shapeSize dims if n /= length xs then Left (ElementCountMismatch n (length xs)) else Right (Tensor dims (stridesFor RowMajor dims) 0 (listArray (0, n - 1) xs)) + +{- | Given shape then values in column-major storage order, construct a column-major CPU +tensor. Validate shape/count as tensor; logical tensorValues still traverses row-major +coordinates. +-} tensorColumnMajor :: [Int] -> [a] -> Either MathError (Tensor a) tensorColumnMajor dims xs = do Tensor _ _ offset storage <- tensor dims xs Right (Tensor dims (stridesFor ColumnMajor dims) offset storage) + +-- | Return dimensions in axis order. Scalar shape is []; empty axes are retained. tensorShape :: Tensor a -> [Int] tensorShape (Tensor dims _ _ _) = dims + +{- | Return signed element strides for each axis. These describe shared views; they are not +byte offsets and can be zero (broadcast) or negative (reverse slices). +-} tensorStrides :: Tensor a -> [Int] tensorStrides (Tensor _ strides _ _) = strides + +{- | Return backing-array offset in elements of the logical coordinate origin. Combine with +tensorStrides for view indexing. +-} tensorOffset :: Tensor a -> Int tensorOffset (Tensor _ _ offset _) = offset + +{- | Return the Typeable element type name as a String. This is diagnostic metadata, not an +implicit conversion or stable external dtype code. +-} tensorDType :: forall a. (Typeable a) => Tensor a -> String tensorDType _ = show (typeRep (Proxy :: Proxy a)) + +-- | Return CPU, the supported device for this Haskell tensor implementation. tensorDevice :: Tensor a -> Device tensorDevice _ = CPU + +{- | Return logical element count (product of shape), including one for scalars and zero for +any empty axis. +-} numel :: Tensor a -> Int numel = product . tensorShape + +{- | Test whether stored strides exactly match canonical row-major strides for this shape. +Offset does not prevent a contiguous view; column-major layouts generally return False. +-} isContiguous :: Tensor a -> Bool isContiguous t = tensorStrides t == stridesFor RowMajor (tensorShape t) + +{- | Classify canonical row-major strides first, then column-major, otherwise Strided. +Ambiguous single-axis layouts are classified RowMajor. +-} tensorLayout :: Tensor a -> Layout tensorLayout t | isContiguous t = RowMajor | tensorStrides t == stridesFor ColumnMajor (tensorShape t) = ColumnMajor | otherwise = Strided + allIndices :: [Int] -> [[Int]] allIndices dims | 0 `elem` dims = [] allIndices [] = [[]] @@ -166,16 +223,30 @@ linearIndex :: Tensor a -> [Int] -> Int linearIndex (Tensor _ strides offset _) ix = offset + sum (zipWith (*) strides ix) unsafeIndex :: Tensor a -> [Int] -> a unsafeIndex t@(Tensor _ _ _ storage) ix = storage ! linearIndex t ix + +{- | Return logical values in row-major coordinate order, honoring strides/offsets rather +than exposing raw backing storage. +-} tensorValues :: Tensor a -> [a] tensorValues t = [unsafeIndex t ix | ix <- allIndices (tensorShape t)] + +{- | Copy logical values into a new canonical row-major tensor of the same shape. Return +checked construction result; existing views remain unchanged. +-} contiguous :: Tensor a -> Either MathError (Tensor a) contiguous t = tensor (tensorShape t) (tensorValues t) + validIndex :: [Int] -> [Int] -> Bool validIndex dims ix = length dims == length ix && and (zipWith (\i d -> i >= 0 && i < d) ix dims) + +{- | Given tensor then complete zero-based coordinate list, return the element. Wrong +coordinate rank or out-of-range index returns Left InvalidArgument. +-} indexTensor :: Tensor a -> [Int] -> Either MathError a indexTensor t ix | validIndex (tensorShape t) ix = Right (unsafeIndex t ix) | otherwise = Left (InvalidArgument "indexTensor: index out of bounds") + view :: [Int] -> [Int] -> Int -> Tensor a -> Either MathError (Tensor a) view dims strides offset (Tensor _ _ _ storage) = do n <- shapeSize dims @@ -198,12 +269,29 @@ insertAt :: Int -> a -> [a] -> [a] insertAt i x xs = take i xs ++ x : drop i xs removeAt :: Int -> [a] -> [a] removeAt i xs = take i xs ++ drop (i + 1) xs + +{- | Given shape then fill value, construct an immutable row-major tensor with every element +equal to that value. Invalid/overflowing shape fails. +-} tensorFull :: [Int] -> a -> Either MathError (Tensor a) tensorFull dims x = do n <- shapeSize dims; tensor dims (replicate n x) + +{- | Construct a row-major tensor of zeros with the supplied shape. Invalid dimensions or +element-product overflow return Left MathError. +-} tensorZeros :: (Num a) => [Int] -> Either MathError (Tensor a) tensorZeros dims = tensorFull dims 0 + +{- | Construct a row-major tensor of ones with the supplied shape. Scalars contain one 1; +zero axes contain no values. +-} tensorOnes :: (Num a) => [Int] -> Either MathError (Tensor a) tensorOnes dims = tensorFull dims 1 + +{- | Given finite start, exclusive stop, and nonzero finite step, construct a rank-one +arithmetic progression. A step pointing away from stop yields empty output. Reject +invalid inputs or Int-size count overflow. +-} tensorArange :: (RealFloat a) => a -> a -> a -> Either MathError (Tensor a) tensorArange start stop step | any (\x -> isNaN x || isInfinite x) [start, stop, step] || step == 0 = @@ -216,6 +304,11 @@ tensorArange start stop step where ratio = (toRational stop - toRational start) / toRational step size = max 0 (ceiling ratio) + +{- | Given start, stop, then nonnegative count, return a rank-one evenly spaced sequence +including both endpoints when count>=2. Count zero gives empty, count one gives start. +Negative count fails; generic arithmetic is unchecked. +-} tensorLinspace :: (Fractional a) => a -> a -> Int -> Either MathError (Tensor a) tensorLinspace start stop n | n < 0 = Left (InvalidArgument "linspace: negative count") @@ -234,6 +327,11 @@ tensorLinspace start stop n + stop * (fromIntegral i / fromIntegral (n - 1)) | i <- [0 .. n - 1] ] + +{- | Given base, starting exponent, ending exponent, then count, return base raised to +tensorLinspace exponents. Negative count fails; Floating domain/overflow behavior +follows the element type. +-} tensorLogspace :: (Floating a) => a -> a -> a -> Int -> Either MathError (Tensor a) tensorLogspace base start stop n = mapTensor (base **) <$> tensorLinspace start stop n @@ -250,6 +348,10 @@ tensorRandom seed dims = do t <- tensor dims [fromInteger x / 4294967296 | x <- states] Right (t, case reverse states of x : _ -> x; [] -> seed `mod` 4294967296) +{- | Given axis,start,count,nonzero step,then tensor, return a zero-copy strided view. +Negative steps are supported with valid reachable coordinates. Invalid axis/extent, +stride overflow or backing bounds return Left MathError. +-} sliceTensor :: Int -> Int -> Int -> Int -> Tensor a -> Either MathError (Tensor a) sliceTensor axis start count step t = do axisValid axis t @@ -273,6 +375,11 @@ sliceTensor axis start count step t = do (replaceAt axis (fromInteger stride) strides) (if count == 0 then tensorOffset t else fromInteger offset) t + +{- | Given axis then index list then tensor, copy selected positions along that axis in +index-list order, retaining duplicates. Invalid axis/indices or output-size overflow +fail. +-} fancyIndex :: Int -> [Int] -> Tensor a -> Either MathError (Tensor a) fancyIndex axis indices t = do axisValid axis t @@ -285,10 +392,20 @@ fancyIndex axis indices t = do tensor output [unsafeIndex t (replaceAt axis (indices !! (ix !! axis)) ix) | ix <- allIndices output] + +{- | Given an identically shaped Bool mask then tensor, return a rank-one tensor of values +whose mask is True, in logical row-major order. Mask mismatch fails; alias of +maskedSelect. +-} booleanIndex :: Tensor Bool -> Tensor a -> Either MathError (Tensor a) booleanIndex = maskedSelect + +{- | Alias of fancyIndex: given axis, zero-based index list, then tensor, copy those axis +positions. Invalid axis/indices fail; index-list order and duplicates are preserved. +-} gather :: Int -> [Int] -> Tensor a -> Either MathError (Tensor a) gather = fancyIndex + scatterWith :: (a -> a -> a) -> Int -> [Int] -> Tensor a -> Tensor a -> Either MathError (Tensor a) scatterWith combine axis indices updates target = do axisValid axis target @@ -304,10 +421,26 @@ scatterWith combine axis indices updates target = do values final = foldl apply initial (allIndices updateDims) tensor dims [final M.! ix | ix <- allIndices dims] + +{- | Given axis,index list,update tensor,then target, return a new target-shaped tensor with +updates written to selected positions. Update shape replaces that axis with index-list +length; invalid shape/indices fail. Repeated indices use the last update in traversal +order. +-} scatter :: Int -> [Int] -> Tensor a -> Tensor a -> Either MathError (Tensor a) scatter = scatterWith (\_ new -> new) + +{- | Given axis,indices,updates,target, return a new target with updates added at selected +coordinates. Duplicate indices accumulate; update shape and indices follow scatter +validation. +-} scatterAdd :: (Num a) => Int -> [Int] -> Tensor a -> Tensor a -> Either MathError (Tensor a) scatterAdd = scatterWith (+) + +{- | Given new dimensions then tensor, preserve logical element order with unchanged count. +Contiguous input yields a shared view; non-contiguous input is copied. Invalid +dimensions/count fail; no -1 inference. +-} reshapeTensor :: [Int] -> Tensor a -> Either MathError (Tensor a) reshapeTensor dims t = do size <- shapeSize dims @@ -317,8 +450,16 @@ reshapeTensor dims t = do if isContiguous t then view dims (stridesFor RowMajor dims) (tensorOffset t) t else tensor dims (tensorValues t) + +{- | Reshape to rank one with numel entries in logical row-major order. Shares contiguous +storage and copies non-contiguous input; checked reshape errors propagate. +-} flattenTensor :: Tensor a -> Either MathError (Tensor a) flattenTensor t = reshapeTensor [numel t] t + +{- | Remove every length-one axis as a shared view, preserving storage and logical values. A +single-element all-one shape becomes scalar []. +-} squeeze :: Tensor a -> Either MathError (Tensor a) squeeze t = view @@ -326,29 +467,54 @@ squeeze t = [s | (d, s) <- zip (tensorShape t) (tensorStrides t), d /= 1] (tensorOffset t) t + +{- | Given insertion axis in [0,rank] then tensor, insert a length-one dimension as a shared +view. Out-of-range axis returns Left InvalidArgument. +-} unsqueeze :: Int -> Tensor a -> Either MathError (Tensor a) unsqueeze axis t | axis < 0 || axis > length (tensorShape t) = Left (InvalidArgument "unsqueeze: axis out of range") | otherwise = view (insertAt axis 1 (tensorShape t)) (insertAt axis 0 (tensorStrides t)) (tensorOffset t) t + +{- | Given a permutation of all zero-based axes then tensor, return a zero-copy view with +shape/strides reordered. Missing, duplicate or invalid axes fail. +-} permute :: [Int] -> Tensor a -> Either MathError (Tensor a) permute order t | sort order /= [0 .. length (tensorShape t) - 1] = Left (InvalidArgument "permute: axes must be a permutation") | otherwise = view (map (tensorShape t !!) order) (map (tensorStrides t !!) order) (tensorOffset t) t + +{- | Reverse every axis of a tensor as a shared view. For rank two this exchanges +rows/columns; it is not restricted to matrices. +-} transposeTensor :: Tensor a -> Either MathError (Tensor a) transposeTensor t = permute (reverse [0 .. length (tensorShape t) - 1]) t + +{- | Given source axis,destination axis,then tensor, move one axis while preserving the +order of others. Both axes must identify existing dimensions; invalid axes fail. +-} moveAxis :: Int -> Int -> Tensor a -> Either MathError (Tensor a) moveAxis source destination t = do axisValid source t axisValid destination t permute (insertAt destination source (filter (/= source) [0 .. length (tensorShape t) - 1])) t + +{- | Given two existing axes then tensor, exchange their dimensions/strides in a shared +view. Invalid axes return Left MathError. +-} swapAxes :: Int -> Int -> Tensor a -> Either MathError (Tensor a) swapAxes a b t = do axisValid a t axisValid b t permute [if i == a then b else if i == b then a else i | i <- [0 .. length (tensorShape t) - 1]] t + +{- | Given two shapes, align trailing dimensions; equal sizes or a size-one dimension are +compatible. Return the broadcasted shape after nonnegative/Int-size validation; +incompatible dimensions fail. +-} inferBroadcast :: [Int] -> [Int] -> Either MathError [Int] inferBroadcast as bs = do _ <- shapeSize as @@ -364,6 +530,11 @@ inferBroadcast as bs = do | a == 1 = Right b | b == 1 = Right a | otherwise = Left (InvalidArgument "broadcast: incompatible shapes") + +{- | Given target shape then tensor, return a shared zero-stride view where +existing/trailing size-one axes can expand. Target must be exactly a valid broadcast +destination; incompatible/overflowing shapes fail. +-} broadcastTo :: [Int] -> Tensor a -> Either MathError (Tensor a) broadcastTo dims t = do inferred <- inferBroadcast dims (tensorShape t) @@ -379,8 +550,17 @@ broadcastTo dims t = do (zipWith3 (\d old s -> if old == 1 && d /= 1 then 0 else s) dims source strides) (tensorOffset t) t + +{- | Alias of broadcastTo: expand singleton dimensions to a requested compatible target +shape without copying values. Invalid broadcast shapes fail. +-} expand :: [Int] -> Tensor a -> Either MathError (Tensor a) expand = broadcastTo + +{- | Given axis,repetition count,then tensor, repeat each individual axis position +consecutively. Nonnegative count is required; zero yields an empty axis. Invalid +axis/count or size overflow fails. +-} repeatTensor :: Int -> Int -> Tensor a -> Either MathError (Tensor a) repeatTensor axis repetitions t = do axisValid axis t @@ -394,6 +574,11 @@ repeatTensor axis repetitions t = do tensor dims [unsafeIndex t (replaceAt axis (ix !! axis `div` repetitions) ix) | ix <- allIndices dims] + +{- | Given one nonnegative repetition count per existing axis then tensor, tile whole axis +contents into repeated blocks. Rank mismatch, negative repetitions or resulting size +overflow fail. +-} tile :: [Int] -> Tensor a -> Either MathError (Tensor a) tile repetitions t | length repetitions /= length (tensorShape t) || any (< 0) repetitions = @@ -405,6 +590,11 @@ tile repetitions t tensor dims [unsafeIndex t (zipWith mod ix (tensorShape t)) | ix <- allIndices dims] where dimensions = zipWith (\d n -> toInteger d * toInteger n) (tensorShape t) repetitions + +{- | Given existing axis then nonempty tensor list, copy tensors end-to-end along that axis. +All other dimensions must match; empty list, axis/shape mismatch or size overflow +fails. +-} concatenate :: Int -> [Tensor a] -> Either MathError (Tensor a) concatenate _ [] = Left (InvalidArgument "concatenate: nonempty input required") concatenate axis ts@(first : _) = do @@ -427,8 +617,16 @@ concatenate axis ts@(first : _) = do output [ let (t, j) = locate (ix !! axis) ts in unsafeIndex t (replaceAt axis j ix) | ix <- allIndices output ] + +{- | Given insertion axis then nonempty list of equally shaped tensors, insert that axis and +concatenate along it. Invalid insertion axis or incompatible input shapes fail. +-} stack :: Int -> [Tensor a] -> Either MathError (Tensor a) stack axis ts = traverse (unsqueeze axis) ts >>= concatenate axis + +{- | Given axis,nonnegative segment sizes,then tensor, return shared slices partitioning +that axis exactly. Sizes must sum to the axis length; invalid axis/partition fails. +-} splitTensor :: Int -> [Int] -> Tensor a -> Either MathError [Tensor a] splitTensor axis sizes t = do axisValid axis t @@ -436,6 +634,11 @@ splitTensor axis sizes t = do then Left (InvalidArgument "splitTensor: sizes must partition axis") else sequence [sliceTensor axis start count 1 t | (start, count) <- zip (scanl (+) 0 sizes) sizes] + +{- | Given axis,positive chunk count,then tensor, split into exactly that many near-equal +shared slices; earlier chunks get the remainder. Empty chunks are allowed if chunks +exceed axis size. Invalid axis/count fails. +-} chunkTensor :: Int -> Int -> Tensor a -> Either MathError [Tensor a] chunkTensor axis chunks t = do axisValid axis t @@ -444,6 +647,10 @@ chunkTensor axis chunks t = do else do let n = tensorShape t !! axis; (q, r) = n `divMod` chunks splitTensor axis [q + if i < r then 1 else 0 | i <- [0 .. chunks - 1]] t + +{- | Given (before,after) nonnegative padding for every axis,fill value,then tensor, copy +into a padded output. Rank mismatch, negative padding or output-size overflow fails. +-} padTensor :: [(Int, Int)] -> a -> Tensor a -> Either MathError (Tensor a) padTensor padding value t | length padding /= length (tensorShape t) || any (\(a, b) -> a < 0 || b < 0) padding = @@ -461,6 +668,11 @@ padTensor padding value t ] where dimensions = zipWith (\d (a, b) -> toInteger d + toInteger a + toInteger b) (tensorShape t) padding + +{- | Given axis,signed shift,then tensor, cyclically shift elements along the axis, +preserving shape. Positive shifts move values toward larger indices. Invalid axis +fails; the output is copied. +-} roll :: Int -> Int -> Tensor a -> Either MathError (Tensor a) roll axis shift t = do axisValid axis t @@ -472,11 +684,19 @@ roll axis shift t = do (replaceAt axis (fromInteger ((toInteger (ix !! axis) - toInteger shift) `mod` toInteger n)) ix) | ix <- allIndices dims ] + +{- | Given axis then tensor, reverse that axis using a negative-stride shared slice. Invalid +axis returns Left MathError. +-} flipTensor :: Int -> Tensor a -> Either MathError (Tensor a) flipTensor axis t = do axisValid axis t let n = tensorShape t !! axis sliceTensor axis (max 0 (n - 1)) n (-1) t + +{- | Given two distinct axes,integer quarter-turn count,then tensor, repeatedly swap axes +and flip the first. Turns are reduced modulo four; invalid/equal axes fail. +-} rotate :: Int -> Int -> Int -> Tensor a -> Either MathError (Tensor a) rotate axisA axisB turns t = do axisValid axisA t @@ -487,22 +707,47 @@ rotate axisA axisB turns t = do where go 0 x = Right x go k x = swapAxes axisA axisB x >>= flipTensor axisA >>= go (k - 1) + +{- | Flatten logical values and return a rank-one tensor sorted ascending under Ord. +Original shape is not preserved. +-} sortTensor :: (Ord a) => Tensor a -> Either MathError (Tensor a) sortTensor t = tensor [numel t] (sort (tensorValues t)) + +{- | Flatten logical values and return a rank-one tensor of stable zero-based ascending-sort +indices. Ties preserve original order. +-} argsort :: (Ord a) => Tensor a -> Either MathError (Tensor Int) argsort t = tensor [numel t] (map fst (sortOn snd (zip [0 ..] (tensorValues t)))) + +{- | Given k in [0,numel] then tensor, return rank-one (values,flat indices) for k largest +values in descending order. Equal values use reverse stable-sort order. Invalid k +fails. +-} topk :: (Ord a) => Int -> Tensor a -> Either MathError (Tensor a, Tensor Int) topk k t | k < 0 || k > numel t = Left (InvalidArgument "topk: invalid k") | otherwise = let selected = take k (reverse (sortOn snd (zip [0 ..] (tensorValues t)))) in (,) <$> tensor [k] (map snd selected) <*> tensor [k] (map fst selected) + +{- | Return sorted distinct logical values as a rank-one tensor. Input shape/order are not +preserved. +-} unique :: (Ord a) => Tensor a -> Either MathError (Tensor a) unique t = let xs = M.keys (M.fromList [(x, ()) | x <- tensorValues t]) in tensor [length xs] xs + +{- | Return a count-by-rank tensor of zero-based coordinates of nonzero elements in +row-major traversal order. For a nonzero scalar the shape is [1,0]. +-} nonzero :: (Eq a, Num a) => Tensor a -> Either MathError (Tensor Int) nonzero t = let ix = [is | is <- allIndices (tensorShape t), unsafeIndex t is /= 0] in tensor [length ix, length (tensorShape t)] (concat ix) + +{- | Given Bool mask,yes tensor,no tensor, broadcast all three shapes and select yes/no +values elementwise. Incompatible/overflowing broadcast shapes return Left MathError. +-} whereTensor :: Tensor Bool -> Tensor a -> Tensor a -> Either MathError (Tensor a) whereTensor mask yes no = do dims <- inferBroadcast (tensorShape yes) (tensorShape no) >>= inferBroadcast (tensorShape mask) @@ -517,8 +762,16 @@ whereTensor mask yes no = do (tensorValues y) (tensorValues n) ) + +{- | Given broadcastable mask,fill value,then tensor, return a copied result with True +positions replaced. Incompatible mask broadcast or output construction fails. +-} maskedFill :: Tensor Bool -> a -> Tensor a -> Either MathError (Tensor a) maskedFill mask value t = do full <- tensorFull (tensorShape t) value; whereTensor mask full t + +{- | Given mask then identically shaped tensor, return a rank-one copy of True-selected +values in row-major order. Shape mismatch returns Left InvalidArgument. +-} maskedSelect :: Tensor Bool -> Tensor a -> Either MathError (Tensor a) maskedSelect mask t | tensorShape mask /= tensorShape t = Left (InvalidArgument "maskedSelect: mask shape mismatch") @@ -534,30 +787,84 @@ mapTensor f t = case tensor (tensorShape t) (map f (tensorValues t)) of Right r -> r Left _ -> error "mapTensor: shape invariant" +{- | Given binary element function then two tensors, broadcast compatible shapes and return +a new contiguous result. Shape/size failures return Left MathError; function +evaluation/domain errors follow the supplied function. +-} zipTensor :: (a -> b -> c) -> Tensor a -> Tensor b -> Either MathError (Tensor c) zipTensor f a b = do dims <- inferBroadcast (tensorShape a) (tensorShape b) x <- broadcastTo dims a y <- broadcastTo dims b tensor dims (zipWith f (tensorValues x) (tensorValues y)) + +{- | Given two tensors, broadcast compatible shapes and add corresponding values, returning +a new contiguous tensor. Incompatible/overflowing broadcast shapes return Left +MathError. +-} tensorAdd :: (Num a) => Tensor a -> Tensor a -> Either MathError (Tensor a) tensorAdd = zipTensor (+) + +{- | Given two tensors, broadcast compatible shapes and subtract right values from left, +returning a new contiguous tensor. Incompatible/overflowing broadcast shapes return +Left MathError. +-} tensorSubtract :: (Num a) => Tensor a -> Tensor a -> Either MathError (Tensor a) tensorSubtract = zipTensor (-) + +{- | Given two tensors, broadcast compatible shapes and multiply corresponding values, +returning a new contiguous tensor. Incompatible/overflowing broadcast shapes return +Left MathError. +-} tensorMultiply :: (Num a) => Tensor a -> Tensor a -> Either MathError (Tensor a) tensorMultiply = zipTensor (*) + +{- | Given two tensors, broadcast compatible shapes and divide left values by right, +returning a new contiguous tensor. Incompatible/overflowing broadcast shapes return +Left MathError. Division-by-zero/non-finite behavior follows Fractional; it is not +additionally checked. +-} tensorDivide :: (Fractional a) => Tensor a -> Tensor a -> Either MathError (Tensor a) tensorDivide = zipTensor (/) + +{- | Given two tensors, broadcast compatible shapes and compare corresponding values for +equality, returning a new contiguous tensor. Incompatible/overflowing broadcast shapes +return Left MathError. +-} tensorEqual :: (Eq a) => Tensor a -> Tensor a -> Either MathError (Tensor Bool) tensorEqual = zipTensor (==) + +{- | Given two tensors, broadcast compatible shapes and compare corresponding values with +(\<), returning a new contiguous tensor. Incompatible/overflowing broadcast shapes +return Left MathError. +-} tensorLess :: (Ord a) => Tensor a -> Tensor a -> Either MathError (Tensor Bool) tensorLess = zipTensor (<) + +{- | Given two tensors, broadcast compatible shapes and combine Bool values with logical +AND, returning a new contiguous tensor. Incompatible/overflowing broadcast shapes +return Left MathError. +-} tensorAnd :: Tensor Bool -> Tensor Bool -> Either MathError (Tensor Bool) tensorAnd = zipTensor (&&) + +{- | Given two tensors, broadcast compatible shapes and combine Bool values with logical OR, +returning a new contiguous tensor. Incompatible/overflowing broadcast shapes return +Left MathError. +-} tensorOr :: Tensor Bool -> Tensor Bool -> Either MathError (Tensor Bool) tensorOr = zipTensor (||) + +{- | Negate each Bool element, returning a new contiguous tensor of the same shape. No +broadcast or ownership mutation occurs. +-} tensorNot :: Tensor Bool -> Tensor Bool tensorNot = mapTensor not + +{- | Explicitly convert each Real element through exact Rational to the destination +Fractional type, preserving shape. Destination rounding/overflow follows its +conversion; no implicit promotion occurs elsewhere. +-} promoteTensor :: (Real a, Fractional b) => Tensor a -> Tensor b promoteTensor = mapTensor realToFrac @@ -582,10 +889,25 @@ reduceAxes f initial axes keep t tensor output [M.findWithDefault initial ix accumulated | ix <- allIndices output] where dims = tensorShape t + +{- | Given unique zero-based axis list,keep-dimensions Bool,then tensor, reduce those axes +by sum. True retains reduced dimensions as size one; False removes them. +Invalid/duplicate axes fail. Empty reduced groups use zero. +-} sumAxes :: (Num a) => [Int] -> Bool -> Tensor a -> Either MathError (Tensor a) sumAxes = reduceAxes (+) 0 + +{- | Given unique zero-based axis list,keep-dimensions Bool,then tensor, reduce those axes +by product. True retains reduced dimensions as size one; False removes them. +Invalid/duplicate axes fail. Empty reduced groups use one. +-} productAxes :: (Num a) => [Int] -> Bool -> Tensor a -> Either MathError (Tensor a) productAxes = reduceAxes (*) 1 + +{- | Given unique zero-based axis list,keep-dimensions Bool,then tensor, reduce those axes +by arithmetic mean. True retains reduced dimensions as size one; False removes them. +Invalid/duplicate axes fail. Nonempty output with an empty reduced group fails. +-} meanAxes :: (Fractional a) => [Int] -> Bool -> Tensor a -> Either MathError (Tensor a) meanAxes axes keep t = do summed <- sumAxes axes keep t @@ -593,29 +915,61 @@ meanAxes axes keep t = do if count == 0 && numel summed > 0 then Left (DomainError "meanAxes: empty reduction") else Right (mapTensor (/ fromInteger count) summed) + reduceNonempty :: (a -> a -> a) -> [Int] -> Bool -> Tensor a -> Either MathError (Tensor a) reduceNonempty f axes keep t = do reduced <- reduceAxes (\old x -> Just (maybe x (`f` x) old)) Nothing axes keep t case sequence (tensorValues reduced) of Nothing -> Left (DomainError "reduction: empty axis") Just xs -> tensor (tensorShape reduced) xs + +{- | Given unique zero-based axis list,keep-dimensions Bool,then tensor, reduce those axes +by minimum. True retains reduced dimensions as size one; False removes them. +Invalid/duplicate axes fail. Empty reduced groups fail. +-} minAxes :: (Ord a) => [Int] -> Bool -> Tensor a -> Either MathError (Tensor a) minAxes = reduceNonempty min + +{- | Given unique zero-based axis list,keep-dimensions Bool,then tensor, reduce those axes +by maximum. True retains reduced dimensions as size one; False removes them. +Invalid/duplicate axes fail. Empty reduced groups fail. +-} maxAxes :: (Ord a) => [Int] -> Bool -> Tensor a -> Either MathError (Tensor a) maxAxes = reduceNonempty max + argExtreme :: (Ord a) => (a -> a -> Bool) -> Tensor a -> Either MathError Int argExtreme better t = case zip [0 ..] (tensorValues t) of [] -> Left (DomainError "argmin/argmax: empty tensor") x : xs -> Right (fst (foldl (\old new -> if better (snd new) (snd old) then new else old) x xs)) + +{- | Return first zero-based flat row-major index of a minimum logical element. Empty input +returns Left DomainError. +-} argmin :: (Ord a) => Tensor a -> Either MathError Int argmin = argExtreme (<) + +{- | Return first zero-based flat row-major index of a maximum logical element. Empty input +returns Left DomainError. +-} argmax :: (Ord a) => Tensor a -> Either MathError Int argmax = argExtreme (>) + +{- | Given unique zero-based axis list,keep-dimensions Bool,then tensor, reduce those axes +by population variance (dividing by group size). True retains reduced dimensions as +size one; False removes them. Invalid/duplicate axes fail. Empty reduced groups fail as +meanAxes. +-} varianceAxes :: (Fractional a) => [Int] -> Bool -> Tensor a -> Either MathError (Tensor a) varianceAxes axes keep t = do means <- meanAxes axes True t deviations <- zipTensor (\x m -> (x - m) * (x - m)) t means meanAxes axes keep deviations + +{- | Given unique zero-based axis list,keep-dimensions Bool,then tensor, reduce those axes +by scaled Euclidean norm. True retains reduced dimensions as size one; False removes +them. Invalid/duplicate axes fail. Empty groups have norm zero; IEEE NaN/infinity +propagate. +-} normAxes :: (RealFloat a) => [Int] -> Bool -> Tensor a -> Either MathError (Tensor a) normAxes axes keep t = do pairs <- reduceAxes accumulate (0, 1) axes keep t @@ -627,6 +981,7 @@ normAxes axes keep t = do | x == 0 = (scale, ssq) | scale < abs x = (abs x, 1 + ssq * (scale / abs x) ^ (2 :: Int)) | otherwise = (scale, ssq + (abs x / scale) ^ (2 :: Int)) + cumulative :: (a -> a -> a) -> a -> Int -> Tensor a -> Either MathError (Tensor a) cumulative f initial axis t = do axisValid axis t @@ -635,11 +990,23 @@ cumulative f initial axis t = do [ foldl f initial [unsafeIndex t (replaceAt axis k ix) | k <- [0 .. ix !! axis]] | ix <- allIndices (tensorShape t) ] + +{- | Given existing axis then tensor, return inclusive running sums along that axis, +preserving shape. Invalid axis fails; arithmetic follows Num. +-} cumulativeSum :: (Num a) => Int -> Tensor a -> Either MathError (Tensor a) cumulativeSum = cumulative (+) 0 + +{- | Given existing axis then tensor, return inclusive running products along that axis, +preserving shape. Invalid axis fails; arithmetic follows Num. +-} cumulativeProduct :: (Num a) => Int -> Tensor a -> Either MathError (Tensor a) cumulativeProduct = cumulative (*) 1 +{- | Given contraction axes for the first tensor,axes for the second,then both tensors, sum +products over matched axis pairs. Noncontracted left axes precede right axes in the +output. Reject duplicate/out-of-range axes or mismatched contraction dimensions. +-} tensordot :: (Num a) => [Int] -> [Int] -> Tensor a -> Tensor a -> Either MathError (Tensor a) tensordot axesA axesB a b | length axesA /= length axesB @@ -702,6 +1069,10 @@ einsum labels output operands allLabels = nub (concat labels) dimension l = case [d | ls <- labeledDims, (name, d) <- ls, name == l] of d : _ -> d; [] -> 0 +{- | Multiply tensors on their final two dimensions and broadcast leading batch dimensions. +Require rank>=2 and matching inner dimensions; incompatible broadcast or size overflow +fails. Generic Num arithmetic is unchanged. +-} batchedMatmul :: (Num a) => Tensor a -> Tensor a -> Either MathError (Tensor a) batchedMatmul a b | length da < 2 || length db < 2 = @@ -726,6 +1097,11 @@ batchedMatmul a b ] where da = tensorShape a; db = tensorShape b + +{- | Return multidimensional Kronecker product, left-padding the lower-rank shape with ones +and multiplying corresponding axis sizes. Invalid/overflowing resulting dimensions +fail. +-} tensorKronecker :: (Num a) => Tensor a -> Tensor a -> Either MathError (Tensor a) tensorKronecker a b | any (> toInteger (maxBound :: Int)) dimensions = @@ -744,8 +1120,17 @@ tensorKronecker a b da = pad (tensorShape a) db = pad (tensorShape b) dimensions = zipWith (\x y -> toInteger x * toInteger y) da db + +{- | Serialize (shape,logical row-major values) using Haskell Show. Storage strides/offsets +are not retained; the encoding requires a compatible Read instance for round-trip. +-} serializeTensor :: (Show a) => Tensor a -> String serializeTensor t = show (tensorShape t, tensorValues t) + +{- | Read a complete Haskell (shape,values) encoding, permitting only trailing whitespace, +and validate shape/count. Malformed input or invalid dimensions/count returns Left +MathError. +-} deserializeTensor :: (Read a) => String -> Either MathError (Tensor a) deserializeTensor input = case reads input of [((dims, xs), rest)] | all (`elem` " \n\r\t") rest -> tensor dims xs @@ -757,14 +1142,30 @@ the output array is allocated. Shape errors are checked before evaluation. -} data TensorGraph a = Graph [Int] ([Int] -> a) +{- | Wrap an immutable tensor as a lazy TensorGraph leaf, retaining its backing storage +without evaluating a new output array. +-} inputGraph :: Tensor a -> TensorGraph a inputGraph t = Graph (tensorShape t) (unsafeIndex t) + +{- | Given element function then graph, compose a lazy element transform, preserving shape. +No output tensor is allocated until evaluateGraph. +-} mapGraph :: (a -> b) -> TensorGraph a -> TensorGraph b mapGraph f (Graph dims action) = Graph dims (f . action) + +{- | Given binary function then two graphs, validate broadcast shapes and return a fused +lazy graph. Incompatible shapes return Left MathError before evaluation. +-} zipGraph :: (a -> b -> c) -> TensorGraph a -> TensorGraph b -> Either MathError (TensorGraph c) zipGraph f (Graph da a) (Graph db b) = do dims <- inferBroadcast da db let select source ix = zipWith (\d i -> if d == 1 then 0 else i) source (drop (length dims - length source) ix) Right (Graph dims (\ix -> f (a (select da ix)) (b (select db ix)))) + +{- | Evaluate a lazy graph into one contiguous row-major tensor. Adjacent map/zip operations +are fused; scalar evaluation behavior follows supplied functions and checked output +shape errors propagate. +-} evaluateGraph :: TensorGraph a -> Either MathError (Tensor a) evaluateGraph (Graph dims action) = tensor dims [action ix | ix <- allIndices dims] diff --git a/src/HMath/Tensor/Mutable.hs b/src/HMath/Tensor/Mutable.hs index 8eaecdb..3b7edc9 100644 --- a/src/HMath/Tensor/Mutable.hs +++ b/src/HMath/Tensor/Mutable.hs @@ -30,11 +30,27 @@ import Foreign.Storable (Storable, alignment, peekElemOff, pokeElemOff, sizeOf) import HMath.Error import HMath.Tensor +{- | Pinned CPU tensor with shared mutable views and garbage-collected ForeignPtr ownership. +Freeze/thaw copy; callers synchronize concurrent writes. +-} data MutableTensor a = MutableTensor [Int] [Int] Int Int (ForeignPtr a) + +{- | Return current mutable-view dimensions in axis order. Slices/transposes can change the +view shape while sharing storage. +-} mutableShape :: MutableTensor a -> [Int] mutableShape (MutableTensor dims _ _ _ _) = dims + +{- | Given a type Proxy, return the Storable ABI alignment in bytes. This reports the +element type requirement, not a user-selectable alignment. +-} mutableAlignment :: forall a. (Storable a) => Proxy a -> Int mutableAlignment _ = alignment (undefined :: a) + +{- | Given checked dimensions then fill value, allocate pinned row-major storage filled with +that value. Shape/byte-size overflow returns Left MathError; allocation errors remain +IO exceptions. Empty tensors are valid. +-} newMutable :: forall a. (Storable a) => [Int] -> a -> IO (Either MathError (MutableTensor a)) newMutable dims value = case shapeSize dims of Left e -> pure (Left e) @@ -46,6 +62,11 @@ newMutable dims value = case shapeSize dims of withForeignPtr storage $ \pointer -> pokeArray pointer (replicate size value) let strides = if size == 0 then replicate (length dims) 0 else drop 1 (scanr (*) 1 dims) pure (Right (MutableTensor dims strides 0 size storage)) + +{- | Copy logical immutable tensor values to new contiguous pinned mutable storage. +Byte-size overflow returns Left InvalidArgument; allocation failures remain IO +exceptions. The source stays unchanged. +-} thawTensor :: forall a. (Storable a) => Tensor a -> IO (Either MathError (MutableTensor a)) thawTensor t | toInteger (numel t) * toInteger (sizeOf (undefined :: a)) > toInteger (maxBound :: Int) = @@ -64,6 +85,7 @@ thawTensor t storage ) ) + indices :: [Int] -> [[Int]] indices dims | 0 `elem` dims = [] indices [] = [[]] @@ -73,22 +95,46 @@ address (MutableTensor dims strides offset _ _) ix | length ix /= length dims || or (zipWith (\i d -> i < 0 || i >= d) ix dims) = Left (InvalidArgument "mutable tensor: index out of bounds") | otherwise = Right (offset + sum (zipWith (*) ix strides)) + +{- | Given a mutable view then full zero-based coordinate list, read one element through the +view strides. Wrong rank or out-of-range coordinates return Left InvalidArgument. +Callers synchronize concurrent writes. +-} readMutable :: (Storable a) => MutableTensor a -> [Int] -> IO (Either MathError a) readMutable t@(MutableTensor _ _ _ _ storage) ix = case address t ix of Left e -> pure (Left e) Right location -> Right <$> withForeignPtr storage (\pointer -> peekElemOff pointer location) + +{- | Given a mutable view, full coordinate list, then value, update that storage element. +Invalid coordinates return Left InvalidArgument without writing; synchronize concurrent +access externally. +-} writeMutable :: (Storable a) => MutableTensor a -> [Int] -> a -> IO (Either MathError ()) writeMutable t@(MutableTensor _ _ _ _ storage) ix value = case address t ix of Left e -> pure (Left e) Right location -> Right <$> withForeignPtr storage (\pointer -> pokeElemOff pointer location value) + +{- | Given view, coordinates, then transformation, read and replace an element. Invalid +coordinates fail. This read-modify-write is not atomic across threads; callers provide +synchronization. +-} modifyMutable :: (Storable a) => MutableTensor a -> [Int] -> (a -> a) -> IO (Either MathError ()) modifyMutable t ix action = do result <- readMutable t ix case result of { Left e -> pure (Left e); Right value -> writeMutable t ix (action value) } + +{- | Copy current logical view values into a new immutable tensor in row-major order. Return +checked tensor construction errors; later mutable writes do not affect the result. +-} freezeTensor :: (Storable a) => MutableTensor a -> IO (Either MathError (Tensor a)) freezeTensor t = do values <- traverse (readMutable t) (indices (mutableShape t)) pure (sequence values >>= tensor (mutableShape t)) + +{- | Given axis, start, count, nonzero step, then view, return a zero-copy mutable slice +retaining shared ForeignPtr ownership. Negative steps are supported if all reached +indices stay in bounds. Invalid extent/axis or stride overflow fails. +-} sliceMutable :: Int -> Int -> Int -> Int -> MutableTensor a -> Either MathError (MutableTensor a) sliceMutable axis start count step (MutableTensor dims strides offset size storage) | axis < 0 || axis >= length dims = Left (InvalidArgument "sliceMutable: invalid axis") @@ -114,6 +160,10 @@ sliceMutable axis start count step (MutableTensor dims strides offset size stora stride = toInteger (strides !! axis) * toInteger step newOffset = toInteger offset + toInteger start * toInteger (strides !! axis) replace i x xs = take i xs ++ x : drop (i + 1) xs + +{- | Reverse the order of all shape axes and strides, returning a zero-copy mutable view. +For rank two this is a matrix transpose; storage ownership remains shared. +-} transposeMutable :: MutableTensor a -> MutableTensor a transposeMutable (MutableTensor dims strides offset size storage) = MutableTensor (reverse dims) (reverse strides) offset size storage diff --git a/src/HMath/TimeSeries/Core.hs b/src/HMath/TimeSeries/Core.hs index 38bab18..edfccf4 100644 --- a/src/HMath/TimeSeries/Core.hs +++ b/src/HMath/TimeSeries/Core.hs @@ -45,17 +45,34 @@ import HMath.Error -- | Opaque, validated timestamps paired with optional observations. newtype Series = Series [(Double, Maybe Double)] deriving (Eq, Show) +-- | Test whether Double is neither NaN nor infinite. finite :: Double -> Bool finite x = not (isNaN x || isInfinite x) + +{- | Given predicate then message, return Right () or time-series-prefixed Left +InvalidArgument. +-} require :: Bool -> String -> Either MathError () require p s = if p then Right () else Left (InvalidArgument ("time series: " ++ s)) + +{- | Return list unchanged when every sample is finite; otherwise return Left +NonFiniteResult. +-} checked :: [Double] -> Either MathError [Double] checked xs = if all finite xs then Right xs else Left NonFiniteResult + +{- | Given minimum sample count then list, require length between that minimum and 16384 and +all finite values. Invalid input returns Left InvalidArgument. +-} validate :: Int -> [Double] -> Either MathError () validate n xs = require (length xs >= n && length xs <= 16384 && all finite xs) "finite sample count outside supported range" + +{- | Unchecked arithmetic average using per-term division by list length; empty list returns +zero by empty sum. Checked statistical callers validate nonempty input first. +-} average :: [Double] -> Double average xs = sum (map (/ fromIntegral (length xs)) xs) @@ -73,6 +90,9 @@ regularSeries start step xs = do require (finite start && finite step && step > 0) "finite start and positive step required" series (zip [start + fromIntegral i * step | i <- [0 :: Int .. length xs - 1]] xs) +{- | Extract time-ordered (timestamp,Maybe value) observations from a validated Series. +Missing values remain Nothing. +-} observations :: Series -> [(Double, Maybe Double)] observations (Series xs) = xs @@ -89,6 +109,9 @@ isRegular tolerance (Series xs) = do Right (case steps of [] -> True; d : ds -> all (\x -> abs (x - d) <= tolerance * max (abs d) (abs x)) ds) +{- | Time-series timestamp join policy: Inner intersection or Outer union,with missing +values explicit. +-} data Alignment = Inner | Outer | LeftAligned deriving (Eq, Show) -- | Exact timestamp equality. Missing alignment positions are explicit Nothing. @@ -104,6 +127,9 @@ align mode (Series a) (Series b) = do y <- series [(t, M.findWithDefault Nothing t bm) | t <- times] Right (x, y) +{- | Missing-value strategy selecting forward fill,backward fill,or linear interpolation +under the checked boundary rules. +-} data Fill = ForwardFill | BackwardFill | LinearFill deriving (Eq, Show) {- | Directional filling leaves the unavailable leading/trailing end missing. @@ -127,6 +153,7 @@ fillMissing mode (Series xs) = (Just (a, x), Just (b, y)) -> (t, Just ((1 - w) * x + w * y)) where w = fraction a b t _ -> pair +-- | Series resampling policy selecting bin means,last-bin values,or linear point samples. data Resampling = LinearSamples | BinMean | BinLast deriving (Eq, Show) {- | Linear samples require brackets (or an exact timestamp). Bins are @@ -157,6 +184,9 @@ resample method start step count input@(Series xs) = do aggregate [] = Nothing aggregate vs = Just (if method == BinLast then last vs else average vs) +{- | Rolling-window statistic selector for mean,variance,standard deviation,minimum,or +maximum. +-} data Rolling = MovingMean | MovingVariance | MovingSD | MovingMinimum | MovingMaximum deriving (Eq, Show) @@ -273,6 +303,10 @@ yuleWalker order xs = do (phi, v, _) <- durbinLevinson (map (* variance) acf) Right (phi, v, m) +{- | Given maximum lag then samples, compute ACF and Durbin-Levinson partial correlations, +returning lag zero (1) followed by requested PACF lags. Invalid lag/data or singular +covariance recurrence returns Left MathError. +-} partialAutocorrelation :: Int -> [Double] -> Either MathError [Double] partialAutocorrelation order xs = do acf <- autocorrelation order xs diff --git a/src/HMath/TimeSeries/Diagnostics.hs b/src/HMath/TimeSeries/Diagnostics.hs index 985b4c2..b05ec5c 100644 --- a/src/HMath/TimeSeries/Diagnostics.hs +++ b/src/HMath/TimeSeries/Diagnostics.hs @@ -32,6 +32,7 @@ import qualified HMath.Matrix.QR as QR import qualified HMath.Statistics.Advanced as Stats import HMath.TimeSeries.Core +-- | Stationarity-test deterministic terms: level-only or linear-trend specification. data Deterministic = Level | LinearTrend deriving (Eq, Show) {- | Significance level paired with critical value. ADF rejects for smaller @@ -39,9 +40,13 @@ statistics, KPSS for larger ones. No interpolated p value is fabricated. -} data Stationarity = Stationarity { stationarityStatistic :: Double + -- ^ Computed ADF/KPSS stationarity test statistic. , stationarityCriticalValues :: [(Double, Double)] + -- ^ Significance-level and critical-value pairs for the selected test/deterministic specification. , stationarityObservations :: Int + -- ^ Number of effective observations used by the test. , stationarityNull :: String + -- ^ Human-readable null hypothesis, which differs between ADF and KPSS. } deriving (Eq, Show) @@ -215,7 +220,16 @@ anomalies threshold xs = do Right [i | (i, (x, z)) <- zip [0 ..] (zip xs scores), if mad == 0 then x /= median else z > threshold] -data DTWResult = DTWResult {dtwDistance :: Double, dtwPath :: [(Int, Int)]} deriving (Eq, Show) +{- | Dynamic-time-warping accumulated distance and original-series zero-based alignment +path. +-} +data DTWResult = DTWResult + { dtwDistance :: Double + -- ^ Accumulated dynamic-time-warping path cost. + , dtwPath :: [(Int, Int)] + -- ^ Optimal alignment as zero-based index pairs from the two input series. + } + deriving (Eq, Show) {- | Absolute local cost; Sakoe--Chiba radius must include both endpoints. Returns the unnormalized path cost, with diagonal/up/left tie priority. @@ -261,6 +275,9 @@ spectrum sampleRate xs = do _ <- checked (concatMap (\(a, b) -> [a, b]) density) Right density +{- | Prediction-error metric selector; scale/zero-denominator preconditions are checked by +the metric function. +-} data ForecastMetric = MAE | MSE | RMSE | MAPE | SMAPE | MASE Int [Double] deriving (Eq, Show) {- | MAPE and sMAPE are percentages; zero/zero sMAPE contributes zero. MASE diff --git a/src/HMath/TimeSeries/Models.hs b/src/HMath/TimeSeries/Models.hs index e921490..0122879 100644 --- a/src/HMath/TimeSeries/Models.hs +++ b/src/HMath/TimeSeries/Models.hs @@ -46,6 +46,9 @@ import qualified HMath.Optimization.Local as O import qualified HMath.Signal as S import HMath.TimeSeries.Core +{- | Exponential smoothing: Simple alpha; Holt alpha beta; HoltWinters period alpha beta +gamma. Rates lie in [0,1] and seasonal fitting requires complete initial cycles. +-} data Smoothing = Simple Double | Holt Double Double | HoltWinters Int Double Double Double deriving (Eq, Show) @@ -101,7 +104,13 @@ smoothForecast method horizon xs = do -- | Additive reconstruction is trend+seasonal+remainder at every input index. data Decomposition = Decomposition - {trendComponent :: [Double], seasonalComponent :: [Double], remainderComponent :: [Double]} + { trendComponent :: [Double] + -- ^ Estimated trend values aligned with original observations. + , seasonalComponent :: [Double] + -- ^ Estimated seasonal values aligned with original observations. + , remainderComponent :: [Double] + -- ^ Residual values after subtracting trend and seasonality. + } deriving (Eq, Show) {- | Classical additive decomposition with local linear trend smoothing and @@ -120,15 +129,29 @@ decompose period xs = do seasonal = [phases !! (i `mod` period) - average phases | i <- [0 .. length xs - 1]] decomposition xs trend seasonal +{- | Seasonal period,odd LOESS windows,and inner/robust iteration counts for STL +decomposition. Use defaultSTLConfig then checked record updates. +-} data STLConfig = STLConfig { stlPeriod :: Int + -- ^ Positive seasonal cycle length in observations. , stlSeasonalWindow :: Int + -- ^ Odd LOESS window for seasonal subseries. , stlTrendWindow :: Int + -- ^ Odd LOESS window for trend smoothing. , stlLowPassWindow :: Int + -- ^ Odd low-pass LOESS smoothing window. , stlInnerIterations :: Int + -- ^ Number of STL seasonal/trend backfitting passes. , stlRobustIterations :: Int + -- ^ Number of robust outer reweighting passes; zero disables robust reweighting. } deriving (Eq, Show) + +{- | Given seasonal period, construct STL options with seasonal window 7, odd trend window +above 2*period, odd low-pass window at/above period, two inner iterations and no robust +outer iterations. stl validates the resulting configuration. +-} defaultSTLConfig :: Int -> STLConfig defaultSTLConfig period = STLConfig period 7 (oddAbove (2 * period + 1)) (oddAbove period) 2 0 where @@ -234,8 +257,16 @@ decomposition xs trend seasonal = do -- | Intercept followed by lag coefficients; observations stored chronologically. data ARModel = ARModel [Double] [Double] deriving (Eq, Show) +{- | Return AR intercept followed by lag-1 through lag-p coefficients. The model retains +observations chronologically for forecastAR. +-} arCoefficients :: ARModel -> [Double] arCoefficients (ARModel b _) = b + +{- | Given AR order then finite chronological samples, fit intercept and lag coefficients by +checked OLS. Require order in [0,64], \<=4096 samples and more than 2*order+1 +observations; invalid/ill-conditioned fits fail. +-} fitAR :: Int -> [Double] -> Either MathError ARModel fitAR order xs = do validate 2 xs @@ -245,6 +276,11 @@ fitAR order xs = do b <- ols [[1] ++ [xs !! (t - j) | j <- [1 .. order]] | t <- [order .. length xs - 1]] (drop order xs) Right (ARModel b xs) + +{- | Given horizon in [0,16384] then fitted AR model, recursively forecast future samples +from latest observations. Zero horizon returns []; invalid horizon or non-finite +predictions fail. +-} forecastAR :: Int -> ARModel -> Either MathError [Double] forecastAR horizon (ARModel b xs) = do require (horizon >= 0 && horizon <= 16384) "invalid AR forecast horizon" @@ -256,28 +292,65 @@ forecastAR horizon (ARModel b xs) = do go (k - 1) (value : past) (value : acc) go horizon (reverse xs) [] +{- | Ordinary (p,d,q),seasonal (P,D,Q),and cycle period s. fitSARIMA validates supported +order/sample budgets. +-} data SARIMAOrder = SARIMAOrder { arOrder :: Int + -- ^ Ordinary autoregressive order p. , differenceOrder :: Int + -- ^ Ordinary differencing order d. , maOrder :: Int + -- ^ Ordinary moving-average order q. , seasonalAROrder :: Int + -- ^ Seasonal autoregressive order P. , seasonalDifferenceOrder :: Int + -- ^ Seasonal differencing order D. , seasonalMAOrder :: Int + -- ^ Seasonal moving-average order Q. , seasonalPeriod :: Int + -- ^ Seasonal cycle length s used to place seasonal polynomial lags. } deriving (Eq, Show) + +{- | Opaque fitted ARIMA/SARIMA state with differencing,parameters,innovation residuals,and +original history for forecasting. +-} data ARIMAModel = ARIMAModel SARIMAOrder [Double] [Double] [Double] [Double] Double deriving (Eq, Show) + +{- | Return fitted intercept,ordinary AR,ordinary MA,seasonal AR,seasonal MA parameters in +that order. Intercept belongs to the differenced process. +-} arimaParameters :: ARIMAModel -> [Double] arimaParameters (ARIMAModel _ b _ _ _ _) = b + +{- | Return fitted innovation residuals in chronological order, on the model's differenced +process. +-} arimaResiduals :: ARIMAModel -> [Double] arimaResiduals (ARIMAModel _ _ _ _ es _) = es + +-- | Return fitted innovation-variance estimate stored in an ARIMA/SARIMA model. arimaInnovationVariance :: ARIMAModel -> Double arimaInnovationVariance (ARIMAModel _ _ _ _ _ v) = v + +{- | Given optimization options,p,d,q,then finite chronological series, fit nonseasonal +ARIMA through fitSARIMA with seasonal orders zero. Invalid order/sample bounds, +unstable or nonconvergent/ill-conditioned fit returns Left MathError. +-} fitARIMA :: O.OptimizeOptions -> Int -> Int -> Int -> [Double] -> Either MathError ARIMAModel fitARIMA options p d q = fitSARIMA options (SARIMAOrder p d q 0 0 0 1) + +{- | Given optimization options,MA order q,then samples, fit ARIMA(0,0,q). +Order/sample/optimization errors propagate from fitARIMA. +-} fitMA :: O.OptimizeOptions -> Int -> [Double] -> Either MathError ARIMAModel fitMA options q = fitARIMA options 0 0 q + +{- | Given optimization options,AR order p,MA order q,then samples, fit ARIMA(p,0,q). +Invalid or nonconvergent fits return Left MathError. +-} fitARMA :: O.OptimizeOptions -> Int -> Int -> [Double] -> Either MathError ARIMAModel fitARMA options p q = fitARIMA options p 0 q @@ -415,6 +488,10 @@ coefficientPartials order b = [partial j | j <- [0 .. length b - 1]] ) | otherwise = (replicate (p + bigP * s) 0, replicate (q + bigQ * s) 0) +{- | Given horizon in [0,16384] then fitted ARIMA/SARIMA model, forecast recursively with +future innovations set to zero and undo ordinary/seasonal differencing. Invalid horizon +or non-finite predictions fail. +-} forecastARIMA :: Int -> ARIMAModel -> Either MathError [Double] forecastARIMA horizon (ARIMAModel order b xs zs es _) = do require (horizon >= 0 && horizon <= 16384) "invalid SARIMA forecast horizon" @@ -434,12 +511,20 @@ forecastARIMA horizon (ARIMAModel order b xs zs es _) = do loop (k - 1) (value : original) (z : transformed) (0 : errors) (value : acc) loop horizon (reverse xs) (reverse zs) (reverse es) [] +{- | Opaque fitted vector autoregression with intercept/lag coefficients and chronological +multivariate history. +-} data VARModel = VARModel Int [[Double]] [[Double]] deriving (Eq, Show) -- | Rows are response components, columns are intercept then lag-major predictors. varCoefficients :: VARModel -> [[Double]] varCoefficients (VARModel _ b _) = b +{- | Given lag order then chronological multivariate rows, fit response-wise OLS with +intercept and lag-major features. Require finite rectangular data, dimensions\<=16, +rows\<=2048, order in [1,16], sufficient samples and \<=20000000 fitting work. +Invalid/ill-conditioned fits fail. +-} fitVAR :: Int -> [[Double]] -> Either MathError VARModel fitVAR order xs = do require (not (null xs) && not (null ((!! 0) xs))) "empty VAR data" @@ -458,6 +543,11 @@ fitVAR order xs = do let design = [1 : concat [xs !! (t - j) | j <- [1 .. order]] | t <- [order .. n - 1]] b <- mapM (ols design) (transpose (drop order xs)) Right (VARModel order b xs) + +{- | Given horizon then VAR model, recursively return future multivariate observation rows. +Require horizon in [0,16384] and horizon*components\<=262144; invalid bounds or +non-finite predictions fail. +-} forecastVAR :: Int -> VARModel -> Either MathError [[Double]] forecastVAR horizon (VARModel order b xs) = do require diff --git a/src/HMath/Trigonometry.hs b/src/HMath/Trigonometry.hs index 2db767b..9ab15c0 100644 --- a/src/HMath/Trigonometry.hs +++ b/src/HMath/Trigonometry.hs @@ -88,13 +88,40 @@ sinChecked , acosChecked , atanChecked :: (RealFloat a) => a -> Either MathError a + +{- | Sine of a radian argument. Return Right result for finite input in the stated domain; +invalid input/poles or non-finite output return Left MathError. +-} sinChecked = checked sin + +{- | Cosine of a radian argument. Return Right result for finite input in the stated domain; +invalid input/poles or non-finite output return Left MathError. +-} cosChecked = checked cos + +{- | Tangent of a radian argument; represented poles at odd pi/2 are rejected. Return Right +result for finite input in the stated domain; invalid input/poles or non-finite output +return Left MathError. +-} tanChecked x = do a <- normalizeSignedAngle x if abs a == pi / 2 then Left (DomainError "tangent pole") else checked tan x + +{- | Principal inverse sine in [-pi/2,pi/2]; require abs(x)\<=1. Return Right result for +finite input in the stated domain; invalid input/poles or non-finite output return Left +MathError. +-} asinChecked = restricted (\x -> abs x <= 1) "asin needs abs x <= 1" asin + +{- | Principal inverse cosine in [0,pi]; require abs(x)\<=1. Return Right result for finite +input in the stated domain; invalid input/poles or non-finite output return Left +MathError. +-} acosChecked = restricted (\x -> abs x <= 1) "acos needs abs x <= 1" acos + +{- | Principal inverse tangent in (-pi/2,pi/2). Return Right result for finite input in the +stated domain; invalid input/poles or non-finite output return Left MathError. +-} atanChecked = checked atan -- | Conventional atan2(y,x), range [-pi,pi]. Rejects the undefined origin. @@ -104,18 +131,48 @@ atan2Checked y x | otherwise = Right (atan2 y x) sec, csc, cot, asec, acsc, acot :: (RealFloat a) => a -> Either MathError a + +{- | Secant 1/cos(x) in radians; represented odd-pi/2 poles fail. Return Right result for +finite input in the stated domain; invalid input/poles or non-finite output return Left +MathError. +-} sec x = do a <- normalizeSignedAngle x if abs a == pi / 2 then Left (DomainError "secant pole") else checked (\v -> 1 / cos v) x + +{- | Cosecant 1/sin(x) in radians; represented multiples of pi fail. Return Right result for +finite input in the stated domain; invalid input/poles or non-finite output return Left +MathError. +-} csc x = do a <- wrap 0 pi x if a == 0 then Left (DomainError "cosecant pole") else checked (\v -> 1 / sin v) x + +{- | Cotangent cos(x)/sin(x) in radians; represented multiples of pi fail. Return Right +result for finite input in the stated domain; invalid input/poles or non-finite output +return Left MathError. +-} cot x = do a <- wrap 0 pi x if a == 0 then Left (DomainError "cotangent pole") else checked (\v -> cos v / sin v) x + +{- | Principal inverse secant acos(1/x); require abs(x)>=1. Return Right result for finite +input in the stated domain; invalid input/poles or non-finite output return Left +MathError. +-} asec = restricted (\x -> abs x >= 1) "asec needs abs x >= 1" (acos . recip) + +{- | Principal inverse cosecant asin(1/x); require abs(x)>=1. Return Right result for finite +input in the stated domain; invalid input/poles or non-finite output return Left +MathError. +-} acsc = restricted (\x -> abs x >= 1) "acsc needs abs x >= 1" (asin . recip) + +{- | Inverse cotangent atan2(1,x), with range (0,pi). Return Right result for finite input +in the stated domain; invalid input/poles or non-finite output return Left MathError. +-} acot = checked (atan2 1) + sinhChecked , coshChecked , tanhChecked @@ -123,32 +180,89 @@ sinhChecked , acoshChecked , atanhChecked :: (RealFloat a) => a -> Either MathError a + +{- | Hyperbolic sine. Return Right result for finite input in the stated domain; invalid +input/poles or non-finite output return Left MathError. +-} sinhChecked = checked sinh + +{- | Hyperbolic cosine. Return Right result for finite input in the stated domain; invalid +input/poles or non-finite output return Left MathError. +-} coshChecked = checked cosh + +{- | Hyperbolic tangent. Return Right result for finite input in the stated domain; invalid +input/poles or non-finite output return Left MathError. +-} tanhChecked = checked tanh + +{- | Inverse hyperbolic sine. Return Right result for finite input in the stated domain; +invalid input/poles or non-finite output return Left MathError. +-} asinhChecked = checked asinh + +{- | Principal real inverse hyperbolic cosine; require x>=1. Return Right result for finite +input in the stated domain; invalid input/poles or non-finite output return Left +MathError. +-} acoshChecked = restricted (>= 1) "acosh needs x >= 1" acosh + +{- | Inverse hyperbolic tangent; require abs(x)\<1. Return Right result for finite input in +the stated domain; invalid input/poles or non-finite output return Left MathError. +-} atanhChecked = restricted (\x -> abs x < 1) "atanh needs abs x < 1" atanh + sech, csch, coth, asech, acsch, acoth :: (RealFloat a) => a -> Either MathError a + -- exponential formulas avoid overflowing cosh/sinh for large finite arguments. + +{- | Hyperbolic secant 1/cosh(x), using a scaled exponential formula for large arguments. +Return Right result for finite input in the stated domain; invalid input/poles or +non-finite output return Left MathError. +-} sech = checked (\x -> let e = exp (-abs x) in 2 * e / (1 + e * e)) + +{- | Hyperbolic cosecant 1/sinh(x); reject zero. Return Right result for finite input in the +stated domain; invalid input/poles or non-finite output return Left MathError. +-} csch = restricted (/= 0) "csch pole" (\x -> if abs x < 1 then 1 / sinh x else let e = exp (-abs x) in signum x * 2 * e / (1 - e * e)) + +{- | Hyperbolic cotangent 1/tanh(x); reject zero. Return Right result for finite input in +the stated domain; invalid input/poles or non-finite output return Left MathError. +-} coth = restricted (/= 0) "coth pole" (recip . tanh) + +{- | Inverse hyperbolic secant; require 0\ x > 0 && x <= 1) "asech needs 0 < x <= 1" (\x -> log (1 + sqrt (1 - x * x)) - log x) + +{- | Inverse hyperbolic cosecant; reject zero and use a log formula near zero. Return Right +result for finite input in the stated domain; invalid input/poles or non-finite output +return Left MathError. +-} acsch = restricted (/= 0) "acsch needs x /= 0" (\x -> if abs x < 1e-15 then signum x * (log 2 - log (abs x)) else asinh (1 / x)) + +{- | Inverse hyperbolic cotangent; require abs(x)>1. Return Right result for finite input in +the stated domain; invalid input/poles or non-finite output return Left MathError. +-} acoth = restricted (\x -> abs x > 1) "acoth needs abs x > 1" (atanh . recip) + +{- | Given a finite radian angle, return Right (sin x,cos x), propagating checked +input/result failures. Example: sincos 0 == Right (0,1). +-} sincos :: (RealFloat a) => a -> Either MathError (a, a) sincos x = do s <- sinChecked x; c <- cosChecked x; Right (s, c) @@ -169,15 +283,42 @@ wrap lo hi x in Right (if r >= hi then lo else max lo r) normalizeAngle, normalizeSignedAngle :: (RealFloat a) => a -> Either MathError a + +{- | Wrap a finite radian angle into [0,2*pi). Non-finite input fails. Reduction uses the +represented period; no exact huge-angle reduction against irrational pi is promised. +-} normalizeAngle = wrap 0 (2 * pi) + +{- | Wrap a finite radian angle into [-pi,pi). Non-finite input fails. The positive endpoint +pi wraps to -pi. +-} normalizeSignedAngle = wrap (-pi) pi + +{- | Given angles a then b, return the signed wrapped difference a-b in [-pi,pi). Reject +non-finite input. Normalize operands first to avoid avoidable subtraction overflow. +-} angleDifference :: (RealFloat a) => a -> a -> Either MathError a angleDifference a b | not (all finite [a, b]) = Left (DomainError "non-finite angle") | otherwise = do x <- normalizeSignedAngle a; y <- normalizeSignedAngle b; normalizeSignedAngle (x - y) + versine, haversine, sinc, cosc :: (RealFloat a) => a -> Either MathError a + +{- | Versine 1-cos(x), evaluated as 2*sin(x/2)^2 for a radian input. Return Right result for +finite input in the stated domain; invalid input/poles or non-finite output return Left +MathError. +-} versine = checked (\x -> 2 * sin (x / 2) ^ (2 :: Int)) + +{- | Haversine sin(x/2)^2 for a radian input. Return Right result for finite input in the +stated domain; invalid input/poles or non-finite output return Left MathError. +-} haversine = checked (\x -> sin (x / 2) ^ (2 :: Int)) + +{- | Unnormalized sinc sin(x)/x for radians, with continuous value 1 at zero. Return Right +result for finite input in the stated domain; invalid input/poles or non-finite output +return Left MathError. +-} sinc x | x == 0 = Right 1 | otherwise = checked (\v -> sin v / v) x @@ -198,6 +339,10 @@ greatCircleAngle (lat1, lon1) (lat2, lon2) h = max 0 (min 1 a) Right (2 * atan2 (sqrt h) (sqrt (1 - h))) +{- | Given finite nonnegative sphere radius and two (latitude,longitude) radian pairs, +return radius times the central angle. Reject invalid latitude, non-finite input, or +result overflow. Distance uses the radius units. +-} greatCircleDistance :: (RealFloat a) => a -> (a, a) -> (a, a) -> Either MathError a greatCircleDistance radius a b | not (finite radius) || radius < 0 = Left (DomainError "invalid sphere radius") @@ -225,9 +370,16 @@ sphericalAngles a b c where angle x y z = acos (max (-1) (min 1 ((cos x - cos y * cos z) / (sin y * sin z)))) +{- | Given three side angles of a nondegenerate minor spherical triangle, compute +interior-angle sum minus pi. Side/domain errors propagate from sphericalAngles. +Multiply by radius squared for area. +-} sphericalExcess :: (RealFloat a) => a -> a -> a -> Either MathError a sphericalExcess a b c = do (x, y, z) <- sphericalAngles a b c; Right (x + y + z - pi) +{- | Checked complex trigonometric/hyperbolic principal-branch function selector,including +reciprocal secant/cosecant/cotangent variants. +-} data ComplexFunction = CSin | CCos @@ -248,6 +400,11 @@ data ComplexFunction | CCsch | CCoth deriving (Eq, Show) + +{- | Given a ComplexFunction selector then complex input, compute the selected +principal-branch Data.Complex function or reciprocal. Reject non-finite components and +non-finite results/poles with Left DomainError. +-} complexFunction :: (RealFloat a) => ComplexFunction -> Complex a -> Either MathError (Complex a) complexFunction name z | not (finite (realPart z) && finite (imagPart z)) = @@ -275,6 +432,7 @@ complexFunction name z CSech -> 1 / cosh z CCsch -> 1 / sinh z CCoth -> cosh z / sinh z + complexSin , complexCos , complexTan @@ -288,17 +446,77 @@ complexSin , complexAcosh , complexAtanh :: (RealFloat a) => Complex a -> Either MathError (Complex a) + +{- | Principal complex sine, dispatched through complexFunction. Return Right complex +result; non-finite input components or a pole/overflow producing non-finite components +return Left DomainError. Angles use radians. +-} complexSin = complexFunction CSin + +{- | Principal complex cosine, dispatched through complexFunction. Return Right complex +result; non-finite input components or a pole/overflow producing non-finite components +return Left DomainError. Angles use radians. +-} complexCos = complexFunction CCos + +{- | Principal complex tangent, dispatched through complexFunction. Return Right complex +result; non-finite input components or a pole/overflow producing non-finite components +return Left DomainError. Angles use radians. +-} complexTan = complexFunction CTan + +{- | Principal complex inverse sine, dispatched through complexFunction. Return Right +complex result; non-finite input components or a pole/overflow producing non-finite +components return Left DomainError. Angles use radians. +-} complexAsin = complexFunction CAsin + +{- | Principal complex inverse cosine, dispatched through complexFunction. Return Right +complex result; non-finite input components or a pole/overflow producing non-finite +components return Left DomainError. Angles use radians. +-} complexAcos = complexFunction CAcos + +{- | Principal complex inverse tangent, dispatched through complexFunction. Return Right +complex result; non-finite input components or a pole/overflow producing non-finite +components return Left DomainError. Angles use radians. +-} complexAtan = complexFunction CAtan + +{- | Principal complex hyperbolic sine, dispatched through complexFunction. Return Right +complex result; non-finite input components or a pole/overflow producing non-finite +components return Left DomainError. Angles use radians. +-} complexSinh = complexFunction CSinh + +{- | Principal complex hyperbolic cosine, dispatched through complexFunction. Return Right +complex result; non-finite input components or a pole/overflow producing non-finite +components return Left DomainError. Angles use radians. +-} complexCosh = complexFunction CCosh + +{- | Principal complex hyperbolic tangent, dispatched through complexFunction. Return Right +complex result; non-finite input components or a pole/overflow producing non-finite +components return Left DomainError. Angles use radians. +-} complexTanh = complexFunction CTanh + +{- | Principal complex inverse hyperbolic sine, dispatched through complexFunction. Return +Right complex result; non-finite input components or a pole/overflow producing +non-finite components return Left DomainError. Angles use radians. +-} complexAsinh = complexFunction CAsinh + +{- | Principal complex inverse hyperbolic cosine, dispatched through complexFunction. Return +Right complex result; non-finite input components or a pole/overflow producing +non-finite components return Left DomainError. Angles use radians. +-} complexAcosh = complexFunction CAcosh + +{- | Principal complex inverse hyperbolic tangent, dispatched through complexFunction. +Return Right complex result; non-finite input components or a pole/overflow producing +non-finite components return Left DomainError. Angles use radians. +-} complexAtanh = complexFunction CAtanh {- | Unit-amplitude periodic waves. Period must be positive and finite. Square diff --git a/src/HMath/Units.hs b/src/HMath/Units.hs index 7636fcc..50ee40d 100644 --- a/src/HMath/Units.hs +++ b/src/HMath/Units.hs @@ -94,6 +94,9 @@ module HMath.Units ( import HMath.Constants (constantName, constantValue, mathematicalConstants) import HMath.Error (MathError (..)) +{- | Opaque nine-exponent dimensional witness: seven SI bases plus data and plane-angle +tags. Construct with dimension. +-} newtype Dimension = Dimension [Integer] deriving (Eq, Show) {- | Exponents in order length, mass, time, current, temperature, amount, @@ -104,8 +107,12 @@ dimension xs | length xs /= 9 = Left (InvalidArgument "dimension requires nine exponents") | otherwise = Right (Dimension xs) +{- | Return nine exact integer exponents ordered as length, mass, time, current, +temperature, amount, luminous intensity, data, plane angle. +-} dimensionExponents :: Dimension -> [Integer] dimensionExponents (Dimension xs) = xs + dimensionless , lengthDimension , massDimension @@ -114,13 +121,42 @@ dimensionless , angleDimension , dataDimension :: Dimension + +{- | Dimension witness with all nine exponents zero; all unspecified exponents are zero. Use +to construct or compare dimension-safe units/quantities. +-} dimensionless = Dimension (replicate 9 0) + +{- | Dimension witness with length exponent one; all unspecified exponents are zero. Use to +construct or compare dimension-safe units/quantities. +-} lengthDimension = base 0 + +{- | Dimension witness with mass exponent one; all unspecified exponents are zero. Use to +construct or compare dimension-safe units/quantities. +-} massDimension = base 1 + +{- | Dimension witness with time exponent one; all unspecified exponents are zero. Use to +construct or compare dimension-safe units/quantities. +-} timeDimension = base 2 + +{- | Dimension witness with temperature exponent one; all unspecified exponents are zero. +Use to construct or compare dimension-safe units/quantities. +-} temperatureDimension = base 4 + +{- | Dimension witness with data tag exponent one; all unspecified exponents are zero. Use +to construct or compare dimension-safe units/quantities. +-} dataDimension = base 7 + +{- | Dimension witness with plane-angle tag exponent one; all unspecified exponents are +zero. Use to construct or compare dimension-safe units/quantities. +-} angleDimension = base 8 + base :: Int -> Dimension base i = Dimension [if i == j then 1 else 0 | j <- [0 .. 8]] combine :: (Integer -> Integer -> Integer) -> Dimension -> Dimension -> Dimension @@ -128,13 +164,30 @@ combine op (Dimension a) (Dimension b) = Dimension (zipWith op a b) scaleDimension :: Integer -> Dimension -> Dimension scaleDimension n (Dimension xs) = Dimension (map (n *) xs) +{- | Opaque exact affine unit definition SI=value*scale+offset. Nonzero offsets are +restricted to absolute-temperature units. +-} data Unit = Unit String Dimension Rational Rational deriving (Eq, Show) + +-- | Return the display name/symbol of a Unit, for example "m". No conversion is performed. unitName :: Unit -> String unitName (Unit name _ _ _) = name + +{- | Return the dimensional-exponent witness of a Unit. Compatible conversions require equal +dimensions. +-} unitDimension :: Unit -> Dimension unitDimension (Unit _ dim _ _) = dim + +{- | Return exact Rational scale in the conversion SI = value*scale + offset. All public +Unit constructors require a positive scale. +-} unitScale :: Unit -> Rational unitScale (Unit _ _ scale _) = scale + +{- | Return exact Rational affine offset in SI = value*scale + offset. Only temperature +units may have a nonzero offset. +-} unitOffset :: Unit -> Rational unitOffset (Unit _ _ _ offset) = offset @@ -147,6 +200,10 @@ unit name dim scale offset | otherwise = Right (Unit name dim scale offset) unitProduct, unitQuotient :: Unit -> Unit -> Either MathError Unit + +{- | Multiply two zero-offset units: add dimension exponents and multiply Rational scales. +Any affine offset returns Left DomainError. This constructs a Unit, not a Quantity. +-} unitProduct a b | unitOffset a /= 0 || unitOffset b /= 0 = Left (DomainError "cannot multiply affine units") | otherwise = @@ -157,6 +214,10 @@ unitProduct a b (unitScale a * unitScale b) 0 ) + +{- | Divide two zero-offset units: subtract dimension exponents and divide their positive +scales. Affine units fail with DomainError. +-} unitQuotient a b | unitOffset a /= 0 || unitOffset b /= 0 = Left (DomainError "cannot divide affine units") | otherwise = @@ -167,56 +228,116 @@ unitQuotient a b (unitScale a / unitScale b) 0 ) + +{- | Given zero-offset Unit then Integer exponent, multiply its exponents and raise its +positive scale to that power. Negative powers are valid; affine units fail. +-} unitPower :: Unit -> Integer -> Either MathError Unit unitPower a n | unitOffset a /= 0 = Left (DomainError "cannot exponentiate affine units") | otherwise = Right (Unit (unitName a ++ "^" ++ show n) (scaleDimension n (unitDimension a)) (unitScale a ^^ n) 0) +{- | Opaque exact SI-valued dimensional quantity,tagging absolute temperatures separately +from differences. Construct with quantity or temperatureDifference. +-} data Quantity = Quantity Dimension Rational Bool deriving (Eq, Show) + +{- | Given Unit then Rational value, construct an exact SI-valued Quantity using its scale +and offset. A temperature unit constructs an absolute temperature; use +temperatureDifference for differences. +-} quantity :: Unit -> Rational -> Quantity quantity u x = Quantity (unitDimension u) (x * unitScale u + unitOffset u) (unitDimension u == temperatureDimension) + +{- | Given temperature Unit then Rational difference, multiply by its scale while ignoring +its affine offset. A non-temperature unit returns Left DomainError. The result is not +an absolute temperature. +-} temperatureDifference :: Unit -> Rational -> Either MathError Quantity temperatureDifference u x | unitDimension u /= temperatureDimension = Left (DomainError "temperature difference requires temperature unit") | otherwise = Right (Quantity temperatureDimension (x * unitScale u) False) + +{- | Return a Quantity's dimensional-exponent witness, without changing its SI value or +absolute-temperature tag. +-} quantityDimension :: Quantity -> Dimension quantityDimension (Quantity d _ _) = d + +{- | Return exact Rational SI value of a Quantity. For absolute temperature this is an +absolute kelvin value; preserve quantityDimension when interpreting the number. +-} siValue :: Quantity -> Rational siValue (Quantity _ x _) = x + +{- | Given destination Unit then Quantity, convert its SI value to that unit. Reject +incompatible dimensions. Apply affine offsets only for absolute temperatures, not +differences. +-} inUnit :: Unit -> Quantity -> Either MathError Rational inUnit u (Quantity d x absoluteTemp) | unitDimension u /= d = Left (DomainError "incompatible dimensions") | otherwise = Right ((x - (if absoluteTemp then unitOffset u else 0)) / unitScale u) + +{- | Given source Unit, destination Unit, then Rational value, convert exactly through SI. +Incompatible dimensions fail. Example: convert kilometre metre 2 == Right 2000. +-} convert :: Unit -> Unit -> Rational -> Either MathError Rational convert a b x = inUnit b (quantity a x) + addQuantity , subtractQuantity , multiplyQuantity , divideQuantity :: Quantity -> Quantity -> Either MathError Quantity + +{- | Add equal-dimension quantities. Two absolute temperatures cannot be added; absolute +plus difference produces an absolute temperature. Incompatible dimensions return Left +DomainError. +-} addQuantity (Quantity d a absA) (Quantity e b absB) | d /= e = Left (DomainError "incompatible dimensions") | absA && absB = Left (DomainError "cannot add absolute temperatures") | otherwise = Right (Quantity d (a + b) (absA || absB)) + +{- | Subtract equal-dimension quantities. Absolute minus absolute produces a difference; +difference minus absolute is invalid. Incompatible dimensions return Left DomainError. +-} subtractQuantity (Quantity d a absA) (Quantity e b absB) | d /= e = Left (DomainError "incompatible dimensions") | not absA && absB = Left (DomainError "cannot subtract absolute temperature from difference") | otherwise = Right (Quantity d (a - b) (absA && not absB)) + +{- | Multiply SI values and add dimension exponents. Any absolute-temperature operand fails +with DomainError; temperature differences can participate in products. +-} multiplyQuantity (Quantity d a absA) (Quantity e b absB) | absA || absB = Left (DomainError "cannot multiply absolute temperatures") | otherwise = Right (Quantity (combine (+) d e) (a * b) False) + +{- | Divide SI values and subtract dimension exponents. Reject a zero divisor or +absolute-temperature operands. Result preserves exact Rational arithmetic. +-} divideQuantity (Quantity d a absA) (Quantity e b absB) | absA || absB = Left (DomainError "cannot divide absolute temperatures") | b == 0 = Left (DomainError "quantity division by zero") | otherwise = Right (Quantity (combine (-) d e) (a / b) False) -data SIPrefix = SIPrefix {prefixName :: String, prefixSymbol :: String, prefixExponent :: Int} +-- | SI prefix name,symbol,and power-of-ten exponent. prefixed rejects affine units. +data SIPrefix = SIPrefix + { prefixName :: String + -- ^ SI prefix name, such as kilo. + , prefixSymbol :: String + -- ^ SI prefix symbol, such as k; micro uses ASCII u in this catalog. + , prefixExponent :: Int + -- ^ Integer power of ten multiplying the base unit scale. + } deriving (Eq, Show) {- | BIPM prefixes through the 2022 quetta/ronna and ronto/quecto additions. @@ -253,6 +374,9 @@ siPrefixes = ] ] +{- | Given SIPrefix then zero-offset Unit, multiply its scale by 10^prefixExponent and +prepend its symbol. Reject affine units or absolute exponent above 10000. +-} prefixed :: SIPrefix -> Unit -> Either MathError Unit prefixed p u | unitOffset u /= 0 = Left (DomainError "cannot prefix affine unit") @@ -263,62 +387,302 @@ prefixed p u in Right (Unit (prefixSymbol p ++ unitName u) (unitDimension u) (s * unitScale u) 0) metre, kilometre, centimetre, millimetre, inch, foot, yard, mile, nauticalMile :: Unit + +{- | The metre Unit: 1 metre. Non-temperature definitions use an exact Rational scale and +zero affine offset. Use quantity or convert to construct/convert values; temperature +differences use temperatureDifference. +-} metre = Unit "m" lengthDimension 1 0 + +{- | The kilometre Unit: 1000 metres. Non-temperature definitions use an exact Rational +scale and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} kilometre = Unit "km" lengthDimension 1000 0 + +{- | The centimetre Unit: 0.01 metre. Non-temperature definitions use an exact Rational +scale and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} centimetre = Unit "cm" lengthDimension 0.01 0 + +{- | The millimetre Unit: 0.001 metre. Non-temperature definitions use an exact Rational +scale and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} millimetre = Unit "mm" lengthDimension 0.001 0 + +{- | The inch Unit: 0.0254 metre. Non-temperature definitions use an exact Rational scale +and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} inch = Unit "in" lengthDimension 0.0254 0 + +{- | The foot Unit: 0.3048 metre. Non-temperature definitions use an exact Rational scale +and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} foot = Unit "ft" lengthDimension 0.3048 0 + +{- | The yard Unit: 0.9144 metre. Non-temperature definitions use an exact Rational scale +and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} yard = Unit "yd" lengthDimension 0.9144 0 + +{- | The mile Unit: 1609.344 metres. Non-temperature definitions use an exact Rational scale +and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} mile = Unit "mi" lengthDimension 1609.344 0 + +{- | The nauticalMile Unit: 1852 metres. Non-temperature definitions use an exact Rational +scale and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} nauticalMile = Unit "nmi" lengthDimension 1852 0 + squareMetre, hectare, cubicMetre, litre, millilitre :: Unit + +{- | The squareMetre Unit: 1 square metre. Non-temperature definitions use an exact Rational +scale and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} squareMetre = Unit "m^2" (scaleDimension 2 lengthDimension) 1 0 + +{- | The hectare Unit: 10000 square metres. Non-temperature definitions use an exact +Rational scale and zero affine offset. Use quantity or convert to construct/convert +values; temperature differences use temperatureDifference. +-} hectare = Unit "ha" (scaleDimension 2 lengthDimension) 10000 0 + +{- | The cubicMetre Unit: 1 cubic metre. Non-temperature definitions use an exact Rational +scale and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} cubicMetre = Unit "m^3" (scaleDimension 3 lengthDimension) 1 0 + +{- | The litre Unit: 0.001 cubic metre. Non-temperature definitions use an exact Rational +scale and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} litre = Unit "L" (scaleDimension 3 lengthDimension) 0.001 0 + +{- | The millilitre Unit: 0.000001 cubic metre. Non-temperature definitions use an exact +Rational scale and zero affine offset. Use quantity or convert to construct/convert +values; temperature differences use temperatureDifference. +-} millilitre = Unit "mL" (scaleDimension 3 lengthDimension) 0.000001 0 + kilogram, gram, tonne, pound, second, minute, hour, day :: Unit + +{- | The kilogram Unit: 1 kilogram. Non-temperature definitions use an exact Rational scale +and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} kilogram = Unit "kg" massDimension 1 0 + +{- | The gram Unit: 0.001 kilogram. Non-temperature definitions use an exact Rational scale +and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} gram = Unit "g" massDimension 0.001 0 + +{- | The tonne Unit: 1000 kilograms. Non-temperature definitions use an exact Rational scale +and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} tonne = Unit "t" massDimension 1000 0 + +{- | The pound Unit: 0.45359237 kilogram. Non-temperature definitions use an exact Rational +scale and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} pound = Unit "lb" massDimension 0.45359237 0 + +{- | The second Unit: 1 second. Non-temperature definitions use an exact Rational scale and +zero affine offset. Use quantity or convert to construct/convert values; temperature +differences use temperatureDifference. +-} second = Unit "s" timeDimension 1 0 + +{- | The minute Unit: 60 seconds. Non-temperature definitions use an exact Rational scale +and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} minute = Unit "min" timeDimension 60 0 + +{- | The hour Unit: 3600 seconds. Non-temperature definitions use an exact Rational scale +and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} hour = Unit "h" timeDimension 3600 0 + +{- | The day Unit: 86400 seconds. Non-temperature definitions use an exact Rational scale +and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} day = Unit "d" timeDimension 86400 0 + metresPerSecond, kilometresPerHour, milesPerHour, metresPerSecondSquared :: Unit + +{- | The metresPerSecond Unit: 1 metre per second. Non-temperature definitions use an exact +Rational scale and zero affine offset. Use quantity or convert to construct/convert +values; temperature differences use temperatureDifference. +-} metresPerSecond = Unit "m/s" (combine (-) lengthDimension timeDimension) 1 0 + +{- | The kilometresPerHour Unit: 1000/3600 metres per second. Non-temperature definitions +use an exact Rational scale and zero affine offset. Use quantity or convert to +construct/convert values; temperature differences use temperatureDifference. +-} kilometresPerHour = Unit "km/h" (unitDimension metresPerSecond) (1000 / 3600) 0 + +{- | The milesPerHour Unit: 1609.344/3600 metres per second. Non-temperature definitions use +an exact Rational scale and zero affine offset. Use quantity or convert to +construct/convert values; temperature differences use temperatureDifference. +-} milesPerHour = Unit "mi/h" (unitDimension metresPerSecond) (1609.344 / 3600) 0 + +{- | The metresPerSecondSquared Unit: 1 metre per second squared. Non-temperature +definitions use an exact Rational scale and zero affine offset. Use quantity or convert +to construct/convert values; temperature differences use temperatureDifference. +-} metresPerSecondSquared = Unit "m/s^2" (combine (-) lengthDimension (scaleDimension 2 timeDimension)) 1 0 + newton, joule, watt, pascal, bar, atmosphere :: Unit + +{- | The newton Unit: 1 kg*m/s^2. Non-temperature definitions use an exact Rational scale +and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} newton = Unit "N" (combine (+) massDimension (unitDimension metresPerSecondSquared)) 1 0 + +{- | The joule Unit: 1 newton metre. Non-temperature definitions use an exact Rational scale +and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} joule = Unit "J" (combine (+) (unitDimension newton) lengthDimension) 1 0 + +{- | The watt Unit: 1 joule per second. Non-temperature definitions use an exact Rational +scale and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} watt = Unit "W" (combine (-) (unitDimension joule) timeDimension) 1 0 + +{- | The pascal Unit: 1 newton per square metre. Non-temperature definitions use an exact +Rational scale and zero affine offset. Use quantity or convert to construct/convert +values; temperature differences use temperatureDifference. +-} pascal = Unit "Pa" (combine (-) (unitDimension newton) (unitDimension squareMetre)) 1 0 + +{- | The bar Unit: 100000 pascals. Non-temperature definitions use an exact Rational scale +and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} bar = Unit "bar" (unitDimension pascal) 100000 0 + +{- | The atmosphere Unit: 101325 pascals. Non-temperature definitions use an exact Rational +scale and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} atmosphere = Unit "atm" (unitDimension pascal) 101325 0 + kelvin, celsius, fahrenheit, hertz, bit, byte, kibibyte, mebibyte, gigabyte :: Unit + +{- | The kelvin Unit: absolute temperature with SI=value. Non-temperature definitions use an +exact Rational scale and zero affine offset. Use quantity or convert to +construct/convert values; temperature differences use temperatureDifference. +-} kelvin = Unit "K" temperatureDimension 1 0 + +{- | The celsius Unit: absolute temperature with SI=value+273.15 kelvin. Non-temperature +definitions use an exact Rational scale and zero affine offset. Use quantity or convert +to construct/convert values; temperature differences use temperatureDifference. +-} celsius = Unit "degC" temperatureDimension 1 273.15 + +{- | The fahrenheit Unit: absolute temperature with SI=(value-32)*5/9+273.15 kelvin. +Non-temperature definitions use an exact Rational scale and zero affine offset. Use +quantity or convert to construct/convert values; temperature differences use +temperatureDifference. +-} fahrenheit = Unit "degF" temperatureDimension (5 / 9) (273.15 - 32 * 5 / 9) + +{- | The hertz Unit: 1 inverse second. Non-temperature definitions use an exact Rational +scale and zero affine offset. Use quantity or convert to construct/convert values; +temperature differences use temperatureDifference. +-} hertz = Unit "Hz" (scaleDimension (-1) timeDimension) 1 0 + +{- | The bit Unit: 1 data bit. Non-temperature definitions use an exact Rational scale and +zero affine offset. Use quantity or convert to construct/convert values; temperature +differences use temperatureDifference. +-} bit = Unit "bit" dataDimension 1 0 + +{- | The byte Unit: 8 data bits. Non-temperature definitions use an exact Rational scale and +zero affine offset. Use quantity or convert to construct/convert values; temperature +differences use temperatureDifference. +-} byte = Unit "B" dataDimension 8 0 + +{- | The kibibyte Unit: 8192 data bits (1024 bytes). Non-temperature definitions use an +exact Rational scale and zero affine offset. Use quantity or convert to +construct/convert values; temperature differences use temperatureDifference. +-} kibibyte = Unit "KiB" dataDimension (8 * 1024) 0 + +{- | The mebibyte Unit: 8388608 data bits (1024^2 bytes). Non-temperature definitions use an +exact Rational scale and zero affine offset. Use quantity or convert to +construct/convert values; temperature differences use temperatureDifference. +-} mebibyte = Unit "MiB" dataDimension (8 * 1024 * 1024) 0 + +{- | The gigabyte Unit: 8000000000 data bits (10^9 bytes). Non-temperature definitions use +an exact Rational scale and zero affine offset. Use quantity or convert to +construct/convert values; temperature differences use temperatureDifference. +-} gigabyte = Unit "GB" dataDimension (8 * 10 ^ (9 :: Int)) 0 + radian, degree, gradian :: Unit + +{- | The radian Unit: 1 radian. Non-temperature definitions use an exact Rational scale and +zero affine offset. Use quantity or convert to construct/convert values; temperature +differences use temperatureDifference. +-} radian = Unit "rad" angleDimension 1 0 + +{- | The degree Unit: pi/180 radian, using the stored 50-place Rational pi approximation. +Non-temperature definitions use an exact Rational scale and zero affine offset. Use +quantity or convert to construct/convert values; temperature differences use +temperatureDifference. +-} degree = Unit "deg" angleDimension (piR / 180) 0 + +{- | The gradian Unit: pi/200 radian, using the stored Rational pi approximation. +Non-temperature definitions use an exact Rational scale and zero affine offset. Use +quantity or convert to construct/convert values; temperature differences use +temperatureDifference. +-} gradian = Unit "grad" angleDimension (piR / 200) 0 + piR :: Rational piR = case filter ((== "pi") . constantName) mathematicalConstants of c : _ -> constantValue c [] -> 3.14159265358979323846264338327950288419716939937510 radiansToDegrees, degreesToRadians, radiansToGradians, gradiansToRadians :: (Floating a) => a -> a + +{- | Convert radians to degrees by multiplying by 180/pi in the chosen Floating type. No +finite-input validation is added. +-} radiansToDegrees x = x * 180 / pi + +-- | Convert degrees to radians by multiplying by pi/180 in the chosen Floating type. degreesToRadians x = x * pi / 180 + +-- | Convert radians to gradians (400 per full turn) by multiplying by 200/pi. radiansToGradians x = x * 200 / pi + +-- | Convert gradians to radians by multiplying by pi/200. gradiansToRadians x = x * pi / 200 diff --git a/src/HMath/Vector.hs b/src/HMath/Vector.hs index 756d4ce..b11bf03 100644 --- a/src/HMath/Vector.hs +++ b/src/HMath/Vector.hs @@ -50,28 +50,72 @@ import HMath.Error import HMath.Matrix (Matrix, fromListChecked) import HMath.Matrix.Internal (finiteValues, stableNorm) +{- | Immutable dynamically sized coordinate list. Construct with vector; checked binary +operations reject dimension mismatch. +-} newtype Vector a = Vector [a] deriving (Eq, Show) + +{- | Opaque vector whose length matches its KnownNat type index. Construct with fixedVector +for a checked dynamic/static boundary. +-} newtype FixedVector (n :: Nat) a = FixedVector [a] deriving (Eq, Show) + +{- | Opaque dynamic vector with canonical nonzero coordinate entries. Construct with +sparseVector; duplicate indices add. +-} data SparseVector a = SparseVector Int (IM.IntMap a) deriving (Eq, Show) + +{- | Wrap a list as an immutable dynamic vector without numeric validation. The list order +is preserved. Example: vectorValues (vector [1,2]) == [1,2]. +-} vector :: [a] -> Vector a vector = Vector + +{- | Extract the immutable list of vector values in order; no shape conversion or numeric +validation occurs. +-} vectorValues :: Vector a -> [a] vectorValues (Vector xs) = xs + +{- | Return the number of coordinates in a dynamic vector. Empty vectors have dimension +zero. +-} vectorDimension :: Vector a -> Int vectorDimension = length . vectorValues + +{- | Construct a vector whose list length equals the type-level KnownNat size. A mismatch +returns Left InvalidArgument. For example, fixedVector @3 requires exactly three +values. +-} fixedVector :: forall n a. (KnownNat n) => [a] -> Either MathError (FixedVector n a) fixedVector xs | toInteger (length xs) == toInteger (natVal (Proxy :: Proxy n)) = Right (FixedVector xs) | otherwise = Left (InvalidArgument "fixedVector: dimension differs from type-level size") + +{- | Extract the ordered coordinates of a type-indexed vector; its length is the type-level +size. +-} fixedValues :: FixedVector n a -> [a] fixedValues (FixedVector xs) = xs + +{- | Given nonnegative dimension and (zero-based index,value) entries, sum duplicate indices +and remove explicit zeros. Reject out-of-range indices or negative dimension. +-} sparseVector :: (Eq a, Num a) => Int -> [(Int, a)] -> Either MathError (SparseVector a) sparseVector n xs | n < 0 || any (\(i, _) -> i < 0 || i >= n) xs = Left (InvalidArgument "sparseVector: invalid dimension/index") | otherwise = Right (SparseVector n (IM.filter (/= 0) (IM.fromListWith (+) xs))) + +{- | Expand a sparse vector to a dense list of its declared dimension, filling absent +entries with zero. +-} sparseVectorValues :: (Num a) => SparseVector a -> [a] sparseVectorValues (SparseVector n xs) = [IM.findWithDefault 0 i xs | i <- [0 .. n - 1]] + +{- | Given start, count, then vector, return the half-open slice [start,start+count). Reject +negative or out-of-range bounds; an empty end slice is valid. +-} vectorSlice :: Int -> Int -> Vector a -> Either MathError (Vector a) vectorSlice start count (Vector xs) | start < 0 || count < 0 || start > n || count > n - start = @@ -79,40 +123,95 @@ vectorSlice start count (Vector xs) | otherwise = Right (Vector (take count (drop start xs))) where n = length xs + +{- | Concatenate a list of vectors in order. Return Left InvalidArgument if the combined +dimension would overflow Int; an empty list gives an empty vector. +-} vectorConcat :: [Vector a] -> Either MathError (Vector a) vectorConcat vs | sum (map (toInteger . vectorDimension) vs) > toInteger (maxBound :: Int) = Left (InvalidArgument "vectorConcat: size overflow") | otherwise = Right (Vector (concatMap vectorValues vs)) + zipVector :: (a -> b -> c) -> Vector a -> Vector b -> Either MathError (Vector c) zipVector f (Vector a) (Vector b) | length a /= length b = Left (VectorLengthMismatch (length a) (length b)) | otherwise = Right (Vector (zipWith f a b)) + +{- | Add corresponding values of equally sized vectors, returning a new vector. Unequal +dimensions return VectorLengthMismatch. Generic Num arithmetic is unchecked. +-} vectorAdd :: (Num a) => Vector a -> Vector a -> Either MathError (Vector a) vectorAdd = zipVector (+) + +{- | Subtract corresponding right-hand coordinates from left-hand coordinates. Unequal +dimensions return VectorLengthMismatch; Num arithmetic is unchecked. +-} vectorSubtract :: (Num a) => Vector a -> Vector a -> Either MathError (Vector a) vectorSubtract = zipVector (-) + +{- | Given scalar then vector, multiply every coordinate by the scalar. Return a new vector, +retaining the original dimension and Num arithmetic behavior. +-} vectorScale :: (Num a) => a -> Vector a -> Vector a vectorScale s (Vector xs) = Vector (map (s *) xs) + +{- | Sum coordinatewise products of equally sized vectors. Empty vectors give zero; unequal +dimensions return VectorLengthMismatch. No floating-point finiteness check is added. +-} vectorDot :: (Num a) => Vector a -> Vector a -> Either MathError a vectorDot a b = sum . vectorValues <$> zipVector (*) a b + +{- | Compute the right-handed cross product of two three-dimensional vectors. Any other +dimension returns Left InvalidArgument. +-} cross :: (Num a) => Vector a -> Vector a -> Either MathError (Vector a) cross (Vector [a, b, c]) (Vector [d, e, f]) = Right (Vector [b * f - c * e, c * d - a * f, a * e - b * d]) cross _ _ = Left (InvalidArgument "cross: vectors must have dimension three") + +{- | Return the matrix of pairwise products a[i]*b[j], with shape (dimension a,dimension b). +Matrix construction can return shape/count errors. +-} outer :: (Num a) => Vector a -> Vector a -> Either MathError (Matrix a) outer (Vector a) (Vector b) = fromListChecked (length a) (length b) [x * y | x <- a, y <- b] + +{- | Given a,b,c, compute scalar triple product a dot (b cross c). All three vectors must +have dimension three; dimension errors propagate. +-} triple :: (Num a) => Vector a -> Vector a -> Vector a -> Either MathError a triple a b c = cross b c >>= vectorDot a + +{- | Count nonzero coordinates, returning Int. This is the usual sparsity count rather than +a norm satisfying homogeneity. +-} norm0 :: (Eq a, Num a) => Vector a -> Int norm0 = length . filter (/= 0) . vectorValues + +{- | Sum absolute coordinate values. Empty vector returns zero; arithmetic follows the +chosen Num type. +-} norm1 :: (Num a) => Vector a -> a norm1 = sum . map abs . vectorValues + +{- | Compute Euclidean length using a scaled stable norm to reduce intermediate +overflow/underflow. Empty vector returns zero; the result itself is not wrapped in +Either. +-} norm2 :: (RealFloat a) => Vector a -> a norm2 = stableNorm . vectorValues + +{- | Return maximum absolute coordinate, or zero for an empty vector. NaN coordinates +propagate rather than being silently discarded. +-} normInfinity :: (Ord a, Num a) => Vector a -> a normInfinity v = case [x | x <- vectorValues v, x /= x] of x : _ -> x [] -> maximum (0 : map abs (vectorValues v)) + +{- | Given positive exponent p then finite vector, compute the scaled p-norm. Positive +infinity selects normInfinity. NaN/nonpositive p or non-finite coordinates fail; p\<1 is +accepted as a quasi-norm. +-} normP :: (RealFloat a) => a -> Vector a -> Either MathError a normP p v@(Vector xs) | isNaN p || p <= 0 = Left (DomainError "normP: p must be positive") @@ -121,6 +220,10 @@ normP p v@(Vector xs) finiteValues xs let s = normInfinity v Right (if s == 0 then 0 else s * (sum [abs (x / s) ** p | x <- xs]) ** (1 / p)) + +{- | Return a unit-length vector in the same direction. Reject non-finite coordinates, zero +norm, or non-finite resulting norm. Empty input is a zero vector and fails. +-} normalizeVector :: (RealFloat a) => Vector a -> Either MathError (Vector a) normalizeVector v@(Vector xs) = do finiteValues xs @@ -128,20 +231,35 @@ normalizeVector v@(Vector xs) = do if n == 0 then Left (DomainError "normalizeVector: zero vector") else if isInfinite n then Left NonFiniteResult else Right (vectorScale (1 / n) v) + +{- | Given a then b, return the projection of a onto b. Dimensions must agree and b must +have nonzero finite norm; non-finite input/result fails. +-} project :: (RealFloat a) => Vector a -> Vector a -> Either MathError (Vector a) project a b = do u <- normalizeVector b s <- vectorDot a u finiteValues (vectorValues a) checkedVector (vectorScale s u) + checkedVector :: (RealFloat a) => Vector a -> Either MathError (Vector a) checkedVector v | any (\x -> isNaN x || isInfinite x) (vectorValues v) = Left NonFiniteResult | otherwise = Right v + +{- | Given incident vector then surface normal, return incident minus twice its projection +onto the normal. The normal is normalized internally; invalid dimensions, zero normal, +or non-finite values fail. +-} reflect :: (RealFloat a) => Vector a -> Vector a -> Either MathError (Vector a) reflect incident normal = do p <- project incident normal vectorSubtract incident (vectorScale 2 p) >>= checkedVector + +{- | Given positive finite refractive-index ratio, incident vector, then normal, return the +refracted unit-direction expression. Normalize both inputs; reject invalid dimensions, +zero vectors, non-finite values, or total internal reflection. +-} refract :: (RealFloat a) => a -> Vector a -> Vector a -> Either MathError (Vector a) refract eta incident normal | eta <= 0 || isNaN eta || isInfinite eta = @@ -154,19 +272,36 @@ refract eta incident normal if k < 0 then Left (DomainError "refract: total internal reflection") else vectorSubtract (vectorScale eta i) (vectorScale (eta * d + sqrt k) n) >>= checkedVector + +{- | Return Euclidean distance between equal-sized finite vectors. Dimension mismatch and +non-finite input/intermediate/result return Left MathError. +-} distance :: (RealFloat a) => Vector a -> Vector a -> Either MathError a distance a b = do finiteValues (vectorValues a ++ vectorValues b) difference <- vectorSubtract a b >>= checkedVector let result = norm2 difference if isNaN result || isInfinite result then Left NonFiniteResult else Right result + +{- | Return normalized dot product clamped to [-1,1]. Equal dimensions and nonzero finite +vectors are required; validation errors propagate. +-} cosineSimilarity :: (RealFloat a) => Vector a -> Vector a -> Either MathError a cosineSimilarity a b = do u <- normalizeVector a v <- normalizeVector b max (-1) . min 1 <$> vectorDot u v + +{- | Return the angle in radians, acos of cosineSimilarity, between two nonzero finite +equally sized vectors. Invalid dimensions or zero/non-finite vectors fail. +-} angle :: (RealFloat a) => Vector a -> Vector a -> Either MathError a angle a b = acos <$> cosineSimilarity a b + +{- | Given finite nonnegative relative tolerance then vectors, perform two-pass modified +Gram-Schmidt, returning an orthonormal basis in input order. Reject unequal dimensions, +zero/dependent vectors (RankDeficient), invalid tolerance, or non-finite data. +-} gramSchmidt :: (RealFloat a) => a -> [Vector a] -> Either MathError [Vector a] gramSchmidt tolerance vs | tolerance < 0 || isNaN tolerance || isInfinite tolerance = Left InvalidTolerance diff --git a/tools/build_docs.py b/tools/build_docs.py index c97a149..e1ae34d 100644 --- a/tools/build_docs.py +++ b/tools/build_docs.py @@ -7,6 +7,10 @@ import sys from pathlib import Path +import yaml +from check_api_docs import check_reference, read_haddock +from haskell_reference import generate_reference, repair_module_anchors + root = Path(__file__).resolve().parent.parent subprocess.run( [ @@ -36,7 +40,40 @@ reference = Path(component["dist-dir"]) / "doc/html/hmath" if not (reference / "index.html").is_file(): raise SystemExit(f"Haddock reference not found: {reference}") +interface = reference / "hmath.haddock" +check_reference(interface) +subprocess.run( + [sys.executable, "tools/check_haskell_doc_examples.py"], cwd=root, check=True +) +staging = root / "build-docs/site-src" +if staging.exists(): + shutil.rmtree(staging) +shutil.copytree(root / "docs", staging) +config = yaml.safe_load((root / "mkdocs.yml").read_text()) +config["docs_dir"] = str(staging) +config["site_dir"] = str(root / "site") +html_pages = repair_module_anchors(reference) +navigation = generate_reference(reference, staging, read_haddock(interface), html_pages) +for section in config["nav"]: + for item in section.get("API Reference", []): + if "Haskell API" in item: + item["Haskell API"] = navigation +config_path = root / "build-docs/mkdocs.generated.yml" +config_path.write_text(yaml.safe_dump(config, sort_keys=False)) subprocess.run( - [sys.executable, "-m", "mkdocs", "build", "--strict"], cwd=root, check=True + [ + sys.executable, + "-m", + "mkdocs", + "build", + "--strict", + "--config-file", + str(config_path), + ], + cwd=root, + check=True, ) shutil.copytree(reference, root / "site/haskell", dirs_exist_ok=True) +for name, content in html_pages.items(): + (root / "site/haskell" / name).write_text(content) +subprocess.run([sys.executable, "tools/check_docs_links.py"], cwd=root, check=True) diff --git a/tools/check_api_docs.py b/tools/check_api_docs.py new file mode 100644 index 0000000..77b73f4 --- /dev/null +++ b/tools/check_api_docs.py @@ -0,0 +1,149 @@ +# SPDX-License-Identifier: MPL-2.0 +"""Check source-derived public API inventories against their reference entries.""" + +import argparse +import ast +import json +import re +import subprocess +from pathlib import Path + +ROOT = Path(__file__).resolve().parent.parent +PROTOCOLS = {"__add__", "__matmul__", "__enter__", "__exit__", "__del__"} + + +def python_exports(path, module): + """Inventory definitions rather than incidental imported stdlib names.""" + tree = ast.parse(path.read_text()) + names = set() + for node in tree.body: + if isinstance( + node, (ast.FunctionDef, ast.ClassDef) + ) and not node.name.startswith("_"): + name = f"{module}.{node.name}" + names.add(name) + if isinstance(node, ast.ClassDef): + for member in node.body: + if isinstance(member, ast.FunctionDef) and ( + not member.name.startswith("_") or member.name in PROTOCOLS + ): + names.add(f"{name}.{member.name}") + return names + + +def check_entries(names, page, pattern): + text = page.read_text() + sections = re.split(r"(?=^### )", text, flags=re.MULTILINE) + covered = {} + for section in sections: + match = re.match(pattern, section) + if match: + covered[match[1]] = section + missing = names - covered.keys() + if missing: + raise ValueError(f"{page}: missing entries: {', '.join(sorted(missing))}") + for name in sorted(names): + section = covered[name] + if "**Parameters:**" not in section or "**Returns:**" not in section: + raise ValueError(f"{page}: {name} lacks parameter/return contracts") + return len(names) + + +def read_haddock(interface): + result = subprocess.run( + ["haddock", "--show-interface", str(interface)], + check=True, + capture_output=True, + text=True, + ) + # Haddock currently writes this JSON to stderr, despite a successful exit. + return json.loads(result.stdout.strip() or result.stderr.strip()) + + +def check_haskell(data): + public = { + name + for module in data["inst_ifaces"] + for name in module["visible_exports"] + if name.startswith("$hmath-") and name.rsplit("$", 1)[1][0].islower() + } + documented = { + name + for module in data["inst_ifaces"] + for name, prose in module["doc_map"].items() + if prose + } + public_types = set() + for module in data["inst_ifaces"]: + name = module["module"].split("$")[-1] + source = ROOT / "src" / Path(*name.split(".")).with_suffix(".hs") + if not source.is_file(): + continue + declarations = re.findall( + r"^(?:data|newtype|type|class)\s+(?:\([^\n]*?\)\s*=>\s*)?([A-Z]\w*)", + source.read_text(), + re.MULTILINE, + ) + for declaration in declarations: + symbol = module["module"] + "$" + declaration + if symbol in module["visible_exports"]: + public_types.add(symbol) + missing = sorted(public - documented) + if missing: + labels = [".".join(name.split("$")[-2:]) for name in missing] + raise ValueError( + "Haskell public functions/methods/fields without prose:\n" + + "\n".join(labels) + ) + missing_types = sorted(public_types - documented) + if missing_types: + labels = [".".join(name.split("$")[-2:]) for name in missing_types] + raise ValueError("Haskell public types without prose:\n" + "\n".join(labels)) + return len(public), len(public_types) + + +def check_reference(interface=None): + python = set() + for module in ("hmath", "hmath_cffi"): + python |= python_exports(ROOT / "bindings/python" / f"{module}.py", module) + counts = { + "Python": check_entries( + python, ROOT / "docs/reference/python.md", r"### `(hmath(?:_cffi)?\.[\w.]+)" + ) + } + c = set() + for header in ("hmath.h", "hmath_dlpack.h"): + c.update( + re.findall( + r"^HMATH_API\s+[\w\s*]+?\b(hmath_\w+)\s*\([^;]*\);", + (ROOT / "include" / header).read_text(), + re.MULTILINE, + ) + ) + counts["C"] = check_entries(c, ROOT / "docs/reference/c.md", r"### `(hmath_\w+)`") + wave = set( + re.findall( + r"^pub fun (\w+)\(", + (ROOT / "bindings/wave/hmath.wave").read_text(), + re.MULTILINE, + ) + ) + counts["Wave"] = check_entries( + wave, ROOT / "docs/reference/wave.md", r"### `(\w+)\(" + ) + if interface: + functions, types = check_haskell(read_haddock(interface)) + counts["Haskell functions, methods and fields"] = functions + counts["Haskell types"] = types + print( + "API reference coverage: " + + "; ".join(f"{key}: {count}" for key, count in counts.items()) + ) + return counts + + +if __name__ == "__main__": + parser = argparse.ArgumentParser(description=__doc__) + parser.add_argument("--haddock-interface", type=Path) + args = parser.parse_args() + check_reference(args.haddock_interface) diff --git a/tools/check_docs_links.py b/tools/check_docs_links.py new file mode 100644 index 0000000..89738ed --- /dev/null +++ b/tools/check_docs_links.py @@ -0,0 +1,58 @@ +# SPDX-License-Identifier: MPL-2.0 +"""Validate local files and fragment targets in the completed documentation site.""" + +import os +import re +from html import unescape +from pathlib import Path +from urllib.parse import unquote, urlsplit + +import yaml + +root = Path(__file__).resolve().parent.parent +site = root / "site" +base = urlsplit(yaml.safe_load((root / "mkdocs.yml").read_text())["site_url"]).path +pages = {path: path.read_text() for path in site.rglob("*.html")} +anchors = { + path: { + unescape(value) + for _, value in re.findall(r"""\s(?:id|name)=(["'])(.*?)\1""", content) + } + for path, content in pages.items() +} +resolved = {} +failures = set() +for page, content in pages.items(): + for _, href in re.findall(r"""\shref=(["'])(.*?)\1""", content): + href = unescape(href) + url = urlsplit(href) + if url.scheme or url.netloc: + continue + path = unquote(url.path) + if path.startswith(base): + target = site / path[len(base) :] + elif path.startswith("/"): + target = site / path.lstrip("/") + else: + target = page.parent / path if path else page + target = Path(os.path.normpath(target)) + requested = target + if requested not in resolved: + if target.is_dir(): + target /= "index.html" + resolved[requested] = (target, target.is_file()) + target, exists = resolved[requested] + if not exists: + failures.add((str(page.relative_to(site)), href, "missing file")) + elif ( + url.fragment + and target in anchors + and unquote(url.fragment) not in anchors[target] + ): + failures.add((str(page.relative_to(site)), href, "missing anchor")) +if failures: + examples = "\n".join(str(item) for item in sorted(failures)[:12]) + raise SystemExit(f"{len(failures)} broken documentation links:\n{examples}") +print( + f"Documentation links: {len(pages)} HTML pages, no missing local files or anchors" +) diff --git a/tools/check_haskell_doc_examples.py b/tools/check_haskell_doc_examples.py new file mode 100644 index 0000000..f304df8 --- /dev/null +++ b/tools/check_haskell_doc_examples.py @@ -0,0 +1,23 @@ +# SPDX-License-Identifier: MPL-2.0 +"""Compile and run complete Haskell programs embedded in the reference.""" + +import re +import subprocess +import tempfile +from pathlib import Path + +root = Path(__file__).resolve().parent.parent +for page in sorted((root / "docs").rglob("*.md")): + examples = re.findall( + r"^```haskell\n(.*?)^```", page.read_text(), re.MULTILINE | re.DOTALL + ) + for number, source in enumerate(examples, 1): + if not re.search(r"^main\s*(?:::|=)", source, re.MULTILINE): + continue # GHCi fragments are not standalone programs. + with tempfile.TemporaryDirectory(prefix="hmath-docs-haskell-") as temporary: + program = Path(temporary) / "Main.hs" + program.write_text(source) + subprocess.run( + ["runghc", "-isrc", str(program)], cwd=root, check=True, timeout=60 + ) + print(f"{page.relative_to(root)}: Haskell example {number} passes") diff --git a/tools/haskell_reference.py b/tools/haskell_reference.py new file mode 100644 index 0000000..960c178 --- /dev/null +++ b/tools/haskell_reference.py @@ -0,0 +1,214 @@ +# SPDX-License-Identifier: MPL-2.0 +"""Integrate Haddock's rendered public declarations into the documentation site.""" + +import re +from collections import defaultdict +from dataclasses import dataclass, field +from html import escape, unescape +from html.parser import HTMLParser +from pathlib import Path +from urllib.parse import urlsplit + +VOID = { + "area", + "base", + "br", + "col", + "embed", + "hr", + "img", + "input", + "link", + "meta", + "param", + "source", + "track", + "wbr", +} + + +@dataclass +class Node: + tag: str + attrs: dict = field(default_factory=dict) + children: list = field(default_factory=list) + + def walk(self): + yield self + for child in self.children: + if isinstance(child, Node): + yield from child.walk() + + def text(self): + return "".join( + child.text() if isinstance(child, Node) else child + for child in self.children + ) + + +class Document(HTMLParser): + def __init__(self, text): + super().__init__(convert_charrefs=True) + self.root = Node("document") + self.stack = [self.root] + self.feed(text) + self.close() + + def handle_starttag(self, tag, attrs): + node = Node(tag, dict(attrs)) + self.stack[-1].children.append(node) + if tag not in VOID: + self.stack.append(node) + + def handle_endtag(self, tag): + for index in range(len(self.stack) - 1, 0, -1): + if self.stack[index].tag == tag: + del self.stack[index:] + break + + def handle_data(self, data): + self.stack[-1].children.append(data) + + +def render(node, module_pages): + if isinstance(node, str): + return escape(node) + attrs = dict(node.attrs) + if node.tag == "a": + href = attrs.get("href", "") + parsed = urlsplit(href) + if not parsed.scheme and parsed.path: + if parsed.path in module_pages: + href = f"../{Path(parsed.path).stem}/" + if parsed.fragment: + href += "#" + parsed.fragment + else: + href = "../../../haskell/" + href + attrs["href"] = href + attributes = "".join( + f' {escape(key)}="{escape(value or "", quote=True)}"' + for key, value in attrs.items() + ) + opening = f"<{node.tag}{attributes}>" + if node.tag in VOID: + return opening + return ( + opening + + "".join(render(child, module_pages) for child in node.children) + + f"" + ) + + +def repair_module_anchors(reference): + """Resolve Haddock instance links that otherwise point to absent local methods.""" + pages = {path.name: path.read_text() for path in reference.glob("HMath*.html")} + ids = { + name: set(re.findall(r'\bid="([^"]+)"', text)) for name, text in pages.items() + } + owners = defaultdict(set) + for name, anchors in ids.items(): + for anchor in anchors: + owners[unescape(anchor)].add(name) + + def repair(name, match): + tag = match[0] + href = re.search(r'\bhref="#([^"]+)"', tag) + if not href or href[1] in ids[name]: + return tag + anchor = unescape(href[1]) + destinations = owners[anchor] + title = re.search(r'\btitle="([^"]+)"', tag) + target = title[1].replace(".", "-") + ".html" if title else None + if target not in destinations: + target = next(iter(destinations)) if len(destinations) == 1 else None + if target: + return tag.replace(href[0], f'href="{target}#{href[1]}"') + # Inherited Prelude methods have no local declaration. Keep the method + # signature as text rather than generating a broken anchor to it. + return tag.replace(href[0], "") + + return { + name: re.sub( + r"]*>", lambda match, owner=name: repair(owner, match), text + ) + for name, text in pages.items() + } + + +def generate_reference(reference, docs, data, html_pages): + """Generate one searchable Material page per public Haddock module.""" + modules = [module for module in data["inst_ifaces"] if module["visible_exports"]] + pages = { + module["module"].split("$")[-1].replace(".", "-") + ".html" + for module in modules + } + destination = docs / "reference/haskell" + destination.mkdir(parents=True, exist_ok=True) + navigation = [{"Module index": "reference/haskell.md"}] + index = [ + "\n## All public modules\n", + "Select a module for its types, constructors, method signatures and function contracts.\n", + ] + for module in sorted(modules, key=lambda item: item["module"]): + name = module["module"].split("$")[-1] + basename = name.replace(".", "-") + document = Document(html_pages[f"{basename}.html"]) + interface = next( + ( + node + for node in document.root.walk() + if node.attrs.get("id") == "interface" + ), + None, + ) + if interface is None: + continue + description = next( + ( + node + for node in document.root.walk() + if node.attrs.get("id") == "description" + ), + None, + ) + # Give each declaration a real heading for page navigation and search. + for node in list(interface.walk()): + if "top" not in node.attrs.get("class", "").split(): + continue + signature = next( + ( + child + for child in node.children + if isinstance(child, Node) + and "src" in child.attrs.get("class", "").split() + ), + None, + ) + if signature: + definition = next( + ( + child + for child in signature.walk() + if "def" in child.attrs.get("class", "").split() + ), + None, + ) + if definition: + anchor = "api-" + definition.attrs.get( + "id", definition.text() + ).replace(":", "-") + node.children.insert( + 0, Node("h2", {"id": anchor}, [definition.text()]) + ) + content = f"# {name}\n\n" + content += '
\n' + if description: + content += render(description, pages) + "\n" + content += render(interface, pages) + "\n
\n" + (destination / f"{basename}.md").write_text(content) + path = f"reference/haskell/{basename}.md" + navigation.append({name: path}) + index.append(f"- [{name}](haskell/{basename}.md)\n") + with (docs / "reference/haskell.md").open("a") as output: + output.write("\n".join(index)) + return navigation