├── .pre-commit-config.yaml ├── test ├── Spec.hs └── Examples │ ├── Quantum.hs │ ├── Spreadsheets.hs │ └── Readme.hs ├── CHANGELOG.md ├── nix └── modules │ └── flake │ ├── devshell.nix │ ├── pre-commit.nix │ └── haskell.nix ├── .github └── workflows │ └── ci.yml ├── .gitignore ├── flake.nix ├── LICENSE ├── src └── LAoP │ ├── Dist.hs │ ├── Relation.hs │ ├── Utils.hs │ ├── Utils │ └── Internal.hs │ ├── Dist │ └── Internal.hs │ ├── Matrix │ ├── Nat.hs │ ├── Type.hs │ └── Internal.hs │ └── Relation │ └── Internal.hs ├── laop.cabal ├── flake.lock ├── benchmark └── Main.hs └── README.md /.pre-commit-config.yaml: -------------------------------------------------------------------------------- 1 | /nix/store/64ad661ksq68n5i5r7g37wn9idba06lh-pre-commit-config.json -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Examples.Readme qualified as RD 4 | 5 | main :: IO () 6 | main = do 7 | putStrLn ("Testing if README works" :: String) 8 | RD.exec 9 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | `laop` uses [PVP Versioning][1]. 4 | The changelog is available [on GitHub][2]. 5 | 6 | ## 0.2.0.0 7 | 8 | - Compiles with GHC 9.2.8 9 | - Update nix infrastructure 10 | - Cleans up death code and warnings 11 | - Changed `nat` to `reifyToNatural` 12 | 13 | 14 | ## 0.1.1.1 15 | 16 | * Bump base version to work with cabal 17 | 18 | ## 0.1.1.0 19 | 20 | * Package is more organized and now has tests and benchmarks separated 21 | * Repository is more organized and clean 22 | * Added CI 23 | 24 | [1]: https://pvp.haskell.org 25 | [2]: https://github.com/bolt12/laop2/releases 26 | -------------------------------------------------------------------------------- /nix/modules/flake/devshell.nix: -------------------------------------------------------------------------------- 1 | { 2 | perSystem = { config, pkgs, ... }: { 3 | # Default shell. 4 | devShells.default = pkgs.mkShell { 5 | name = "laop"; 6 | meta.description = "Haskell development environment"; 7 | # See https://community.flake.parts/haskell-flake/devshell#composing-devshells 8 | inputsFrom = [ 9 | config.haskellProjects.ghc910.outputs.devShell # See ./nix/modules/haskell.nix 10 | config.pre-commit.devShell # See ./nix/modules/pre-commit.nix 11 | ]; 12 | packages = with pkgs; [ 13 | just 14 | nixd 15 | ghciwatch 16 | ]; 17 | }; 18 | }; 19 | } 20 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: [master] 7 | 8 | jobs: 9 | build: 10 | name: ghc ${{ matrix.ghc }} 11 | runs-on: ubuntu-22.04 12 | strategy: 13 | matrix: 14 | cabal: ["3.0"] 15 | ghc: 16 | - "ghc927" 17 | - "ghc96" 18 | - "ghc910" 19 | 20 | steps: 21 | - uses: actions/checkout@v2 22 | 23 | - uses: cachix/install-nix-action@v20 24 | name: Install Nix 25 | 26 | - name: Build 27 | run: | 28 | nix build .#${{ matrix.ghc }}-laop 29 | 30 | 31 | - name: Test 32 | run: | 33 | nix develop .#${{ matrix.ghc }}-laop -c cabal v2-test --enable-tests 34 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ### Haskell 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | *.prof 12 | *.aux 13 | *.hp 14 | *.eventlog 15 | .virtualenv 16 | .hsenv 17 | .hpc 18 | .cabal-sandbox/ 19 | cabal.sandbox.config 20 | cabal.config 21 | cabal.project.local 22 | .ghc.environment.* 23 | .HTF/ 24 | # Stack 25 | .stack-work/ 26 | stack.yaml.lock 27 | 28 | ### IDE/support 29 | # Vim 30 | [._]*.s[a-v][a-z] 31 | [._]*.sw[a-p] 32 | [._]s[a-v][a-z] 33 | [._]sw[a-p] 34 | *~ 35 | tags 36 | 37 | # IntellijIDEA 38 | .idea/ 39 | .ideaHaskellLib/ 40 | *.iml 41 | 42 | # Atom 43 | .haskell-ghc-mod.json 44 | 45 | # VS 46 | .vscode/ 47 | 48 | # Emacs 49 | *# 50 | .dir-locals.el 51 | TAGS 52 | 53 | # other 54 | .DS_Store 55 | hackage.sh 56 | 57 | # Vim Sessions 58 | *.vim 59 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Nix template for Haskell projects"; 3 | inputs = { 4 | nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; 5 | flake-parts.url = "github:hercules-ci/flake-parts"; 6 | flake-parts.inputs.nixpkgs-lib.follows = "nixpkgs"; 7 | nixos-unified.url = "github:srid/nixos-unified"; 8 | haskell-flake.url = "github:srid/haskell-flake"; 9 | fourmolu-nix.url = "github:jedimahdi/fourmolu-nix"; 10 | 11 | git-hooks-nix.url = "github:cachix/git-hooks.nix"; 12 | git-hooks-nix.flake = false; 13 | }; 14 | 15 | outputs = inputs: 16 | # This will import ./nix/modules/flake/*.nix 17 | # cf. https://nixos-unified.org/autowiring.html#flake-parts 18 | # 19 | # To write your own Nix, add or edit files in ./nix/modules/flake/ 20 | inputs.nixos-unified.lib.mkFlake 21 | { inherit inputs; root = ./.; }; 22 | } 23 | -------------------------------------------------------------------------------- /nix/modules/flake/pre-commit.nix: -------------------------------------------------------------------------------- 1 | { inputs, ... }: 2 | { 3 | imports = [ 4 | (inputs.git-hooks-nix + /flake-module.nix) 5 | inputs.fourmolu-nix.flakeModule 6 | ]; 7 | perSystem = { config, ... }: { 8 | pre-commit.settings = { 9 | hooks = { 10 | nixpkgs-fmt.enable = true; 11 | cabal-gild.enable = true; 12 | fourmolu = { 13 | enable = true; 14 | package = config.fourmolu.wrapper; 15 | }; 16 | hlint.enable = false; 17 | }; 18 | }; 19 | 20 | fourmolu.settings = { 21 | indentation = 2; 22 | comma-style = "leading"; 23 | record-brace-space = true; 24 | indent-wheres = true; 25 | import-export-style = "diff-friendly"; 26 | respectful = true; 27 | haddock-style = "multi-line"; 28 | newlines-between-decls = 1; 29 | extensions = [ "ImportQualifiedPost" ]; 30 | }; 31 | }; 32 | } 33 | -------------------------------------------------------------------------------- /test/Examples/Quantum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | module Examples.Quantum where 4 | 5 | import Data.Complex 6 | import LAoP.Matrix.Type 7 | import LAoP.Utils 8 | import Prelude hiding (id, (.)) 9 | 10 | deriving instance (Ord a) => Ord (Complex a) 11 | 12 | xor :: (Bool, Bool) -> Bool 13 | xor (False, b) = b 14 | xor (True, b) = not b 15 | 16 | ker :: (Num e) => Matrix e a b -> Matrix e a a 17 | ker m = tr m . m 18 | 19 | cnot :: Matrix (Complex Double) (Bool, Bool) (Bool, Bool) 20 | cnot = kr fstM (fromF xor) 21 | 22 | ccnot :: (Num e, Ord e) => Matrix e ((Bool, Bool), Bool) ((Bool, Bool), Bool) 23 | ccnot = kr fstM (fromF f) 24 | where 25 | f = xor . tp (uncurry (&&)) id 26 | tp f g (a, b) = (f a, g b) 27 | 28 | had :: Matrix (Complex Double) Bool Bool 29 | had = (1 / sqrt 2) .| fromLists [[1, 1], [1, -1]] 30 | 31 | bell :: Matrix (Complex Double) (Bool, Bool) (Bool, Bool) 32 | bell = cnot . (had >< iden) 33 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Armando Santos 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /test/Examples/Spreadsheets.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Examples.Spreadsheets where 4 | 5 | import GHC.Generics 6 | import LAoP.Matrix.Type 7 | import LAoP.Utils 8 | import Prelude hiding (id, (.)) 9 | 10 | data Student = Student1 | Student2 | Student3 | Student4 11 | deriving (Eq, Show, Enum, Bounded, Generic) 12 | 13 | data Question = Question1 | Question2 | Question3 | Question4 14 | deriving (Eq, Show, Enum, Bounded, Generic) 15 | 16 | data Results = Exam | Test | Final 17 | deriving (Eq, Show, Enum, Bounded, Generic) 18 | 19 | test :: Matrix Float One Results 20 | test = point Test 21 | 22 | exam :: Matrix Float One Results 23 | exam = point Exam 24 | 25 | final :: Matrix Float One Results 26 | final = point Final 27 | 28 | m :: Matrix Float Question Student 29 | m = fromLists [[95, 90, 100, 40], [20, 90, 90, 0], [30, 20, 95, 0], [50, 80, 100, 30]] 30 | 31 | w :: Matrix Float Question One 32 | w = fromLists [[0.2, 0.3, 0.2, 0.3]] 33 | 34 | xls :: 35 | Matrix Float Student One -> 36 | Matrix Float (Either Question Results) (Either One Student) 37 | xls t = join (fork w m) (fork zeros r) 38 | where 39 | rExam = m . tr w 40 | rTest = tr t 41 | rFinal = rTest `maxPW` rExam 42 | r = (rExam . tr exam) + (rTest . tr test) + (rFinal . tr final) 43 | 44 | -- | Overloaded, point-wise 'max' function 45 | maxPW :: (Ord e) => Matrix e a b -> Matrix e a b -> Matrix e a b 46 | maxPW = zipWithM max 47 | -------------------------------------------------------------------------------- /src/LAoP/Dist.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | 3 | ----------------------------------------------------------------------------- 4 | 5 | {- | 6 | Module : LAoP.Dist 7 | Copyright : (c) Armando Santos 2019-2020 8 | Maintainer : armandoifsantos@gmail.com 9 | Stability : experimental 10 | 11 | __LAoP__ is a library for algebraic (inductive) construction and manipulation of matrices 12 | in Haskell. See for the 13 | motivation behind the library, the underlying theory, and implementation details. 14 | 15 | This module exports a type synonym 'Dist' 16 | that represents a stochastic distribution 17 | matrix and several distribution construction 18 | functions. 19 | -} 20 | module LAoP.Dist ( 21 | -- | If the sum of the rows of a column matrix 22 | -- is equal to 1 then this stochastic matrix 23 | -- can be seen as a probability distribution. 24 | -- 25 | -- 26 | -- This module is still experimental but it's 27 | -- already possible to model probabilistic programming 28 | -- problems with it. Import 'Matrix.Nat' or 'Matrix.Type' 29 | -- to access LAoP matrix combinators and then all you have 30 | -- to do is to define your sample space, either by creating a new data 31 | -- type or by abstracting it out via 'Natural'. 32 | -- 33 | -- Write manipulation functions and promote them to matrices via 34 | -- 'fromF' or 'fromF'' and you're good to go! 35 | 36 | -- * 'Dist' and 'Prob' type synonyms 37 | Dist (..), 38 | Prob, 39 | 40 | -- * Constraint type synonyms 41 | Countable, 42 | CountableN, 43 | CountableDimsN, 44 | FLN, 45 | Liftable, 46 | TrivialP, 47 | 48 | -- * Functor instance equivalent functions 49 | fmapD, 50 | 51 | -- * Applicative equivalent functions 52 | unitD, 53 | multD, 54 | 55 | -- * Selective equivalent functions 56 | selectD, 57 | branchD, 58 | ifD, 59 | 60 | -- * Monad equivalent functions 61 | returnD, 62 | bindD, 63 | 64 | -- * Distribution construction functions 65 | choose, 66 | shape, 67 | linear, 68 | uniform, 69 | negExp, 70 | normal, 71 | 72 | -- * Converto to list of pairs 73 | toValues, 74 | 75 | -- * Pretty print distribution 76 | prettyDist, 77 | prettyPrintDist, 78 | ) 79 | where 80 | 81 | import LAoP.Dist.Internal 82 | -------------------------------------------------------------------------------- /nix/modules/flake/haskell.nix: -------------------------------------------------------------------------------- 1 | { root, inputs, ... }: 2 | { 3 | imports = [ 4 | inputs.haskell-flake.flakeModule 5 | ]; 6 | perSystem = { self', lib, config, pkgs, ... }: 7 | let 8 | ghcDefault = "ghc910"; 9 | ghcVersions = [ "ghc927" "ghc96" ghcDefault ]; 10 | in 11 | { 12 | # Our only Haskell project. You can have multiple projects, but this template 13 | # has only one. 14 | # See https://github.com/srid/haskell-flake/blob/master/example/flake.nix 15 | haskellProjects = lib.genAttrs ghcVersions (ghc: { 16 | # The base package set (this value is the default) 17 | basePackages = pkgs.haskell.packages.${ghc}; 18 | 19 | # To avoid unnecessary rebuilds, we filter projectRoot: 20 | # https://community.flake.parts/haskell-flake/local#rebuild 21 | projectRoot = builtins.toString (lib.fileset.toSource { 22 | inherit root; 23 | fileset = lib.fileset.unions [ 24 | (root + /src) 25 | (root + /benchmark) 26 | (root + /test) 27 | (root + /laop.cabal) 28 | (root + /LICENSE) 29 | (root + /README.md) 30 | (root + /CHANGELOG.md) 31 | ]; 32 | }); 33 | 34 | # Packages to add on top of `basePackages` 35 | packages = { 36 | # Add source or Hackage overrides here 37 | # (Local packages are added automatically) 38 | /* 39 | aeson.source = "1.5.0.0" # Hackage version 40 | shower.source = inputs.shower; # Flake input 41 | */ 42 | }; 43 | 44 | # Add your package overrides here 45 | settings = { 46 | laop = { 47 | stan = false; 48 | # haddock = false; 49 | }; 50 | /* 51 | aeson = { 52 | check = false; 53 | }; 54 | */ 55 | }; 56 | 57 | # Development shell configuration 58 | devShell = { 59 | hlsCheck.enable = false; 60 | mkShellArgs = { 61 | shellHook = '' 62 | export SHELL=/run/current-system/sw/bin/bash 63 | ''; 64 | }; 65 | tools = hp: { 66 | # needed to get on a GHC910 dev env 67 | hlint = null; 68 | }; 69 | }; 70 | 71 | # What should haskell-flake add to flake outputs? 72 | autoWire = [ "packages" "apps" "checks" ]; # Wire all but the devShell 73 | }); 74 | 75 | # Default package & app. 76 | packages.default = self'.packages."${ghcDefault}-laop"; 77 | apps.default = self'.apps."${ghcDefault}-laop"; 78 | }; 79 | } 80 | -------------------------------------------------------------------------------- /laop.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: laop 3 | version: 0.2.0.0 4 | synopsis: Matrix programming library 5 | description: 6 | Matrix programming library that uses a type-safe inductive definition 7 | inspired by the Linear Algebra of Programming 8 | 9 | homepage: https://github.com/bolt12/laop 10 | bug-reports: https://github.com/bolt12/laop/issues 11 | license: MIT 12 | license-file: LICENSE 13 | author: Armando Santos 14 | maintainer: Armando Santos 15 | copyright: 2023 Armando Santos 16 | category: Data 17 | build-type: Simple 18 | extra-doc-files: 19 | CHANGELOG.md 20 | README.md 21 | 22 | tested-with: ghc ==8.10.7 || ==9.2.8 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/bolt12/laop.git 27 | 28 | common common-options 29 | build-depends: 30 | base >=4.12.0.0 && <5, 31 | deepseq, 32 | 33 | ghc-options: 34 | -Wall 35 | -Wno-unticked-promoted-constructors 36 | -Wcompat 37 | -Wincomplete-uni-patterns 38 | -Wincomplete-record-updates 39 | -Wpartial-fields 40 | -Widentities 41 | -Wredundant-constraints 42 | -Wunused-packages 43 | -fhide-source-paths 44 | -Wmissing-export-lists 45 | -Wpartial-fields 46 | -Wno-compat-unqualified-imports 47 | -Wno-duplicate-exports 48 | 49 | -- Needed because ghc considers exporting f and f' the same name 50 | default-language: Haskell2010 51 | default-extensions: ImportQualifiedPost 52 | 53 | library 54 | import: common-options 55 | hs-source-dirs: src 56 | exposed-modules: 57 | LAoP.Dist 58 | LAoP.Dist.Internal 59 | LAoP.Matrix.Internal 60 | LAoP.Matrix.Nat 61 | LAoP.Matrix.Type 62 | LAoP.Relation 63 | LAoP.Relation.Internal 64 | LAoP.Utils 65 | LAoP.Utils.Internal 66 | 67 | test-suite laop-test 68 | import: common-options 69 | type: exitcode-stdio-1.0 70 | hs-source-dirs: test 71 | other-modules: 72 | Examples.Readme 73 | Examples.Spreadsheets 74 | 75 | main-is: Spec.hs 76 | build-depends: laop 77 | ghc-options: 78 | -threaded 79 | -rtsopts 80 | -with-rtsopts=-N 81 | -funfolding-use-threshold=16 82 | -fexcess-precision 83 | -optc-O3 84 | -optc-ffast-math 85 | 86 | default-extensions: ImportQualifiedPost 87 | 88 | benchmark laop-benchmark 89 | import: common-options 90 | type: exitcode-stdio-1.0 91 | hs-source-dirs: benchmark 92 | main-is: Main.hs 93 | build-depends: 94 | QuickCheck, 95 | criterion, 96 | deepseq, 97 | laop, 98 | 99 | ghc-options: 100 | -threaded 101 | -rtsopts 102 | -with-rtsopts=-N 103 | -funfolding-use-threshold=16 104 | -fexcess-precision 105 | -optc-O3 106 | -optc-ffast-math 107 | 108 | default-extensions: ImportQualifiedPost 109 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-parts": { 4 | "inputs": { 5 | "nixpkgs-lib": [ 6 | "nixpkgs" 7 | ] 8 | }, 9 | "locked": { 10 | "lastModified": 1743550720, 11 | "narHash": "sha256-hIshGgKZCgWh6AYJpJmRgFdR3WUbkY04o82X05xqQiY=", 12 | "owner": "hercules-ci", 13 | "repo": "flake-parts", 14 | "rev": "c621e8422220273271f52058f618c94e405bb0f5", 15 | "type": "github" 16 | }, 17 | "original": { 18 | "owner": "hercules-ci", 19 | "repo": "flake-parts", 20 | "type": "github" 21 | } 22 | }, 23 | "fourmolu-nix": { 24 | "locked": { 25 | "lastModified": 1707266073, 26 | "narHash": "sha256-tCFzZQJicDdYjnuJiNK4hiiRAH7c2wQzMhOCdUMbVKE=", 27 | "owner": "jedimahdi", 28 | "repo": "fourmolu-nix", 29 | "rev": "717f5a91b0d7b97b1be7ecc3a0fd42d37ffe1c9b", 30 | "type": "github" 31 | }, 32 | "original": { 33 | "owner": "jedimahdi", 34 | "repo": "fourmolu-nix", 35 | "type": "github" 36 | } 37 | }, 38 | "git-hooks-nix": { 39 | "flake": false, 40 | "locked": { 41 | "lastModified": 1742649964, 42 | "narHash": "sha256-DwOTp7nvfi8mRfuL1escHDXabVXFGT1VlPD1JHrtrco=", 43 | "owner": "cachix", 44 | "repo": "git-hooks.nix", 45 | "rev": "dcf5072734cb576d2b0c59b2ac44f5050b5eac82", 46 | "type": "github" 47 | }, 48 | "original": { 49 | "owner": "cachix", 50 | "repo": "git-hooks.nix", 51 | "type": "github" 52 | } 53 | }, 54 | "haskell-flake": { 55 | "locked": { 56 | "lastModified": 1745726030, 57 | "narHash": "sha256-tijlLHeWoLje/YB26iztpELOpJYB/mVomOKTWeXubwQ=", 58 | "owner": "srid", 59 | "repo": "haskell-flake", 60 | "rev": "7d09d90a676a9fdf5574a9af7cce44085ea126db", 61 | "type": "github" 62 | }, 63 | "original": { 64 | "owner": "srid", 65 | "repo": "haskell-flake", 66 | "type": "github" 67 | } 68 | }, 69 | "nixos-unified": { 70 | "locked": { 71 | "lastModified": 1745965553, 72 | "narHash": "sha256-Dffk3pP0/ibGLtGn4yVYgFDeyE+Y29cVtFTU2JutSME=", 73 | "owner": "srid", 74 | "repo": "nixos-unified", 75 | "rev": "66ed53ebd5580e07963f8f2fc6a6e7160af9f4d4", 76 | "type": "github" 77 | }, 78 | "original": { 79 | "owner": "srid", 80 | "repo": "nixos-unified", 81 | "type": "github" 82 | } 83 | }, 84 | "nixpkgs": { 85 | "locked": { 86 | "lastModified": 1746397377, 87 | "narHash": "sha256-5oLdRa3vWSRbuqPIFFmQBGGUqaYZBxX+GGtN9f/n4lU=", 88 | "owner": "nixos", 89 | "repo": "nixpkgs", 90 | "rev": "ed30f8aba41605e3ab46421e3dcb4510ec560ff8", 91 | "type": "github" 92 | }, 93 | "original": { 94 | "owner": "nixos", 95 | "ref": "nixpkgs-unstable", 96 | "repo": "nixpkgs", 97 | "type": "github" 98 | } 99 | }, 100 | "root": { 101 | "inputs": { 102 | "flake-parts": "flake-parts", 103 | "fourmolu-nix": "fourmolu-nix", 104 | "git-hooks-nix": "git-hooks-nix", 105 | "haskell-flake": "haskell-flake", 106 | "nixos-unified": "nixos-unified", 107 | "nixpkgs": "nixpkgs" 108 | } 109 | } 110 | }, 111 | "root": "root", 112 | "version": 7 113 | } 114 | -------------------------------------------------------------------------------- /src/LAoP/Relation.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | 3 | ----------------------------------------------------------------------------- 4 | 5 | {- | 6 | Module : LAoP.Relation 7 | Copyright : (c) Armando Santos 2019-2020 8 | Maintainer : armandoifsantos@gmail.com 9 | Stability : experimental 10 | 11 | The AoP discipline generalises functions to relations which are 12 | Boolean matrices. 13 | 14 | This module offers many of the combinators of the Algebra of 15 | Programming discipline. It is still under construction and very 16 | experimental. 17 | 18 | This is an Internal module and it is no supposed to be imported. 19 | -} 20 | module LAoP.Relation ( 21 | -- | This definition makes use of the fact that 'Void' is 22 | -- isomorphic to 0 and '()' to 1 and captures matrix 23 | -- dimensions as stacks of 'Either's. 24 | -- 25 | -- There exists two type families that make it easier to write 26 | -- matrix dimensions: 'FromNat' and 'Count'. This approach 27 | -- leads to a very straightforward implementation 28 | -- of LAoP combinators. 29 | 30 | -- * Relation data type 31 | Relation (..), 32 | Boolean, 33 | 34 | -- * Constraint type synonyms 35 | Countable, 36 | CountableDims, 37 | CountableN, 38 | CountableDimsN, 39 | FLN, 40 | Liftable, 41 | Trivial, 42 | TrivialP, 43 | 44 | -- * Primitives 45 | one, 46 | join, 47 | (|||), 48 | fork, 49 | (===), 50 | 51 | -- * Auxiliary type families 52 | FromNat, 53 | Count, 54 | Normalize, 55 | 56 | -- * Matrix construction and conversion 57 | FromLists, 58 | fromLists, 59 | fromF, 60 | fromF', 61 | toRel, 62 | toLists, 63 | toList, 64 | toBool, 65 | pt, 66 | belongs, 67 | relationBuilder, 68 | zeros, 69 | ones, 70 | bang, 71 | point, 72 | 73 | -- * Relational operations 74 | conv, 75 | intersection, 76 | union, 77 | sse, 78 | implies, 79 | iff, 80 | ker, 81 | img, 82 | 83 | -- * Taxonomy of binary relations 84 | injective, 85 | entire, 86 | simple, 87 | surjective, 88 | representation, 89 | function, 90 | abstraction, 91 | injection, 92 | surjection, 93 | bijection, 94 | domain, 95 | range, 96 | 97 | -- * Function division 98 | divisionF, 99 | 100 | -- * Relation division 101 | divR, 102 | divL, 103 | divS, 104 | shrunkBy, 105 | overriddenBy, 106 | 107 | -- * Relational pairing 108 | splitR, 109 | 110 | -- ** Projections 111 | fstR, 112 | sndR, 113 | 114 | -- ** Bifunctor 115 | (><), 116 | 117 | -- * Relational coproduct 118 | eitherR, 119 | 120 | -- ** Injections 121 | i1, 122 | i2, 123 | 124 | -- ** Bifunctor 125 | (-|-), 126 | 127 | -- * Relational "currying" 128 | trans, 129 | untrans, 130 | 131 | -- * (Endo-)Relational properties 132 | reflexive, 133 | coreflexive, 134 | transitive, 135 | symmetric, 136 | antiSymmetric, 137 | irreflexive, 138 | connected, 139 | preorder, 140 | partialOrder, 141 | linearOrder, 142 | equivalence, 143 | partialEquivalence, 144 | difunctional, 145 | 146 | -- * Conditionals 147 | equalizer, 148 | 149 | -- ** McCarthy's Conditional 150 | predR, 151 | guard, 152 | cond, 153 | 154 | -- * Relational composition and lifting 155 | iden, 156 | comp, 157 | fromF, 158 | fromF', 159 | 160 | -- ** Relational application 161 | pointAp, 162 | pointApBool, 163 | 164 | -- * Matrix printing 165 | pretty, 166 | prettyPrint, 167 | ) 168 | where 169 | 170 | import LAoP.Relation.Internal 171 | -------------------------------------------------------------------------------- /src/LAoP/Utils.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | 3 | ----------------------------------------------------------------------------- 4 | 5 | {- | 6 | Module : LAoP.Utils 7 | Copyright : (c) Armando Santos 2019-2020 8 | Maintainer : armandoifsantos@gmail.com 9 | Stability : experimental 10 | 11 | __LAoP__ is a library for algebraic (inductive) construction and manipulation of matrices 12 | in Haskell. See for the 13 | motivation behind the library, the underlying theory, and implementation details. 14 | 15 | This module provides the 'Natural' data type. 16 | The semantic associated with this data type is that 17 | it's meant to be a restricted 'Int' value. 18 | -} 19 | module LAoP.Utils ( 20 | -- | Utility module that provides the 'Natural' data type. 21 | -- The semantic associated with this data type is that 22 | -- it's meant to be a restricted 'Int' value. For example 23 | -- the type @Natural 1 6@ can only be instanciated with @nat n@ 24 | -- where @1 <= n <= 6@. Why, You might ask, because with normal 25 | -- 'Int's it is not possible to have a decent @Enum (Int, Int)@ 26 | -- instance. See the following probabilistic programming model as and 27 | -- example: 28 | -- 29 | -- We want to calculate the probability of the sum of two dice throws. 30 | -- To do this we start by defining the sample space: 31 | -- 32 | -- @ 33 | -- type SampleSpace = Int -- We think 'Int' are enough 34 | -- 35 | -- die :: Dist Int 6 36 | -- die = unifrom [1..6] 37 | -- 38 | -- -- Promote 'Int' addition to a matrix 39 | -- addM = fromF (uncurry (+)) -- Impossible 40 | -- @ 41 | -- 42 | -- The last line is impossible because @(Int, Int)@ does not have 43 | -- a good 'Enum' instance: @[(0, 1), (0, 2), .. (0, maxBound), (1, 0), 44 | -- ..]@. And we'd like the addition matrix to be of 36 columns by 12 45 | -- rows but limited to integers up to @6@! 46 | -- 47 | -- One way to solve this issue is by defining and auxilary data type to 48 | -- represent the sample space: 49 | -- 50 | -- @ 51 | -- data SampleSpace = S1 | S2 | S3 | S4 | S5 | S6 52 | -- deriving (Show, Eq, Enum, Bounded) -- Enum and Bounded are 53 | -- important 54 | -- @ 55 | -- 56 | -- And write the sample space addition function: 57 | -- 58 | -- @ 59 | -- ssAdd :: SampleSpace -> SampleSpace -> Int 60 | -- ssAdd a b = (fromEnum a + 1) + (fromEnum b + 1) 61 | -- @ 62 | -- 63 | -- And then promote that function to matrix and everything is alright: 64 | -- 65 | -- @ 66 | -- ssAddM = fromF' (uncurry ssAdd) 67 | -- 68 | -- dieSumProb = ssAddM `comp` (khatri die die) 69 | -- @ 70 | -- 71 | -- This is a nice solution for small sample spaces. But for larger ones 72 | -- it is not feasible to write a data type with hundreds of constructors 73 | -- and then write manipulation functions that need to deal with them. 74 | -- To mitigate this limitation the 'Natural' type comes a long way and 75 | -- allows one to model the sample in an easier way. See for instance: 76 | -- 77 | -- @ 78 | -- ssAdd :: Natural 1 6 -> Natural 1 6 -> Natural 1 12 79 | -- ssAdd = coerceNat (+) 80 | -- 81 | -- ssAddM = fromF' (uncurry sumSS) 82 | -- 83 | -- die :: Dist (Natural 1 6) 6 84 | -- die = uniform [nat @1 @6 1 .. nat 6] 85 | -- 86 | -- dieSumProb = ssAddM `comp` (khatri die die) 87 | -- @ 88 | -- 89 | -- * 'Natural' data type 90 | Natural, 91 | reifyToNatural, 92 | 93 | -- * Coerce auxiliar functions to help promote 'Int' typed functions to 94 | 95 | -- 'Natural' typed functions. 96 | coerceNat, 97 | coerceNat2, 98 | coerceNat3, 99 | 100 | -- * Bounded List data type 101 | BoundedList (..), 102 | 103 | -- * Category type-class 104 | Category (..), 105 | ) 106 | where 107 | 108 | import LAoP.Utils.Internal 109 | -------------------------------------------------------------------------------- /test/Examples/Readme.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 7 | 8 | module Examples.Readme ( 9 | exec, 10 | ) 11 | where 12 | 13 | import GHC.Generics qualified as G 14 | import LAoP.Matrix.Type 15 | import LAoP.Relation qualified as R 16 | import LAoP.Utils 17 | import Prelude hiding (id, (.)) 18 | 19 | -- Monty Hall Problem 20 | data Outcome = Win | Lose 21 | deriving (Bounded, Enum, Eq, Show, G.Generic) 22 | 23 | switch :: Outcome -> Outcome 24 | switch Win = Lose 25 | switch Lose = Win 26 | 27 | firstChoice :: Matrix Double () Outcome 28 | firstChoice = col [1 / 3, 2 / 3] 29 | 30 | secondChoice :: Matrix Double Outcome Outcome 31 | secondChoice = fromF switch 32 | 33 | -- Dice sum 34 | 35 | type SS = Natural 1 6 -- Sample Space 36 | 37 | sumSS :: SS -> SS -> Natural 2 12 38 | sumSS = coerceNat (+) 39 | 40 | sumSSM :: Matrix Double (SS, SS) (Natural 2 12) 41 | sumSSM = fromF (uncurry sumSS) 42 | 43 | condition :: (Int, Int) -> Int -> Int 44 | condition (a, b) c = 45 | if a == b 46 | then a * 3 47 | else a + b + c 48 | 49 | conditionSS :: (SS, SS) -> SS -> Natural 3 18 50 | conditionSS = coerceNat2 condition 51 | 52 | conditionalThrows :: Matrix Double () (Natural 3 18) 53 | conditionalThrows = fromF (uncurry conditionSS) . kr (kr die die) die 54 | 55 | die :: Matrix Double () SS 56 | die = col $ map (const (1 / 6)) [reifyToNatural @1 @6 1 .. reifyToNatural 6] 57 | 58 | -- Sprinkler 59 | data G = Dry | Wet 60 | deriving (Bounded, Enum, Eq, Show, G.Generic) 61 | 62 | data S = Off | On 63 | deriving (Bounded, Enum, Eq, Show, G.Generic) 64 | 65 | data R = No | Yes 66 | deriving (Bounded, Enum, Eq, Show, G.Generic) 67 | 68 | rain :: Matrix Double () R 69 | rain = matrixBuilder gen 70 | where 71 | gen (_, No) = 0.8 72 | gen (_, Yes) = 0.2 73 | 74 | sprinkler :: Matrix Double R S 75 | sprinkler = matrixBuilder gen 76 | where 77 | gen (No, Off) = 0.6 78 | gen (No, On) = 0.4 79 | gen (Yes, Off) = 0.99 80 | gen (Yes, On) = 0.01 81 | 82 | grass :: Matrix Double (S, R) G 83 | grass = matrixBuilder gen 84 | where 85 | gen ((Off, No), Dry) = 1 86 | gen ((Off, Yes), Dry) = 0.2 87 | gen ((On, No), Dry) = 0.1 88 | gen ((On, Yes), Dry) = 0.01 89 | gen ((Off, No), Wet) = 0 90 | gen ((Off, Yes), Wet) = 0.8 91 | gen ((On, No), Wet) = 0.9 92 | gen ((On, Yes), Wet) = 0.99 93 | 94 | tag f = kr f id 95 | 96 | state g s r = tag g . tag s . r 97 | 98 | grass_wet :: Matrix Double () (G, (S, R)) -> Matrix Double One One 99 | grass_wet s = row [0, 1] . fstM . s 100 | 101 | rainning :: Matrix Double (G, (S, R)) One 102 | rainning = row [0, 1] . sndM . sndM 103 | 104 | -- Alcuin Puzzle 105 | 106 | data Being = Farmer | Fox | Goose | Beans 107 | deriving (Bounded, Enum, Eq, Show, G.Generic) 108 | 109 | data Bank = LeftB | RightB 110 | deriving (Bounded, Enum, Eq, Show, G.Generic) 111 | 112 | eats :: Being -> Being -> Bool 113 | eats Fox Goose = True 114 | eats Goose Beans = True 115 | eats _ _ = False 116 | 117 | eatsR :: R.Relation Being Being 118 | eatsR = R.toRel eats 119 | 120 | cross :: Bank -> Bank 121 | cross LeftB = RightB 122 | cross RightB = LeftB 123 | 124 | crossR :: R.Relation Bank Bank 125 | crossR = R.fromF cross 126 | 127 | -- | Initial state, everyone in the left bank 128 | locationLeft :: Being -> Bank 129 | locationLeft _ = LeftB 130 | 131 | locationLeftR :: R.Relation Being Bank 132 | locationLeftR = R.fromF locationLeft 133 | 134 | -- | Initial state, everyone in the right bank 135 | locationRight :: Being -> Bank 136 | locationRight _ = RightB 137 | 138 | locationRightR :: R.Relation Being Bank 139 | locationRightR = R.fromF locationRight 140 | 141 | -- Properties 142 | 143 | -- Being at the same bank 144 | sameBank :: R.Relation Being Bank -> R.Relation Being Being 145 | sameBank = R.ker 146 | 147 | -- Risk of somebody eating somebody else 148 | canEat :: R.Relation Being Bank -> R.Relation Being Being 149 | canEat w = sameBank w `R.intersection` eatsR 150 | 151 | -- "Starvation" property. 152 | inv :: R.Relation Being Bank -> Bool 153 | inv w = (w `R.comp` canEat w) `R.sse` (w `R.comp` farmer) 154 | where 155 | farmer :: R.Relation Being Being 156 | farmer = R.fromF (const Farmer) 157 | 158 | -- Arbitrary state 159 | bankState :: Being -> Bank -> Bool 160 | bankState Farmer LeftB = True 161 | bankState Fox LeftB = True 162 | bankState Goose RightB = True 163 | bankState Beans RightB = True 164 | bankState _ _ = False 165 | 166 | bankStateR :: R.Relation Being Bank 167 | bankStateR = R.toRel bankState 168 | 169 | -- Main 170 | exec :: IO () 171 | exec = do 172 | putStrLn "Monty Hall Problem solution:" 173 | prettyPrint (secondChoice . firstChoice) 174 | putStrLn "\n Sum of dices probability:" 175 | prettyPrint (sumSSM . kr die die) 176 | putStrLn "\n Conditional dice throw:" 177 | prettyPrint conditionalThrows 178 | putStrLn "\n Checking that the last result is indeed a distribution: " 179 | prettyPrint (bang . sumSSM . kr die die) 180 | putStrLn "\n Probability of grass being wet:" 181 | prettyPrint (grass_wet (state grass sprinkler rain)) 182 | putStrLn "\n Probability of rain:" 183 | prettyPrint (rainning . state grass sprinkler rain) 184 | putStrLn "\n Is the arbitrary state a valid state? (Alcuin Puzzle)" 185 | print (inv bankStateR) 186 | -------------------------------------------------------------------------------- /src/LAoP/Utils/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# OPTIONS_GHC -Wno-orphans #-} 9 | 10 | module LAoP.Utils.Internal ( 11 | -- * 'Natural' data type 12 | Natural (..), 13 | reifyToNatural, 14 | 15 | -- * Coerce auxiliar functions to help promote 'Int' typed functions to 16 | 17 | -- 'Natural' typed functions. 18 | coerceNat, 19 | coerceNat2, 20 | coerceNat3, 21 | 22 | -- * 'BoundedList' data type 23 | BoundedList (..), 24 | 25 | -- * Category type class 26 | Category (..), 27 | ) 28 | where 29 | 30 | import Control.DeepSeq 31 | import Data.Coerce 32 | import Data.Kind 33 | import Data.List 34 | import Data.Maybe 35 | import Data.Proxy 36 | import GHC.Generics 37 | import GHC.TypeLits hiding (Natural) 38 | import Prelude hiding (id, (.)) 39 | import Prelude qualified 40 | 41 | {- | Wrapper around 'Int's that have a restrictive semantic associated. 42 | A value of type @'Natural' n m@ can only be instanciated with some 'Int' 43 | @i@ that's @n <= i <= m@. 44 | -} 45 | newtype Natural (start :: Nat) (end :: Nat) = Nat Int 46 | deriving (Show, Read, Eq, Ord, NFData, Generic) 47 | 48 | {- | Throws a runtime error if any of the operations overflows or 49 | underflows. 50 | -} 51 | instance (KnownNat n, KnownNat m) => Num (Natural n m) where 52 | (Nat a) + (Nat b) = reifyToNatural @n @m (a + b) 53 | (Nat a) - (Nat b) = reifyToNatural @n @m (a - b) 54 | (Nat a) * (Nat b) = reifyToNatural @n @m (a * b) 55 | abs (Nat a) = reifyToNatural @n @m (abs a) 56 | signum (Nat a) = reifyToNatural @n @m (signum a) 57 | fromInteger i = reifyToNatural @n @m (fromInteger i) 58 | 59 | {- | Natural constructor function. Throws a runtime error if the 'Int' value is greater 60 | than the corresponding @m@ or lower than @n@ in the @'Natural' n m@ type. 61 | -} 62 | reifyToNatural :: forall n m. (KnownNat n, KnownNat m) => Int -> Natural n m 63 | reifyToNatural i = 64 | let start = fromInteger (natVal (Proxy :: Proxy n)) 65 | end = fromInteger (natVal (Proxy :: Proxy m)) 66 | in if start <= i && i <= end 67 | then Nat i 68 | else error "Off limits" 69 | 70 | {- | Auxiliary function that promotes binary 'Int' functions to 'Natural' binary 71 | functions. 72 | -} 73 | coerceNat :: (Int -> Int -> Int) -> (Natural a a' -> Natural b b' -> Natural c c') 74 | coerceNat = coerce 75 | 76 | {- | Auxiliary function that promotes ternary (binary) 'Int' functions to 'Natural' 77 | functions. 78 | -} 79 | coerceNat2 :: ((Int, Int) -> Int -> Int) -> ((Natural a a', Natural b b') -> Natural c c' -> Natural d d') 80 | coerceNat2 = coerce 81 | 82 | {- | Auxiliary function that promotes ternary (binary) 'Int' functions to 'Natural' 83 | functions. 84 | -} 85 | coerceNat3 :: (Int -> Int -> a) -> (Natural b b' -> Natural c c' -> a) 86 | coerceNat3 = coerce 87 | 88 | instance (KnownNat n, KnownNat m) => Bounded (Natural n m) where 89 | minBound = Nat $ fromInteger (natVal (Proxy :: Proxy n)) 90 | maxBound = Nat $ fromInteger (natVal (Proxy :: Proxy m)) 91 | 92 | instance (KnownNat n, KnownNat m) => Enum (Natural n m) where 93 | toEnum i = 94 | let start = fromInteger (natVal (Proxy :: Proxy n)) 95 | in reifyToNatural (start + i) 96 | 97 | -- \| Throws a runtime error if the value is off limits 98 | fromEnum (Nat nat) = 99 | let start = fromInteger (natVal (Proxy :: Proxy n)) 100 | end = fromInteger (natVal (Proxy :: Proxy m)) 101 | in if start <= nat && nat <= end 102 | then nat - start 103 | else error "Off limits" 104 | 105 | {- | Optimized 'Enum' instance for tuples that comply with the given 106 | constraints. 107 | -} 108 | instance 109 | ( Enum a 110 | , Enum b 111 | , Bounded b 112 | ) => 113 | Enum (a, b) 114 | where 115 | toEnum i = 116 | let (listB :: [b]) = [minBound .. maxBound] 117 | lengthB = length listB 118 | fstI = div i lengthB 119 | sndI = mod i lengthB 120 | in (toEnum fstI, toEnum sndI) 121 | 122 | fromEnum (a, b) = 123 | let (listB :: [b]) = [minBound .. maxBound] 124 | lengthB = length listB 125 | fstI = fromEnum a 126 | sndI = fromEnum b 127 | in fstI * lengthB + sndI 128 | 129 | instance 130 | ( Bounded a 131 | , Bounded b 132 | ) => 133 | Bounded (Either a b) 134 | where 135 | minBound = Left (minBound :: a) 136 | maxBound = Right (maxBound :: b) 137 | 138 | instance 139 | ( Enum a 140 | , Bounded a 141 | , Enum b 142 | , Bounded b 143 | ) => 144 | Enum (Either a b) 145 | where 146 | toEnum i = 147 | let la = fmap Left ([minBound .. maxBound] :: [a]) 148 | lb = fmap Right ([minBound .. maxBound] :: [b]) 149 | in (la ++ lb) !! i 150 | 151 | fromEnum (Left a) = fromEnum a 152 | fromEnum (Right b) = fromEnum (maxBound :: a) + fromEnum b + 1 153 | 154 | {- | Powerset data type. 155 | 156 | This data type is a newtype wrapper around '[]'. This exists in order to 157 | implement an 'Enum' and 'Bounded' instance that cannot be harmful for the outside. 158 | -} 159 | newtype BoundedList a = L [a] 160 | deriving (Eq, Show, Read) 161 | 162 | powerset :: [a] -> [[a]] 163 | powerset [] = [[]] 164 | powerset (x : xs) = powerset xs ++ [x : ps | ps <- powerset xs] 165 | 166 | instance 167 | ( Enum a 168 | , Bounded a 169 | ) => 170 | Bounded (BoundedList a) 171 | where 172 | minBound = L [] 173 | maxBound = L [minBound .. maxBound] 174 | 175 | instance 176 | ( Bounded a 177 | , Enum a 178 | , Eq a 179 | ) => 180 | Enum (BoundedList a) 181 | where 182 | toEnum i = 183 | let as = [minBound .. maxBound] 184 | in L (powerset as !! i) 185 | 186 | fromEnum (L []) = 0 187 | fromEnum (L x) = 188 | let as = [minBound .. maxBound] 189 | in fromMaybe (error "Does not exist") $ elemIndex x (powerset as) 190 | 191 | -- | Constrained category instance 192 | class Category k where 193 | type Object k o :: Constraint 194 | type Object k o = () 195 | id :: (Object k a) => k a a 196 | (.) :: k b c -> k a b -> k a c 197 | 198 | instance Category (->) where 199 | id = Prelude.id 200 | (.) = (Prelude..) 201 | -------------------------------------------------------------------------------- /src/LAoP/Dist/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | 13 | module LAoP.Dist.Internal ( 14 | Dist (..), 15 | Prob, 16 | Countable, 17 | CountableN, 18 | CountableDimsN, 19 | FLN, 20 | Liftable, 21 | TrivialP, 22 | fmapD, 23 | unitD, 24 | multD, 25 | selectD, 26 | branchD, 27 | ifD, 28 | returnD, 29 | bindD, 30 | (??), 31 | choose, 32 | shape, 33 | linear, 34 | uniform, 35 | negExp, 36 | normal, 37 | toValues, 38 | prettyDist, 39 | prettyPrintDist, 40 | ) 41 | where 42 | 43 | import Control.DeepSeq 44 | import Data.Bool 45 | import Data.List (sortBy) 46 | import Data.Proxy 47 | import GHC.TypeLits 48 | import LAoP.Matrix.Internal qualified as I 49 | import LAoP.Matrix.Type hiding (Countable, CountableDims, CountableDimsN, CountableN, FLN, Liftable, TrivialP) 50 | import LAoP.Utils 51 | import Prelude hiding (id, (.)) 52 | 53 | -- | Type synonym for probability value 54 | type Prob = Double 55 | 56 | {- | Type synonym for column vector matrices. This represents a probability 57 | distribution. 58 | -} 59 | newtype Dist a = D (Matrix Prob () a) 60 | deriving (Show, Num, Eq, Ord, NFData) via (Matrix Prob () a) 61 | 62 | -- | Constraint type synonyms to keep the type signatures less convoluted 63 | type Countable a = KnownNat (I.Count a) 64 | 65 | type CountableN a = KnownNat (I.Count (I.Normalize a)) 66 | type CountableDimsN a b = (CountableN a, CountableN b) 67 | type FLN a b = I.FL (I.Normalize a) (I.Normalize b) 68 | type Liftable a b = (Bounded a, Bounded b, Enum a, Enum b, Eq b, Num Prob, Ord Prob) 69 | type TrivialP a b = Normalize (a, b) ~ Normalize (Normalize a, Normalize b) 70 | 71 | -- | Functor instance 72 | fmapD :: 73 | ( Liftable a b 74 | , CountableDimsN a b 75 | , FLN b a 76 | ) => 77 | (a -> b) -> 78 | Dist a -> 79 | Dist b 80 | fmapD f (D m) = D (fromF' f `comp` m) 81 | 82 | -- | Applicative/Monoidal instance 'unit' function 83 | unitD :: Dist () 84 | unitD = D (one 1) 85 | 86 | -- | Applicative/Monoidal instance 'mult' function 87 | multD :: 88 | ( CountableDimsN a b 89 | , CountableN (a, b) 90 | , FLN (a, b) a 91 | , FLN (a, b) b 92 | , TrivialP a b 93 | ) => 94 | Dist a -> 95 | Dist b -> 96 | Dist (a, b) 97 | multD (D a) (D b) = D (kr a b) 98 | 99 | -- | Selective instance function 100 | selectD :: 101 | ( FLN b b 102 | , CountableN b 103 | ) => 104 | Dist (Either a b) -> 105 | Matrix Prob a b -> 106 | Dist b 107 | selectD (D d) m = D (selectM d m) 108 | 109 | {- | Chooses which of the two given effectful 110 | functions to apply to a given argument; 111 | -} 112 | branchD :: 113 | ( CountableDimsN a b 114 | , CountableDimsN c (Either b c) 115 | , FLN c b 116 | , FLN a b 117 | , FLN a a 118 | , FLN b b 119 | , FLN c c 120 | , FLN b a 121 | , FLN b c 122 | , FLN (Either b c) b 123 | , FLN (Either b c) c 124 | ) => 125 | Dist (Either a b) -> 126 | Matrix Prob a c -> 127 | Matrix Prob b c -> 128 | Dist c 129 | branchD x l r = f x `selectD` g l `selectD` r 130 | where 131 | f (D m) = D (fork (tr i1) (i1 `comp` tr i2) `comp` m) 132 | g m = i2 `comp` m 133 | 134 | -- | Branch on a Boolean value, skipping unnecessary computations. 135 | ifD :: 136 | ( CountableDimsN a (Either () a) 137 | , FLN a a 138 | , FLN a () 139 | , FLN () a 140 | , FLN (Either () a) a 141 | ) => 142 | Dist Bool -> 143 | Dist a -> 144 | Dist a -> 145 | Dist a 146 | ifD x (D t) (D e) = branchD x' t e 147 | where 148 | x' = bool (Right ()) (Left ()) `fmapD` x 149 | 150 | -- | Monad instance 'return' function 151 | returnD :: forall a. (Enum a, FLN () a, Countable a) => a -> Dist a 152 | returnD a = D (col l) 153 | where 154 | i = fromInteger $ natVal (Proxy :: Proxy (Count a)) 155 | x = fromEnum a 156 | l = take x [0, 0 ..] ++ [1] ++ take (i - x - 1) [0, 0 ..] 157 | 158 | -- | Monad instance '(>>=)' function 159 | bindD :: Dist a -> Matrix Prob a b -> Dist b 160 | bindD (D d) m = D (m `comp` d) 161 | 162 | -- | Extract probabilities given an Event. 163 | (??) :: 164 | ( Enum a 165 | , Countable a 166 | ) => 167 | (a -> Bool) -> 168 | Dist a -> 169 | Prob 170 | (??) p d = 171 | let l = toValues d 172 | x = filter (p . fst) l 173 | in sum . map snd $ x 174 | 175 | -- Distribution Construction 176 | 177 | -- | Constructs a Bernoulli distribution 178 | choose :: (FLN () a) => Prob -> Dist a 179 | choose prob = D (col [prob, 1 - prob]) 180 | 181 | -- | Creates a distribution given a shape function 182 | shape :: (FLN () a) => (Prob -> Prob) -> [a] -> Dist a 183 | shape _ [] = error "Probability.shape: empty list" 184 | shape f xs = 185 | let incr = 1 / fromIntegral (length xs - 1) 186 | ps = map f (iterate (+ incr) 0) 187 | in fromFreqs (zip xs ps) 188 | 189 | -- | Constructs a Linear distribution 190 | linear :: (FLN () a) => [a] -> Dist a 191 | linear = shape id 192 | 193 | -- | Constructs an Uniform distribution 194 | uniform :: (FLN () a) => [a] -> Dist a 195 | uniform = shape (const 1) 196 | 197 | -- | Constructs an Negative Exponential distribution 198 | negExp :: (FLN () a) => [a] -> Dist a 199 | negExp = shape (\x -> exp (-x)) 200 | 201 | -- | Constructs an Normal distribution 202 | normal :: (FLN () a) => [a] -> Dist a 203 | normal = shape (normalCurve 0.5 0.5) 204 | 205 | -- | Transforms a 'Dist' into a list of pairs. 206 | toValues :: forall a. (Enum a, Countable a) => Dist a -> [(a, Prob)] 207 | toValues (D d) = 208 | let rrows = fromInteger (natVal (Proxy :: Proxy (Count a))) 209 | probs = toList d 210 | res = zip (map toEnum [0 .. rrows]) probs 211 | in res 212 | 213 | -- | Pretty a distribution 214 | prettyDist :: forall a. (Show a, Enum a, Countable a) => Dist a -> String 215 | prettyDist d = 216 | let values = sortBy (\(_, pp1) (_, pp2) -> compare pp2 pp1) (toValues @a d) 217 | w = maximum (map (length . show . fst) values) 218 | in concatMap 219 | (\(x, p) -> showR w x ++ ' ' : showProb p ++ "\n") 220 | values 221 | where 222 | showProb p = show (p * 100) ++ "%" 223 | showR _ x = show x ++ " " 224 | 225 | -- | Pretty Print a distribution 226 | prettyPrintDist :: forall a. (Show a, Enum a, Countable a) => Dist a -> IO () 227 | prettyPrintDist = putStrLn . prettyDist @a 228 | 229 | -- Auxiliary functions 230 | 231 | fromFreqs :: (FLN () a) => [(a, Prob)] -> Dist a 232 | fromFreqs xs = D (col (map (\(_, p) -> p / q) xs)) 233 | where 234 | q = sum $ map snd xs 235 | 236 | normalCurve :: Prob -> Prob -> Prob -> Prob 237 | normalCurve mean dev x = 238 | let u = (x - mean) / dev 239 | in exp (-1 / 2 * u ^ (2 :: Int)) / sqrt (2 * pi) 240 | -------------------------------------------------------------------------------- /benchmark/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | 11 | module Main (main) where 12 | 13 | import Control.DeepSeq 14 | import Criterion.Main 15 | import Data.Proxy 16 | import GHC.TypeLits 17 | import LAoP.Dist.Internal 18 | import LAoP.Matrix.Type hiding (Countable, CountableN, FLN) 19 | import LAoP.Matrix.Type qualified as T (FLN) 20 | import LAoP.Utils 21 | import Test.QuickCheck 22 | import Prelude hiding (id, (.)) 23 | 24 | selectM2 :: 25 | ( Num e 26 | , T.FLN b b 27 | , CountableN b 28 | ) => 29 | Matrix e cols (Either a b) -> 30 | Matrix e a b -> 31 | Matrix e cols b 32 | selectM2 m y = join y iden `comp` m 33 | 34 | selectD2 :: 35 | ( FLN b b 36 | , CountableN b 37 | ) => 38 | Dist (Either a b) -> 39 | Matrix Prob a b -> 40 | Dist b 41 | selectD2 (D d) m = D (join m iden `comp` d) 42 | 43 | -- Composition with iden 44 | compId = comp iden 45 | 46 | randomDist :: forall a. (Countable a, FLN () a) => Gen (Dist a) 47 | randomDist = do 48 | let size = fromInteger (natVal (Proxy :: Proxy (Count a))) 49 | l <- vectorOf size (arbitrary :: Gen Prob) 50 | let ln = normalize l 51 | lr = map (: []) ln 52 | m = fromLists lr 53 | return (D m) 54 | 55 | randomMatrix :: forall a b. (CountableDims a b, FLN a b) => Gen (Matrix Prob a b) 56 | randomMatrix = do 57 | let cols = fromInteger (natVal (Proxy :: Proxy (Count a))) 58 | rows = fromInteger (natVal (Proxy :: Proxy (Count b))) 59 | l <- vectorOf (cols * rows) arbitrary 60 | let lr = buildList l cols 61 | m = fromLists lr 62 | return m 63 | 64 | buildList [] _ = [] 65 | buildList l r = take r l : buildList (drop r l) r 66 | 67 | normalize :: [Prob] -> [Prob] 68 | normalize l = 69 | let l' = map abs l 70 | s = sum l' 71 | in map (/ s) l' 72 | 73 | -- Probability 74 | newtype Probability = P Double 75 | deriving (Num, Show, Fractional, NFData) via Double 76 | newtype Dist' a = D' {unD :: [(a, Probability)]} 77 | deriving (Show, NFData) 78 | 79 | instance Functor Dist' where 80 | fmap f (D' d) = D' [(f x, p) | (x, p) <- d] 81 | 82 | instance Applicative Dist' where 83 | pure x = D' [(x, 1)] 84 | fm <*> m = D' [(f x, q * p) | (f, p) <- unD fm, (x, q) <- unD m] 85 | 86 | class (Applicative f) => Selective f where 87 | select :: f (Either a b) -> f (a -> b) -> f b 88 | 89 | instance Selective Dist' where 90 | select x y = (\e f -> either f id e) <$> x <*> y -- selectA 91 | 92 | instance Monad Dist' where 93 | return = pure 94 | (D' d) >>= f = D' [(y, q * p) | (x, p) <- d, (y, q) <- unD (f x)] 95 | 96 | normalize2 :: forall a. (Enum a, Bounded a) => [Probability] -> [(a, Probability)] 97 | normalize2 l = 98 | let l' = map abs l 99 | as = [minBound .. maxBound] 100 | s = sum l' 101 | probs = map (/ s) l' 102 | in zip as probs 103 | 104 | randomDist2 :: forall a. (Countable a, Enum a, Bounded a) => Gen (Dist' a) 105 | randomDist2 = do 106 | let size = fromInteger (natVal (Proxy :: Proxy (Count a))) 107 | l <- vectorOf size (arbitrary :: Gen Prob) 108 | let ln = normalize2 @a (map P l) 109 | return (D' ln) 110 | 111 | normalize3 :: forall a. [a] -> [Probability] -> [(a, Probability)] 112 | normalize3 as l = 113 | let s = sum l 114 | probs = map (/ s) l 115 | in zip as probs 116 | 117 | randomDistF :: forall a b. (CountableDims a b, CoArbitrary a, Arbitrary b) => Gen (Dist' (a -> b)) 118 | randomDistF = do 119 | let a = fromInteger (natVal (Proxy :: Proxy (Count a))) 120 | b = fromInteger (natVal (Proxy :: Proxy (Count b))) 121 | size = a * b 122 | l <- vectorOf size (arbitrary :: Gen Prob) 123 | l2 <- vectorOf size (arbitrary :: Gen (a -> b)) 124 | let !ln = normalize3 l2 (map P l) 125 | return (D' ln) 126 | 127 | instance CoArbitrary (Natural a b) 128 | 129 | instance forall (a :: Nat) (b :: Nat). (KnownNat a, KnownNat b) => Arbitrary (Natural a b) where 130 | arbitrary = 131 | let bottom = fromInteger (natVal (Proxy :: Proxy a)) 132 | top = fromInteger (natVal (Proxy :: Proxy b)) 133 | in do 134 | x <- arbitrary `suchThat` (\n -> n >= bottom && n <= top) 135 | return (nat x) 136 | 137 | setupEnv = do 138 | m11 <- generate (resize 1 (randomMatrix @(Natural 0 10) @(Natural 0 10))) 139 | m12 <- generate (resize 1 (randomMatrix @(Natural 0 10) @(Natural 0 10))) 140 | m21 <- generate (resize 1 (randomMatrix @(Natural 0 100) @(Natural 0 100))) 141 | m22 <- generate (resize 1 (randomMatrix @(Natural 0 100) @(Natural 0 100))) 142 | m31 <- generate (resize 1 (randomMatrix @(Natural 0 200) @(Natural 0 200))) 143 | m32 <- generate (resize 1 (randomMatrix @(Natural 0 200) @(Natural 0 200))) 144 | return (m11, m12, m21, m22, m31, m32) 145 | 146 | setupEnv2 = do 147 | m21 <- generate (resize 1 (randomMatrix @(Natural 0 100) @(Natural 0 100))) 148 | m40 <- generate (resize 1 (randomMatrix @(Natural 0 100) @(Either (Natural 0 100) (Natural 0 100)))) 149 | dist <- generate (resize 1 (randomDist @(Either (Natural 0 100) (Natural 0 100)))) 150 | dist2 <- generate (resize 1 (randomMatrix @(Natural 0 100) @(Natural 0 100))) 151 | distList1 <- generate (resize 1 (randomDist2 @(Either (Natural 0 100) (Natural 0 100)))) 152 | distList2 <- generate (resize 1 (randomDistF @(Natural 0 100) @(Natural 0 100))) 153 | return (m21, m40, dist, dist2, distList1, distList2) 154 | 155 | main :: IO () 156 | main = 157 | defaultMain 158 | [ env setupEnv $ \ ~(m11, m12, m21, m22, m31, m32) -> 159 | bgroup 160 | "Matrix Composition" 161 | [ bgroup 162 | "10x10" 163 | [ bench "WHNF - 10x10" $ whnf (comp m11) m12 164 | , bench "NF - 10x10" $ nf (comp m11) m12 165 | ] 166 | , bgroup 167 | "100x100" 168 | [ bench "WHNF - 100x100" $ whnf (comp m21) m22 169 | , bench "NF - 100x100" $ nf (comp m21) m22 170 | ] 171 | , bgroup 172 | "200x200" 173 | [ bench "WHNF - 200x200" $ whnf (comp m31) m32 174 | , bench "NF - 200x200" $ nf (comp m31) m32 175 | ] 176 | , bgroup 177 | "200x200 - RULES" 178 | [ bench "No rules - 200x200" $ nf (comp m21) iden 179 | , bench "Rules - 200x200" $ nf compId m21 180 | ] 181 | ] 182 | , env setupEnv2 $ \ ~(m21, m40, dist, dist2, dl1, dl2) -> 183 | bgroup 184 | "Matrix vs List - `select`" 185 | [ bgroup 186 | "Distribution `select` - 100+100 / 100x100" 187 | [ bench "List Distribution - Applicative version" $ nf (select dl1) dl2 188 | , bench "Matrix Distribution - Applicative version" $ nf (selectD2 dist) dist2 189 | , bench "Matrix Distribution - Selective version" $ nf (selectD dist) dist2 190 | ] 191 | , bgroup 192 | "Matrix `select` - 100x(100+100) / 100x100" 193 | [ bench "Applicative version" $ nf (selectM2 m40) m21 194 | , bench "Selective version" $ nf (selectM m40) m21 195 | ] 196 | ] 197 | ] 198 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # laop - Linear Algebra of Programming library 2 | 3 | [![built with nix](https://img.shields.io/badge/Built_With-Nix-5277C3.svg?logo=nixos&labelColor=73C3D5)](https://builtwithnix.org) 4 | [![GitHub CI](https://github.com/bolt12/laop/workflows/CI/badge.svg)](https://github.com/bolt12/laop/actions) 5 | [![Hackage](https://img.shields.io/hackage/v/laop.svg?logo=haskell)](https://hackage.haskell.org/package/laop) 6 | 7 | The LAoP discipline generalises relations and functions treating them as 8 | Boolean matrices and in turn consider these as arrows. 9 | 10 | __LAoP__ is a library for algebraic (inductive) construction and manipulation of matrices 11 | in Haskell. See [my Msc Thesis](https://github.com/bolt12/master-thesis) for the 12 | motivation behind the library, the underlying theory, and implementation details. 13 | 14 | This module offers many of the combinators mentioned in the work of 15 | [Macedo (2012)](https://repositorium.sdum.uminho.pt/handle/1822/22894) and [Oliveira (2012)](https://pdfs.semanticscholar.org/ccf5/27fa9179081223bffe8067edd81948644fc0.pdf). 16 | 17 | See the package in hackage [here](https://hackage.haskell.org/package/laop-0.1.1.0) 18 | 19 | A Functional Pearl has been written and can be regarded as the [reference document](https://github.com/bolt12/tymfgg-pearl) ([ACM link](https://dl.acm.org/doi/abs/10.1145/3406088.3409019)) for this library. 20 | 21 | ## Features 22 | 23 | This library offers 3 main matrix programming modules: 24 | 25 | - One in which matrices are typed with type level natural numbers; 26 | - One in which matrices are typed with arbitrary generic data types; 27 | - One in which matrices are regarded as relations, i.e. boolean matrices; 28 | 29 | There's also an experimental module that uses matrices to represent probability 30 | distributions. 31 | 32 | The most interesting feature is that matrices are represented as an inductive data type. 33 | Given this formulation, matrix algorithms can be expressed in a much more elegant and 34 | calculational style than the traditional vector of vectors representation. This data type 35 | guarantees that a matrix will always have valid dimensions. It can also express block matrix 36 | computations naturally, which leads to total, efficient and statically typed manipulation 37 | and transformation functions. 38 | 39 | Like matrix multiplication, other common operations, such as matrix transposition, benefit from a block-oriented structure that leads to a simple and natural divide-and-conquer algorithmic solution. Performance wise, this means that without much effort we can obtain optimal cache-oblivious algorithms. 40 | 41 | Given this, this new matrix formulation compared to other libraries: 42 | 43 | - Is more compositional and polymorphic and does not have partial matrix manipulation functions (hence less chances for usage errors); 44 | - Our implementation of matrices enables simple manipulation of submatrices, making it particularly suitable for formal verification and equation reasoning, using the mathematical framework defined by the linear algebra of programming. Furthermore, the data type constructors ensure that the matrices of this kind are sound, i.e. malformed matrices with incorrect dimensions of the sort, can not be constructed. 45 | 46 | ## Known issues 47 | 48 | Unfortunately, due to the use of type-level programming features, this approach sometimes requires type dimensions to be constrainted, in some way, impossible to write idiomatic Arrow instances, for example. Type inference isn't perfect, when it comes to infer the types of matrices which dimensions are computed using type level naturals multiplication, the compiler needs type annotations in order to succeed. And not all kinds of programs can be modeled using matrices, namely programs that deal with arbitrary infinite data types such as lists or integers (although there are some workarounds). 49 | 50 | ## Notes 51 | 52 | This is still a work in progress, any feedback is welcome! 53 | 54 | ## Example 55 | 56 | ```Haskell 57 | {-# LANGUAGE DeriveGeneric #-} 58 | {-# LANGUAGE FlexibleContexts #-} 59 | {-# LANGUAGE TypeOperators #-} 60 | {-# LANGUAGE TypeApplications #-} 61 | {-# LANGUAGE DataKinds #-} 62 | 63 | module Main where 64 | 65 | import Matrix.Type 66 | import Utils 67 | import Dist 68 | import GHC.TypeLits 69 | import Data.Coerce 70 | import GHC.Generics 71 | import Control.Category hiding (id) 72 | import Prelude hiding ((.)) 73 | 74 | -- Monty Hall Problem 75 | data Outcome = Win | Lose 76 | deriving (Bounded, Enum, Eq, Show, Generic) 77 | 78 | switch :: Outcome -> Outcome 79 | switch Win = Lose 80 | switch Lose = Win 81 | 82 | firstChoice :: Matrix Double () Outcome 83 | firstChoice = col [1/3, 2/3] 84 | 85 | secondChoice :: Matrix Double Outcome Outcome 86 | secondChoice = fromF' switch 87 | 88 | -- Dice sum 89 | 90 | type SS = Natural 1 6 -- Sample Space 91 | 92 | sumSS :: SS -> SS -> Natural 2 12 93 | sumSS = coerceNat (+) 94 | 95 | sumSSM = fromF' (uncurry sumSS) 96 | 97 | condition :: (Int, Int) -> Int -> Int 98 | condition (fst, snd) thrd = if fst == snd 99 | then fst * 3 100 | else fst + snd + thrd 101 | 102 | conditionSS :: (SS, SS) -> SS -> Natural 3 18 103 | conditionSS = coerceNat2 condition 104 | 105 | conditionalThrows = fromF' (uncurry conditionSS) . khatri (khatri die die) die 106 | 107 | die :: Matrix Double () SS 108 | die = col $ map (const (1/6)) [nat @1 @6 1 .. nat 6] 109 | 110 | -- Sprinkler 111 | 112 | rain :: Matrix Double () Bool 113 | rain = col [0.8, 0.2] 114 | 115 | sprinkler :: Matrix Double Bool Bool 116 | sprinkler = fromLists [[0.6, 0.99], [0.4, 0.01]] 117 | 118 | grass :: Matrix Double (Bool, Bool) Bool 119 | grass = fromLists [[1, 0.2, 0.1, 0.01], [0, 0.8, 0.9, 0.99]] 120 | 121 | state :: Matrix Double () (Bool, (Bool, Bool)) 122 | state = khatri grass identity . khatri sprinkler identity . rain 123 | 124 | grass_wet :: Matrix Double (Bool, (Bool, Bool)) One 125 | grass_wet = row [0,1] . kp1 126 | 127 | rainning :: Matrix Double (Bool, (Bool, Bool)) One 128 | rainning = row [0,1] . kp2 . kp2 129 | 130 | -- Alcuin Puzzle 131 | 132 | data Being = Farmer | Fox | Goose | Beans 133 | deriving (Bounded, Enum, Eq, Show, Generic) 134 | 135 | data Bank = LeftB | RightB 136 | deriving (Bounded, Enum, Eq, Show, Generic) 137 | 138 | eats :: Being -> Being -> Bool 139 | eats Fox Goose = True 140 | eats Goose Beans = True 141 | eats _ _ = False 142 | 143 | eatsR :: R.Relation Being Being 144 | eatsR = R.toRel eats 145 | 146 | cross :: Bank -> Bank 147 | cross LeftB = RightB 148 | cross RightB = LeftB 149 | 150 | crossR :: R.Relation Bank Bank 151 | crossR = R.fromF' cross 152 | 153 | -- | Initial state, everyone in the left bank 154 | locationLeft :: Being -> Bank 155 | locationLeft _ = LeftB 156 | 157 | locationLeftR :: R.Relation Being Bank 158 | locationLeftR = R.fromF' locationLeft 159 | 160 | -- | Initial state, everyone in the right bank 161 | locationRight :: Being -> Bank 162 | locationRight _ = RightB 163 | 164 | locationRightR :: R.Relation Being Bank 165 | locationRightR = R.fromF' locationRight 166 | 167 | -- Properties 168 | 169 | -- Being at the same bank 170 | sameBank :: R.Relation Being Bank -> R.Relation Being Being 171 | sameBank = R.ker 172 | 173 | -- Risk of somebody eating somebody else 174 | canEat :: R.Relation Being Bank -> R.Relation Being Being 175 | canEat w = sameBank w `R.intersection` eatsR 176 | 177 | -- "Starvation" property. 178 | inv :: R.Relation Being Bank -> Bool 179 | inv w = (w `R.comp` canEat w) `R.sse` (w `R.comp` farmer) 180 | where 181 | farmer :: R.Relation Being Being 182 | farmer = R.fromF' (const Farmer) 183 | 184 | -- Arbitrary state 185 | bankState :: Being -> Bank -> Bool 186 | bankState Farmer LeftB = True 187 | bankState Fox LeftB = True 188 | bankState Goose RightB = True 189 | bankState Beans RightB = True 190 | bankState _ _ = False 191 | 192 | bankStateR :: R.Relation Being Bank 193 | bankStateR = R.toRel bankState 194 | 195 | -- Main 196 | 197 | main :: IO () 198 | main = do 199 | putStrLn "Monty Hall Problem solution:" 200 | prettyPrint (secondChoice . firstChoice) 201 | putStrLn "\n Sum of dices probability:" 202 | prettyPrint (sumSSM `comp` khatri die die) 203 | putStrLn "\n Conditional dice throw:" 204 | prettyPrint conditionalThrows 205 | putStrLn "\n Checking that the last result is indeed a distribution: " 206 | prettyPrint (bang . sumSSM . khatri die die) 207 | putStrLn "\n Probability of grass being wet:" 208 | prettyPrint (grass_wet . state) 209 | putStrLn "\n Probability of rain:" 210 | prettyPrint (rainning . state) 211 | putStrLn "\n Is the arbitrary state a valid state? (Alcuin Puzzle)" 212 | print (inv bankStateR) 213 | ``` 214 | 215 | ```Shell 216 | Monty Hall Problem solution: 217 | ┌ ┐ 218 | │ 0.6666666666666666 │ 219 | │ 0.3333333333333333 │ 220 | └ ┘ 221 | 222 | Sum of dices probability: 223 | ┌ ┐ 224 | │ 2.7777777777777776e-2 │ 225 | │ 5.555555555555555e-2 │ 226 | │ 8.333333333333333e-2 │ 227 | │ 0.1111111111111111 │ 228 | │ 0.1388888888888889 │ 229 | │ 0.16666666666666666 │ 230 | │ 0.1388888888888889 │ 231 | │ 0.1111111111111111 │ 232 | │ 8.333333333333333e-2 │ 233 | │ 5.555555555555555e-2 │ 234 | │ 2.7777777777777776e-2 │ 235 | └ ┘ 236 | 237 | Conditional dice throw: 238 | ┌ ┐ 239 | │ 2.7777777777777776e-2 │ 240 | │ 9.259259259259259e-3 │ 241 | │ 1.8518518518518517e-2 │ 242 | │ 6.481481481481481e-2 │ 243 | │ 5.555555555555555e-2 │ 244 | │ 8.333333333333333e-2 │ 245 | │ 0.12962962962962962 │ 246 | │ 0.1111111111111111 │ 247 | │ 0.1111111111111111 │ 248 | │ 0.12962962962962962 │ 249 | │ 8.333333333333333e-2 │ 250 | │ 5.555555555555555e-2 │ 251 | │ 6.481481481481481e-2 │ 252 | │ 1.8518518518518517e-2 │ 253 | │ 9.259259259259259e-3 │ 254 | │ 2.7777777777777776e-2 │ 255 | └ ┘ 256 | 257 | Checking that the last result is indeed a distribution: 258 | ┌ ┐ 259 | │ 1.0 │ 260 | └ ┘ 261 | 262 | Probability of grass being wet: 263 | ┌ ┐ 264 | │ 0.4483800000000001 │ 265 | └ ┘ 266 | 267 | Probability of rain: 268 | ┌ ┐ 269 | │ 0.2 │ 270 | └ ┘ 271 | 272 | Is the arbitrary state a valid state? (Alcuin Puzzle) 273 | False 274 | ``` 275 | -------------------------------------------------------------------------------- /src/LAoP/Matrix/Nat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE KindSignatures #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | {-# LANGUAGE NoStarIsType #-} 16 | 17 | ----------------------------------------------------------------------------- 18 | 19 | ----------------------------------------------------------------------------- 20 | 21 | {- | 22 | Module : LAoP.Matrix.Nat 23 | Copyright : (c) Armando Santos 2019-2020 24 | Maintainer : armandoifsantos@gmail.com 25 | Stability : experimental 26 | 27 | The LAoP discipline generalises relations and functions treating them as 28 | Boolean matrices and in turn consider these as arrows. 29 | 30 | __LAoP__ is a library for algebraic (inductive) construction and manipulation of matrices 31 | in Haskell. See for the 32 | motivation behind the library, the underlying theory, and implementation details. 33 | 34 | This module offers a newtype wrapper around 'Matrix.Type.Matrix' that 35 | uses type level naturals instead of standard data types for the matrices 36 | dimensions. 37 | -} 38 | module LAoP.Matrix.Nat ( 39 | -- | LAoP (Linear Algebra of Programming) Inductive Matrix definition. 40 | -- 41 | -- LAoP generalises relations and functions treating them as 42 | -- Boolean matrices and in turn consider these as arrows. 43 | -- This library offers many of the combinators mentioned in the work of 44 | -- Macedo (2012) and Oliveira (2012). 45 | -- 46 | -- This definition is a wrapper around 'Matrix.Type' but 47 | -- dimensions are type level Naturals. Type inference might not 48 | -- be as desired. 49 | -- 50 | -- There exists two type families that make it easier to write 51 | -- matrix dimensions: 'FromNat' and 'Count'. This approach 52 | -- leads to a very straightforward implementation 53 | -- of LAoP combinators. 54 | 55 | -- * Type safe matrix representation 56 | Matrix (..), 57 | 58 | -- * Constraint type synonyms 59 | Countable, 60 | CountableDims, 61 | CountableN, 62 | CountableNz, 63 | CountableDimsN, 64 | FLN, 65 | FLNz, 66 | Liftable, 67 | TrivialE, 68 | TrivialP, 69 | 70 | -- * Primitives 71 | one, 72 | join, 73 | fork, 74 | 75 | -- * Auxiliary type families 76 | I.FromNat, 77 | I.Count, 78 | I.Normalize, 79 | 80 | -- * Matrix construction and conversion 81 | I.FL, 82 | fromLists, 83 | toLists, 84 | toList, 85 | matrixBuilder', 86 | row, 87 | col, 88 | zeros, 89 | ones, 90 | bang, 91 | constant, 92 | 93 | -- * Misc 94 | 95 | -- ** Get dimensions 96 | columns, 97 | rows, 98 | 99 | -- ** Matrix Transposition 100 | tr, 101 | 102 | -- ** Scalar multiplication/division of matrices 103 | (.|), 104 | (./), 105 | 106 | -- ** Selective operator 107 | select, 108 | 109 | -- ** McCarthy's Conditional 110 | cond, 111 | 112 | -- ** Matrix "abiding" 113 | abideJF, 114 | abideFJ, 115 | 116 | -- ** Zip Matrices 117 | zipWithM, 118 | 119 | -- * Biproduct approach 120 | 121 | -- ** Fork 122 | (===), 123 | 124 | -- *** Projections 125 | p1, 126 | p2, 127 | 128 | -- ** Join 129 | (|||), 130 | 131 | -- *** Injections 132 | i1, 133 | i2, 134 | 135 | -- ** Bifunctors 136 | (-|-), 137 | (><), 138 | 139 | -- ** Applicative matrix combinators 140 | 141 | -- | Note that given the restrictions imposed it is not possible to 142 | -- implement the standard type classes present in standard Haskell. 143 | -- *** Matrix pairing projections 144 | fstM, 145 | sndM, 146 | 147 | -- *** Matrix pairing 148 | kr, 149 | 150 | -- * Matrix composition and lifting 151 | 152 | -- ** Arrow matrix combinators 153 | 154 | -- | Note that given the restrictions imposed it is not possible to 155 | -- implement the standard type classes present in standard Haskell. 156 | iden, 157 | comp, 158 | fromF', 159 | fromF, 160 | 161 | -- * Matrix printing 162 | pretty, 163 | prettyPrint, 164 | ) 165 | where 166 | 167 | import Control.DeepSeq 168 | import Data.List (sort) 169 | import Data.Proxy (Proxy) 170 | import GHC.TypeLits 171 | import LAoP.Matrix.Internal qualified as I 172 | 173 | newtype Matrix e (cols :: Nat) (rows :: Nat) = M (I.Matrix e (I.FromNat cols) (I.FromNat rows)) 174 | deriving (Show, Num, Eq, Ord, NFData) via (I.Matrix e (I.FromNat cols) (I.FromNat rows)) 175 | 176 | -- | Constraint type synonyms to keep the type signatures less convoluted 177 | type Countable a = KnownNat (I.Count a) 178 | 179 | type CountableDims a b = (Countable a, Countable b) 180 | type CountableN a = KnownNat (I.Count (I.FromNat a)) 181 | type CountableNz a = KnownNat (I.Count (I.Normalize a)) 182 | type CountableDimsN a b = (CountableN a, CountableN b) 183 | type FLN e a b = I.FL (I.FromNat a) (I.FromNat b) 184 | type FLNz e a b = I.FL (I.Normalize a) (I.Normalize b) 185 | type Liftable e a b = (Bounded a, Bounded b, Enum a, Enum b, Eq b, Num e, Ord e) 186 | type TrivialE a b = I.FromNat (a + b) ~ Either (I.FromNat a) (I.FromNat b) 187 | type TrivialP a b = I.FromNat (a * b) ~ I.FromNat (I.Count (I.FromNat a) * I.Count (I.FromNat b)) 188 | 189 | -- Primitives 190 | 191 | one :: e -> Matrix e 1 1 192 | one = M . I.One 193 | 194 | join :: 195 | (TrivialE a b) => 196 | Matrix e a rows -> 197 | Matrix e b rows -> 198 | Matrix e (a + b) rows 199 | join (M a) (M b) = M (I.Join a b) 200 | 201 | infixl 3 ||| 202 | (|||) :: 203 | (TrivialE a b) => 204 | Matrix e a rows -> 205 | Matrix e b rows -> 206 | Matrix e (a + b) rows 207 | (|||) = join 208 | 209 | fork :: 210 | (TrivialE a b) => 211 | Matrix e cols a -> 212 | Matrix e cols b -> 213 | Matrix e cols (a + b) 214 | fork (M a) (M b) = M (I.Fork a b) 215 | 216 | infixl 2 === 217 | (===) :: 218 | (TrivialE a b) => 219 | Matrix e cols a -> 220 | Matrix e cols b -> 221 | Matrix e cols (a + b) 222 | (===) = fork 223 | 224 | -- Construction 225 | 226 | fromLists :: (FLN e cols rows) => [[e]] -> Matrix e cols rows 227 | fromLists = M . I.fromLists 228 | 229 | {- | Matrix builder function. Constructs a matrix provided with 230 | a construction function that operates with indices. 231 | -} 232 | matrixBuilder' :: 233 | (FLN e cols rows, CountableN cols, CountableN rows) => 234 | ((Int, Int) -> e) -> 235 | Matrix e cols rows 236 | matrixBuilder' = M . I.matrixBuilder' 237 | 238 | col :: (I.FL () (I.FromNat rows)) => [e] -> Matrix e 1 rows 239 | col = M . I.col 240 | 241 | row :: (I.FL (I.FromNat cols) ()) => [e] -> Matrix e cols 1 242 | row = M . I.row 243 | 244 | fromF' :: 245 | ( Liftable e a b 246 | , CountableN cols 247 | , CountableN rows 248 | , FLN e rows cols 249 | ) => 250 | (a -> b) -> 251 | Matrix e cols rows 252 | fromF' = M . I.fromF' 253 | 254 | fromF :: 255 | forall e a b. 256 | ( Liftable e a b 257 | , KnownNat (I.Count a) 258 | , KnownNat (I.Count b) 259 | , I.FL (I.FromNat (I.Count b)) (I.FromNat (I.Count a)) 260 | ) => 261 | (a -> b) -> 262 | Matrix e (I.Count a) (I.Count b) 263 | fromF f = 264 | let minA = minBound @a 265 | maxA = maxBound @a 266 | minB = minBound @b 267 | maxB = maxBound @b 268 | ccols = fromInteger $ natVal (undefined :: Proxy (I.Count a)) 269 | rrows = fromInteger $ natVal (undefined :: Proxy (I.Count b)) 270 | elementsA = take ccols [minA .. maxA] 271 | elementsB = take rrows [minB .. maxB] 272 | combinations = (,) <$> elementsA <*> elementsB 273 | combAp = 274 | map snd 275 | . sort 276 | . map 277 | ( \(a, b) -> 278 | if f a == b 279 | then ((fromEnum a, fromEnum b), 1) 280 | else ((fromEnum a, fromEnum b), 0) 281 | ) 282 | $ combinations 283 | mList = buildList combAp rrows 284 | in tr $ fromLists mList 285 | where 286 | buildList [] _ = [] 287 | buildList l r = take r l : buildList (drop r l) r 288 | 289 | -- Conversion 290 | 291 | toLists :: Matrix e cols rows -> [[e]] 292 | toLists (M m) = I.toLists m 293 | 294 | toList :: Matrix e cols rows -> [e] 295 | toList (M m) = I.toList m 296 | 297 | -- Zeros Matrix 298 | 299 | zeros :: 300 | (Num e, FLN e cols rows, CountableN cols, CountableN rows) => 301 | Matrix e cols rows 302 | zeros = M I.zeros 303 | 304 | -- Ones Matrix 305 | 306 | ones :: 307 | (Num e, FLN e cols rows, CountableN cols, CountableN rows) => 308 | Matrix e cols rows 309 | ones = M I.ones 310 | 311 | -- Const Matrix 312 | 313 | constant :: 314 | (FLN e cols rows, CountableN cols, CountableN rows) => 315 | e -> 316 | Matrix e cols rows 317 | constant = M . I.constant 318 | 319 | -- Bang Matrix 320 | 321 | bang :: 322 | forall e cols. 323 | (Num e, Enum e, I.FL (I.FromNat cols) (), CountableN cols) => 324 | Matrix e cols 1 325 | bang = M I.bang 326 | 327 | -- iden Matrix 328 | 329 | iden :: 330 | (Num e, FLN e cols cols, CountableN cols) => 331 | Matrix e cols cols 332 | iden = M I.iden 333 | 334 | -- Matrix composition (MMM) 335 | 336 | comp :: (Num e) => Matrix e cr rows -> Matrix e cols cr -> Matrix e cols rows 337 | comp (M a) (M b) = M (I.comp a b) 338 | 339 | -- Scalar multiplication of matrices 340 | 341 | infixl 7 .| 342 | 343 | -- | Scalar multiplication of matrices. 344 | (.|) :: (Num e) => e -> Matrix e cols rows -> Matrix e cols rows 345 | (.|) e (M m) = M (e I..| m) 346 | 347 | -- Scalar division of matrices 348 | 349 | infixl 7 ./ 350 | 351 | -- | Scalar multiplication of matrices. 352 | (./) :: (Fractional e) => Matrix e cols rows -> e -> Matrix e cols rows 353 | (./) (M m) e = M (m I../ e) 354 | 355 | p1 :: 356 | ( Num e 357 | , CountableDimsN n m 358 | , FLN e n m 359 | , FLN e m m 360 | , TrivialE m n 361 | ) => 362 | Matrix e (m + n) m 363 | p1 = M I.p1 364 | 365 | p2 :: 366 | ( Num e 367 | , CountableDimsN n m 368 | , FLN e m n 369 | , FLN e n n 370 | , TrivialE m n 371 | ) => 372 | Matrix e (m + n) n 373 | p2 = M I.p2 374 | 375 | -- Injections 376 | 377 | i1 :: 378 | ( Num e 379 | , CountableDimsN n rows 380 | , FLN e n rows 381 | , FLN e rows rows 382 | , TrivialE rows n 383 | ) => 384 | Matrix e rows (rows + n) 385 | i1 = tr p1 386 | 387 | i2 :: 388 | ( Num e 389 | , CountableDimsN rows m 390 | , FLN e m rows 391 | , FLN e rows rows 392 | , TrivialE m rows 393 | ) => 394 | Matrix e rows (m + rows) 395 | i2 = tr p2 396 | 397 | -- Dimensions 398 | 399 | rows :: (CountableN rows) => Matrix e cols rows -> Int 400 | rows (M m) = I.rows m 401 | 402 | columns :: (CountableN cols) => Matrix e cols rows -> Int 403 | columns (M m) = I.columns m 404 | 405 | infixl 5 -|- 406 | 407 | -- | Coproduct Bifunctor (Direct sum) 408 | (-|-) :: 409 | ( Num e 410 | , CountableDimsN j k 411 | , FLN e k k 412 | , FLN e j k 413 | , FLN e k j 414 | , FLN e j j 415 | , TrivialE n m 416 | , TrivialE k j 417 | ) => 418 | Matrix e n k -> 419 | Matrix e m j -> 420 | Matrix e (n + m) (k + j) 421 | (-|-) (M a) (M b) = M ((I.-|-) a b) 422 | 423 | -- | Khatri Rao Product first projection 424 | fstM :: 425 | forall e m k. 426 | ( Num e 427 | , CountableDimsN m k 428 | , CountableN (m * k) 429 | , FLN e (m * k) m 430 | , TrivialP m k 431 | ) => 432 | Matrix e (m * k) m 433 | fstM = M (I.fstM @e @(I.FromNat m) @(I.FromNat k)) 434 | 435 | -- | Khatri Rao Product second projection 436 | sndM :: 437 | forall e m k. 438 | ( Num e 439 | , CountableDimsN k m 440 | , FLN e (m * k) k 441 | , CountableN (m * k) 442 | , TrivialP m k 443 | ) => 444 | Matrix e (m * k) k 445 | sndM = M (I.sndM @e @(I.FromNat m) @(I.FromNat k)) 446 | 447 | -- | Khatri Rao Product 448 | kr :: 449 | forall e cols a b. 450 | ( Num e 451 | , CountableDimsN a b 452 | , CountableN (a * b) 453 | , FLN e (a * b) a 454 | , FLN e (a * b) b 455 | , TrivialP a b 456 | ) => 457 | Matrix e cols a -> 458 | Matrix e cols b -> 459 | Matrix e cols (a * b) 460 | kr a b = 461 | let fstM' = fstM @e @a @b 462 | sndM' = sndM @e @a @b 463 | in comp (tr fstM') a * comp (tr sndM') b 464 | 465 | -- | Product Bifunctor (Kronecker) 466 | infixl 4 >< 467 | 468 | (><) :: 469 | forall e m p n q. 470 | ( Num e 471 | , CountableDimsN m n 472 | , CountableDimsN p q 473 | , CountableDimsN (m * n) (p * q) 474 | , FLN e (m * n) m 475 | , FLN e (m * n) n 476 | , FLN e (p * q) p 477 | , FLN e (p * q) q 478 | , TrivialP m n 479 | , TrivialP p q 480 | ) => 481 | Matrix e m p -> 482 | Matrix e n q -> 483 | Matrix e (m * n) (p * q) 484 | (><) a b = 485 | let fstM' = fstM @e @m @n 486 | sndM' = sndM @e @m @n 487 | in kr (comp a fstM') (comp b sndM') 488 | 489 | -- | Matrix abide Join Fork 490 | abideJF :: Matrix e cols rows -> Matrix e cols rows 491 | abideJF (M m) = M (I.abideJF m) 492 | 493 | -- | Matrix abide Fork Join 494 | abideFJ :: Matrix e cols rows -> Matrix e cols rows 495 | abideFJ (M m) = M (I.abideFJ m) 496 | 497 | -- | Matrix transposition 498 | tr :: Matrix e cols rows -> Matrix e rows cols 499 | tr (M m) = M (I.tr m) 500 | 501 | -- Selective 'select' operator 502 | select :: 503 | ( Num e 504 | , FLN e rows1 rows1 505 | , CountableN rows1 506 | , I.FromNat rows2 ~ I.FromNat rows1 507 | , I.FromNat cols1 ~ I.FromNat cols2 508 | , I.FromNat rows3 ~ Either (I.FromNat cols3) (I.FromNat rows1) 509 | ) => 510 | Matrix e cols1 rows3 -> 511 | Matrix e cols3 rows1 -> 512 | Matrix e cols2 rows2 513 | select (M m) (M y) = M (I.select m y) 514 | 515 | -- McCarthy's Conditional 516 | 517 | cond :: 518 | ( I.FromNat (I.Count (I.FromNat cols)) ~ I.FromNat cols 519 | , CountableN cols 520 | , I.FL () (I.FromNat cols) 521 | , I.FL (I.FromNat cols) () 522 | , FLN e cols cols 523 | , Liftable e a Bool 524 | ) => 525 | (a -> Bool) -> 526 | Matrix e cols rows -> 527 | Matrix e cols rows -> 528 | Matrix e cols rows 529 | cond p (M a) (M b) = M (I.cond p a b) 530 | 531 | -- Pretty print 532 | 533 | pretty :: (CountableDimsN cols rows, Show e) => Matrix e cols rows -> String 534 | pretty (M m) = I.pretty m 535 | 536 | prettyPrint :: (CountableDimsN cols rows, Show e) => Matrix e cols rows -> IO () 537 | prettyPrint (M m) = I.prettyPrint m 538 | 539 | -- | Zip two matrices with a given binary function 540 | zipWithM :: (e -> f -> g) -> Matrix e cols rows -> Matrix f cols rows -> Matrix g cols rows 541 | zipWithM f (M a) (M b) = M (I.zipWithM f a b) 542 | -------------------------------------------------------------------------------- /src/LAoP/Matrix/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | {-# LANGUAGE NoStarIsType #-} 16 | 17 | ----------------------------------------------------------------------------- 18 | 19 | ----------------------------------------------------------------------------- 20 | 21 | {- | 22 | Module : LAoP.Matrix.Type 23 | Copyright : (c) Armando Santos 2019-2020 24 | Maintainer : armandoifsantos@gmail.com 25 | Stability : experimental 26 | 27 | The LAoP discipline generalises relations and functions treating them as 28 | Boolean matrices and in turn consider these as arrows. 29 | 30 | __LAoP__ is a library for algebraic (inductive) construction and manipulation of matrices 31 | in Haskell. See for the 32 | motivation behind the library, the underlying theory, and implementation details. 33 | 34 | This module offers a newtype wrapper around 'Matrix.Type.Matrix' that 35 | uses arbitrary types instead of canonical data types for the matrices 36 | dimensions. 37 | 38 | __NOTE__: If the types in the dimensions are custom they must need to 39 | implement a 'Generic' instance. 40 | -} 41 | module LAoP.Matrix.Type ( 42 | -- | LAoP (Linear Algebra of Programming) Inductive Matrix definition. 43 | -- 44 | -- LAoP generalises relations and functions treating them as 45 | -- Boolean matrices and in turn consider these as arrows. 46 | -- This library offers many of the combinators mentioned in the work of 47 | -- Macedo (2012) and Oliveira (2012). 48 | -- 49 | -- This definition is a wrapper around 'Matrix.Type' but 50 | -- dimensions are arbitrary data types. Type inference might not 51 | -- be as desired. 52 | 53 | -- __NOTE__: If the types in the dimensions are custom they must need to 54 | -- implement a 'Generic' instance. 55 | -- 56 | 57 | -- * Type safe matrix representation 58 | Matrix (..), 59 | 60 | -- * Constraint type aliases 61 | Countable, 62 | CountableDims, 63 | CountableN, 64 | CountableDimsN, 65 | FLN, 66 | Liftable, 67 | Trivial, 68 | TrivialP, 69 | 70 | -- * Type aliases 71 | Zero, 72 | One, 73 | 74 | -- * Primitives 75 | one, 76 | join, 77 | fork, 78 | 79 | -- * Auxiliary type families 80 | I.FromNat, 81 | I.Count, 82 | I.Normalize, 83 | 84 | -- * Matrix construction and conversion 85 | I.FromLists, 86 | fromLists, 87 | toLists, 88 | toList, 89 | matrixBuilder', 90 | matrixBuilder, 91 | row, 92 | col, 93 | zeros, 94 | ones, 95 | bang, 96 | point, 97 | constant, 98 | 99 | -- * Functor instance equivalent function 100 | fmapM, 101 | bimapM, 102 | 103 | -- * Applicative/Monoidal instance equivalent functions 104 | unitM, 105 | multM, 106 | 107 | -- * Selective equivalent instance function 108 | selectM, 109 | 110 | -- * Monad equivalent instance function 111 | returnM, 112 | bindM, 113 | 114 | -- * Misc 115 | 116 | -- ** Get dimensions 117 | columns, 118 | columns', 119 | rows, 120 | rows', 121 | 122 | -- ** Matrix Transposition 123 | tr, 124 | 125 | -- ** Scalar multiplication/division of matrices 126 | (.|), 127 | (./), 128 | 129 | -- ** McCarthy's Conditional 130 | cond, 131 | 132 | -- ** Matrix "abiding" 133 | abideJF, 134 | abideFJ, 135 | 136 | -- ** Zip Matrices 137 | zipWithM, 138 | 139 | -- * Biproduct approach 140 | 141 | -- ** Fork 142 | (===), 143 | 144 | -- *** Projections 145 | p1, 146 | p2, 147 | 148 | -- ** Join 149 | (|||), 150 | 151 | -- *** Injections 152 | i1, 153 | i2, 154 | 155 | -- ** Bifunctors 156 | (-|-), 157 | (><), 158 | 159 | -- ** Applicative matrix combinators 160 | 161 | -- | Note that given the restrictions imposed it is not possible to 162 | -- implement the standard type classes present in standard Haskell. 163 | -- *** Matrix pairing projections 164 | fstM, 165 | sndM, 166 | 167 | -- *** Matrix pairing 168 | kr, 169 | 170 | -- * Matrix composition and lifting 171 | 172 | -- ** Arrow matrix combinators 173 | 174 | -- | Note that given the restrictions imposed it is not possible to 175 | -- implement the standard type classes present in standard Haskell. 176 | iden, 177 | comp, 178 | fromF', 179 | fromF, 180 | 181 | -- * Relation 182 | toRel, 183 | 184 | -- * Matrix printing 185 | pretty, 186 | prettyPrint, 187 | ) 188 | where 189 | 190 | import Control.DeepSeq 191 | import Data.Kind 192 | import Data.Proxy 193 | import Data.Void 194 | import GHC.TypeLits hiding (Natural) 195 | import LAoP.Matrix.Internal qualified as I 196 | import LAoP.Utils 197 | import Prelude hiding (id, (.)) 198 | 199 | newtype Matrix e (cols :: Type) (rows :: Type) = M (I.Matrix e (I.Normalize cols) (I.Normalize rows)) 200 | deriving (Show, Num, Eq, Ord, NFData) via (I.Matrix e (I.Normalize cols) (I.Normalize rows)) 201 | 202 | -- | Constraint type synonyms to keep the type signatures less convoluted 203 | type Countable a = KnownNat (I.Count a) 204 | 205 | type CountableDims a b = (Countable a, Countable b) 206 | type CountableN a = KnownNat (I.Count (I.Normalize a)) 207 | type CountableDimsN a b = (CountableN a, CountableN b) 208 | type FLN a b = I.FromLists (I.Normalize a) (I.Normalize b) 209 | type Liftable e a b = (Bounded a, Bounded b, Enum a, Enum b, Eq b, Num e, Ord e) 210 | type Trivial a = I.Normalize (I.Normalize a) ~ I.Normalize (I.Normalize (I.Normalize a)) 211 | type Trivial2 a = I.Normalize a ~ I.Normalize (I.Normalize a) 212 | type Trivial3 a = I.FromNat (I.Count (I.Normalize (I.Normalize a))) ~ I.Normalize (I.Normalize a) 213 | type TrivialP a b = I.Normalize (a, b) ~ I.Normalize (I.Normalize a, I.Normalize b) 214 | 215 | {- | It is possible to implement a constrained version of the category type 216 | class. 217 | -} 218 | instance (Num e) => Category (Matrix e) where 219 | type Object (Matrix e) a = (FLN a a, CountableN a) 220 | id = iden 221 | (.) = comp 222 | 223 | -- | Bifunctor equivalent function 224 | bimapM :: 225 | ( Liftable e a b 226 | , Liftable e c d 227 | , CountableDimsN a c 228 | , CountableDimsN b d 229 | , FLN d c 230 | , FLN b a 231 | ) => 232 | (a -> b) -> 233 | (c -> d) -> 234 | Matrix e a c -> 235 | Matrix e b d 236 | bimapM f g m = fromF g . m . tr (fromF f) 237 | 238 | -- | Zero type alias 239 | type Zero = Void 240 | 241 | -- | One type alias 242 | type One = () 243 | 244 | -- Primitives 245 | 246 | -- | Unit matrix constructor 247 | one :: e -> Matrix e One One 248 | one = M . I.One 249 | 250 | -- | Matrix 'Join' constructor 251 | join :: 252 | Matrix e a rows -> 253 | Matrix e b rows -> 254 | Matrix e (Either a b) rows 255 | join (M a) (M b) = M (I.Join a b) 256 | 257 | infixl 3 ||| 258 | 259 | -- | Matrix 'Join' constructor 260 | (|||) :: 261 | Matrix e a rows -> 262 | Matrix e b rows -> 263 | Matrix e (Either a b) rows 264 | (|||) = join 265 | 266 | -- | Matrix 'Fork' constructor 267 | fork :: 268 | Matrix e cols a -> 269 | Matrix e cols b -> 270 | Matrix e cols (Either a b) 271 | fork (M a) (M b) = M (I.Fork a b) 272 | 273 | infixl 2 === 274 | 275 | -- | Matrix 'Fork' constructor 276 | (===) :: 277 | Matrix e cols a -> 278 | Matrix e cols b -> 279 | Matrix e cols (Either a b) 280 | (===) = fork 281 | 282 | -- Functor hierarchy 283 | 284 | -- | Functor instance equivalent function 285 | fmapM :: 286 | ( Liftable e a b 287 | , CountableDimsN a b 288 | , FLN b a 289 | ) => 290 | (a -> b) -> 291 | Matrix e c a -> 292 | Matrix e c b 293 | fmapM f m = fromF f . m 294 | 295 | -- | Applicative instance equivalent 'unit' function, 296 | unitM :: (Num e) => Matrix e () () 297 | unitM = one 1 298 | 299 | -- | Applicative instance equivalent 'unit' function, 300 | multM :: 301 | ( CountableDimsN a b 302 | , CountableN (a, b) 303 | , Num e 304 | , FLN (a, b) a 305 | , FLN (a, b) b 306 | , TrivialP a b 307 | ) => 308 | Matrix e c a -> 309 | Matrix e c b -> 310 | Matrix e c (a, b) 311 | multM = kr 312 | 313 | -- | Monad instance equivalent 'return' function, 314 | returnM :: 315 | forall e a. 316 | ( Num e 317 | , Enum e 318 | , Enum a 319 | , FLN () a 320 | , Countable a 321 | ) => 322 | a -> 323 | Matrix e One a 324 | returnM a = col l 325 | where 326 | i = fromInteger $ natVal (Proxy :: Proxy (I.Count a)) 327 | x = fromEnum a 328 | l = take x [0, 0 ..] ++ [1] ++ take (i - x - 1) [0, 0 ..] 329 | 330 | -- | Monad instance equivalent '(>>=)' function, 331 | bindM :: (Num e) => Matrix e a b -> Matrix e b c -> Matrix e a c 332 | bindM = flip comp 333 | 334 | -- Construction 335 | 336 | {- | Build a matrix out of a list of list of elements. Throws a runtime 337 | error if the dimensions do not match. 338 | -} 339 | fromLists :: (FLN cols rows) => [[e]] -> Matrix e cols rows 340 | fromLists = M . I.fromLists 341 | 342 | {- | Matrix builder function. Constructs a matrix provided with 343 | a construction function that operates with indices. 344 | -} 345 | matrixBuilder' :: 346 | (FLN cols rows, CountableDimsN cols rows) => 347 | ((Int, Int) -> e) -> 348 | Matrix e cols rows 349 | matrixBuilder' = M . I.matrixBuilder' 350 | 351 | {- | Matrix builder function. Constructs a matrix provided with 352 | a construction function that operates with arbitrary types. 353 | -} 354 | matrixBuilder :: 355 | ( FLN a b 356 | , Enum a 357 | , Enum b 358 | , Bounded a 359 | , Bounded b 360 | , Countable b 361 | ) => 362 | ((a, b) -> e) -> 363 | Matrix e a b 364 | matrixBuilder f = M (I.matrixBuilder f) 365 | 366 | -- | Constructs a column vector matrix 367 | col :: (FLN () rows) => [e] -> Matrix e One rows 368 | col = M . I.col 369 | 370 | -- | Constructs a row vector matrix 371 | row :: (FLN cols ()) => [e] -> Matrix e cols One 372 | row = M . I.row 373 | 374 | {- | Lifts functions to matrices with arbitrary dimensions. 375 | 376 | NOTE: Be careful to not ask for a matrix bigger than the cardinality of 377 | types @a@ or @b@ allows. 378 | -} 379 | fromF' :: 380 | ( Liftable e a b 381 | , CountableDimsN cols rows 382 | , FLN rows cols 383 | ) => 384 | (a -> b) -> 385 | Matrix e cols rows 386 | fromF' = M . I.fromF' 387 | 388 | {- | Lifts functions to matrices with dimensions matching @a@ and @b@ 389 | cardinality's. 390 | -} 391 | fromF :: 392 | ( Liftable e a b 393 | , CountableDimsN a b 394 | , FLN b a 395 | ) => 396 | (a -> b) -> 397 | Matrix e a b 398 | fromF = M . I.fromF 399 | 400 | -- | Lifts relation functions to Boolean Matrix 401 | toRel :: 402 | ( Liftable (Natural 0 1) a b 403 | , CountableDims a b 404 | , FLN b a 405 | ) => 406 | (a -> b -> Bool) -> 407 | Matrix (Natural 0 1) a b 408 | toRel = M . I.toRel 409 | 410 | -- Conversion 411 | 412 | -- | Converts a matrix to a list of lists of elements. 413 | toLists :: Matrix e cols rows -> [[e]] 414 | toLists (M m) = I.toLists m 415 | 416 | -- | Converts a matrix to a list of elements. 417 | toList :: Matrix e cols rows -> [e] 418 | toList (M m) = I.toList m 419 | 420 | -- Zeros Matrix 421 | 422 | -- | The zero matrix. A matrix wholly filled with zeros. 423 | zeros :: 424 | (Num e, FLN cols rows, CountableDimsN cols rows) => 425 | Matrix e cols rows 426 | zeros = M I.zeros 427 | 428 | -- Ones Matrix 429 | 430 | {- | The ones matrix. A matrix wholly filled with ones. 431 | 432 | Also known as T (Top) matrix. 433 | -} 434 | ones :: 435 | (Num e, FLN cols rows, CountableDimsN cols rows) => 436 | Matrix e cols rows 437 | ones = M I.ones 438 | 439 | -- Const Matrix 440 | 441 | {- | The constant matrix constructor. A matrix wholly filled with a given 442 | value. 443 | -} 444 | constant :: 445 | (FLN cols rows, CountableDimsN cols rows) => 446 | e -> 447 | Matrix e cols rows 448 | constant = M . I.constant 449 | 450 | -- Bang Matrix 451 | 452 | -- | The T (Top) row vector matrix. 453 | bang :: 454 | forall e cols. 455 | (Num e, Enum e, FLN cols (), CountableN cols) => 456 | Matrix e cols One 457 | bang = M I.bang 458 | 459 | -- | Point constant relation 460 | point :: 461 | ( Bounded a 462 | , Enum a 463 | , Eq a 464 | , Num e 465 | , Ord e 466 | , CountableN a 467 | , FLN a One 468 | ) => 469 | a -> 470 | Matrix e One a 471 | point = fromF . const 472 | 473 | -- iden Matrix 474 | 475 | -- | iden matrix 476 | iden :: 477 | (Num e, FLN a a, CountableN a) => 478 | Matrix e a a 479 | iden = M I.iden 480 | {-# NOINLINE iden #-} 481 | 482 | -- Matrix composition (MMM) 483 | 484 | {- | Matrix composition. Equivalent to matrix-matrix multiplication. 485 | 486 | This definition takes advantage of divide-and-conquer and fusion laws 487 | from LAoP. 488 | -} 489 | comp :: (Num e) => Matrix e cr rows -> Matrix e cols cr -> Matrix e cols rows 490 | comp (M a) (M b) = M (I.comp a b) 491 | {-# NOINLINE comp #-} 492 | 493 | {-# RULES 494 | "comp/iden1" forall m. comp m iden = m 495 | "comp/iden2" forall m. comp iden m = m 496 | #-} 497 | 498 | -- Scalar multiplication of matrices 499 | 500 | infixl 7 .| 501 | 502 | -- | Scalar multiplication of matrices. 503 | (.|) :: (Num e) => e -> Matrix e cols rows -> Matrix e cols rows 504 | (.|) e (M m) = M (e I..| m) 505 | 506 | -- Scalar division of matrices 507 | 508 | infixl 7 ./ 509 | 510 | -- | Scalar multiplication of matrices. 511 | (./) :: (Fractional e) => Matrix e cols rows -> e -> Matrix e cols rows 512 | (./) (M m) e = M (m I../ e) 513 | 514 | -- | Biproduct first component projection 515 | p1 :: 516 | ( Num e 517 | , CountableDimsN n m 518 | , FLN n m 519 | , FLN m m 520 | ) => 521 | Matrix e (Either m n) m 522 | p1 = M I.p1 523 | 524 | -- | Biproduct second component projection 525 | p2 :: 526 | ( Num e 527 | , CountableDimsN n m 528 | , FLN m n 529 | , FLN n n 530 | ) => 531 | Matrix e (Either m n) n 532 | p2 = M I.p2 533 | 534 | -- Injections 535 | 536 | -- | Biproduct first component injection 537 | i1 :: 538 | ( Num e 539 | , CountableDimsN n m 540 | , FLN n m 541 | , FLN m m 542 | ) => 543 | Matrix e m (Either m n) 544 | i1 = tr p1 545 | 546 | -- | Biproduct second component injection 547 | i2 :: 548 | ( Num e 549 | , CountableDimsN n m 550 | , FLN m n 551 | , FLN n n 552 | ) => 553 | Matrix e n (Either m n) 554 | i2 = tr p2 555 | 556 | -- Dimensions 557 | 558 | {- | Obtain the number of rows. 559 | 560 | NOTE: The 'KnownNat' constraint is needed in order to obtain the 561 | dimensions in constant time. For a version that doesn't require the 562 | constraint see 'rows''. 563 | -} 564 | rows :: (CountableN rows) => Matrix e cols rows -> Int 565 | rows (M m) = I.rows m 566 | 567 | {- | Obtain the number of rows in an inefficient manner, but without any 568 | constraints. 569 | 570 | For a more efficient version see 'rows'. 571 | -} 572 | rows' :: Matrix e cols rows -> Int 573 | rows' (M m) = I.rows' m 574 | 575 | {- | Obtain the number of columns. 576 | 577 | NOTE: The 'KnownNat' constraint is needed in order to obtain the 578 | dimensions in constant time. For a version that doesn't require the 579 | constraint see 'columns''. 580 | -} 581 | columns :: (CountableN cols) => Matrix e cols rows -> Int 582 | columns (M m) = I.columns m 583 | 584 | {- | Obtain the number of columns in an inefficient manner, but without any 585 | constraints. 586 | 587 | For a more efficient version see 'columns'. 588 | -} 589 | columns' :: Matrix e cols rows -> Int 590 | columns' (M m) = I.columns' m 591 | 592 | -- Coproduct Bifunctor 593 | 594 | infixl 5 -|- 595 | 596 | -- | Matrix coproduct functor also known as matrix direct sum. 597 | (-|-) :: 598 | ( Num e 599 | , CountableDimsN j k 600 | , FLN k k 601 | , FLN j k 602 | , FLN k j 603 | , FLN j j 604 | ) => 605 | Matrix e n k -> 606 | Matrix e m j -> 607 | Matrix e (Either n m) (Either k j) 608 | (-|-) (M a) (M b) = M ((I.-|-) a b) 609 | 610 | -- Khatri Rao Product and projections 611 | 612 | -- | Khatri Rao product first component projection matrix. 613 | fstM :: 614 | forall e m k. 615 | ( Num e 616 | , CountableDimsN m k 617 | , CountableN (m, k) 618 | , FLN (m, k) m 619 | , TrivialP m k 620 | ) => 621 | Matrix e (m, k) m 622 | fstM = M (I.fstM @e @(I.Normalize m) @(I.Normalize k)) 623 | 624 | -- | Khatri Rao product second component projection matrix. 625 | sndM :: 626 | forall e m k. 627 | ( Num e 628 | , CountableDimsN k m 629 | , CountableN (m, k) 630 | , FLN (m, k) k 631 | , TrivialP m k 632 | ) => 633 | Matrix e (m, k) k 634 | sndM = M (I.sndM @e @(I.Normalize m) @(I.Normalize k)) 635 | 636 | {- | Khatri Rao Matrix product also known as matrix pairing. 637 | 638 | NOTE: That this is not a true categorical product, see for instance: 639 | 640 | @ 641 | | fstM . kr a b == a 642 | kr a b ==> | 643 | | sndM . kr a b == b 644 | @ 645 | 646 | __Emphasis__ on the implication symbol. 647 | -} 648 | kr :: 649 | forall e cols a b. 650 | ( Num e 651 | , CountableDimsN a b 652 | , CountableN (a, b) 653 | , FLN (a, b) a 654 | , FLN (a, b) b 655 | , TrivialP a b 656 | ) => 657 | Matrix e cols a -> 658 | Matrix e cols b -> 659 | Matrix e cols (a, b) 660 | kr a b = 661 | let fstM' = fstM @e @a @b 662 | sndM' = sndM @e @a @b 663 | in comp (tr fstM') a * comp (tr sndM') b 664 | 665 | -- Product Bifunctor (Kronecker) 666 | 667 | infixl 4 >< 668 | 669 | -- | Matrix product functor also known as Kronecker product 670 | (><) :: 671 | forall e m p n q. 672 | ( Num e 673 | , CountableDimsN m n 674 | , CountableDimsN p q 675 | , CountableDimsN (m, n) (p, q) 676 | , FLN (m, n) m 677 | , FLN (m, n) n 678 | , FLN (p, q) p 679 | , FLN (p, q) q 680 | , TrivialP m n 681 | , TrivialP p q 682 | ) => 683 | Matrix e m p -> 684 | Matrix e n q -> 685 | Matrix e (m, n) (p, q) 686 | (><) a b = 687 | let fstM' = fstM @e @m @n 688 | sndM' = sndM @e @m @n 689 | in kr (comp a fstM') (comp b sndM') 690 | 691 | -- Matrix abide Join Fork 692 | 693 | {- | Matrix "abiding" followin the 'Join'-'Fork' abide law. 694 | 695 | Law: 696 | 697 | @ 698 | 'Join' ('Fork' a c) ('Fork' b d) == 'Fork' ('Join' a b) ('Join' c d) 699 | @ 700 | -} 701 | abideJF :: Matrix e cols rows -> Matrix e cols rows 702 | abideJF (M m) = M (I.abideJF m) 703 | 704 | -- Matrix abide Fork Join 705 | 706 | {- | Matrix "abiding" followin the 'Fork'-'Join' abide law. 707 | 708 | Law: 709 | 710 | @ 711 | 'Fork' ('Join' a b) ('Join' c d) == 'Join' ('Fork' a c) ('Fork' b d) 712 | @ 713 | -} 714 | abideFJ :: Matrix e cols rows -> Matrix e cols rows 715 | abideFJ (M m) = M (I.abideFJ m) 716 | 717 | -- Matrix transposition 718 | 719 | -- | Matrix transposition. 720 | tr :: Matrix e cols rows -> Matrix e rows cols 721 | tr (M m) = M (I.tr m) 722 | 723 | -- Selective 'select' operator 724 | 725 | {- | Selective functors 'select' operator equivalent inspired by the 726 | ArrowMonad solution presented in the paper. 727 | -} 728 | selectM :: 729 | ( Num e 730 | , FLN b b 731 | , CountableN b 732 | ) => 733 | Matrix e cols (Either a b) -> 734 | Matrix e a b -> 735 | Matrix e cols b 736 | selectM (M m) (M y) = M (I.select m y) 737 | 738 | -- McCarthy's Conditional 739 | 740 | -- | McCarthy's Conditional expresses probabilistic choice. 741 | cond :: 742 | ( Trivial2 a 743 | , Trivial3 a 744 | , CountableN a 745 | , FLN () a 746 | , FLN a () 747 | , FLN a a 748 | , Liftable e a Bool 749 | ) => 750 | (a -> Bool) -> 751 | Matrix e a b -> 752 | Matrix e a b -> 753 | Matrix e a b 754 | cond p (M a) (M b) = M (I.cond p a b) 755 | 756 | -- Pretty print 757 | 758 | -- | Matrix pretty printer 759 | pretty :: (CountableDimsN cols rows, Show e) => Matrix e cols rows -> String 760 | pretty (M m) = I.pretty m 761 | 762 | -- | Matrix pretty printer 763 | prettyPrint :: (CountableDimsN cols rows, Show e) => Matrix e cols rows -> IO () 764 | prettyPrint (M m) = I.prettyPrint m 765 | 766 | -- | Zip two matrices with a given binary function 767 | zipWithM :: (e -> f -> g) -> Matrix e a b -> Matrix f a b -> Matrix g a b 768 | zipWithM f (M a) (M b) = M (I.zipWithM f a b) 769 | -------------------------------------------------------------------------------- /src/LAoP/Relation/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | ----------------------------------------------------------------------------- 14 | 15 | ----------------------------------------------------------------------------- 16 | 17 | {- | 18 | Module : LAoP.Relation.Internal 19 | Copyright : (c) Armando Santos 2019-2020 20 | Maintainer : armandoifsantos@gmail.com 21 | Stability : experimental 22 | 23 | The AoP discipline generalises functions to relations which are 24 | Boolean matrices. 25 | 26 | This module offers many of the combinators of the Algebra of 27 | Programming discipline. It is still under construction and very 28 | experimental. 29 | 30 | This is an Internal module and it is no supposed to be imported. 31 | -} 32 | module LAoP.Relation.Internal ( 33 | -- | This definition makes use of the fact that 'Void' is 34 | -- isomorphic to 0 and 'One' to 1 and captures matrix 35 | -- dimensions as stacks of 'Either's. 36 | -- 37 | -- There exists two type families that make it easier to write 38 | -- matrix dimensions: 'FromNat' and 'Count'. This approach 39 | -- leads to a very straightforward implementation 40 | -- of LAoP combinators. 41 | 42 | -- * Relation data type 43 | Relation (..), 44 | Boolean, 45 | 46 | -- * Constraint type synonyms 47 | Countable, 48 | CountableDims, 49 | CountableN, 50 | CountableDimsN, 51 | FLN, 52 | Liftable, 53 | Trivial, 54 | TrivialP, 55 | 56 | -- * Primitives 57 | one, 58 | join, 59 | (|||), 60 | fork, 61 | (===), 62 | 63 | -- * Auxiliary type families 64 | I.FromNat, 65 | I.Count, 66 | I.Normalize, 67 | 68 | -- * Matrix construction and conversion 69 | I.FromLists, 70 | fromLists, 71 | fromF', 72 | fromF, 73 | fromRel, 74 | toRel, 75 | toLists, 76 | toList, 77 | toBool, 78 | pt, 79 | belongs, 80 | relationBuilder', 81 | relationBuilder, 82 | zeros, 83 | ones, 84 | bang, 85 | point, 86 | 87 | -- * Relational operations 88 | conv, 89 | intersection, 90 | union, 91 | sse, 92 | implies, 93 | iff, 94 | ker, 95 | img, 96 | 97 | -- * Taxonomy of binary relations 98 | injective, 99 | entire, 100 | simple, 101 | surjective, 102 | representation, 103 | function, 104 | abstraction, 105 | injection, 106 | surjection, 107 | bijection, 108 | domain, 109 | range, 110 | 111 | -- * Function division 112 | divisionF, 113 | 114 | -- * Relation division 115 | divR, 116 | divL, 117 | divS, 118 | shrunkBy, 119 | overriddenBy, 120 | 121 | -- * Relational pairing 122 | splitR, 123 | 124 | -- ** Projections 125 | fstR, 126 | sndR, 127 | 128 | -- ** Bifunctor 129 | (><), 130 | 131 | -- * Relational coproduct 132 | eitherR, 133 | 134 | -- ** Injections 135 | i1, 136 | i2, 137 | 138 | -- ** Bifunctor 139 | (-|-), 140 | 141 | -- * Relational "currying" 142 | trans, 143 | untrans, 144 | 145 | -- * (Endo-)Relational properties 146 | reflexive, 147 | coreflexive, 148 | transitive, 149 | symmetric, 150 | antiSymmetric, 151 | irreflexive, 152 | connected, 153 | preorder, 154 | partialOrder, 155 | linearOrder, 156 | equivalence, 157 | partialEquivalence, 158 | difunctional, 159 | 160 | -- * Conditionals 161 | equalizer, 162 | 163 | -- ** McCarthy's Conditional 164 | predR, 165 | guard, 166 | cond, 167 | 168 | -- * Relational composition and lifting 169 | iden, 170 | comp, 171 | fromF', 172 | fromF, 173 | 174 | -- ** Relational application 175 | pointAp, 176 | pointApBool, 177 | 178 | -- * Matrix printing 179 | pretty, 180 | prettyPrint, 181 | ) 182 | where 183 | 184 | import Control.DeepSeq 185 | import Data.Bool 186 | import GHC.TypeLits hiding (Natural) 187 | import LAoP.Matrix.Internal qualified as I 188 | import LAoP.Utils.Internal 189 | import Prelude hiding (id, (.)) 190 | 191 | -- | Boolean type synonym for working with boolean matrices 192 | type Boolean = Natural 0 1 193 | 194 | -- | Relation data type. 195 | newtype Relation a b = R (I.Matrix Boolean (I.Normalize a) (I.Normalize b)) 196 | deriving (Show, Eq, Ord, NFData) via (I.Matrix (Natural 1 1) (I.Normalize a) (I.Normalize b)) 197 | 198 | deriving instance (Read (I.Matrix Boolean (I.Normalize a) (I.Normalize b))) => Read (Relation a b) 199 | 200 | -- | Constraint type synonyms to keep the type signatures less convoluted 201 | type Countable a = KnownNat (I.Count a) 202 | 203 | type CountableDims a b = (Countable a, Countable b) 204 | type CountableN a = KnownNat (I.Count (I.Normalize a)) 205 | type CountableDimsN a b = (CountableN a, CountableN b) 206 | type FLN a b = I.FromLists (I.Normalize a) (I.Normalize b) 207 | type Liftable a b = (Bounded a, Bounded b, Enum a, Enum b, Eq b, Num Boolean, Ord Boolean) 208 | type Trivial a = I.Normalize a ~ I.Normalize (I.Normalize a) 209 | type TrivialP a b = I.Normalize (a, b) ~ I.Normalize (I.Normalize a, I.Normalize b) 210 | 211 | {- | It is possible to implement a constrained version of the category type 212 | class. 213 | -} 214 | instance Category Relation where 215 | type Object Relation a = (FLN a a, CountableN a) 216 | id = iden 217 | (.) = comp 218 | 219 | instance Num (Relation a b) where 220 | -- \| Matrix addition becomes Boolean matrix disjointion 221 | (R a) + (R b) = R (I.orM a b) 222 | 223 | -- \| Matrix subtraction becomes Relational subtraction 224 | (R a) - (R b) = R (I.subM a b) 225 | 226 | -- \| Matrix multiplication becomes Boolean matrix conjointion 227 | (R a) * (R b) = R (I.andM a b) 228 | 229 | -- \| Matrix negation becomes Boolean matrix negation 230 | negate (R a) = R (I.negateM a) 231 | 232 | abs = error "abs: does not exist" 233 | 234 | signum = error "signum: does not exist" 235 | 236 | fromInteger = error "fromInteger: does not exist" 237 | 238 | -- Type alias 239 | type One = () 240 | 241 | -- Primitives 242 | 243 | -- | Unit matrix constructor 244 | one :: Boolean -> Relation One One 245 | one = R . I.One 246 | 247 | {- | Boolean Matrix 'Join' constructor, also known as relational coproduct. 248 | 249 | See 'eitherR'. 250 | -} 251 | join :: Relation a c -> Relation b c -> Relation (Either a b) c 252 | join (R a) (R b) = R (I.Join a b) 253 | 254 | infixl 3 ||| 255 | 256 | {- | Boolean Matrix 'Join' constructor 257 | 258 | See 'eitherR'. 259 | -} 260 | (|||) :: 261 | Relation a c -> 262 | Relation b c -> 263 | Relation (Either a b) c 264 | (|||) = join 265 | 266 | -- | Boolean Matrix 'Fork' constructor, also known as relational product. 267 | fork :: Relation c a -> Relation c b -> Relation c (Either a b) 268 | fork (R a) (R b) = R (I.Fork a b) 269 | 270 | infixl 2 === 271 | 272 | -- | Boolean Matrix 'Fork' constructor 273 | (===) :: 274 | Relation c a -> 275 | Relation c b -> 276 | Relation c (Either a b) 277 | (===) = fork 278 | 279 | -- Construction 280 | 281 | {- | Build a matrix out of a list of list of elements. Throws a runtime 282 | error if the dimensions do not match. 283 | -} 284 | fromLists :: (FLN a b) => [[Boolean]] -> Relation a b 285 | fromLists = R . I.fromLists 286 | 287 | {- | Relation builder function. Constructs a relation provided with 288 | a construction function that operates with indices. 289 | -} 290 | relationBuilder' :: 291 | (FLN a b, CountableDimsN a b) => 292 | ((Int, Int) -> Boolean) -> 293 | Relation a b 294 | relationBuilder' = R . I.matrixBuilder' 295 | 296 | {- | Relation builder function. Constructs a relation provided with 297 | a construction function that operates with arbitrary types. 298 | -} 299 | relationBuilder :: 300 | ( FLN a b 301 | , Enum a 302 | , Enum b 303 | , Bounded a 304 | , Bounded b 305 | , CountableDims a b 306 | ) => 307 | ((a, b) -> Boolean) -> 308 | Relation a b 309 | relationBuilder = R . I.matrixBuilder 310 | 311 | {- | Lifts functions to matrices with arbitrary dimensions. 312 | 313 | NOTE: Be careful to not ask for a matrix bigger than the cardinality of 314 | types @a@ or @b@ allows. 315 | -} 316 | fromF' :: 317 | ( Liftable a b 318 | , CountableDimsN c d 319 | , FLN d c 320 | ) => 321 | (a -> b) -> 322 | Relation c d 323 | fromF' f = R (I.fromFRel' f) 324 | 325 | {- | Lifts functions to matrices with dimensions matching @a@ and @b@ 326 | cardinality's. 327 | -} 328 | fromF :: 329 | ( Liftable a b 330 | , CountableDimsN a b 331 | , FLN b a 332 | ) => 333 | (a -> b) -> 334 | Relation a b 335 | fromF f = R (I.fromFRel f) 336 | 337 | -- | Lifts relation functions to 'Relation' 338 | toRel :: 339 | ( Liftable a b 340 | , CountableDims a b 341 | , FLN b a 342 | ) => 343 | (a -> b -> Bool) -> 344 | Relation a b 345 | toRel = R . I.toRel 346 | 347 | -- | Lowers a 'Relation' to a function 348 | fromRel :: 349 | ( Liftable a b 350 | , Eq a 351 | , CountableDimsN a b 352 | , FLN a One 353 | , FLN b One 354 | ) => 355 | Relation a b -> 356 | (a -> b -> Bool) 357 | fromRel r a b = pointApBool a b r 358 | 359 | -- Conversion 360 | 361 | -- | Converts a matrix to a list of lists of elements. 362 | toLists :: Relation a b -> [[Boolean]] 363 | toLists (R m) = I.toLists m 364 | 365 | -- | Converts a matrix to a list of elements. 366 | toList :: Relation a b -> [Boolean] 367 | toList (R m) = I.toList m 368 | 369 | -- | Converts a well typed 'Relation' to 'Bool'. 370 | toBool :: Relation One One -> Bool 371 | toBool r = case toList r of 372 | [Nat 0] -> False 373 | _ -> True 374 | 375 | {- | Power transpose. 376 | 377 | Maps a relation to a set valued function. 378 | -} 379 | pt :: 380 | ( Liftable a b 381 | , Eq a 382 | , CountableDimsN a b 383 | , FLN a One 384 | , FLN b One 385 | ) => 386 | Relation a b -> 387 | (a -> BoundedList b) 388 | pt r a = 389 | let (L lb) = maxBound 390 | in L [b | b <- lb, toBool (pointAp a b r)] 391 | 392 | -- | Belongs relation 393 | belongs :: 394 | ( Bounded a 395 | , Enum a 396 | , Eq a 397 | , CountableDims (BoundedList a) a 398 | , FLN a (BoundedList a) 399 | ) => 400 | Relation (BoundedList a) a 401 | belongs = toRel elemR 402 | where 403 | elemR (L l) x = x `elem` l 404 | 405 | -- Zeros Matrix 406 | 407 | {- | The zero relation. A relation where no element of type @a@ relates 408 | with elements of type @b@. 409 | 410 | Also known as ⊥ (Bottom) Relation. 411 | 412 | @ 413 | r `.` ⊥ == ⊥ `.` r == ⊥ 414 | ⊥ ``sse`` R && R ``sse`` T == True 415 | @ 416 | -} 417 | zeros :: 418 | (FLN a b, CountableDimsN a b) => 419 | Relation a b 420 | zeros = relationBuilder' (const (reifyToNatural 0)) 421 | 422 | -- Ones Matrix 423 | 424 | {- | The ones relation. A relation where every element of type @a@ relates 425 | with every element of type @b@. 426 | 427 | Also known as T (Top) Relation or universal Relation. 428 | 429 | @ 430 | ⊥ ``sse`` R && R ``sse`` T == True 431 | @ 432 | -} 433 | ones :: 434 | (FLN a b, CountableDimsN a b) => 435 | Relation a b 436 | ones = relationBuilder' (const (reifyToNatural 1)) 437 | 438 | -- Bang Matrix 439 | 440 | -- | The T (Top) row vector relation. 441 | bang :: 442 | (FLN a One, CountableN a) => 443 | Relation a One 444 | bang = ones 445 | 446 | -- | Point constant relation 447 | point :: 448 | ( Bounded a 449 | , Enum a 450 | , Eq a 451 | , CountableN a 452 | , FLN a One 453 | ) => 454 | a -> 455 | Relation One a 456 | point = fromF . const 457 | 458 | -- iden Matrix 459 | 460 | {- | iden matrix 461 | 462 | @ 463 | 'iden' `.` r == r == r `.` 'iden' 464 | @ 465 | -} 466 | iden :: 467 | (FLN a a, CountableN a) => Relation a a 468 | iden = relationBuilder' (bool (reifyToNatural 0) (reifyToNatural 1) . uncurry (==)) 469 | 470 | {- | Relational composition 471 | 472 | @ 473 | r `.` (s `.` p) = (r `.` s) `.` p 474 | @ 475 | -} 476 | comp :: Relation b c -> Relation a b -> Relation a c 477 | comp (R a) (R b) = R (I.compRel a b) 478 | 479 | {- | Relational right division 480 | 481 | @'divR' x y@ is the largest relation @z@ which, 482 | pre-composed with @y@, approximates @x@. 483 | -} 484 | divR :: Relation b c -> Relation b a -> Relation a c 485 | divR (R x) (R y) = R (I.divR x y) 486 | 487 | {- | Relational left division 488 | 489 | The dual division operator: 490 | 491 | @ 492 | 'divL' y x == 'conv' ('divR' ('conv' x) ('conv' y) 493 | @ 494 | -} 495 | divL :: Relation c b -> Relation a b -> Relation a c 496 | divL (R x) (R y) = R (I.divL x y) 497 | 498 | {- | Relational symmetric division 499 | 500 | @'pointAp' c b ('divS' s r)@ means that @b@ and @c@ 501 | are related to exactly the same outputs by @r@ and by @s@. 502 | -} 503 | divS :: Relation c a -> Relation b a -> Relation c b 504 | divS (R x) (R y) = R (I.divS x y) 505 | 506 | {- | Relational shrinking. 507 | 508 | @r ``shrunkBy`` s@ is the largest part of @r@ such that, 509 | if it yields an output for an input @x@, it must be a maximum, 510 | with respect to @s@, among all possible outputs of @x@ by @r@. 511 | -} 512 | shrunkBy :: Relation b a -> Relation a a -> Relation b a 513 | shrunkBy r s = r `intersection` divR s (conv r) 514 | 515 | {- | Relational overriding. 516 | 517 | @r ``overriddenBy`` s@ yields the relation which contains the 518 | whole of @s@ and that part of @r@ where @s@ is undefined. 519 | 520 | @ 521 | 'zeros' ``overriddenBy`` s == s 522 | r ``overriddenBy`` 'zeros' == r 523 | r ``overriddenBy`` r == r 524 | @ 525 | -} 526 | overriddenBy :: 527 | ( FLN b b 528 | , CountableN b 529 | ) => 530 | Relation a b -> 531 | Relation a b -> 532 | Relation a b 533 | overriddenBy r s = s `union` r `intersection` divR zeros (conv s) 534 | 535 | {- | Relational application. 536 | 537 | If @a@ and @b@ are related by 'Relation' @r@ 538 | then @'pointAp' a b r == 'one' ('nat' 1)@ 539 | -} 540 | pointAp :: 541 | ( Liftable a b 542 | , Eq a 543 | , CountableDimsN a b 544 | , FLN a One 545 | , FLN b One 546 | ) => 547 | a -> 548 | b -> 549 | Relation a b -> 550 | Relation One One 551 | pointAp a b r = conv (point b) . r . point a 552 | 553 | {- | Relational application 554 | 555 | The same as 'pointAp' but converts 'Boolean' to 'Bool' 556 | -} 557 | pointApBool :: 558 | ( Liftable a b 559 | , Eq a 560 | , CountableDimsN a b 561 | , FLN a One 562 | , FLN b One 563 | ) => 564 | a -> 565 | b -> 566 | Relation a b -> 567 | Bool 568 | pointApBool a b r = toBool $ conv (point b) . r . point a 569 | 570 | {- | Relational converse 571 | 572 | Given binary 'Relation' r, writing @'pointAp' a b r@ 573 | (read: “@b@ is related to @a@ by @r@”) means the same as 574 | @'pointAp' b a ('conv' r)@, where @'conv' r@ is said to be 575 | the converse of @r@. 576 | In terms of grammar, @'conv' r@ corresponds to the passive voice 577 | -} 578 | conv :: Relation a b -> Relation b a 579 | conv (R a) = R (I.tr a) 580 | 581 | -- | Relational inclusion (subset or equal) 582 | sse :: Relation a b -> Relation a b -> Bool 583 | sse a b = a <= b 584 | 585 | -- | Relational implication (the same as @'sse'@) 586 | implies :: Relation a b -> Relation a b -> Relation a b 587 | implies r s = negate r `union` s 588 | 589 | -- | Relational bi-implication 590 | iff :: Relation a b -> Relation a b -> Bool 591 | iff r s = r == s 592 | 593 | {- | Relational intersection 594 | 595 | Lifts pointwise conjointion. 596 | 597 | @ 598 | (r ``intersection`` s) ``intersection`` t == r ``intersection`` (s ``intersection`` t) 599 | x ``sse`` r ``intersection`` s == x ``intersection`` r && x ``intersection`` s 600 | @ 601 | -} 602 | intersection :: Relation a b -> Relation a b -> Relation a b 603 | intersection a b = a * b 604 | 605 | {- | Relational union 606 | 607 | Lifts pointwise disjointion. 608 | 609 | @ 610 | (r ``union`` s) ``union`` t == r `'union' (s ``union`` t) 611 | r ``union`` s ``sse`` x == r ``sse`` x && s ``sse`` x 612 | r `.` (s ``union`` t) == (r `.` s) ``union`` (r `.` t) 613 | (s ``union`` t) `.` r == (s `.` r) ``union`` (t `.` r) 614 | @ 615 | -} 616 | union :: Relation a b -> Relation a b -> Relation a b 617 | union a b = a + b 618 | 619 | {- | Relation Kernel 620 | 621 | @ 622 | 'ker' r == 'conv' r `.` r 623 | 'ker' r == 'img' ('conv' r) 624 | @ 625 | -} 626 | ker :: Relation a b -> Relation a a 627 | ker r = conv r . r 628 | 629 | {- | Relation Image 630 | 631 | @ 632 | 'img' r == r `.` conv r 633 | 'img' r == 'ker' ('conv' r) 634 | @ 635 | -} 636 | img :: Relation a b -> Relation b b 637 | img r = r . conv r 638 | 639 | {- | Function division. Special case of 'divS'. 640 | 641 | NOTE: _This is only valid_ if @f@ and @g@ are 'function's, i.e. 'simple' and 642 | 'entire'. 643 | 644 | @'divisionF' f g == 'conv' g `.` f@ 645 | -} 646 | divisionF :: Relation a c -> Relation b c -> Relation a b 647 | divisionF f g = conv g . f 648 | 649 | -- Taxonomy of binary relations 650 | 651 | -- | A 'Relation' @r@ is 'simple' 'iff' @'coreflexive' ('img' r)@ 652 | simple :: (CountableN b, FLN b b) => Relation a b -> Bool 653 | simple = coreflexive . img 654 | 655 | -- | A 'Relation' @r@ is 'injective' 'iff' @'coreflexive' ('ker' r)@ 656 | injective :: (CountableN a, FLN a a) => Relation a b -> Bool 657 | injective = coreflexive . ker 658 | 659 | -- | A 'Relation' @r@ is 'entire' 'iff' @'reflexive' ('ker' r)@ 660 | entire :: (CountableN a, FLN a a) => Relation a b -> Bool 661 | entire = reflexive . ker 662 | 663 | -- | A 'Relation' @r@ is 'surjective' 'iff' @'reflexive' ('img' r)@ 664 | surjective :: (CountableN b, FLN b b) => Relation a b -> Bool 665 | surjective = reflexive . img 666 | 667 | {- | A 'Relation' @r@ is a 'function' 'iff' @'simple' r && 'entire' r@ 668 | 669 | A 'function' @f@ enjoys the following properties, where @r@ and @s@ are binary 670 | relations: 671 | 672 | @ 673 | f `.` r ``sse`` s == r ``sse`` f `.` s 674 | r `.` f ``sse`` s == r ``sse`` s `.` f 675 | @ 676 | -} 677 | function :: 678 | ( CountableDimsN a b 679 | , FLN a a 680 | , FLN b b 681 | ) => 682 | Relation a b -> 683 | Bool 684 | function r = simple r && entire r 685 | 686 | -- | A 'Relation' @r@ is a 'representation' 'iff' @'injective' r && 'entire' r@ 687 | representation :: 688 | ( CountableN a 689 | , FLN a a 690 | ) => 691 | Relation a b -> 692 | Bool 693 | representation r = injective r && entire r 694 | 695 | -- | A 'Relation' @r@ is an 'abstraction' 'iff' @'surjective' r && 'simple' r@ 696 | abstraction :: 697 | ( CountableN b 698 | , FLN b b 699 | ) => 700 | Relation a b -> 701 | Bool 702 | abstraction r = surjective r && simple r 703 | 704 | -- | A 'Relation' @r@ is a 'surjection' 'iff' @'function' r && 'abstraction' r@ 705 | surjection :: 706 | ( CountableDimsN a b 707 | , FLN a a 708 | , FLN b b 709 | ) => 710 | Relation a b -> 711 | Bool 712 | surjection r = function r && abstraction r 713 | 714 | -- | A 'Relation' @r@ is a 'injection' 'iff' @'function' r && 'representation' r@ 715 | injection :: 716 | ( CountableDimsN a b 717 | , FLN a a 718 | , FLN b b 719 | ) => 720 | Relation a b -> 721 | Bool 722 | injection r = function r && representation r 723 | 724 | -- | A 'Relation' @r@ is an 'bijection' 'iff' @'injection' r && 'surjection' r@ 725 | bijection :: 726 | ( CountableDimsN a b 727 | , FLN b b 728 | , FLN a a 729 | ) => 730 | Relation a b -> 731 | Bool 732 | bijection r = injection r && surjection r 733 | 734 | -- Properties of relations 735 | 736 | -- | A 'Relation' @r@ is 'reflexive' 'iff' @'id' ``sse`` r@ 737 | reflexive :: (CountableN a, FLN a a) => Relation a a -> Bool 738 | reflexive r = id <= r 739 | 740 | -- | A 'Relation' @r@ is 'coreflexive' 'iff' @r ``sse`` 'id'@ 741 | coreflexive :: (CountableN a, FLN a a) => Relation a a -> Bool 742 | coreflexive r = r <= id 743 | 744 | -- | A 'Relation' @r@ is 'transitive' 'iff' @(r `.` r) ``sse`` r@ 745 | transitive :: Relation a a -> Bool 746 | transitive r = (r . r) `sse` r 747 | 748 | -- | A 'Relation' @r@ is 'symmetric' 'iff' @r == 'conv' r@ 749 | symmetric :: Relation a a -> Bool 750 | symmetric r = r == conv r 751 | 752 | -- | A 'Relation' @r@ is anti-symmetric 'iff' @(r ``intersection`` 'conv' r) ``sse`` 'id'@ 753 | antiSymmetric :: (CountableN a, FLN a a) => Relation a a -> Bool 754 | antiSymmetric r = (r `intersection` conv r) `sse` id 755 | 756 | -- | A 'Relation' @r@ is 'irreflexive' 'iff' @(r ``intersection`` 'id') == 'zeros'@ 757 | irreflexive :: (CountableN a, FLN a a) => Relation a a -> Bool 758 | irreflexive r = (r `intersection` id) == zeros 759 | 760 | -- | A 'Relation' @r@ is 'connected' 'iff' @(r ``union`` 'conv' r) == 'ones'@ 761 | connected :: (CountableN a, FLN a a) => Relation a a -> Bool 762 | connected r = (r `union` conv r) == ones 763 | 764 | -- | A 'Relation' @r@ is a 'preorder' 'iff' @'reflexive' r && 'transitive' r@ 765 | preorder :: (CountableN a, FLN a a) => Relation a a -> Bool 766 | preorder r = reflexive r && transitive r 767 | 768 | -- | A 'Relation' @r@ is a partial-order 'iff' @'antiSymmetric' r && 'preorder' r@ 769 | partialOrder :: (CountableN a, FLN a a) => Relation a a -> Bool 770 | partialOrder r = antiSymmetric r && preorder r 771 | 772 | -- | A 'Relation' @r@ is a linear-order 'iff' @'connected' r && 'partialOrder' r@ 773 | linearOrder :: (CountableN a, FLN a a) => Relation a a -> Bool 774 | linearOrder r = connected r && partialOrder r 775 | 776 | -- | A 'Relation' @r@ is an 'equivalence' 'iff' @'symmetric' r && 'preorder' r@ 777 | equivalence :: (CountableN a, FLN a a) => Relation a a -> Bool 778 | equivalence r = symmetric r && preorder r 779 | 780 | -- | A 'Relation' @r@ is a partial-equivalence 'iff' @'partialOrder' r && 'equivalence' r@ 781 | partialEquivalence :: (CountableN a, FLN a a) => Relation a a -> Bool 782 | partialEquivalence r = partialOrder r && equivalence r 783 | 784 | {- | A 'Relation' @r@ is 'difunctional' or regular wherever 785 | @r `.` 'conv' r `.` r == r@ 786 | -} 787 | difunctional :: Relation a b -> Bool 788 | difunctional r = r . conv r . r == r 789 | 790 | -- Relational pairing 791 | 792 | {- | Relational pairing. 793 | 794 | NOTE: That this is not a true categorical product, see for instance: 795 | 796 | @ 797 | | 'fstR' `.` 'splitR' a b ``sse`` a 798 | 'splitR' a b <=> | 799 | | 'sndR' `.` 'splitR' a b ``sse`` b 800 | @ 801 | 802 | __Emphasis__ on the 'sse'. 803 | 804 | @ 805 | 'splitR' r s `.` f == 'splitR' (r `.` f) (s `.` f) 806 | (R '><' S) `.` 'splitR' p q == 'splitR' (r `.` p) (s `.` q) 807 | 'conv' ('splitR' r s) `.` 'splitR' x y == ('conv' r `.` x) ``intersection`` ('conv' s `.` y) 808 | @ 809 | 810 | @ 811 | 'eitherR' ('splitR' r s) ('splitR' t v) == 'splitR' ('eitherR' r t) ('eitherR' s v) 812 | @ 813 | -} 814 | splitR :: 815 | ( CountableDimsN a b 816 | , CountableN (a, b) 817 | , FLN (a, b) a 818 | , FLN (a, b) b 819 | , TrivialP a b 820 | ) => 821 | Relation c a -> 822 | Relation c b -> 823 | Relation c (a, b) 824 | splitR (R f) (R g) = R (I.kr f g) 825 | 826 | {- | Relational pairing first component projection 827 | 828 | @ 829 | 'fstR' `.` 'splitR' r s ``sse`` r 830 | @ 831 | -} 832 | fstR :: 833 | forall a b. 834 | ( CountableDimsN a b 835 | , CountableN (a, b) 836 | , FLN (a, b) a 837 | , TrivialP a b 838 | ) => 839 | Relation (a, b) a 840 | fstR = R (I.fstM @Boolean @(I.Normalize a) @(I.Normalize b)) 841 | 842 | {- | Relational pairing second component projection 843 | 844 | @ 845 | 'sndR' `.` 'splitR' r s ``sse`` s 846 | @ 847 | -} 848 | sndR :: 849 | forall a b. 850 | ( CountableDimsN a b 851 | , CountableN (a, b) 852 | , FLN (a, b) b 853 | , TrivialP a b 854 | ) => 855 | Relation (a, b) b 856 | sndR = R (I.sndM @Boolean @(I.Normalize a) @(I.Normalize b)) 857 | 858 | -- Relational pairing functor 859 | 860 | infixl 4 >< 861 | 862 | {- | Relational pairing functor 863 | 864 | @ 865 | r '><' s == 'splitR' (r `.` fstR) (s `.` sndR) 866 | (r '><' s) `.` (p '><' q) == (r `.` p) '><' (s `.` q) 867 | @ 868 | -} 869 | (><) :: 870 | ( CountableDimsN a b 871 | , CountableDimsN c d 872 | , CountableDimsN (a, c) (b, d) 873 | , FLN (a, c) a 874 | , FLN (a, c) c 875 | , FLN (b, d) b 876 | , FLN (b, d) d 877 | , TrivialP a c 878 | , TrivialP b d 879 | ) => 880 | Relation a b -> 881 | Relation c d -> 882 | Relation (a, c) (b, d) 883 | (><) (R a) (R b) = R ((I.><) a b) 884 | 885 | -- Relational co-products 886 | 887 | {- | Relational coproduct. 888 | 889 | @ 890 | | 'eitherR' a b `.` 'i1' == a 891 | 'eitherR' a b <=> | 892 | | 'eitherR' a b `.` 'i2' == b 893 | @ 894 | 895 | @ 896 | 'eitherR' r s `.` 'conv' ('eitherR' t u) == (r `.` 'conv' t) ``union`` (s `.` 'conv' u) 897 | @ 898 | 899 | @ 900 | 'eitherR' ('splitR' r s) ('splitR' t v) == 'splitR' ('eitherR' r t) ('eitherR' s v) 901 | @ 902 | -} 903 | eitherR :: Relation a c -> Relation b c -> Relation (Either a b) c 904 | eitherR = join 905 | 906 | {- | Relational coproduct first component injection 907 | 908 | @ 909 | 'img' 'i1' ``union`` 'img' 'i2' == 'id' 910 | 'i1' `.` 'i2' = 'zeros' 911 | @ 912 | -} 913 | i1 :: 914 | ( CountableDimsN a b 915 | , FLN b a 916 | , FLN a a 917 | ) => 918 | Relation a (Either a b) 919 | i1 = R I.i1 920 | 921 | {- | Relational coproduct second component injection 922 | 923 | @ 924 | 'img' 'i1' ``union`` 'img' 'i2' == 'id' 925 | 'i1' `.` 'i2' = 'zeros' 926 | @ 927 | -} 928 | i2 :: 929 | ( CountableDimsN a b 930 | , FLN a b 931 | , FLN b b 932 | ) => 933 | Relation b (Either a b) 934 | i2 = R I.i2 935 | 936 | infixl 5 -|- 937 | 938 | {- | Relational coproduct functor. 939 | 940 | @ 941 | r '-|-' s == 'eitherR' ('i1' `.` r) ('i2' `.` s) 942 | @ 943 | -} 944 | (-|-) :: 945 | ( CountableDimsN b d 946 | , FLN b b 947 | , FLN d b 948 | , FLN b d 949 | , FLN d d 950 | ) => 951 | Relation a b -> 952 | Relation c d -> 953 | Relation (Either a c) (Either b d) 954 | (-|-) (R a) (R b) = R ((I.-|-) a b) 955 | 956 | -- Relational "Currying" 957 | 958 | {- | Relational 'trans' 959 | 960 | Every n-ary relation can be expressed as a binary relation through 961 | 'trans'/'untrans'; 962 | more-over, where each particular attribute is placed (input/output) is irrelevant. 963 | -} 964 | trans :: 965 | ( CountableDimsN a b 966 | , CountableN c 967 | , CountableDimsN (a, b) (c, b) 968 | , FLN (c, b) c 969 | , FLN (c, b) b 970 | , FLN (a, b) a 971 | , FLN (a, b) b 972 | , TrivialP a b 973 | , TrivialP c b 974 | ) => 975 | Relation (a, b) c -> 976 | Relation a (c, b) 977 | trans r = splitR r sndR . conv fstR 978 | 979 | {- | Relational 'untrans' 980 | 981 | Every n-ary relation can be expressed as a binary relation through 982 | 'trans'/'untrans'; 983 | more-over, where each particular attribute is placed (input/output) is irrelevant. 984 | -} 985 | untrans :: 986 | ( CountableDimsN a b 987 | , CountableN c 988 | , CountableDimsN (a, b) (c, b) 989 | , FLN (c, b) c 990 | , FLN (c, b) b 991 | , FLN (a, b) b 992 | , FLN (a, b) a 993 | , TrivialP a b 994 | , TrivialP c b 995 | ) => 996 | Relation a (c, b) -> 997 | Relation (a, b) c 998 | untrans s = fstR . conv (splitR (conv s) sndR) 999 | 1000 | {- | Transforms predicate @p@ into a correflexive relation. 1001 | 1002 | @ 1003 | 'predR' ('const' True) == 'id' 1004 | 'predR' ('const' False) == 'zeros' 1005 | @ 1006 | 1007 | @ 1008 | 'predR' q `.` 'predR' p == 'predR' q ``union`` 'predR' p 1009 | @ 1010 | -} 1011 | predR :: 1012 | ( Bounded a 1013 | , Enum a 1014 | , CountableN a 1015 | , FLN a a 1016 | , FLN Bool a 1017 | ) => 1018 | Relation a Bool -> 1019 | Relation a a 1020 | predR p = id `intersection` divisionF (fromF (const True)) p 1021 | 1022 | {- | Equalizes functions @f@ and @g@. 1023 | That is, @'equalizer' f g@ is the largest coreflexive 1024 | that restricts @g@ so that @f@ and @g@ yield the same outputs. 1025 | 1026 | @ 1027 | 'equalizer' r r == 'id' 1028 | 'equalizer' ('point' True) ('point' False) == 'zeros' 1029 | @ 1030 | -} 1031 | equalizer :: 1032 | ( CountableN a 1033 | , FLN a a 1034 | ) => 1035 | Relation a b -> 1036 | Relation a b -> 1037 | Relation a a 1038 | equalizer f g = id `intersection` divisionF f g 1039 | 1040 | {- | Relational conditional guard. 1041 | 1042 | @ 1043 | 'guard' p = 'i2' ``overriddenBy`` 'i1' `.` 'predR' p 1044 | @ 1045 | -} 1046 | guard :: 1047 | ( Bounded b 1048 | , Enum b 1049 | , CountableN b 1050 | , FLN b b 1051 | , FLN Bool b 1052 | ) => 1053 | Relation b Bool -> 1054 | Relation b (Either b b) 1055 | guard p = conv (eitherR (predR p) (predR (negate p))) 1056 | 1057 | -- | Relational McCarthy's conditional. 1058 | cond :: 1059 | ( Bounded b 1060 | , Enum b 1061 | , CountableN b 1062 | , FLN b b 1063 | , FLN Bool b 1064 | ) => 1065 | Relation b Bool -> 1066 | Relation b c -> 1067 | Relation b c -> 1068 | Relation b c 1069 | cond p r s = eitherR r s . guard p 1070 | 1071 | {- | Relational domain. 1072 | 1073 | For injective relations, 'domain' and 'ker'nel coincide, 1074 | since @'ker' r ``sse`` 'id'@ in such situations. 1075 | -} 1076 | domain :: 1077 | ( CountableN a 1078 | , FLN a a 1079 | ) => 1080 | Relation a b -> 1081 | Relation a a 1082 | domain r = ker r `intersection` id 1083 | 1084 | {- | Relational range. 1085 | 1086 | For functions, 'range' and 'img' (image) coincide, 1087 | since @'img' f ``sse`` id@ for any @f@. 1088 | -} 1089 | range :: 1090 | ( CountableN b 1091 | , FLN b b 1092 | ) => 1093 | Relation a b -> 1094 | Relation b b 1095 | range r = img r `intersection` id 1096 | 1097 | -- Relation pretty print 1098 | 1099 | -- | Relation pretty printing 1100 | pretty :: (CountableDimsN a b) => Relation a b -> String 1101 | pretty (R a) = I.pretty a 1102 | 1103 | -- | Relation pretty printing 1104 | prettyPrint :: (CountableDimsN a b) => Relation a b -> IO () 1105 | prettyPrint (R a) = I.prettyPrint a 1106 | -------------------------------------------------------------------------------- /src/LAoP/Matrix/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE InstanceSigs #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE StrictData #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilyDependencies #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | {-# LANGUAGE NoStarIsType #-} 17 | 18 | ----------------------------------------------------------------------------- 19 | 20 | ----------------------------------------------------------------------------- 21 | 22 | {- | 23 | Module : LAoP.Matrix.Internal 24 | Copyright : (c) Armando Santos 2019-2020 25 | Maintainer : armandoifsantos@gmail.com 26 | Stability : experimental 27 | 28 | The LAoP discipline generalises relations and functions treating them as 29 | Boolean matrices and in turn consider these as arrows. 30 | 31 | __LAoP__ is a library for algebraic (inductive) construction and manipulation of matrices 32 | in Haskell. See for the 33 | motivation behind the library, the underlying theory, and implementation details. 34 | 35 | This module offers many of the combinators mentioned in the work of 36 | Macedo (2012) and Oliveira (2012). 37 | 38 | This is an Internal module and it is no supposed to be imported. 39 | -} 40 | module LAoP.Matrix.Internal ( 41 | -- | This definition makes use of the fact that 'Void' is 42 | -- isomorphic to 0 and '()' to 1 and captures matrix 43 | -- dimensions as stacks of 'Either's. 44 | -- 45 | -- There exists two type families that make it easier to write 46 | -- matrix dimensions: 'FromNat' and 'Count'. This approach 47 | -- leads to a very straightforward implementation 48 | -- of LAoP combinators. 49 | 50 | -- * Type safe matrix representation 51 | Matrix (..), 52 | 53 | -- * Constraint type aliases 54 | Countable, 55 | CountableDims, 56 | CountableN, 57 | CountableDimsN, 58 | FL, 59 | FLN, 60 | Liftable, 61 | Trivial, 62 | 63 | -- * Primitives 64 | one, 65 | join, 66 | fork, 67 | 68 | -- * Auxiliary type families 69 | FromNat, 70 | Count, 71 | Normalize, 72 | 73 | -- * Matrix construction and conversion 74 | FromLists, 75 | fromLists, 76 | toLists, 77 | toList, 78 | matrixBuilder, 79 | matrixBuilder', 80 | row, 81 | col, 82 | zeros, 83 | ones, 84 | bang, 85 | constant, 86 | 87 | -- * Misc 88 | 89 | -- ** Get dimensions 90 | columns, 91 | columns', 92 | rows, 93 | rows', 94 | 95 | -- ** Matrix Transposition 96 | tr, 97 | 98 | -- ** Scalar multiplication/division of matrices 99 | (.|), 100 | (./), 101 | 102 | -- ** Selective operator 103 | select, 104 | branch, 105 | 106 | -- ** McCarthy's Conditional 107 | cond, 108 | 109 | -- ** Matrix "abiding" 110 | abideJF, 111 | abideFJ, 112 | 113 | -- ** Zip matrices 114 | zipWithM, 115 | 116 | -- * Biproduct approach 117 | 118 | -- ** Fork 119 | (===), 120 | 121 | -- *** Projections 122 | p1, 123 | p2, 124 | 125 | -- ** Join 126 | (|||), 127 | 128 | -- *** Injections 129 | i1, 130 | i2, 131 | 132 | -- ** Bifunctors 133 | (-|-), 134 | (><), 135 | 136 | -- ** Applicative matrix combinators 137 | 138 | -- | Note that given the restrictions imposed it is not possible to 139 | -- implement the standard type classes present in standard Haskell. 140 | 141 | -- *** Matrix pairing projections 142 | fstM, 143 | sndM, 144 | 145 | -- *** Matrix pairing 146 | kr, 147 | 148 | -- * Matrix composition and lifting 149 | 150 | -- ** Arrow matrix combinators 151 | 152 | -- | Note that given the restrictions imposed it is not possible to 153 | -- implement the standard type classes present in standard Haskell. 154 | iden, 155 | comp, 156 | fromF', 157 | fromF, 158 | 159 | -- * Matrix printing 160 | pretty, 161 | prettyPrint, 162 | 163 | -- * Other 164 | toBool, 165 | fromBool, 166 | compRel, 167 | divR, 168 | divL, 169 | divS, 170 | fromFRel, 171 | fromFRel', 172 | toRel, 173 | negateM, 174 | orM, 175 | andM, 176 | subM, 177 | ) 178 | where 179 | 180 | import Control.DeepSeq 181 | import Data.Bool 182 | import Data.Kind 183 | import Data.List 184 | import Data.Maybe 185 | import Data.Proxy 186 | import Data.Type.Equality 187 | import GHC.Generics 188 | import GHC.TypeLits hiding (Natural) 189 | import LAoP.Utils.Internal 190 | import Prelude hiding (id, (.)) 191 | 192 | -- | LAoP (Linear Algebra of Programming) Inductive Matrix definition. 193 | data Matrix e cols rows where 194 | One :: e -> Matrix e () () 195 | Join :: Matrix e a rows -> Matrix e b rows -> Matrix e (Either a b) rows 196 | Fork :: Matrix e cols a -> Matrix e cols b -> Matrix e cols (Either a b) 197 | 198 | deriving instance (Show e) => Show (Matrix e cols rows) 199 | 200 | {- | Type family that computes the cardinality of a given type dimension. 201 | 202 | It can also count the cardinality of custom types that implement the 203 | 'Generic' instance. 204 | -} 205 | type family Count (d :: Type) :: Nat where 206 | Count (Natural n m) = (m - n) + 1 207 | Count (BoundedList a) = (^) 2 (Count a) 208 | Count (Either a b) = (+) (Count a) (Count b) 209 | Count (a, b) = (*) (Count a) (Count b) 210 | Count (a -> b) = (^) (Count b) (Count a) 211 | -- Generics 212 | Count (M1 _ _ f p) = Count (f p) 213 | Count (K1 _ _ _) = 1 214 | Count (V1 _) = 0 215 | Count (U1 _) = 1 216 | Count ((:*:) a b p) = Count (a p) * Count (b p) 217 | Count ((:+:) a b p) = Count (a p) + Count (b p) 218 | Count d = Count (Rep d R) 219 | 220 | {- | Type family that computes of a given type dimension from a given natural 221 | 222 | Thanks to Li-Yao Xia this type family is super fast. 223 | -} 224 | type family FromNat (n :: Nat) :: Type where 225 | FromNat 1 = () 226 | FromNat n = FromNat' (Mod n 2 == 0) (FromNat (Div n 2)) 227 | 228 | type family FromNat' (b :: Bool) (m :: Type) :: Type where 229 | FromNat' 'True m = Either m m 230 | FromNat' 'False m = Either () (Either m m) 231 | 232 | {- | Type family that normalizes the representation of a given data 233 | structure 234 | -} 235 | type family Normalize (d :: Type) :: Type where 236 | Normalize (Either a b) = Either (Normalize a) (Normalize b) 237 | Normalize d = FromNat (Count d) 238 | 239 | -- | Constraint type synonyms to keep the type signatures less convoluted 240 | type Countable a = KnownNat (Count a) 241 | 242 | type CountableN a = KnownNat (Count (Normalize a)) 243 | type CountableDims a b = (Countable a, Countable b) 244 | type CountableDimsN a b = (CountableN a, CountableN b) 245 | type FL a b = FromLists a b 246 | type FLN a b = FromLists (Normalize a) (Normalize b) 247 | type Liftable e a b = (Bounded a, Bounded b, Enum a, Enum b, Eq b, Num e, Ord e) 248 | type Trivial a = FromNat (Count a) ~ a 249 | 250 | {- | It is possible to implement a constrained version of the category type 251 | class. 252 | -} 253 | instance (Num e) => Category (Matrix e) where 254 | type Object (Matrix e) a = (FL a a, Countable a) 255 | id = iden 256 | (.) = comp 257 | 258 | instance (NFData e) => NFData (Matrix e cols rows) where 259 | rnf (One e) = rnf e 260 | rnf (Join a b) = rnf a `seq` rnf b 261 | rnf (Fork a b) = rnf a `seq` rnf b 262 | 263 | instance (Eq e) => Eq (Matrix e cols rows) where 264 | (One a) == (One b) = a == b 265 | (Join a b) == (Join c d) = a == c && b == d 266 | (Fork a b) == (Fork c d) = a == c && b == d 267 | x@(Fork _ _) == y@(Join _ _) = x == abideJF y 268 | x@(Join _ _) == y@(Fork _ _) = abideJF x == y 269 | 270 | instance (Num e) => Num (Matrix e cols rows) where 271 | a + b = zipWithM (+) a b 272 | 273 | a - b = zipWithM (-) a b 274 | 275 | a * b = zipWithM (*) a b 276 | 277 | abs (One a) = One (abs a) 278 | abs (Join a b) = Join (abs a) (abs b) 279 | abs (Fork a b) = Fork (abs a) (abs b) 280 | 281 | signum (One a) = One (signum a) 282 | signum (Join a b) = Join (signum a) (signum b) 283 | signum (Fork a b) = Fork (signum a) (signum b) 284 | 285 | fromInteger = error "fromInteger: doesn't exist" 286 | 287 | instance (Ord e) => Ord (Matrix e cols rows) where 288 | (One a) <= (One b) = a <= b 289 | (Join a b) <= (Join c d) = (a <= c) && (b <= d) 290 | (Fork a b) <= (Fork c d) = (a <= c) && (b <= d) 291 | x@(Fork _ _) <= y@(Join _ _) = x <= abideJF y 292 | x@(Join _ _) <= y@(Fork _ _) = abideJF x <= y 293 | 294 | -- Primitives 295 | 296 | -- | Unit matrix constructor 297 | one :: e -> Matrix e () () 298 | one = One 299 | 300 | -- | Matrix 'Join' constructor 301 | join :: Matrix e a rows -> Matrix e b rows -> Matrix e (Either a b) rows 302 | join = Join 303 | 304 | infixl 3 ||| 305 | 306 | -- | Matrix 'Join' constructor 307 | (|||) :: Matrix e a rows -> Matrix e b rows -> Matrix e (Either a b) rows 308 | (|||) = Join 309 | 310 | -- | Matrix 'Fork' constructor 311 | fork :: Matrix e cols a -> Matrix e cols b -> Matrix e cols (Either a b) 312 | fork = Fork 313 | 314 | infixl 2 === 315 | 316 | -- | Matrix 'Fork' constructor 317 | (===) :: Matrix e cols a -> Matrix e cols b -> Matrix e cols (Either a b) 318 | (===) = Fork 319 | 320 | -- Construction 321 | 322 | {- | Type class for defining the 'fromList' conversion function. 323 | 324 | Given that it is not possible to branch on types at the term level type 325 | classes are needed very much like an inductive definition but on types. 326 | -} 327 | class FromLists cols rows where 328 | -- | Build a matrix out of a list of list of elements. Throws a runtime 329 | -- error if the dimensions do not match. 330 | fromLists :: [[e]] -> Matrix e cols rows 331 | 332 | instance FromLists () () where 333 | fromLists [[e]] = One e 334 | fromLists _ = error "Wrong dimensions" 335 | 336 | instance (FromLists cols ()) => FromLists (Either () cols) () where 337 | fromLists [h : t] = Join (One h) (fromLists [t]) 338 | fromLists _ = error "Wrong dimensions" 339 | 340 | instance {-# OVERLAPPABLE #-} (FromLists a (), FromLists b (), Countable a) => FromLists (Either a b) () where 341 | fromLists [l] = 342 | let rowsA = fromInteger (natVal (Proxy :: Proxy (Count a))) 343 | in Join (fromLists [take rowsA l]) (fromLists [drop rowsA l]) 344 | fromLists _ = error "Wrong dimensions" 345 | 346 | instance (FromLists () rows) => FromLists () (Either () rows) where 347 | fromLists ([h] : t) = Fork (One h) (fromLists t) 348 | fromLists _ = error "Wrong dimensions" 349 | 350 | instance {-# OVERLAPPABLE #-} (FromLists () a, FromLists () b, Countable a) => FromLists () (Either a b) where 351 | fromLists l@([_] : _) = 352 | let rowsA = fromInteger (natVal (Proxy :: Proxy (Count a))) 353 | in Fork (fromLists (take rowsA l)) (fromLists (drop rowsA l)) 354 | fromLists _ = error "Wrong dimensions" 355 | 356 | instance 357 | (FromLists (Either a b) c, FromLists (Either a b) d, Countable c) => 358 | FromLists (Either a b) (Either c d) 359 | where 360 | fromLists l@(h : t) = 361 | let lh = length h 362 | rowsC = fromInteger (natVal (Proxy :: Proxy (Count c))) 363 | condition = all ((== lh) . length) t 364 | in if lh > 0 && condition 365 | then Fork (fromLists (take rowsC l)) (fromLists (drop rowsC l)) 366 | else error "Not all rows have the same length" 367 | fromLists _ = error "Wrong dimensions" 368 | 369 | {- | Matrix builder function. Constructs a matrix provided with 370 | a construction function that operates with indices. 371 | -} 372 | matrixBuilder' :: 373 | forall e cols rows. 374 | ( FL cols rows 375 | , CountableDims cols rows 376 | ) => 377 | ((Int, Int) -> e) -> 378 | Matrix e cols rows 379 | matrixBuilder' f = 380 | let c = fromInteger $ natVal (Proxy :: Proxy (Count cols)) 381 | r = fromInteger $ natVal (Proxy :: Proxy (Count rows)) 382 | positions = [(a, b) | a <- [0 .. (r - 1)], b <- [0 .. (c - 1)]] 383 | in fromLists . map (map f) . groupBy (\(x, _) (w, _) -> x == w) $ positions 384 | 385 | {- | Matrix builder function. Constructs a matrix provided with 386 | a construction function that operates with arbitrary types. 387 | -} 388 | matrixBuilder :: 389 | forall e a b. 390 | ( FLN a b 391 | , Enum a 392 | , Enum b 393 | , Bounded a 394 | , Bounded b 395 | , Countable b 396 | ) => 397 | ((a, b) -> e) -> 398 | Matrix e (Normalize a) (Normalize b) 399 | matrixBuilder f = 400 | let r = fromInteger $ natVal (Proxy :: Proxy (Count b)) 401 | positions = [(a, b) | a <- [minBound .. maxBound], b <- [minBound .. maxBound]] 402 | in fromLists . map (map f) . transpose . buildList r $ positions 403 | where 404 | buildList _ [] = [] 405 | buildList r l = take r l : buildList r (drop r l) 406 | 407 | -- | Constructs a column vector matrix 408 | col :: (FL () rows) => [e] -> Matrix e () rows 409 | col = fromLists . map (: []) 410 | 411 | -- | Constructs a row vector matrix 412 | row :: (FL cols ()) => [e] -> Matrix e cols () 413 | row = fromLists . (: []) 414 | 415 | {- | Lifts functions to matrices with arbitrary dimensions. 416 | 417 | NOTE: Be careful to not ask for a matrix bigger than the cardinality of 418 | types @a@ or @b@ allows. 419 | -} 420 | fromF' :: 421 | forall a b cols rows e. 422 | ( Liftable e a b 423 | , CountableDims cols rows 424 | , FL rows cols 425 | ) => 426 | (a -> b) -> 427 | Matrix e cols rows 428 | fromF' f = 429 | let minA = minBound @a 430 | maxA = maxBound @a 431 | minB = minBound @b 432 | maxB = maxBound @b 433 | ccols = fromInteger $ natVal (Proxy :: Proxy (Count cols)) 434 | rrows = fromInteger $ natVal (Proxy :: Proxy (Count rows)) 435 | elementsA = take ccols [minA .. maxA] 436 | elementsB = take rrows [minB .. maxB] 437 | combinations = (,) <$> elementsA <*> elementsB 438 | combAp = 439 | map snd 440 | . sort 441 | . map 442 | ( \(a, b) -> 443 | if f a == b 444 | then ((fromEnum a, fromEnum b), 1) 445 | else ((fromEnum a, fromEnum b), 0) 446 | ) 447 | $ combinations 448 | mList = buildList combAp rrows 449 | in tr $ fromLists mList 450 | where 451 | buildList [] _ = [] 452 | buildList l r = take r l : buildList (drop r l) r 453 | 454 | {- | Lifts functions to matrices with dimensions matching @a@ and @b@ 455 | cardinality's. 456 | -} 457 | fromF :: 458 | forall a b e. 459 | ( Liftable e a b 460 | , CountableDimsN a b 461 | , FLN b a 462 | ) => 463 | (a -> b) -> 464 | Matrix e (Normalize a) (Normalize b) 465 | fromF = fromF' 466 | 467 | -- Conversion 468 | 469 | -- | Converts a matrix to a list of lists of elements. 470 | toLists :: Matrix e cols rows -> [[e]] 471 | toLists (One e) = [[e]] 472 | toLists (Fork l r) = toLists l ++ toLists r 473 | toLists (Join l r) = zipWith (++) (toLists l) (toLists r) 474 | 475 | -- | Converts a matrix to a list of elements. 476 | toList :: Matrix e cols rows -> [e] 477 | toList = concat . toLists 478 | 479 | -- Zeros Matrix 480 | 481 | -- | The zero matrix. A matrix wholly filled with zeros. 482 | zeros :: (Num e, FL cols rows, CountableDims cols rows) => Matrix e cols rows 483 | zeros = matrixBuilder' (const 0) 484 | 485 | -- Ones Matrix 486 | 487 | {- | The ones matrix. A matrix wholly filled with ones. 488 | 489 | Also known as T (Top) matrix. 490 | -} 491 | ones :: (Num e, FL cols rows, CountableDims cols rows) => Matrix e cols rows 492 | ones = matrixBuilder' (const 1) 493 | 494 | -- Const Matrix 495 | 496 | {- | The constant matrix constructor. A matrix wholly filled with a given 497 | value. 498 | -} 499 | constant :: (FL cols rows, CountableDims cols rows) => e -> Matrix e cols rows 500 | constant e = matrixBuilder' (const e) 501 | 502 | -- Bang Matrix 503 | 504 | -- | The T (Top) row vector matrix. 505 | bang :: forall e cols. (Num e, Enum e, FL cols (), Countable cols) => Matrix e cols () 506 | bang = 507 | let c = fromInteger $ natVal (Proxy :: Proxy (Count cols)) 508 | in fromLists [take c [1, 1 ..]] 509 | 510 | -- iden Matrix 511 | 512 | -- | iden matrix. 513 | iden :: forall e cols. (Num e, FL cols cols, Countable cols) => Matrix e cols cols 514 | iden = matrixBuilder' (bool 0 1 . uncurry (==)) 515 | {-# NOINLINE iden #-} 516 | 517 | -- Matrix composition (MMM) 518 | 519 | {- | Matrix composition. Equivalent to matrix-matrix multiplication. 520 | 521 | This definition takes advantage of divide-and-conquer and fusion laws 522 | from LAoP. 523 | -} 524 | comp :: (Num e) => Matrix e cr rows -> Matrix e cols cr -> Matrix e cols rows 525 | comp (One a) (One b) = One (a * b) 526 | comp (Join a b) (Fork c d) = comp a c + comp b d -- Divide-and-conquer law 527 | comp (Fork a b) c = Fork (comp a c) (comp b c) -- Fork fusion law 528 | comp c (Join a b) = Join (comp c a) (comp c b) -- Join fusion law 529 | {-# NOINLINE comp #-} 530 | 531 | {-# RULES 532 | "comp/iden1" forall m. comp m iden = m 533 | "comp/iden2" forall m. comp iden m = m 534 | #-} 535 | 536 | -- Scalar multiplication of matrices 537 | 538 | infixl 7 .| 539 | 540 | -- | Scalar multiplication of matrices. 541 | (.|) :: (Num e) => e -> Matrix e cols rows -> Matrix e cols rows 542 | (.|) e (One a) = One (e * a) 543 | (.|) e (Join a b) = Join (e .| a) (e .| b) 544 | (.|) e (Fork a b) = Fork (e .| a) (e .| b) 545 | 546 | -- Scalar division of matrices 547 | 548 | infixl 7 ./ 549 | 550 | -- | Scalar multiplication of matrices. 551 | (./) :: (Fractional e) => Matrix e cols rows -> e -> Matrix e cols rows 552 | (./) (One a) e = One (a / e) 553 | (./) (Join a b) e = Join (a ./ e) (b ./ e) 554 | (./) (Fork a b) e = Fork (a ./ e) (b ./ e) 555 | 556 | -- Projections 557 | 558 | -- | Biproduct first component projection 559 | p1 :: (Num e, CountableDims n m, FL n m, FL m m) => Matrix e (Either m n) m 560 | p1 = join id zeros 561 | 562 | -- | Biproduct second component projection 563 | p2 :: (Num e, CountableDims n m, FL m n, FL n n) => Matrix e (Either m n) n 564 | p2 = join zeros id 565 | 566 | -- Injections 567 | 568 | -- | Biproduct first component injection 569 | i1 :: (Num e, CountableDims n m, FL n m, FL m m) => Matrix e m (Either m n) 570 | i1 = tr p1 571 | 572 | -- | Biproduct second component injection 573 | i2 :: (Num e, CountableDims n m, FL m n, FL n n) => Matrix e n (Either m n) 574 | i2 = tr p2 575 | 576 | -- Dimensions 577 | 578 | {- | Obtain the number of rows. 579 | 580 | NOTE: The 'KnownNat' constraint is needed in order to obtain the 581 | dimensions in constant time. For a version that doesn't require the 582 | constraint see 'rows''. 583 | -} 584 | rows :: forall e cols rows. (Countable rows) => Matrix e cols rows -> Int 585 | rows _ = fromInteger $ natVal (Proxy :: Proxy (Count rows)) 586 | 587 | {- | Obtain the number of rows in an inefficient manner, but without any 588 | constraints. 589 | 590 | For a more efficient version see 'rows'. 591 | -} 592 | rows' :: Matrix e cols rows -> Int 593 | rows' (One _) = 1 594 | rows' (Join lhs _) = rows' lhs 595 | rows' (Fork top bottom) = rows' top + rows' bottom 596 | 597 | {- | Obtain the number of columns. 598 | 599 | NOTE: The 'KnownNat' constraint is needed in order to obtain the 600 | dimensions in constant time. For a version that doesn't require the 601 | constraint see 'columns''. 602 | -} 603 | columns :: forall e cols rows. (Countable cols) => Matrix e cols rows -> Int 604 | columns _ = fromInteger $ natVal (Proxy :: Proxy (Count cols)) 605 | 606 | {- | Obtain the number of columns in an inefficient manner, but without any 607 | constraints. 608 | 609 | For a more efficient version see 'columns'. 610 | -} 611 | columns' :: Matrix e cols rows -> Int 612 | columns' (One _) = 1 613 | columns' (Join lhs rhs) = columns' lhs + columns' rhs 614 | columns' (Fork top _) = columns' top 615 | 616 | -- Coproduct Bifunctor 617 | 618 | infixl 5 -|- 619 | 620 | -- | Matrix coproduct functor also known as matrix direct sum. 621 | (-|-) :: 622 | forall e n k m j. 623 | ( Num e 624 | , CountableDims j k 625 | , FL k k 626 | , FL j k 627 | , FL k j 628 | , FL j j 629 | ) => 630 | Matrix e n k -> 631 | Matrix e m j -> 632 | Matrix e (Either n m) (Either k j) 633 | (-|-) a b = Join (i1 . a) (i2 . b) 634 | 635 | -- Khatri Rao Product and projections 636 | 637 | -- | Khatri Rao product first component projection matrix. 638 | fstM :: 639 | forall e m k. 640 | ( Num e 641 | , CountableDims k m 642 | , FL (Normalize (m, k)) m 643 | , CountableN (m, k) 644 | ) => 645 | Matrix e (Normalize (m, k)) m 646 | fstM = matrixBuilder' f 647 | where 648 | offset = fromInteger (natVal (Proxy :: Proxy (Count k))) 649 | f (x, y) 650 | | y >= (x * offset) && y <= (x * offset + offset - 1) = 1 651 | | otherwise = 0 652 | 653 | -- | Khatri Rao product second component projection matrix. 654 | sndM :: 655 | forall e m k. 656 | ( Num e 657 | , CountableDims k m 658 | , FL (Normalize (m, k)) k 659 | , CountableN (m, k) 660 | ) => 661 | Matrix e (Normalize (m, k)) k 662 | sndM = matrixBuilder' f 663 | where 664 | offset = fromInteger (natVal (Proxy :: Proxy (Count k))) 665 | f (x, y) 666 | | x == y || mod (y - x) offset == 0 = 1 667 | | otherwise = 0 668 | 669 | {- | Khatri Rao Matrix product also known as matrix pairing. 670 | 671 | NOTE: That this is not a true categorical product, see for instance: 672 | 673 | @ 674 | | fstM . kr a b == a 675 | kr a b ==> | 676 | | sndM . kr a b == b 677 | @ 678 | 679 | __Emphasis__ on the implication symbol. 680 | -} 681 | kr :: 682 | forall e cols a b. 683 | ( Num e 684 | , CountableDims a b 685 | , CountableN (a, b) 686 | , FL (Normalize (a, b)) a 687 | , FL (Normalize (a, b)) b 688 | ) => 689 | Matrix e cols a -> 690 | Matrix e cols b -> 691 | Matrix e cols (Normalize (a, b)) 692 | kr a b = 693 | let fstM' = fstM @e @a @b 694 | sndM' = sndM @e @a @b 695 | in (tr fstM' . a) * (tr sndM' . b) 696 | 697 | -- Product Bifunctor (Kronecker) 698 | 699 | infixl 4 >< 700 | 701 | -- | Matrix product functor also known as kronecker product 702 | (><) :: 703 | forall e m p n q. 704 | ( Num e 705 | , CountableDims m n 706 | , CountableDims p q 707 | , CountableDimsN (m, n) (p, q) 708 | , FL (Normalize (m, n)) m 709 | , FL (Normalize (m, n)) n 710 | , FL (Normalize (p, q)) p 711 | , FL (Normalize (p, q)) q 712 | ) => 713 | Matrix e m p -> 714 | Matrix e n q -> 715 | Matrix e (Normalize (m, n)) (Normalize (p, q)) 716 | (><) a b = 717 | let fstM' = fstM @e @m @n 718 | sndM' = sndM @e @m @n 719 | in kr (a . fstM') (b . sndM') 720 | 721 | -- Matrix abide Join Fork 722 | 723 | {- | Matrix "abiding" following the 'Join'-'Fork' exchange law. 724 | 725 | Law: 726 | 727 | @ 728 | 'Join' ('Fork' a c) ('Fork' b d) == 'Fork' ('Join' a b) ('Join' c d) 729 | @ 730 | -} 731 | abideJF :: Matrix e cols rows -> Matrix e cols rows 732 | abideJF (Join (Fork a c) (Fork b d)) = Fork (Join (abideJF a) (abideJF b)) (Join (abideJF c) (abideJF d)) -- Join-Fork abide law 733 | abideJF (One e) = One e 734 | abideJF (Join a b) = Join (abideJF a) (abideJF b) 735 | abideJF (Fork a b) = Fork (abideJF a) (abideJF b) 736 | 737 | -- Matrix abide Fork Join 738 | 739 | {- | Matrix "abiding" followin the 'Fork'-'Join' abide law. 740 | 741 | @ 742 | 'Fork' ('Join' a b) ('Join' c d) == 'Join' ('Fork' a c) ('Fork' b d) 743 | @ 744 | -} 745 | abideFJ :: Matrix e cols rows -> Matrix e cols rows 746 | abideFJ (Fork (Join a b) (Join c d)) = Join (Fork (abideFJ a) (abideFJ c)) (Fork (abideFJ b) (abideFJ d)) -- Fork-Join abide law 747 | abideFJ (One e) = One e 748 | abideFJ (Join a b) = Join (abideFJ a) (abideFJ b) 749 | abideFJ (Fork a b) = Fork (abideFJ a) (abideFJ b) 750 | 751 | -- Matrix transposition 752 | 753 | -- | Matrix transposition. 754 | tr :: Matrix e cols rows -> Matrix e rows cols 755 | tr (One e) = One e 756 | tr (Join a b) = Fork (tr a) (tr b) 757 | tr (Fork a b) = Join (tr a) (tr b) 758 | 759 | -- Selective 'select' operator 760 | 761 | {- | Selective functors 'select' operator equivalent inspired by the 762 | ArrowMonad solution presented in the paper. 763 | -} 764 | select :: (Num e, FL b b, Countable b) => Matrix e cols (Either a b) -> Matrix e a b -> Matrix e cols b 765 | select (Fork a b) y = y . a + b -- Divide-and-conquer law 766 | select (Join (Fork a c) (Fork b d)) y = join (y . a + c) (y . b + d) -- Pattern matching + DnC law 767 | select m y = join y id . m 768 | 769 | branch :: 770 | ( Num e 771 | , CountableDims a b 772 | , CountableDims c (Either b c) 773 | , FL c b 774 | , FL a b 775 | , FL a a 776 | , FL b b 777 | , FL c c 778 | , FL b a 779 | , FL b c 780 | , FL (Either b c) b 781 | , FL (Either b c) c 782 | ) => 783 | Matrix e cols (Either a b) -> 784 | Matrix e a c -> 785 | Matrix e b c -> 786 | Matrix e cols c 787 | branch x l r = f x `select` g l `select` r 788 | where 789 | f :: 790 | (Num e, Countable a, CountableDims b c, FL a b, FL c b, FL b b, FL b a, FL a a) => 791 | Matrix e cols (Either a b) -> 792 | Matrix e cols (Either a (Either b c)) 793 | f m = fork (tr i1) (i1 . tr i2) . m 794 | g :: (Num e, CountableDims b c, FL b c, FL c c) => Matrix e a c -> Matrix e a (Either b c) 795 | g m = i2 . m 796 | 797 | -- McCarthy's Conditional 798 | 799 | -- | McCarthy's Conditional expresses probabilistic choice. 800 | cond :: 801 | ( Trivial cols 802 | , Countable cols 803 | , FL () cols 804 | , FL cols () 805 | , FL cols cols 806 | , Bounded a 807 | , Enum a 808 | , Num e 809 | , Ord e 810 | ) => 811 | (a -> Bool) -> 812 | Matrix e cols rows -> 813 | Matrix e cols rows -> 814 | Matrix e cols rows 815 | cond p f g = join f g . grd p 816 | 817 | grd :: 818 | ( Trivial q 819 | , Countable q 820 | , FL () q 821 | , FL q () 822 | , FL q q 823 | , Bounded a 824 | , Enum a 825 | , Num e 826 | , Ord e 827 | ) => 828 | (a -> Bool) -> 829 | Matrix e q (Either q q) 830 | grd f = fork (corr f) (corr (not . f)) 831 | 832 | corr :: 833 | forall e a q. 834 | ( Trivial q 835 | , Countable q 836 | , FL () q 837 | , FL q () 838 | , FL q q 839 | , Liftable e a Bool 840 | ) => 841 | (a -> Bool) -> 842 | Matrix e q q 843 | corr p = 844 | let f = fromF' p :: Matrix e q () 845 | in kr f (id :: Matrix e q q) 846 | 847 | -- Pretty print 848 | 849 | -- | Matrix pretty printer 850 | pretty :: (CountableDims cols rows, Show e) => Matrix e cols rows -> String 851 | pretty m = 852 | concat 853 | [ "┌ " 854 | , unwords (replicate (columns m) blank) 855 | , " ┐\n" 856 | , unlines 857 | ["│ " ++ unwords (fmap (fill . show . getElem i) [1 .. columns m]) ++ " │" | i <- [1 .. rows m]] 858 | , "└ " 859 | , unwords (replicate (columns m) blank) 860 | , " ┘" 861 | ] 862 | where 863 | strings = map show (toList m) 864 | widest = maximum $ map length strings 865 | fill str = replicate (widest - length str) ' ' ++ str 866 | blank = fill "" 867 | safeGet i j 868 | | i > rows m || j > columns m || i < 1 || j < 1 = Nothing 869 | | otherwise = Just $ unsafeGet i j (toList m) 870 | unsafeGet i j l = l !! encode (i, j) 871 | encode (i, j) = (i - 1) * columns m + j - 1 872 | getElem i j = 873 | fromMaybe 874 | ( error $ 875 | "getElem: Trying to get the " 876 | ++ show (i, j) 877 | ++ " element from a " 878 | ++ show (rows m) 879 | ++ "x" 880 | ++ show (columns m) 881 | ++ " matrix." 882 | ) 883 | (safeGet i j) 884 | 885 | -- | Matrix pretty printer 886 | prettyPrint :: (CountableDims cols rows, Show e) => Matrix e cols rows -> IO () 887 | prettyPrint = putStrLn . pretty 888 | 889 | -- | Zip two matrices with a given binary function 890 | zipWithM :: (e -> f -> g) -> Matrix e cols rows -> Matrix f cols rows -> Matrix g cols rows 891 | zipWithM f (One a) (One b) = One (f a b) 892 | zipWithM f (Join a b) (Join c d) = Join (zipWithM f a c) (zipWithM f b d) 893 | zipWithM f (Fork a b) (Fork c d) = Fork (zipWithM f a c) (zipWithM f b d) 894 | zipWithM f x@(Fork _ _) y@(Join _ _) = zipWithM f x (abideJF y) 895 | zipWithM f x@(Join _ _) y@(Fork _ _) = zipWithM f (abideJF x) y 896 | 897 | -- Relational operators functions 898 | 899 | type Boolean = Natural 0 1 900 | type Relation a b = Matrix Boolean a b 901 | 902 | -- | Helper conversion function 903 | toBool :: (Num e, Eq e) => e -> Bool 904 | toBool n 905 | | n == 0 = False 906 | | n == 1 = True 907 | | otherwise = error "toBool: argument out of range" 908 | 909 | -- | Helper conversion function 910 | fromBool :: Bool -> Natural 0 1 911 | fromBool True = reifyToNatural 1 912 | fromBool False = reifyToNatural 0 913 | 914 | -- | Relational negation 915 | negateM :: Relation cols rows -> Relation cols rows 916 | negateM (One (Nat p)) = One (Nat (negate p)) 917 | negateM (Join a b) = Join (negateM a) (negateM b) 918 | negateM (Fork a b) = Fork (negateM a) (negateM b) 919 | 920 | -- | Relational addition 921 | orM :: Relation cols rows -> Relation cols rows -> Relation cols rows 922 | orM (One a) (One b) = One (fromBool (toBool a || toBool b)) 923 | orM (Join a b) (Join c d) = Join (orM a c) (orM b d) 924 | orM (Fork a b) (Fork c d) = Fork (orM a c) (orM b d) 925 | orM x@(Fork _ _) y@(Join _ _) = orM x (abideJF y) 926 | orM x@(Join _ _) y@(Fork _ _) = orM (abideJF x) y 927 | 928 | -- | Relational multiplication 929 | andM :: Relation cols rows -> Relation cols rows -> Relation cols rows 930 | andM (One a) (One b) = One (fromBool (toBool a && toBool b)) 931 | andM (Join a b) (Join c d) = Join (andM a c) (andM b d) 932 | andM (Fork a b) (Fork c d) = Fork (andM a c) (andM b d) 933 | andM x@(Fork _ _) y@(Join _ _) = andM x (abideJF y) 934 | andM x@(Join _ _) y@(Fork _ _) = andM (abideJF x) y 935 | 936 | -- | Relational subtraction 937 | subM :: Relation cols rows -> Relation cols rows -> Relation cols rows 938 | subM (One a) (One b) = if a - b < reifyToNatural 0 then One (reifyToNatural 0) else One (a - b) 939 | subM (Join a b) (Join c d) = Join (subM a c) (subM b d) 940 | subM (Fork a b) (Fork c d) = Fork (subM a c) (subM b d) 941 | subM x@(Fork _ _) y@(Join _ _) = subM x (abideJF y) 942 | subM x@(Join _ _) y@(Fork _ _) = subM (abideJF x) y 943 | 944 | -- | Matrix relational composition. 945 | compRel :: Relation cr rows -> Relation cols cr -> Relation cols rows 946 | compRel (One a) (One b) = One (fromBool (toBool a && toBool b)) 947 | compRel (Join a b) (Fork c d) = orM (compRel a c) (compRel b d) -- Divide-and-conquer law 948 | compRel (Fork a b) c = Fork (compRel a c) (compRel b c) -- Fork fusion law 949 | compRel c (Join a b) = Join (compRel c a) (compRel c b) -- Join fusion law 950 | 951 | -- | Matrix relational right division 952 | divR :: Relation b c -> Relation b a -> Relation a c 953 | divR (One a) (One b) = One (fromBool (not (toBool b) || toBool a)) -- b implies a 954 | divR (Join a b) (Join c d) = andM (divR a c) (divR b d) 955 | divR (Fork a b) c = Fork (divR a c) (divR b c) 956 | divR c (Fork a b) = Join (divR c a) (divR c b) 957 | 958 | -- | Matrix relational left division 959 | divL :: Relation c b -> Relation a b -> Relation a c 960 | divL x y = tr (divR (tr y) (tr x)) 961 | 962 | -- | Matrix relational symmetric division 963 | divS :: Relation c a -> Relation b a -> Relation c b 964 | divS s r = divL r s `intersection` divR (tr r) (tr s) 965 | where 966 | intersection = andM 967 | 968 | {- | Lifts functions to relations with arbitrary dimensions. 969 | 970 | NOTE: Be careful to not ask for a relation bigger than the cardinality of 971 | types @a@ or @b@ allows. 972 | -} 973 | fromFRel' :: 974 | forall a b cols rows. 975 | ( Liftable Boolean a b 976 | , CountableDims cols rows 977 | , FL rows cols 978 | ) => 979 | (a -> b) -> 980 | Relation cols rows 981 | fromFRel' = fromF' 982 | 983 | {- | Lifts functions to relations with dimensions matching @a@ and @b@ 984 | cardinality's. 985 | -} 986 | fromFRel :: 987 | forall a b. 988 | ( Liftable Boolean a b 989 | , CountableDimsN a b 990 | , FLN b a 991 | ) => 992 | (a -> b) -> 993 | Relation (Normalize a) (Normalize b) 994 | fromFRel = fromFRel' 995 | 996 | -- | Lifts a relation function to a Boolean Matrix 997 | toRel :: 998 | forall a b. 999 | ( Bounded a 1000 | , Bounded b 1001 | , Enum a 1002 | , Enum b 1003 | , CountableDims a b 1004 | , FLN b a 1005 | ) => 1006 | (a -> b -> Bool) -> 1007 | Relation (Normalize a) (Normalize b) 1008 | toRel f = 1009 | let minA = minBound @a 1010 | maxA = maxBound @a 1011 | minB = minBound @b 1012 | maxB = maxBound @b 1013 | ccols = fromInteger $ natVal (Proxy :: Proxy (Count a)) 1014 | rrows = fromInteger $ natVal (Proxy :: Proxy (Count b)) 1015 | elementsA = take ccols [minA .. maxA] 1016 | elementsB = take rrows [minB .. maxB] 1017 | combinations = (,) <$> elementsA <*> elementsB 1018 | combAp = 1019 | map snd 1020 | . sort 1021 | . map 1022 | ( \(a, b) -> 1023 | if uncurry f (a, b) 1024 | then ((fromEnum a, fromEnum b), reifyToNatural 1) 1025 | else ((fromEnum a, fromEnum b), reifyToNatural 0) 1026 | ) 1027 | $ combinations 1028 | mList = buildList combAp rrows 1029 | in tr $ fromLists mList 1030 | where 1031 | buildList [] _ = [] 1032 | buildList l r = take r l : buildList (drop r l) r 1033 | --------------------------------------------------------------------------------