├── .github └── workflows │ └── build.yml ├── .gitignore ├── CHANGES.md ├── Makefile ├── README.md ├── TODO ├── alg.opam ├── docs ├── .gitignore └── Makefile ├── dune-project ├── src ├── .gitignore ├── ARS.ml ├── Makefile ├── algebra.ml ├── alphabet.ml ├── automaton.ml ├── category.ml ├── combinatoryLogic.ml ├── dune ├── extlib.ml ├── field.ml ├── globular.ml ├── graph.ml ├── group.ml ├── hypergraph.ml ├── matrix.ml ├── module.ml ├── monoid.ml ├── precategory.ml ├── precubical.ml ├── ring.ml ├── series.ml ├── simplicial.ml ├── term.ml ├── test │ └── test.ml └── utils.ml ├── test ├── .gitignore ├── 2group │ ├── Makefile │ ├── dune │ ├── groups.ml │ └── groups2.ml ├── Makefile ├── anick0.ml ├── anick1.ml ├── anick2.ml ├── anick3.ml ├── braids.ml ├── catpres.ml ├── cl.ml ├── dihedral.ml ├── dune ├── gen.ml ├── jordan.ml ├── kb.ml ├── kleene.ml ├── mirai.ml ├── mon.ml ├── mone.ml ├── moni.ml ├── qgroup.ml ├── quaternion.ml ├── rig.ml ├── squierGroup.ml ├── squierGroupFull.tex ├── squierMonoid.ml ├── stl.ml ├── stl2.ml ├── uatao.ml └── uatao2.ml └── tools ├── Makefile ├── bergman ├── Makefile ├── bergman ├── bergman.css ├── bergman.ml ├── bergmanjs.ml ├── dune ├── index.html ├── lexer.mll ├── parser.mly └── pol.ml ├── kb ├── .merlin ├── Makefile ├── dune ├── index.html ├── kb.css ├── kb.ml ├── lexer.mll ├── parser.mly └── parserRefs.ml └── rewr2 ├── Makefile ├── dune ├── index.html └── rewr2.ml /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: Build 2 | on: [push] 3 | jobs: 4 | build: 5 | runs-on: ubuntu-latest 6 | steps: 7 | - name: Checkout code 8 | uses: actions/checkout@v4 9 | - name: Install required packages 10 | run: sudo apt-get -y install ocaml ocaml-dune ocaml-odoc js-of-ocaml pandoc 11 | - name: Build 12 | run: dune build 13 | - name: Test 14 | run: dune runtest 15 | - name: Build doc 16 | run: make -C docs && rm -f docs/.gitignore 17 | - name: Upload website artifact 18 | uses: actions/upload-pages-artifact@v3 19 | with: 20 | path: docs 21 | deploy: 22 | needs: build 23 | permissions: 24 | pages: write 25 | id-token: write 26 | environment: 27 | name: github-pages 28 | url: ${{ steps.deployment.outputs.page_url }} 29 | runs-on: ubuntu-latest 30 | steps: 31 | - name: Deploy website 32 | id: deployment 33 | uses: actions/deploy-pages@v4 34 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.aux 3 | *.log 4 | *.pdf 5 | _build 6 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 0.2.0 (unreleased) 2 | ===== 3 | 4 | - abstract rewriting systems: 5 | - added 6 | - monoids: 7 | - named rules 8 | - critical branchings 9 | - rewriting paths and zigzags 10 | - coherence cells 11 | - groups: 12 | - add the quaternion group 13 | - precubical sets 14 | 15 | 0.1.0 (22-11-2023) 16 | ===== 17 | 18 | - Initial release. 19 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: build 2 | 3 | build: 4 | @dune build 5 | 6 | doc: 7 | @dune build @doc 8 | 9 | clean: 10 | @dune clean 11 | 12 | test: 13 | @dune runtest 14 | 15 | .PHONY: test 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | OCaml algebra 2 | ========= 3 | 4 | A library to manipulate and compute with algebraic structures in OCaml. It 5 | implements structures such as 6 | 7 | - monoids 8 | - groups 9 | - rings 10 | - modules 11 | - algebras 12 | - matrices 13 | - graphs 14 | - automata 15 | - and so on... 16 | 17 | It also features some free and presented such structures. 18 | 19 | Documentation 20 | ------------- 21 | 22 | You can have a look at the [generated documentation for the 23 | modules](https://smimram.github.io/ocaml-alg/alg/). 24 | 25 | Tools 26 | ----- 27 | 28 | Some online tools are implemented using this library: 29 | 30 | - [Bergman 2](https://smimram.github.io/ocaml-alg/bergman/) is a new 31 | implementation for a Gröbner basis calculator 32 | - [KB](https://smimram.github.io/ocaml-alg/kb/) implements Knuth-Bendix and 33 | Squier completion on term rewriting systems 34 | - [Rewr 2](https://smimram.github.io/ocaml-alg/rewr2/) implements Knuth-Bendix completion for string rewriting systems 35 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | - use Alphabet.Map instead of Map.Make 2 | - move Bergman here 3 | -------------------------------------------------------------------------------- /alg.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.2.0" 4 | synopsis: "A library for manipulating various algebraic structures" 5 | description: 6 | "A library to manipulate and compute with algebraic structures in OCaml. It implements structures such as monoids, groups, rings, modules, algebras, matrices, graphs, automata and so on. It also features some free and presented such structures." 7 | maintainer: ["Samuel Mimram "] 8 | authors: ["Samuel Mimram "] 9 | license: "GPL-2.0" 10 | homepage: "https://github.com/smimram/ocaml-alg" 11 | bug-reports: "https://github.com/smimram/ocaml-alg/issues" 12 | depends: [ 13 | "dune" {>= "2.8"} 14 | "odoc" {with-doc} 15 | ] 16 | build: [ 17 | ["dune" "subst"] {dev} 18 | [ 19 | "dune" 20 | "build" 21 | "-p" 22 | name 23 | "-j" 24 | jobs 25 | "@install" 26 | "@runtest" {with-test} 27 | "@doc" {with-doc} 28 | ] 29 | ] 30 | dev-repo: "git+https://github.com/smimram/ocaml-alg.git" 31 | -------------------------------------------------------------------------------- /docs/.gitignore: -------------------------------------------------------------------------------- 1 | alg 2 | bergman 3 | kb 4 | rewr2 5 | index.html 6 | -------------------------------------------------------------------------------- /docs/Makefile: -------------------------------------------------------------------------------- 1 | DOCS_DIR := $(shell pwd) 2 | 3 | all: alg bergman kb rewr2 index.html 4 | 5 | index.html: 6 | pandoc -s ../README.md -o $@ 7 | 8 | doc build: 9 | $(MAKE) -C .. $@ 10 | 11 | clean: 12 | rm -rf alg bergman kb rewr2 13 | 14 | alg: doc 15 | mkdir -p $@ 16 | cp -r ../_build/default/_doc/_html/* alg/ 17 | chmod -R +w alg/* 18 | 19 | bergman: build 20 | mkdir -p $@ 21 | cd ../_build/default/tools/bergman; mv bergmanjs.bc.js bergman.js; cp index.html bergman.css bergman.js $(DOCS_DIR)/bergman 22 | 23 | kb: build 24 | mkdir -p $@ 25 | cd ../_build/default/tools/kb; mv kb.bc.js kb.js; cp index.html kb.css kb.js $(DOCS_DIR)/kb 26 | 27 | rewr2: build 28 | mkdir -p $@ 29 | cd ../_build/default/tools/rewr2; mv rewr2.bc.js rewr2.js; cp index.html rewr2.js $(DOCS_DIR)/rewr2 30 | 31 | ci: all 32 | git ci . -m "Update documentation." 33 | 34 | %.html: %.md 35 | pandoc -s $< -o $@ 36 | 37 | .PHONY: alg bergman kb 38 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (version 0.2.0) 3 | (name alg) 4 | (source (github smimram/ocaml-alg)) 5 | (license GPL-2.0) 6 | (authors "Samuel Mimram ") 7 | (maintainers "Samuel Mimram ") 8 | 9 | (generate_opam_files true) 10 | 11 | (package 12 | (name alg) 13 | (synopsis "A library for manipulating various algebraic structures") 14 | (description "A library to manipulate and compute with algebraic structures in OCaml. It implements structures such as monoids, groups, rings, modules, algebras, matrices, graphs, automata and so on. It also features some free and presented such structures.") 15 | ) 16 | -------------------------------------------------------------------------------- /src/.gitignore: -------------------------------------------------------------------------------- 1 | test 2 | -------------------------------------------------------------------------------- /src/ARS.ml: -------------------------------------------------------------------------------- 1 | (** Abstract rewriting systems. *) 2 | 3 | (** Signature for specifying rewriting steps. *) 4 | module type Span = sig 5 | type obj 6 | 7 | type t 8 | 9 | val source : t -> obj 10 | 11 | val target : t -> obj 12 | 13 | val eq : t -> t -> bool 14 | 15 | val to_string : t -> string 16 | end 17 | 18 | (** Create an abstract rewriting system with given objects and rewriting 19 | steps. *) 20 | module Make (Obj : Alphabet.T) (Step : Span with type obj = Obj.t) = struct 21 | (** Rewriting paths. *) 22 | module Path = struct 23 | type t = 24 | | Empty of Obj.t 25 | | Step of t * Step.t 26 | 27 | let empty u = Empty u 28 | 29 | let step s = Step (Empty (Step.source s), s) 30 | 31 | let rec source = function 32 | | Empty u -> u 33 | | Step (p, _) -> source p 34 | 35 | let target = function 36 | | Empty u -> u 37 | | Step (_, r) -> Step.target r 38 | 39 | let rec to_string = function 40 | | Empty u -> Obj.to_string u 41 | | Step (p, s) -> Printf.sprintf "%s -%s→ %s" (to_string p) (Step.to_string s) (Obj.to_string (Step.target s)) 42 | 43 | let rec eq p q = 44 | match p, q with 45 | | Empty u, Empty u' -> Obj.eq u u' 46 | | Step (p, s), Step (p', s') -> eq p p' && Step.eq s s' 47 | | _ -> false 48 | 49 | let append_step p s = 50 | assert (Obj.eq (target p) (Step.source s)); 51 | Step (p,s) 52 | 53 | let rec append p = function 54 | | Step (q, s) -> Step (append p q, s) 55 | | Empty t -> 56 | assert (Obj.eq (target p) t); 57 | p 58 | 59 | (** Length of a path. *) 60 | let rec length = function 61 | | Step (p, _) -> 1 + length p 62 | | Empty _ -> 0 63 | end 64 | 65 | (** Rewriting zigzags. *) 66 | module Zigzag = struct 67 | (** A rewriting zigzag. *) 68 | type t = 69 | | Step of Step.t 70 | | Comp of t * t 71 | | Id of Obj.t 72 | | Inv of t 73 | 74 | (** String representation. *) 75 | let rec to_string = function 76 | | Step s -> Step.to_string s 77 | | Comp (p1,p2) -> "(" ^ to_string p1 ^ "." ^ to_string p2 ^ ")" 78 | | Id t -> Obj.to_string t 79 | | Inv p -> "(" ^ to_string p ^ ")-" 80 | 81 | let rec source = function 82 | | Step s -> Step.source s 83 | | Comp (p, _) -> source p 84 | | Id t -> t 85 | | Inv p -> target p 86 | and target = function 87 | | Step s -> Step.target s 88 | | Comp (_, p) -> target p 89 | | Id t -> t 90 | | Inv p -> source p 91 | 92 | (** Equality between paths. *) 93 | let rec eq p p' = 94 | match p, p' with 95 | | Step s, Step s' -> Step.eq s s' 96 | | Comp (p, q), Comp (p', q') -> eq p p' && eq q q' 97 | | Id t, Id t' -> Obj.eq t t' 98 | | Inv p, Inv p' -> eq p p' 99 | | _ -> false 100 | 101 | (** Number of steps in a path. *) 102 | let rec length = function 103 | | Step _ -> 1 104 | | Comp (p, q) -> length p + length q 105 | | Id _ -> 0 106 | | Inv p -> length p 107 | 108 | (** Path reduced to one step. *) 109 | let step s = Step s 110 | 111 | (** Concatenation of two paths. *) 112 | let append p1 p2 = 113 | (* Printf.printf "compose %s with %s\n%!" (to_string p1) (to_string p2); *) 114 | (* Printf.printf "%s vs %s\n%!" (string_of_term (target p1)) (string_of_term (source p2)); *) 115 | assert (Obj.eq (target p1) (source p2)); 116 | Comp (p1, p2) 117 | 118 | let comp = append 119 | 120 | (** Concatenation of a list of paths. *) 121 | let rec concat = function 122 | | [p] -> p 123 | | p::l -> append p (concat l) 124 | | [] -> assert false 125 | 126 | (** Inverse of a path. *) 127 | let inv p = Inv p 128 | 129 | (** Create a zigzag from a path. *) 130 | let rec of_path p = 131 | match p with 132 | | Path.Empty t -> Id t 133 | | Step (p, s) -> append (of_path p) (step s) 134 | 135 | (** Put path in canonical form. *) 136 | let rec canonize p = 137 | (* Printf.printf "canonize: %s\n%!" (to_string p); *) 138 | match p with 139 | | Comp (Id _, p) -> canonize p 140 | | Comp (p, Id _) -> canonize p 141 | | Comp (Comp (p, q), r) -> canonize (Comp (p, Comp (q, r))) 142 | | Comp (Step s, p) -> 143 | ( 144 | match canonize p with 145 | | Inv (Step s') when Step.eq s s' -> Id (Step.source s) 146 | | Comp (Inv (Step s'), p) when Step.eq s s' -> p 147 | | Id _ -> Step s 148 | | p -> Comp (Step s, p) 149 | ) 150 | | Comp (Inv (Step s), p) -> 151 | ( 152 | match canonize p with 153 | | Step s' when Step.eq s s' -> Id (Step.target s') 154 | | Comp (Step s', p) when Step.eq s s' -> p 155 | | Id _ -> Inv (Step s) 156 | | p -> Comp (Inv (Step s), p) 157 | ) 158 | | Comp (p, q) -> canonize (Comp (canonize p, q)) 159 | | Inv (Inv p) -> canonize p 160 | | Inv (Comp (p, q)) -> canonize (Comp (Inv q, Inv p)) 161 | | Inv (Id t) -> Id t 162 | | Inv (Step s) -> Inv (Step s) 163 | | Id t -> Id t 164 | | Step s -> Step s 165 | 166 | (** Apply a context function to a path. We need to have two function because 167 | of typing issues (variance and polymorphic variants...), but they will 168 | always be the same in practice. *) 169 | let rec map tm rs = function 170 | | Step s -> Step (rs s) 171 | | Comp (p, q) -> Comp (map tm rs p, map tm rs q) 172 | | Id t -> Id (tm t) 173 | | Inv p -> Inv (map tm rs p) 174 | 175 | let is_id = function 176 | | Id _ -> true 177 | | _ -> false 178 | 179 | let is_inv = function 180 | | Inv _ -> true 181 | | _ -> false 182 | 183 | (** List.of_steps in a path. *) 184 | let rec to_list = function 185 | | Step s -> [Step s] 186 | | Comp (p, q) -> (to_list p)@(to_list q) 187 | | Id _ -> [] 188 | | Inv p -> List.map (fun p -> Inv p) (List.rev (to_list p)) 189 | end 190 | end 191 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | @dune build 3 | 4 | test: 5 | @dune exec test/test.exe 6 | 7 | .PHONY: test 8 | -------------------------------------------------------------------------------- /src/algebra.ml: -------------------------------------------------------------------------------- 1 | (** Algebras. *) 2 | 3 | (** An algebra. *) 4 | module type T = sig 5 | (** An element of the algebra. *) 6 | type t 7 | 8 | (** An element of the ring. *) 9 | type r 10 | 11 | include Ring.T with type t := t 12 | 13 | module Field : sig 14 | include Field.T with type t := r 15 | end 16 | 17 | (** Multiplication by a scalar. *) 18 | val cmul : r -> t -> t 19 | end 20 | 21 | (** Algebras over rings (contarily to usual algebras which are over fields). *) 22 | module OverRing = struct 23 | (** Free algebra of a monoid over a ring. *) 24 | module Free (K : Ring.T) (M : Monoid.T) = struct 25 | include Module.FreeLeft(K)(M) 26 | 27 | let one = inj M.one 28 | 29 | let mul_monomial p v = 30 | map (fun u -> inj (M.mul u v)) p 31 | 32 | let mul p q = 33 | map (fun v -> mul_monomial p v) q 34 | 35 | let leading leq (p:t) : K.t * M.t = 36 | let a = ref K.zero in 37 | let u = ref M.one in 38 | iter (fun b v -> if leq !u v then (a := b; u := v)) p; 39 | !a, !u 40 | end 41 | end 42 | 43 | (** Free algebra of a monoid over a field. *) 44 | module Free (K : Field.T) (M : Monoid.T) = struct 45 | include OverRing.Free(K)(M) 46 | 47 | module Field = K 48 | end 49 | module FreeAlgebra (K : Field.T) (M : Monoid.T) = (Free(K)(M) : T) 50 | 51 | (** Presentation of an algebra. *) 52 | module Pres (K : Field.T) (X : Alphabet.T) = struct 53 | module M = Monoid.Free(X) 54 | module A = Free(K)(M) 55 | 56 | type t = 57 | { 58 | leq : M.t -> M.t -> bool; 59 | generators : X.t list; 60 | rules : (M.t * A.t) list; 61 | } 62 | 63 | let free leq generators = 64 | let rules = [] in 65 | { leq; generators; rules } 66 | 67 | (** Orient a polynomial as a rule. *) 68 | let orient pres p = 69 | let a,u = A.leading pres.leq p in 70 | let p = A.cmul (K.inv a) p in 71 | let p = A.sub (A.inj u) p in 72 | u,p 73 | 74 | (** Add a rule to a presentation. *) 75 | let add_rule pres r = 76 | let rules = r :: pres.rules in 77 | { pres with rules } 78 | 79 | (** Add a relation to a presentation. *) 80 | let add_relation pres p = 81 | add_rule pres (orient pres p) 82 | 83 | (** Create a presentation from an alphabet and a list of monomials. *) 84 | let make leq generators pp : t = 85 | List.fold_left add_relation (free leq generators) pp 86 | 87 | (** Minimal reducible words. *) 88 | let heads pres = 89 | List.map (fun (u,p) -> u) pres.rules 90 | 91 | let to_string pres = 92 | "< " 93 | ^ String.concat " " (List.map X.to_string pres.generators) ^ " | " 94 | ^ String.concat " , " (List.map (fun (u,p) -> M.to_string u ^ " -> " ^ A.to_string p) pres.rules) 95 | ^ " >" 96 | 97 | (** Normalize words. *) 98 | let normalize pres p = 99 | let p = ref p in 100 | let loop = ref true in 101 | while !loop do 102 | loop := false; 103 | p := A.map (fun u -> 104 | try 105 | let v,v' = List.find (fun (v,_) -> M.included v u) pres.rules in 106 | loop := true; 107 | let i = M.unifier u v in 108 | let v1 = M.sub u 0 i in 109 | let v2 = M.sub u (i + M.length v) (M.length u - (i + M.length v)) in 110 | let v1 = A.inj v1 in 111 | let v2 = A.inj v2 in 112 | A.mul v1 (A.mul v' v2) 113 | with 114 | | Not_found -> A.inj u 115 | ) !p 116 | done; 117 | !p 118 | 119 | (** Buchberger's completion algorithm. *) 120 | let buchberger pres = 121 | (* TODO: normalize the presentation first *) 122 | let todo = Queue.create () in 123 | List.iter (fun r -> Queue.add r todo) pres.rules; 124 | let pres = ref pres in 125 | (* Add a relation *) 126 | let rel p = 127 | (* Printf.printf "rel: %s\n%!" (A.to_string p); *) 128 | if not (A.eq A.zero p) then 129 | let r = orient !pres p in 130 | pres := add_rule !pres r; 131 | Queue.push r todo 132 | in 133 | while not (Queue.is_empty todo) do 134 | let u,p = Queue.pop todo in 135 | List.iter (fun (v,q) -> 136 | List.iter (fun ((u1,u2),(v1,v2)) -> 137 | (* Printf.printf "unifier: %s|%s->%s|%s vs %s|%s->%s|%s\n%!" *) 138 | (* (M.to_string u1) (M.to_string u) (A.to_string p) (M.to_string u2) *) 139 | (* (M.to_string v1) (M.to_string v) (A.to_string q) (M.to_string v2); *) 140 | (* Compute the S-polynomial *) 141 | let u1 = A.inj u1 in 142 | let u2 = A.inj u2 in 143 | let v1 = A.inj v1 in 144 | let v2 = A.inj v2 in 145 | let s1 = A.mul u1 (A.mul p u2) in 146 | let s2 = A.mul v1 (A.mul q v2) in 147 | let s = A.sub s1 s2 in 148 | let s = normalize !pres s in 149 | rel s 150 | ) (M.unifiers_bicontext u v) 151 | ) !pres.rules 152 | done; 153 | !pres 154 | 155 | (** Reduce a presentation. *) 156 | let reduce pres = 157 | let rules = pres.rules in 158 | let rules = List.map (fun (u,p) -> u, normalize pres p) rules in 159 | let rec aux acc = function 160 | | (u,p)::rules -> 161 | let f l = List.exists (fun (v,q) -> M.included v u) l in 162 | if f acc || f rules then aux acc rules else aux ((u,p)::acc) rules 163 | | [] -> List.rev acc 164 | in 165 | let rules = aux [] rules in 166 | { pres with rules } 167 | 168 | (** Algebra given by a convergent presentation. *) 169 | module Algebra (P : sig val presentation : t end) : T with type t = A.t = struct 170 | include A 171 | 172 | let nf = normalize P.presentation 173 | 174 | (* let inj m = nf (inj m) *) 175 | 176 | (* let cinj c m = nf (cinj c m) *) 177 | 178 | let mul p q = nf (mul p q) 179 | end 180 | 181 | (** Augmentations for presented algebras. *) 182 | module Augmentation = struct 183 | (** An augmentation. *) 184 | type t = A.t -> K.t 185 | 186 | (** Invalid augmentation. *) 187 | exception Invalid 188 | 189 | (** Construct an augmentation by defining it on generators. *) 190 | let make pres (eps : M.t -> K.t) : t = 191 | (* TODO: use a generic function *) 192 | let eps p = 193 | let ans = ref K.zero in 194 | A.iter (fun a u -> 195 | ans := K.add !ans (K.mul a (eps u)) 196 | ) p; 197 | !ans 198 | in 199 | (* Ensure that it is well-defined. *) 200 | assert (K.eq K.one (eps (A.inj M.one))); 201 | List.iter (fun (u,p) -> 202 | if not (K.eq (eps (A.inj u)) (eps p)) then raise Invalid 203 | ) pres.rules; 204 | eps 205 | 206 | (** Traditional augmentation for graded algebras. *) 207 | let graded pres = 208 | make pres (fun u -> if M.eq M.one u then K.one else K.zero) 209 | 210 | (** Traditional augmentation for monoids / groups. *) 211 | let monoid pres = 212 | make pres (fun u -> K.one) 213 | end 214 | 215 | (** Anick resolution. *) 216 | module Anick = struct 217 | type chain = M.Anick.t 218 | 219 | module AMod = struct 220 | module Mod = Module.FreeRight(A)(M.Anick) 221 | 222 | include (Mod : module type of Mod with module Map := Mod.Map) 223 | 224 | (** Normalize a polynomial. *) 225 | let normalize pres p = 226 | let ans = ref zero in 227 | iter (fun u c -> 228 | let u = normalize pres u in 229 | ans := add !ans (cinj c u) 230 | ) p; 231 | !ans 232 | 233 | module Map = struct 234 | include Mod.Map 235 | 236 | (* We need to renormalize when applying a function. *) 237 | let bind pres f p = 238 | (* TODO: more efficient implementation? *) 239 | normalize pres (bind f p) 240 | end 241 | end 242 | 243 | (** Underlying [K]-module of [AMod]. *) 244 | module AKMod = struct 245 | type t = AMod.t 246 | type r = K.t 247 | let cinj a c u = AMod.cinj c (A.cinj a u) 248 | (* let inj c u = AMod.cmul c (A.inj u) *) 249 | let cmul a cu = AMod.cmul cu (A.cmul a A.one) 250 | let iter f (p:t) = 251 | AMod.iter (fun u c -> A.iter (fun a u -> f a c u) u) p 252 | 253 | (** Map a [K]-linear function. *) 254 | let map f p = 255 | let ans = ref AMod.zero in 256 | iter (fun a c u -> ans := AMod.add !ans (cmul a (f c u))) p; 257 | !ans 258 | end 259 | 260 | (** Array of Anick chains up to degree n. *) 261 | let chains pres n = 262 | let cc = Array.make (n+1) [M.Anick.empty] in 263 | if n >= 1 then cc.(1) <- M.Anick.singletons pres.generators; 264 | let left = List.map fst pres.rules in 265 | for i = 1 to n - 1 do 266 | cc.(i+1) <- M.Anick.extend left cc.(i) 267 | done; 268 | cc 269 | 270 | (** Compute the Anick resolution together with the contracting homotopy. *) 271 | let resolution_ch ?augmentation pres n = 272 | let debug = false in 273 | (* TODO: check that the RS is convergent and reduced *) 274 | let augmentation = match augmentation with Some augmentation -> augmentation | None -> Augmentation.graded pres in 275 | if debug then Printf.printf "Resolving...\n%!"; 276 | (* The Anick chains. *) 277 | let cc = chains pres n in 278 | let eps = augmentation in 279 | let eta a = A.cinj a M.one in 280 | (* The differential. *) 281 | let d = Array.init n (fun _ -> AMod.Map.zero) in 282 | (* The 0-th differential. *) 283 | List.iter (fun x -> 284 | d.(0) <- AMod.Map.set d.(0) 285 | (M.Anick.singleton x) 286 | (AMod.cinj 287 | (M.Anick.empty) 288 | (let x = A.inj (M.inj x) in 289 | A.sub x (eta (eps x))) 290 | ); 291 | if debug then Printf.printf "∂₀(%s) = %s\n%!" 292 | (X.to_string x) (AMod.to_string (AMod.Map.app d.(0) (M.Anick.singleton x))) 293 | ) pres.generators; 294 | (* The contracting homotopy. *) 295 | let rec ch n p = 296 | if debug then Printf.printf "η%d(%s) = ?\n%!" n (AMod.to_string p); 297 | AMod.iter (fun u c -> assert (M.Anick.length c = n)) p; 298 | (* The contracting homotopy is only defined on the kernel of d.(n-1). *) 299 | (* assert (n = 0 || AMod.eq AMod.zero (AMod.Map.bind pres d.(n-1) p)); *) 300 | if n <> 0 && not (AMod.eq AMod.zero (AMod.Map.bind pres d.(n-1) p)) then AMod.zero 301 | else if AMod.eq AMod.zero p then AMod.zero 302 | else if n = 0 then 303 | (* Contract. *) 304 | let ans = ref AMod.zero in 305 | AKMod.iter (fun a c u -> 306 | if M.length u = 0 then 307 | (* assert (M.length u > 0) *) 308 | (* TODO: this is messy but should work (instead Anick defines the image of u-1) *) 309 | () 310 | else 311 | for i = 0 to M.length u - 1 do 312 | let v = M.sub u 0 i in 313 | let c = M.Anick.singleton u.(i) in 314 | let u = M.sub u (i+1) (M.length u - (i+1)) in 315 | let a = K.mul a (eps (A.inj v)) in 316 | ans := AMod.add !ans (AKMod.cinj a c u) 317 | done 318 | ) p; 319 | !ans 320 | else 321 | (* Compute leading monomial. *) 322 | let a = ref K.zero in 323 | let c = ref M.Anick.empty in 324 | let u = ref M.one in 325 | let cu = ref M.one in 326 | (* TODO: remove this when the algorithm is working *) 327 | if not (AMod.eq AMod.zero (AMod.Map.bind pres d.(n-1) p)) then 328 | (* We are only defined on the kernel. *) 329 | failwith (AMod.to_string p ^ " not in the kernel.\n%!"); 330 | AKMod.iter (fun a' c' u' -> 331 | let cu' = M.mul (M.Anick.eval c') u' in 332 | if pres.leq !cu cu' then 333 | ( 334 | assert (not (K.eq a' K.zero)); 335 | a := a'; 336 | c := c'; 337 | u := u'; 338 | cu := cu' 339 | ) 340 | ) p; 341 | let a = !a in 342 | let c = !c in 343 | let u = !u in 344 | (* Find where cn u is leftmost reducible. *) 345 | let cn = M.Anick.hd c in 346 | let cnl = M.length cn in 347 | let cnu = M.mul cn u in 348 | let cnul = M.length cnu in 349 | let i = 350 | let ans = ref (-1) in 351 | try 352 | for i = 0 to cnul - 1 do 353 | List.iter (fun (v,_) -> 354 | let vl = M.length v in 355 | if i + vl <= cnul && M.peq cnu i v 0 vl then 356 | ( 357 | ans := i + vl - cnl; 358 | raise Exit 359 | ) 360 | ) pres.rules 361 | done; 362 | Printf.printf "failed (non-reducible): %s\n%!" (AMod.to_string p); 363 | let leading = AKMod.cinj a c u in 364 | Printf.printf "leading: %s\n%!" (AMod.to_string leading); 365 | assert false 366 | with 367 | | Exit -> !ans 368 | in 369 | let u' = M.sub u 0 i in 370 | let u'' = M.sub u i (M.length u - i) in 371 | let c' = u' :: c in 372 | let ans = AKMod.cinj a c' u'' in 373 | let ans = AMod.normalize pres ans in 374 | (* Compute the remainder. *) 375 | let ans' = AMod.Map.bind pres d.(n) ans in 376 | let p' = AMod.sub p ans' in 377 | let p' = AMod.normalize pres p' in 378 | let ans' = ch n p' in 379 | let ans = AMod.normalize pres (AMod.add ans ans') in 380 | if debug then Printf.printf "η%d(%s) = %s\n%!" n (AMod.to_string p) (AMod.to_string ans); 381 | ans 382 | in 383 | (* Fill in higher differentials. *) 384 | for i = 1 to n - 1 do 385 | List.iter (fun c -> 386 | if debug then Printf.printf "\ndiff%d(%s) = ?\n%!" i (M.Anick.to_string c); 387 | let u = M.Anick.hd c in 388 | let c' = M.Anick.tl c in 389 | let p = AMod.cmul (AMod.inj c') (A.inj u) in 390 | (* Printf.printf "p: %s\n%!" (AMod.to_string p); *) 391 | let p' = AMod.Map.bind pres d.(i-1) p in 392 | (* Printf.printf "p': %s\n%!" (AMod.to_string p'); *) 393 | let p' = ch (i-1) p' in 394 | let p = AMod.sub p p' in 395 | let p = AMod.normalize pres p in 396 | if debug then Printf.printf "d%d(%s) = %s\n" i (M.Anick.to_string c) (AMod.to_string p); 397 | d.(i) <- AMod.Map.set d.(i) c p 398 | ) cc.(i+1) 399 | done; 400 | let cc = Array.map (fun l -> l |> Array.of_list |> AMod.Pres.make) cc in 401 | let d = Array.mapi (fun i d -> AMod.Pres.Map.of_map d cc.(i+1) cc.(i)) d in 402 | let s = Array.init (n-2) (fun i -> ch i) in 403 | AMod.Pres.Complex.make cc d, s 404 | 405 | (** Compute the Anick resolution. *) 406 | let resolution ?augmentation pres n = 407 | resolution_ch ?augmentation pres n |> fst 408 | 409 | module KMod = Module.Free(K)(M.Anick) 410 | module MF = Matrix.Functor(A)(K) 411 | module MFL = MF.Labeled(M.Anick)(M.Anick) 412 | 413 | (** Tor complex, whose homology is the one of the algebra (in right A-modules). *) 414 | let complex ?augmentation pres n = 415 | let augmentation = match augmentation with Some augmentation -> augmentation | None -> Augmentation.graded pres in 416 | let r = resolution ~augmentation pres n in 417 | let cc = AMod.Pres.Complex.modules r in 418 | let d = AMod.Pres.Complex.maps r in 419 | (* Tensor morphisms by the algebra. *) 420 | let d = 421 | let id x = x in 422 | Array.map (fun d -> 423 | MFL.map id id (fun p -> 424 | (* let x = ref K.zero in *) 425 | (* let p = normalize pres p in *) 426 | (* A.iter (fun y u -> x := K.add !x y) p; *) 427 | (* !x *) 428 | let p = normalize pres p in 429 | augmentation p 430 | ) d 431 | ) d 432 | in 433 | KMod.Pres.Complex.make cc d 434 | 435 | let betti ?augmentation pres n = 436 | let c = complex ?augmentation pres (n+1) in 437 | KMod.Pres.Complex.betti c 438 | end 439 | end 440 | 441 | (** Generate various classical presentations of algebras. *) 442 | module Generate (K : Field.T) (X : Alphabet.T with type t = int) = struct 443 | module Pres = Pres(K)(X) 444 | open Pres 445 | module M = Pres.M 446 | module A = Pres.A 447 | 448 | let intset n = 449 | let rec aux k = 450 | if k >= n then [] else 451 | k::(aux (k+1)) 452 | in 453 | aux 0 454 | 455 | let braid leq n = 456 | let generators = intset n in 457 | let relations = ref [] in 458 | for i = 0 to n - 2 do 459 | relations := (A.sub (A.inj [|i;i+1;i|]) (A.inj [|i+1;i;i+1|])) :: !relations 460 | done; 461 | for i = 0 to n - 1 do 462 | for j = i + 2 to n - 1 do 463 | relations := (A.sub (A.inj [|i;j|]) (A.inj [|j;i|])) :: !relations 464 | done 465 | done; 466 | let relations = List.rev !relations in 467 | make leq generators relations 468 | 469 | (** The symmetric algebra. *) 470 | let symmetric leq n = 471 | let generators = intset n in 472 | let relations = ref [] in 473 | for i = 0 to n - 1 do 474 | for j = i + 1 to n - 1 do 475 | relations := (A.sub (A.inj [|i;j|]) (A.inj [|j;i|])) :: !relations 476 | done 477 | done; 478 | let relations = List.rev !relations in 479 | make leq generators relations 480 | 481 | let exterior leq n = 482 | let generators = intset n in 483 | let relations = ref [] in 484 | for i = 0 to n - 1 do 485 | for j = i + 1 to n - 1 do 486 | relations := (A.sub (A.inj [|i;j|]) (A.cinj (K.neg K.one) [|j;i|])) :: !relations 487 | done 488 | done; 489 | for i = 0 to n - 1 do 490 | relations := (A.inj [|i;i|]) :: !relations 491 | done; 492 | let relations = List.rev !relations in 493 | make leq generators relations 494 | end 495 | -------------------------------------------------------------------------------- /src/alphabet.ml: -------------------------------------------------------------------------------- 1 | (** Alphabets. *) 2 | 3 | (** An alphabet is simply another name for a set, but the module [Set] already 4 | exists. *) 5 | 6 | (** An alphabet. *) 7 | module type T = sig 8 | (** A letter. *) 9 | type t 10 | 11 | val eq : t -> t -> bool 12 | 13 | val to_string : t -> string 14 | 15 | val compare : t -> t -> int 16 | end 17 | 18 | (** The alphabet of characters. *) 19 | module Char = struct 20 | type t = char 21 | 22 | let eq c d = (c:char) = (d:char) 23 | 24 | let to_string c = String.make 1 c 25 | 26 | let compare c d = compare (c:char) (d:char) 27 | 28 | let leq c d = (c:char) <= (d:char) 29 | 30 | let geq c d = (c:char) >= (d:char) 31 | end 32 | module CharAlphabet : (T with type t = char) = Char 33 | 34 | (* Backup since we need it afterward. *) 35 | module Str = String 36 | 37 | module String : (T with type t = string) = struct 38 | type t = string 39 | let eq s t = (s:string) = (t:string) 40 | 41 | let to_string s = s 42 | 43 | let compare s t = compare (s:string) (t:string) 44 | end 45 | 46 | (** The alphabet of integers. *) 47 | module Int = struct 48 | type t = int 49 | let eq i j = (i:int) = (j:int) 50 | 51 | let to_string = string_of_int 52 | 53 | let compare i j = compare (i:int) (j:int) 54 | 55 | let leq i j = (i:int) <= (j:int) 56 | 57 | let geq i j = (i:int) >= (j:int) 58 | end 59 | module IntAlphabet : (T with type t = int) = Int 60 | 61 | (** The alphabet with one element. *) 62 | module Unit : T with type t = unit = struct 63 | type t = unit 64 | 65 | let eq () () = true 66 | 67 | let compare () () = 0 68 | 69 | let to_string () = "*" 70 | end 71 | 72 | (** Product of alphabets. *) 73 | module Prod (A:T) (B:T) : (T with type t = A.t * B.t) = struct 74 | type t = A.t * B.t 75 | 76 | let eq (a,b) (a',b') = 77 | A.eq a a' && B.eq b b' 78 | 79 | let compare (a,b) (a',b') = 80 | let c = A.compare a a' in 81 | if c = 0 then B.compare b b' 82 | else c 83 | 84 | let to_string (a,b) = 85 | "(" ^ A.to_string a ^ "," ^ B.to_string b ^ ")" 86 | end 87 | 88 | (** Triple product of alphabets. *) 89 | module Prod3 (A:T) (B:T) (C:T) : (T with type t = A.t * B.t * C.t) = struct 90 | type t = A.t * B.t * C.t 91 | 92 | let eq (a,b,c) (a',b',c') = 93 | A.eq a a' && B.eq b b' && C.eq c c' 94 | 95 | let compare (a,b,c) (a',b',c') = 96 | let comp = A.compare a a' in 97 | if comp <> 0 then comp else 98 | let comp = B.compare b b' in 99 | if comp <> 0 then comp else 100 | C.compare c c' 101 | 102 | let to_string (a,b,c) = 103 | "(" ^ A.to_string a ^ "," ^ B.to_string b ^ "," ^ C.to_string c ^ ")" 104 | end 105 | 106 | (** Powerset. *) 107 | module Pow (A:T) = struct 108 | module S = Set.Make(A) 109 | type t = S.t 110 | let eq (u:t) (v:t) = S.equal u v 111 | let compare (u:t) (v:t) = S.compare u v 112 | let to_string (u:t) = 113 | let s = S.fold (fun x s -> if s = "" then A.to_string x else s ^ "," ^ A.to_string x) u "" in 114 | "{" ^ s ^ "}" 115 | let empty : t = S.empty 116 | let of_list l : t = S.of_list l 117 | let add (u:t) (x:A.t) = S.add x u 118 | let mem (u:t) (x:A.t) = S.mem x u 119 | let iter (f:A.t->unit) (u:t) = S.iter f u 120 | end 121 | module PowAlphabet (A:T) : T = Pow(A) 122 | 123 | (** Free monoid monad. *) 124 | module List (A:T) = struct 125 | type t = A.t list 126 | 127 | let eq u v = 128 | try 129 | List.for_all2 (fun x y -> A.eq x y) u v 130 | with 131 | | Invalid_argument _ -> false 132 | 133 | let to_string u = 134 | Str.concat "" (List.map A.to_string u) 135 | 136 | let rec compare u v = 137 | match u,v with 138 | | x::u, y::v -> 139 | let c = A.compare x y in 140 | if c <> 0 then c else compare u v 141 | | [], [] -> 0 142 | | [], _ -> -1 143 | | _, [] -> 1 144 | end 145 | module ListAlphabet (A:T) : T = List(A) 146 | 147 | (** Functions between alphabets. *) 148 | module Map (A:T) (B:T) = struct 149 | module M = Map.Make(A) 150 | 151 | type t = B.t M.t 152 | 153 | let empty : t = M.empty 154 | 155 | let app (f:t) (x:A.t) = M.find x f 156 | 157 | let add (f:t) (x:A.t) v : t = M.add x v f 158 | 159 | (** Is an element in the domain? *) 160 | let mem (f:t) (x:A.t) = M.mem x f 161 | 162 | let iter = M.iter 163 | end 164 | -------------------------------------------------------------------------------- /src/automaton.ml: -------------------------------------------------------------------------------- 1 | (** Automata. *) 2 | 3 | (** Regular expressions. *) 4 | module Regexp (X : Alphabet.T) = struct 5 | type t = 6 | | Letter of X.t 7 | | Union of t * t 8 | | Empty 9 | | Concat of t * t (** concatenation *) 10 | | Singl (** empty word singleton *) 11 | | Star of t 12 | 13 | let letter a = Letter a 14 | let union r s = Union (r,s) 15 | let empty = Empty 16 | let concat r s = Concat (r,s) 17 | let star r = Star r 18 | 19 | let rec unions = function 20 | | [] -> Empty 21 | | [r] -> r 22 | | r::l -> union r (unions l) 23 | 24 | (* 25 | let rec to_string = function 26 | | Letter a -> X.to_string a 27 | | Union (r,s) -> "(" ^ to_string r ^ ") + (" ^ to_string s ^ ")" 28 | | Empty -> "0" 29 | | Concat (r,s) -> "(" ^ to_string r ^ ")(" ^ to_string s ^ ")" 30 | | Singl -> "1" 31 | | Star r -> "(" ^ to_string r ^ ")*" 32 | *) 33 | 34 | let to_string r = 35 | (* level: 0:+ / 1:x / 2:* *) 36 | let rec aux l r = 37 | let pa l' s = if l' < l then "(" ^ s ^ ")" else s in 38 | match r with 39 | | Letter a -> X.to_string a 40 | | Union (r,s) -> pa 0 (aux 0 r ^ "+" ^ aux 0 s) 41 | | Empty -> "0" 42 | | Concat (r,s) -> pa 1 (aux 1 r ^ "." ^ aux 1 s) 43 | | Singl -> "1" 44 | | Star r -> aux 2 r ^ "*" 45 | in 46 | aux (-1) r 47 | 48 | let rec simpl = function 49 | | Union (Empty, r) -> simpl r 50 | | Union (r, Empty) -> simpl r 51 | | Union (r, s) -> Union (simpl r, simpl s) 52 | | Concat (Empty, r) -> Empty 53 | | Concat (r, Empty) -> Empty 54 | | Concat (Singl, r) -> simpl r 55 | | Concat (r, Singl) -> simpl r 56 | | Concat (r, s) -> Concat (simpl r, simpl s) 57 | | Star Empty -> Empty 58 | | Star r -> Star (simpl r) 59 | | Letter _ | Empty | Singl as r -> r 60 | 61 | let simpl r = 62 | let rec fix f x = 63 | let y = f x in 64 | if y = x then x 65 | else fix f y 66 | in 67 | fix simpl r 68 | 69 | module Series = Series.Make(Field.Int) 70 | 71 | (** Generating series of a regular expression. This expression is assumed to 72 | be unambiguous. *) 73 | let rec series = function 74 | | Letter a -> Series.var 75 | | Union (a, b) -> Series.add (series a) (series b) 76 | | Empty -> Series.zero 77 | | Concat (a, b) -> Series.mul (series a) (series b) 78 | | Singl -> Series.one 79 | | Star a -> Series.star (series a) 80 | end 81 | 82 | module State = Alphabet.Int 83 | 84 | module Make (X : Alphabet.T) = struct 85 | module States = Alphabet.Pow(State) 86 | module T = Alphabet.Map(Alphabet.Prod(State)(X))(States) 87 | module Regexp = Regexp(X) 88 | 89 | type t = 90 | { 91 | states : int; 92 | initial : State.t; 93 | terminal : States.t; 94 | transitions : T.t; 95 | } 96 | 97 | let states aut = aut.states 98 | 99 | let trans aut a x = 100 | try 101 | T.app aut.transitions (a,x) 102 | with 103 | | Not_found -> States.empty 104 | 105 | let add_transition aut a x (b : State.t) = 106 | let bb = trans aut a x in 107 | let bb = States.add bb b in 108 | let transitions = T.add aut.transitions (a,x) bb in 109 | { aut with transitions } 110 | 111 | let create states initial terminal transitions = 112 | let terminal = States.of_list terminal in 113 | let ans = { states; initial; terminal; transitions = T.empty } in 114 | List.fold_left (fun ans (a,x,b) -> add_transition ans a x b) ans transitions 115 | 116 | let kleene aut = 117 | let n = states aut in 118 | let init f = Array.init n (fun i -> Array.init n (fun j -> f i j)) in 119 | let rr = 120 | init 121 | (fun i j -> 122 | let r = ref Regexp.empty in 123 | T.iter (fun (i',a) jj -> 124 | if State.eq i i' && States.mem jj j then r := Regexp.union !r (Regexp.letter a) 125 | ) aut.transitions; 126 | if i = j then r := Regexp.union Regexp.empty !r; 127 | !r 128 | ) 129 | in 130 | let rr = ref rr in 131 | for k = 0 to n - 1 do 132 | let ss = 133 | let rr = !rr in 134 | init 135 | (fun i j -> 136 | Regexp.union 137 | rr.(i).(j) 138 | (Regexp.concat rr.(i).(k) (Regexp.concat (Regexp.star rr.(k).(k)) rr.(k).(j))) 139 | ) 140 | in 141 | rr := ss 142 | done; 143 | let rr = !rr in 144 | let r = ref Regexp.empty in 145 | let i = aut.initial in 146 | States.iter (fun j -> r := Regexp.union !r rr.(i).(j)) aut.terminal; 147 | !r 148 | end 149 | -------------------------------------------------------------------------------- /src/category.ml: -------------------------------------------------------------------------------- 1 | (** Categories. *) 2 | 3 | (** A category. *) 4 | module type T = sig 5 | include Graph.T 6 | 7 | (** Composition of morphisms. *) 8 | val comp : E.t -> E.t -> E.t 9 | 10 | (** Identity morphism. *) 11 | val id : V.t -> E.t 12 | end 13 | 14 | (** Free category on a graph. *) 15 | module Free (G : Graph.T) = struct 16 | module V = G.V 17 | module M = Monoid.Free(G.E) 18 | module E = struct 19 | include Alphabet.Prod3(V)(M)(V) 20 | let to_string (x,f,y) = 21 | if M.eq M.one f then "id"^V.to_string x else M.to_string f 22 | end 23 | let src ((x,f,y):E.t) = x 24 | let tgt ((x,f,y):E.t) = y 25 | let id (x:V.t) : E.t = (x,M.one,x) 26 | let comp ((x,f,y):E.t) ((y',g,z):E.t) : E.t = 27 | assert (V.eq y y'); 28 | x,M.mul f g,z 29 | let inj f : E.t = (G.src f,M.inj f,G.tgt f) 30 | end 31 | module FreeCategory (G : Graph.T) : T = Free(G) 32 | 33 | (** Presentation of a category. *) 34 | module Pres (V : Alphabet.T) (E : Alphabet.T) = struct 35 | module GP = Graph.Pres(V)(E) 36 | module Free = Free(GP.Graph) 37 | 38 | (** A presentation. *) 39 | type t = 40 | { 41 | graph : GP.t; 42 | relations : (Free.E.t * Free.E.t) list; 43 | } 44 | 45 | (** Empty presentation. *) 46 | let empty = { graph = GP.empty; relations = [] } 47 | 48 | let add_object p x = 49 | { p with graph = GP.add_vertex p.graph x } 50 | 51 | let add_morphism p f x y = 52 | assert (GP.has_vertex p.graph x); 53 | assert (GP.has_vertex p.graph y); 54 | { p with graph = GP.add_edge p.graph f (x,y) } 55 | 56 | (** Morphism corresponding to a generator. *) 57 | let morphism p f : Free.E.t = 58 | Free.inj (GP.edge p.graph f) 59 | 60 | let add_relation p f g = 61 | { p with relations = (f,g)::p.relations } 62 | 63 | let to_string p = 64 | let graph = GP.to_string p.graph in 65 | let relations = p.relations in 66 | let relations = List.map (fun (f,g) -> Free.E.to_string f ^ "=" ^ Free.E.to_string g) relations in 67 | let relations = String.concat " , " relations in 68 | graph ^ "\n" ^ relations 69 | end 70 | 71 | (** Category of a monoid. *) 72 | module Monoid (M : Monoid.T) : T = struct 73 | module V = Alphabet.Unit 74 | module E = M 75 | let src _ = () 76 | let tgt _ = () 77 | let comp = M.mul 78 | let id () = M.one 79 | end 80 | 81 | (** Underlying graph of a category. *) 82 | module Graph (C : T) : Graph.T = struct 83 | include C 84 | end 85 | -------------------------------------------------------------------------------- /src/combinatoryLogic.ml: -------------------------------------------------------------------------------- 1 | (** Combinatory logic. *) 2 | 3 | open Extlib 4 | 5 | (** A combinator. *) 6 | type t = I | K | S | App of t * t 7 | 8 | (** String representation. *) 9 | let rec to_string = function 10 | | I -> "I" 11 | | K -> "K" 12 | | S -> "S" 13 | | App (t , u) -> 14 | let pa = match u with App _ -> true | _ -> false in 15 | let pa s = if pa then "("^s^")" else s in 16 | to_string t ^ " " ^ pa (to_string u) 17 | 18 | (** Parser. *) 19 | let rec of_string s = 20 | let s = String.trim s in 21 | let l = String.length s in 22 | match s with 23 | | "I" -> I 24 | | "K" -> K 25 | | "S" -> S 26 | | _ when s.[l-1] = ')' -> 27 | let i = String.matching_parenthesis s (l-1) in 28 | if i = 0 then of_string (String.sub s 1 (l-2)) 29 | else 30 | let t = String.sub s 0 i |> of_string in 31 | let u = String.sub s i (l-i) |> of_string in 32 | App (t, u) 33 | | _ -> 34 | let t = String.sub s 0 (l-1) |> of_string in 35 | let u = String.sub s (l-1) 1 |> of_string in 36 | App (t, u) 37 | 38 | (** Normalize combinator. *) 39 | (* 40 | let rec normalize t = 41 | match t with 42 | | I | K | S -> t 43 | | App (t, v) -> 44 | match normalize t with 45 | | I -> normalize v 46 | | App (K, t) -> normalize t 47 | | App (App (S, t), u) -> normalize (App (App (t, v), App (u, v))) 48 | | t -> App (t, normalize v) 49 | *) 50 | 51 | let rec normalize t = 52 | let rec aux env = function 53 | | I -> 54 | ( 55 | match env with 56 | | t::env -> aux env t 57 | | [] -> I 58 | ) 59 | | K -> 60 | ( 61 | match env with 62 | | t::u::env -> aux env t 63 | | [t] -> App (K, normalize t) 64 | | [] -> K 65 | ) 66 | | S -> 67 | ( 68 | match env with 69 | | t::u::v::env -> aux env (App (App (t,v), App (u,v))) 70 | | [t;u] -> App (App (S, normalize t), normalize u) 71 | | [t] -> App (S, normalize t) 72 | | [] -> S 73 | ) 74 | | App (t, u) -> aux (u::env) t 75 | in 76 | aux [] t 77 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name alg) 3 | (public_name alg) 4 | (flags (:standard -w -27)) 5 | ) 6 | -------------------------------------------------------------------------------- /src/extlib.ml: -------------------------------------------------------------------------------- 1 | let pair x y = x, y 2 | 3 | let unpair f (x,y) = f x y 4 | 5 | module Int = struct 6 | include Int 7 | 8 | let modulo x y = 9 | let ans = x mod y in 10 | if ans >= 0 then ans 11 | else ans + y 12 | 13 | (** Split n in k parts (whose sum is n). *) 14 | let rec splits n k : int list list = 15 | if (n < 0 || k < 0) || (k = 0 && n > 0) then [] 16 | else if k = 0 then [[]] 17 | else List.init (n+1) (fun i -> List.map (fun l -> i::l) (splits (n-i) (k-1))) |> List.flatten 18 | end 19 | 20 | module List = struct 21 | include List 22 | 23 | (** First index where a predicate is satisfied. *) 24 | let index p l = 25 | let rec aux n = function 26 | | x::l -> if p x then n else aux (n+1) l 27 | | [] -> raise Not_found 28 | in 29 | aux 0 l 30 | 31 | (** Replace the nth element of a list. *) 32 | let replace_nth l n x = 33 | let rec aux n k = function 34 | | y::l -> 35 | if n = 0 then k (x::l) 36 | else aux (n-1) (fun l -> k (y::l)) l 37 | | [] -> raise Not_found 38 | in 39 | aux n Fun.id l 40 | 41 | let replace_assoc k v l = 42 | List.map (fun (k',v') -> if k = k' then k, v else k', v') l 43 | 44 | let rec sub l ofs len = 45 | if ofs = 0 && len = 0 then [] 46 | else 47 | match l with 48 | | x::l -> 49 | if ofs = 0 then x::(sub l ofs (len-1)) 50 | else sub l (ofs-1) len 51 | | [] -> invalid_arg "List.sub" 52 | 53 | (** Product of a list of lists (returns the list of all combinations of elements). *) 54 | let rec products = function 55 | | l::ll -> List.map (fun x -> List.map (fun l -> x::l) (products ll)) l |> List.flatten 56 | | [] -> [[]] 57 | 58 | end 59 | 60 | module String = struct 61 | include String 62 | 63 | let subscript s = 64 | String.fold_left 65 | (fun s -> function 66 | | '0' -> "₀" 67 | | '1' -> "₁" 68 | | '2' -> "₂" 69 | | '3' -> "₃" 70 | | '4' -> "₄" 71 | | '5' -> "₅" 72 | | '6' -> "₆" 73 | | '7' -> "₇" 74 | | '8' -> "₈" 75 | | '9' -> "₉" 76 | | _ -> assert false 77 | ) "" s 78 | 79 | let superscript s = 80 | String.fold_left 81 | (fun s -> function 82 | | '0' -> "⁰" 83 | | '1' -> "¹" 84 | | '2' -> "²" 85 | | '3' -> "³" 86 | | '4' -> "⁴" 87 | | '5' -> "⁵" 88 | | '6' -> "⁶" 89 | | '7' -> "⁷" 90 | | '8' -> "⁸" 91 | | '9' -> "⁹" 92 | | _ -> assert false 93 | ) "" s 94 | 95 | (** Find the index of the first character matching a predicate. *) 96 | let find p s = 97 | let ans = ref (-1) in 98 | try 99 | for i = 0 to String.length s - 1 do 100 | if p s.[i] then 101 | ( 102 | ans := i; 103 | raise Exit 104 | ) 105 | done; 106 | raise Not_found 107 | with 108 | | Exit -> !ans 109 | 110 | let rec split_on_predicate p s = 111 | try 112 | let n = find p s in 113 | (String.sub s 0 n)::(split_on_predicate p (String.sub s (n+1) (String.length s - (n+1)))) 114 | with Not_found -> [s] 115 | 116 | let find_index_from p s i = 117 | let ans = ref (-1) in 118 | try 119 | for i = i to String.length s - 1 do 120 | if p s.[i] then ( 121 | ans := i; 122 | raise Exit 123 | ) 124 | done; 125 | raise Not_found 126 | with Exit -> !ans 127 | 128 | (** Find the matching closing parenthesis of an opening parenthesis. *) 129 | let matching_parenthesis s i = 130 | let find_closing a b = 131 | let n = ref 0 in 132 | find_index_from 133 | (fun c -> 134 | if c = a then incr n 135 | else if c = b then decr n; 136 | assert (!n >= 0); 137 | !n = 0 138 | ) s i 139 | in 140 | let find_opening a b = 141 | let n = ref 0 in 142 | let ans = ref (-1) in 143 | try 144 | for i = i downto 0 do 145 | if s.[i] = b then incr n 146 | else if s.[i] = a then decr n; 147 | assert (!n >= 0); 148 | if !n = 0 then ( 149 | ans := i; 150 | raise Exit 151 | ) 152 | done; 153 | raise Not_found 154 | with Exit -> !ans 155 | in 156 | match s.[i] with 157 | | '(' -> find_closing '(' ')' 158 | | ')' -> find_opening '(' ')' 159 | | _ -> assert false 160 | end 161 | -------------------------------------------------------------------------------- /src/field.ml: -------------------------------------------------------------------------------- 1 | (** Fields. *) 2 | 3 | (** A field. *) 4 | module type T = sig 5 | include Ring.T 6 | 7 | (** Inverse. *) 8 | val inv : t -> t 9 | end 10 | 11 | (** The field with two elements. *) 12 | module Bool : (T with type t = bool) = struct 13 | include Ring.Bool 14 | 15 | let inv (x:t) = x 16 | end 17 | 18 | (** The field of floats. *) 19 | module Float : (T with type t = float) = struct 20 | include Ring.Float 21 | 22 | let inv (x:t) : t = 1. /. x 23 | end 24 | 25 | (** The "field" of integers. *) 26 | module Int = struct 27 | include Ring.Int 28 | 29 | let inv x = 30 | if eq one x then one 31 | else if eq (neg one) x then (neg one) 32 | else 33 | failwith ("Cannot invert "^string_of_int x^".") 34 | end 35 | 36 | (** Field of fractions over an euclidean domain. *) 37 | module Fractions (R : Ring.Euclidean) = struct 38 | type t = R.t * R.t 39 | 40 | (** Greatest common divisor. *) 41 | let rec gcd a b = 42 | let rem a b = snd (R.div a b) in 43 | if R.eq R.zero b then a else gcd b (rem a b) 44 | 45 | let canonize ((a,b):t) : t = 46 | let d = gcd a b in 47 | let a,_ = R.div a d in 48 | let b,_ = R.div a d in 49 | (a,b) 50 | 51 | let eq ((a,b):t) ((c,d):t) = 52 | let (a,b) = canonize (a,b) in 53 | let (c,d) = canonize (c,d) in 54 | (R.eq a c && R.eq b d) || (R.eq (R.neg a) c && R.eq (R.neg b) d) 55 | 56 | let add ((a,b):t) ((c,d):t) : t = (R.add (R.mul a d) (R.mul b c), R.mul c d) 57 | 58 | let zero : t = (R.zero, R.one) 59 | 60 | let neg ((a,b):t) : t = (R.neg a, b) 61 | 62 | let mul ((a,b):t) ((c,d):t) : t = (R.mul a c, R.mul c d) 63 | 64 | let one : t = (R.one, R.one) 65 | 66 | let inv ((a,b):t) : t = (b,a) 67 | 68 | let to_string ((a,b):t) = 69 | "(" ^ R.to_string a ^ ")/(" ^ R.to_string b ^ ")" 70 | end 71 | 72 | module FractionsField (R : Ring.Euclidean) : T = Fractions(R) 73 | 74 | (** Field of rational fractions. *) 75 | module RationalFractions (F : T) = struct 76 | (** Ring of polynomials over a field. *) 77 | module Polynomial (F : T) : Ring.Euclidean with type t = Ring.Polynomial(F).t = struct 78 | include Ring.Polynomial(F) 79 | 80 | (** Euclidean division. *) 81 | let div a b = 82 | let db = degree b in 83 | assert (db >= 0); 84 | let q = ref zero in 85 | let r = ref a in 86 | let dr = ref (degree !r) in 87 | while !dr >= db do 88 | (* quotient of leading monomials of r and b *) 89 | let t = monomial (F.mul !r.(!dr) (F.inv b.(db))) (!dr - db) in 90 | q := add !q t; 91 | r := sub !r (mul t b); 92 | dr := degree !r 93 | done; 94 | !q, !r 95 | end 96 | 97 | include Fractions(Polynomial(F)) 98 | end 99 | 100 | module RationalFractionsField (F : T) : T = RationalFractions(F) 101 | 102 | (** Underlying ring of a field. *) 103 | module Ring (F : T) : Ring.T = struct 104 | include F 105 | end 106 | -------------------------------------------------------------------------------- /src/globular.ml: -------------------------------------------------------------------------------- 1 | (** Globular sets. *) 2 | 3 | (** A globular set. *) 4 | module type T = sig 5 | (** A cell. *) 6 | type t 7 | 8 | (** String representation of a cell. *) 9 | val to_string : t -> string 10 | 11 | (** Dimension. *) 12 | val dim : t -> int 13 | 14 | (** Source. *) 15 | val src : t -> t 16 | 17 | (** Target. *) 18 | val tgt : t -> t 19 | end 20 | 21 | (** The terminal globular set. *) 22 | module Terminal : T = struct 23 | type t = int 24 | 25 | let to_string = string_of_int 26 | 27 | let dim n = n 28 | 29 | let src n = 30 | assert (n > 0); 31 | n - 1 32 | 33 | let tgt n = 34 | assert (n > 0); 35 | n - 1 36 | end 37 | 38 | (** Presented globular set. *) 39 | module Pres (X : Alphabet.T) = struct 40 | (* Cells coded as element, (source,target), the source and target being the 41 | element for 0-cells *) 42 | module Cell = Alphabet.Prod3(Alphabet.Int)(X)(X) 43 | module E = Alphabet.Map(X)(Cell) 44 | 45 | (** A globular set. *) 46 | type t = E.t 47 | 48 | (** The empty globular set. *) 49 | let empty : t = E.empty 50 | 51 | let mem (s:t) (g:X.t) = E.mem s g 52 | 53 | (** Dimension of a generator. *) 54 | let dim (s:t) (g:X.t) = 55 | let n,_,_ = E.app s g in 56 | n 57 | 58 | (** Source of a cell. *) 59 | let src (s:t) (g:X.t) = 60 | assert (dim s g > 0); 61 | let n,src,_ = E.app s g in 62 | assert (n > 0); 63 | src 64 | 65 | (** Target of a cell. *) 66 | let tgt (s:t) (g:X.t) = 67 | let n,_,tgt = E.app s g in 68 | assert (n > 0); 69 | tgt 70 | 71 | (** Add a 0-cell. *) 72 | let add0 (s:t) (g:X.t) : t = 73 | E.add s g (0,g,g) 74 | 75 | (** Add an n-cell. *) 76 | let add s (g:X.t) src tgt : t = 77 | assert (mem s src); 78 | assert (mem s tgt); 79 | let n = dim s src + 1 in 80 | assert (dim s tgt + 1 = n); 81 | E.add s g (n,src,tgt) 82 | 83 | module Make (P : sig val presentation : t end) : T = struct 84 | type t = X.t 85 | 86 | let to_string = X.to_string 87 | 88 | let dim = dim P.presentation 89 | 90 | let src = src P.presentation 91 | 92 | let tgt = tgt P.presentation 93 | end 94 | end 95 | 96 | (** A globular theory, the typical example being weak omega-categories. *) 97 | module Theory = struct 98 | module Var = struct 99 | type t = int 100 | 101 | let fresh = 102 | let n = ref (-1) in 103 | fun () -> 104 | incr n; (!n : t) 105 | 106 | let to_string (x:t) = 107 | "x" ^ string_of_int x 108 | end 109 | 110 | module Cons = struct 111 | type t = int 112 | 113 | let fresh = 114 | let n = ref (-1) in 115 | fun () -> 116 | incr n; (!n : t) 117 | 118 | let to_string (x:t) = 119 | "f" ^ string_of_int x 120 | end 121 | 122 | type term = 123 | | Var of Var.t 124 | | Cons of Cons.t * context 125 | (** A context contains terms with their source and target. *) 126 | and context = (term * (term * term)) list 127 | end 128 | -------------------------------------------------------------------------------- /src/graph.ml: -------------------------------------------------------------------------------- 1 | (** Graphs. *) 2 | 3 | (** A graph. *) 4 | module type T = sig 5 | (** Vertices. *) 6 | module V : Alphabet.T 7 | 8 | (** Edges. *) 9 | module E : Alphabet.T 10 | 11 | (** Source. *) 12 | val src : E.t -> V.t 13 | 14 | (** Target. *) 15 | val tgt : E.t -> V.t 16 | end 17 | 18 | (** The terminal graph. *) 19 | module Terminal : T = struct 20 | module V = Alphabet.Unit 21 | module E = Alphabet.Unit 22 | let src () = () 23 | let tgt () = () 24 | end 25 | 26 | module Full (V : Alphabet.T) (E : Alphabet.T) = struct 27 | module V = V 28 | 29 | module E = struct 30 | include Alphabet.Prod(E)(Alphabet.Prod(V)(V)) 31 | let to_string (f,(x,y)) = E.to_string f 32 | end 33 | 34 | let src (f,(x,y)) = x 35 | 36 | let tgt (f,(x,y)) = y 37 | end 38 | 39 | (** Presentation of a graph. *) 40 | module Pres (V : Alphabet.T) (E : Alphabet.T) = struct 41 | module Graph = Full(V)(E) 42 | 43 | type t = 44 | { 45 | vertices : V.t list; 46 | edges : Graph.E.t list; 47 | } 48 | 49 | let empty = { vertices = []; edges = [] } 50 | 51 | let add_vertex p x = { p with vertices = x::p.vertices } 52 | 53 | let add_edge p f ((x:V.t),(y:V.t)) = { p with edges = (f,(x,y))::p.edges } 54 | 55 | let edge p f : Graph.E.t = 56 | let x,y = List.assoc f p.edges in 57 | f,(x,y) 58 | 59 | let has_vertex p x = List.exists (fun y -> V.eq x y) p.vertices 60 | 61 | let to_string g = 62 | let vertices = List.map V.to_string g.vertices in 63 | let vertices = String.concat " , " vertices in 64 | let edges = List.map (fun (f,(x,y)) -> E.to_string f ^ ":" ^ V.to_string x ^ "->" ^ V.to_string y) g.edges in 65 | let edges = String.concat " , " edges in 66 | vertices ^ "\n" ^ edges 67 | end 68 | -------------------------------------------------------------------------------- /src/group.ml: -------------------------------------------------------------------------------- 1 | (** Groups. *) 2 | 3 | (** A group. *) 4 | module type T = sig 5 | include Monoid.T 6 | 7 | val inv : t -> t 8 | end 9 | 10 | (** An abelian group (with additive conventions). *) 11 | module type Additive = sig 12 | include Monoid.Additive 13 | 14 | val neg : t -> t 15 | end 16 | 17 | (** The quaternion group (Q8). *) 18 | module Quaternion = struct 19 | type gen = E | I | J | K 20 | 21 | (* true means negated *) 22 | type t = bool * gen 23 | 24 | let to_string ((s,x):t) = 25 | let s = if s then "-" else "" in 26 | let x = match x with E -> "1" | I -> "i" | J -> "j" | K -> "k" in 27 | s ^ x 28 | 29 | let one : t = false, E 30 | 31 | let i : t = false, I 32 | let j : t = false, J 33 | let k : t = false, K 34 | 35 | let is_negative (s,_) = s 36 | 37 | let neg ((s,x):t) : t = not s, x 38 | 39 | (** All the elements of the group. *) 40 | let elements = [one;i;j;k;neg one;neg i;neg j;neg k] 41 | 42 | let may_neg b x = if b then neg x else x 43 | 44 | let eq (x:t) (y:t) = x = y 45 | 46 | let compare (x:t) (y:t) = compare x y 47 | 48 | let mul ((s,x):t) ((t,y):t) = 49 | let mul_gen x y = 50 | match x, y with 51 | | E, y -> false, y 52 | | x, E -> false, x 53 | | I, J -> false, K 54 | | J, K -> false, I 55 | | K, I -> false, J 56 | | J, I -> true, K 57 | | K, J -> true, I 58 | | I, K -> true, J 59 | | I, I 60 | | J, J 61 | | K, K -> true, E 62 | in 63 | mul_gen x y |> may_neg s |> may_neg t 64 | 65 | let is_commutative = false 66 | 67 | let pow x n = Monoid.simple_pow one mul x n 68 | 69 | let inv x = neg x 70 | end 71 | module QuaternionGroup = (Quaternion : T) 72 | -------------------------------------------------------------------------------- /src/hypergraph.ml: -------------------------------------------------------------------------------- 1 | (** Hypergraphs. *) 2 | 3 | module type T = sig 4 | (** Vertices. *) 5 | module V : Alphabet.T 6 | 7 | (** Edges. *) 8 | module E : Alphabet.T 9 | 10 | (** Source. *) 11 | val src : E.t -> V.t list 12 | 13 | (** Target. *) 14 | val tgt : E.t -> V.t list 15 | end 16 | 17 | module Full (V : Alphabet.T) (E : Alphabet.T) = struct 18 | module V = struct 19 | type t = { label : V.t } 20 | 21 | let label x = x.label 22 | 23 | let eq x y = x == y 24 | 25 | let compare x y = V.compare (label x) (label y) 26 | 27 | let to_string x = V.to_string (label x) 28 | end 29 | 30 | module VL = Alphabet.List(V) 31 | 32 | module E = struct 33 | (* Alphabet.Prod(E)(Alphabet.Prod(Alphabet.List(V))(Alphabet.List(V))) *) 34 | 35 | type t = { label : E.t; src : V.t list; tgt : V.t list } 36 | 37 | let eq f g = f == g 38 | 39 | let compare f g = compare f g 40 | 41 | let to_string f = E.to_string f.label ^ " : " ^ VL.to_string f.src ^ " -> " ^ VL.to_string f.tgt 42 | 43 | let label f = f.label 44 | 45 | let src f = f.src 46 | 47 | let tgt f = f.tgt 48 | 49 | let make l s t = { label = l; src = s; tgt = t} 50 | end 51 | 52 | let src = E.src 53 | 54 | let tgt = E.tgt 55 | end 56 | 57 | (** Presentation of an hypergraph. *) 58 | module Pres (V : Alphabet.T) (E : Alphabet.T) = struct 59 | include Full(V)(E) 60 | 61 | type t = 62 | { 63 | vertices : V.t list; 64 | edges : E.t list; 65 | } 66 | 67 | let vertices g = g.vertices 68 | 69 | let edges g = g.edges 70 | 71 | let empty = { vertices = []; edges = [] } 72 | 73 | let add_vertex g x = { g with vertices = x::(vertices g) } 74 | 75 | let add_edge g e = { g with edges = e::(edges g) } 76 | 77 | let vertex_pred g v = 78 | assert (List.memq v (vertices g)); 79 | List.filter (fun e -> List.memq v (tgt e)) (edges g) 80 | 81 | let vertex_succ g v = 82 | assert (List.memq v (vertices g)); 83 | List.filter (fun e -> List.memq v (src e)) (edges g) 84 | 85 | let edge_pred g e = src e 86 | 87 | let edge_succ g e = tgt e 88 | end 89 | 90 | module Map (V : Alphabet.T) (E : Alphabet.T) = struct 91 | module MV = Map.Make(V) 92 | module ME = Map.Make(E) 93 | end 94 | -------------------------------------------------------------------------------- /src/matrix.ml: -------------------------------------------------------------------------------- 1 | (** Matrices. *) 2 | 3 | (** Matrices over a ring. *) 4 | module Make (R:Ring.T) = struct 5 | (** A matrix. *) 6 | type t = R.t array array 7 | 8 | type matrix = t 9 | 10 | (** Zero matrix. *) 11 | let zero r c : t = Array.init r (fun _ -> Array.make c R.zero) 12 | 13 | (** Initialize a matrix. *) 14 | let init r c f : t = 15 | Array.init r (fun i -> Array.init c (fun j -> f i j)) 16 | 17 | (** Number of rows. *) 18 | let rows (m : t) = Array.length m 19 | 20 | (** Number of columns. *) 21 | let cols (m : t) = Array.length m.(0) 22 | 23 | (** Coefficient. *) 24 | let get (m:t) i j = m.(i).(j) 25 | 26 | (** String representation. *) 27 | let to_string m = 28 | let ans = ref "" in 29 | for i = 0 to rows m - 1 do 30 | for j = 0 to cols m - 1 do 31 | if j <> 0 then ans := !ans ^ " "; 32 | ans := !ans ^ R.to_string m.(i).(j) 33 | done; 34 | ans := !ans ^ "\n" 35 | done; 36 | !ans 37 | 38 | (** Operations on rows. *) 39 | module Row = struct 40 | (** A a row null? *) 41 | let is_zero m i = 42 | Array.for_all (R.eq R.zero) m.(i) 43 | 44 | (** Replace a row by another one. *) 45 | let replace m i mi : t = 46 | Array.init (rows m) (fun k -> if k = i then mi else m.(k)) 47 | 48 | (** Exchange two rows. *) 49 | let exchange m i j : t = 50 | Array.init (rows m) (fun k -> if k = i then m.(j) else if k = j then m.(i) else m.(k)) 51 | 52 | (** Multiply a row by a coefficent. *) 53 | let mult m q i = 54 | assert (not (R.eq R.zero q)); 55 | let mi = Array.init (cols m) (fun k -> R.mul q m.(i).(k)) in 56 | replace m i mi 57 | 58 | (** Add to a row [q] times another row. *) 59 | let madd m i q j = 60 | assert (i <> j); 61 | let mi = Array.init (cols m) (fun k -> R.add m.(i).(k) (R.mul q m.(j).(k))) in 62 | replace m i mi 63 | end 64 | 65 | (** Put a matrix in row echelon form. *) 66 | let row_echelon m = 67 | let m = ref m in 68 | let ip = ref 0 in 69 | let cols = if rows !m = 0 then 0 else cols !m in 70 | try 71 | for j = 0 to cols - 1 do 72 | if !ip >= rows !m then raise Exit; 73 | if R.eq R.zero !m.(!ip).(j) then 74 | ( 75 | try 76 | for i = !ip + 1 to rows !m - 1 do 77 | if not (R.eq R.zero !m.(i).(j)) then (m := Row.exchange !m !ip i; raise Exit) 78 | done 79 | with 80 | | Exit -> () 81 | ); 82 | let a = !m.(!ip).(j) in 83 | if not (R.eq R.zero a) then 84 | ( 85 | for i = !ip + 1 to rows !m - 1 do 86 | let b = !m.(i).(j) in 87 | if not (R.eq R.zero b) then 88 | ( 89 | m := Row.mult !m (R.neg a) i; 90 | m := Row.madd !m i b !ip 91 | ) 92 | done; 93 | incr ip 94 | ) 95 | done; 96 | !m 97 | with 98 | | Exit -> !m 99 | 100 | (** Dimension of the image. *) 101 | let rank m = 102 | let m = row_echelon m in 103 | let n = ref 0 in 104 | try 105 | (* 106 | if rows m = 0 then raise Exit; (* Avoid a problem with undefined cols below. *) 107 | for i = 0 to min (rows m) (cols m) - 1 do 108 | if R.eq R.zero m.(i).(i) then raise Exit else incr n 109 | done; 110 | *) 111 | for i = 0 to rows m - 1 do 112 | if Row.is_zero m i then raise Exit; 113 | incr n 114 | done; 115 | !n 116 | with 117 | | Exit -> !n 118 | 119 | (** Dimension of the kernel. *) 120 | let nullity m = 121 | rows m - rank m 122 | 123 | (** Matrices with labeled basis elements. *) 124 | module Labeled (X:Alphabet.T) = struct 125 | module L = struct 126 | include Map.Make(X) 127 | 128 | let find : X.t -> 'a t -> 'a = find 129 | 130 | let iter : (X.t -> 'a -> unit) -> 'a t -> unit = iter 131 | 132 | let of_array (a:X.t array) = 133 | let ans = ref empty in 134 | for i = 0 to Array.length a - 1 do 135 | ans := add a.(i) i !ans 136 | done; 137 | !ans 138 | end 139 | 140 | type map = int L.t 141 | 142 | (** A matrix with labeled basis elements. *) 143 | type t = map * map * matrix 144 | 145 | (** Underlying (non-labeled) matrix. *) 146 | let matrix ((_,_,m):t) = m 147 | 148 | let zero rows cols : t = 149 | let m = zero (Array.length rows) (Array.length cols) in 150 | L.of_array rows, L.of_array cols, m 151 | 152 | (** Set coefficient. *) 153 | let set ((r,c,m):t) i j x = 154 | let i = L.find i r in 155 | let j = L.find j c in 156 | m.(i).(j) <- x 157 | 158 | (** Coefficient. *) 159 | let get ((r,c,m):t) i j = 160 | let i = L.find i r in 161 | let j = L.find j c in 162 | m.(i).(j) 163 | 164 | (** Rank. *) 165 | let rank ((r,c,m):t) = rank m 166 | 167 | let nullity ((r,c,m):t) = nullity m 168 | 169 | (** Iterate over source basis. *) 170 | let iter_src f ((r,c,m):t) = 171 | L.iter (fun x _ -> f x) r 172 | 173 | (** Iterate over target basis. *) 174 | let iter_tgt f ((r,c,m):t) = 175 | L.iter (fun x _ -> f x) c 176 | 177 | (** Iterate over source and target basis. *) 178 | let iter f (m:t) = 179 | iter_src (fun x -> iter_tgt (fun y -> f x y) m) m 180 | end 181 | end 182 | 183 | (** Functors between different rings. *) 184 | module Functor (R:Ring.T) (R':Ring.T) = struct 185 | module M = Make(R) 186 | module M' = Make(R') 187 | 188 | let map f (m:M.t) : M'.t = 189 | let r = M.rows m in 190 | let c = if r = 0 then 0 else M.cols m in 191 | M'.init r c (fun i j -> f (M.get m i j)) 192 | 193 | module Labeled (X:Alphabet.T) (X':Alphabet.T) = struct 194 | module L = M.Labeled(X) 195 | module L' = M'.Labeled(X') 196 | 197 | let map s t f (m:L.t) : L'.t = 198 | let r,c,m = m in 199 | let lmap (f:X.t->X'.t) (l:L.map) : L'.map = L.L.fold (fun x i l' -> L'.L.add (f x) i l') l L'.L.empty in 200 | let r = lmap s r in 201 | let c = lmap t c in 202 | let m = map f m in 203 | r,c,m 204 | end 205 | end 206 | -------------------------------------------------------------------------------- /src/module.ml: -------------------------------------------------------------------------------- 1 | (** Modules. *) 2 | 3 | (** A left module. *) 4 | module type Left = sig 5 | (** An element of the module. *) 6 | type t 7 | 8 | (** An element of the ring. *) 9 | type r 10 | 11 | module Ring : sig 12 | include Ring.T with type t := r 13 | end 14 | 15 | include Group.Additive with type t := t 16 | 17 | (** Left action of the ring. *) 18 | val cmul : r -> t -> t 19 | end 20 | 21 | (** A right module. *) 22 | module type Right = sig 23 | include Left 24 | 25 | (** Right action of the ring. *) 26 | val cmul : t -> r -> t 27 | end 28 | 29 | (* 30 | (** A bimodule. *) 31 | module type Bi = sig 32 | include Left 33 | include Right 34 | end 35 | *) 36 | 37 | (** By default, by a module, we mean a left module. *) 38 | module type T = Left 39 | 40 | (** Free left module. *) 41 | module FreeLeft (R : Ring.T) (X : Alphabet.T) = struct 42 | module Ring = R 43 | 44 | module E = struct 45 | include Map.Make(X) 46 | 47 | let add x a p = 48 | if R.eq R.zero a then 49 | remove x p 50 | else 51 | add x a p 52 | end 53 | 54 | (** An element of the ring. *) 55 | type r = R.t 56 | 57 | (** An element of the module. *) 58 | type t = r E.t 59 | (* type element = t *) 60 | 61 | let zero : t = E.empty 62 | 63 | let cinj (a:R.t) (x:X.t) : t = E.add x a zero 64 | 65 | let inj x = cinj R.one x 66 | 67 | (** Coefficient of an element. *) 68 | let coeff (p:t) (x:X.t) = 69 | try E.find x p 70 | with Not_found -> R.zero 71 | 72 | let included x y = 73 | E.for_all (fun u a -> coeff y u = a) (x:t) 74 | 75 | let eq x y = 76 | included x y && included y x 77 | 78 | let compare _ _ = failwith "TODO: Module.FreeLeft.compare" 79 | 80 | let add_monomial (p:t) (a:r) (x:X.t) : t = 81 | let a = R.add a (coeff p x) in 82 | E.add x a p 83 | 84 | let add (p:t) (q:t) : t = 85 | E.fold (fun x a p -> add_monomial p a x) q p 86 | 87 | let cmul a (x:t) : t = 88 | E.map (R.mul a) x 89 | 90 | let neg (x:t) = 91 | cmul (R.neg R.one) x 92 | 93 | let sub x y = 94 | add x (neg y) 95 | 96 | let to_string (x:t) = 97 | if eq zero x then "0" else 98 | let ans = ref "" in 99 | E.iter (fun u a -> 100 | if !ans <> "" then ans := !ans ^ "+"; 101 | let a = 102 | if R.eq a R.one then "" else 103 | "(" ^ R.to_string a ^ ")" ^ "*" 104 | in 105 | ans := !ans ^ a ^ X.to_string u 106 | ) x; 107 | !ans 108 | 109 | (** Map a linear function. *) 110 | let map f (p:t) = 111 | E.fold (fun (x:X.t) a q -> add q (cmul a (f x))) p zero 112 | 113 | let iter f p = 114 | E.iter (fun (x:X.t) (a:R.t) -> f a x) p 115 | 116 | (** Morphisms between free modules. *) 117 | module Map = struct 118 | module E = Map.Make(X) 119 | 120 | type map = t E.t 121 | 122 | (** Define a map on a generator. *) 123 | let set (f:map) (x:X.t) (p:t) : map = 124 | E.add x p f 125 | 126 | (** Apply a map to a basis element (defaulting to 0.). *) 127 | let app (f:map) (x:X.t) = 128 | try 129 | E.find x f 130 | with 131 | | Not_found -> zero 132 | 133 | (** Extension of the map to all elements of the free module. *) 134 | let bind f (p:t) = 135 | E.fold (fun (x:X.t) a q -> add q (cmul a (app f x))) p zero 136 | 137 | (** The null morphism. *) 138 | let zero : map = E.empty 139 | 140 | let to_string (f:map) = 141 | E.fold (fun (x:X.t) (p:t) s -> s ^ (X.to_string x) ^ " -> " ^ (to_string p) ^ "\n") f "" 142 | 143 | type t = map 144 | end 145 | 146 | (** A presentation of a free module (a basis). *) 147 | module Pres = struct 148 | (** A presentation. *) 149 | type pres = X.t array 150 | 151 | type t = pres 152 | 153 | (** Create a presentation. *) 154 | let make gen = (gen : t) 155 | 156 | (** Dimension of a presentation. *) 157 | let dim (pres : t) = Array.length pres 158 | 159 | let presentation_to_string pres = 160 | let ans = ref "" in 161 | Array.iter (fun x -> 162 | ans := !ans ^ (if !ans = "" then "" else " ") ^ X.to_string x 163 | ) pres; 164 | !ans 165 | 166 | (** Linear maps between presentations. *) 167 | module Map = struct 168 | module M = Matrix.Make(R) 169 | module L = M.Labeled(X) 170 | 171 | (** A linear map (encoded as a matrix). *) 172 | type map = L.t 173 | type t = map 174 | 175 | (** Apply a morphism to an element. *) 176 | let app (f:t) p = 177 | map (fun x -> 178 | let ans = ref zero in 179 | L.iter_tgt (fun y -> 180 | ans := add !ans (cinj (L.get f x y) y) 181 | ) f; 182 | !ans 183 | ) p 184 | 185 | (** The zero morphism. *) 186 | let zero src tgt : t = L.zero src tgt 187 | 188 | (** Create from a map with given source and target. *) 189 | let of_map f src tgt = 190 | let ans = zero src tgt in 191 | Array.iter (fun x -> 192 | let p = Map.app f x in 193 | iter (fun a y -> L.set ans x y (R.add (L.get ans x y) a)) p 194 | ) src; 195 | ans 196 | 197 | (** Convert to a map. *) 198 | let to_map (f:t) = 199 | let ans = ref Map.zero in 200 | L.iter (fun x y -> 201 | ans := Map.set !ans x (add (Map.app !ans x) (cinj (L.get f x y) y)) 202 | ) f; 203 | !ans 204 | 205 | (** Rank of a map. *) 206 | let rank : t -> int = L.rank 207 | 208 | (** Nullity of a map. *) 209 | let nullity : t -> int = L.nullity 210 | 211 | (* TODO: improve this *) 212 | let to_string f = 213 | Map.to_string (to_map f) 214 | end 215 | 216 | (** Iterate a function on the generators of a module. *) 217 | let iter f (pres:t) = Array.iter f pres 218 | 219 | (** Chain complexes between free modules. *) 220 | module Complex = struct 221 | (** A chain complex. *) 222 | type t = 223 | { 224 | modules : pres array; 225 | d : Map.t array 226 | } 227 | 228 | let modules c = c.modules 229 | 230 | let maps c = c.d 231 | 232 | (** Length of a chain complex. *) 233 | let length c = Array.length c.d 234 | 235 | (** Create a chain complex. *) 236 | let make modules d = 237 | assert (Array.length modules = Array.length d + 1); 238 | { modules; d } 239 | 240 | (** Ensure that a chain complex satsifies d^2=0. *) 241 | let valid c = 242 | try 243 | for i = 1 to length c - 1 do 244 | iter (fun x -> 245 | let y = Map.app c.d.(i-1) (Map.app c.d.(i) (inj x)) in 246 | if not (eq zero y) then 247 | ( 248 | Printf.printf "invalid: %d\n%!" i; 249 | Printf.printf "d(%s) = %s\n%!" (X.to_string x) (to_string (Map.app c.d.(i) (inj x))); 250 | Printf.printf "d^2(%s) = %s\n%!" (X.to_string x) (to_string (Map.app c.d.(i-1) (Map.app c.d.(i) (inj x)))); 251 | raise Exit 252 | ) 253 | ) c.modules.(i+1) 254 | done; 255 | true 256 | with 257 | | Exit -> false 258 | 259 | (** String representation. *) 260 | let to_string c = 261 | let ans = ref "" in 262 | (* ans := !ans ^ "C" ^ string_of_int (length c) ^ ": " ^ presentation_to_string c.modules.(length c) ^ "\n\n"; *) 263 | for i = length c - 1 downto 0 do 264 | ans := !ans ^ "d" ^ string_of_int i ^ ":\n" ^ Map.to_string c.d.(i) ^ "\n"; 265 | (* ans := !ans ^ "C" ^ string_of_int i ^ ": " ^ presentation_to_string c.modules.(i) ^ "\n\n" *) 266 | done; 267 | !ans 268 | 269 | (** Compute betti numbers for the complex. *) 270 | let betti c = 271 | Array.init (length c) (fun i -> 272 | let ker = if i = 0 then dim c.modules.(0) else Map.nullity c.d.(i-1) in 273 | let im = Map.rank c.d.(i) in 274 | ker - im 275 | ) 276 | end 277 | 278 | (** String representation. *) 279 | let to_string = presentation_to_string 280 | end 281 | end 282 | module FreeLeftModule (R : Ring.T) (X : Alphabet.T) = (FreeLeft(R)(X) : Left) 283 | module Free (R : Ring.T) (X : Alphabet.T) = FreeLeft(R)(X) 284 | 285 | module FreeRight (R : Ring.T) (X : Alphabet.T) = struct 286 | include FreeLeft(Ring.Op(R))(X) 287 | 288 | let cinj x a = cinj a x 289 | 290 | let cmul x a = cmul a x 291 | 292 | let to_string (x:t) = 293 | let ans = ref "" in 294 | E.iter (fun u a -> 295 | if not (R.eq a R.zero) then 296 | ( 297 | if !ans <> "" then ans := !ans ^ "+"; 298 | let a = 299 | if R.eq a R.one then "" else 300 | "*" ^ "(" ^ R.to_string a ^ ")" 301 | in 302 | ans := !ans ^ X.to_string u ^ a 303 | ) 304 | ) x; 305 | !ans 306 | end 307 | module FreeRightModule (R : Ring.T) (X : Alphabet.T) = (FreeRight(R)(X) : Right) 308 | -------------------------------------------------------------------------------- /src/precategory.ml: -------------------------------------------------------------------------------- 1 | (** Higher-dimensional precategories. *) 2 | 3 | (** Free precategories. *) 4 | module Make (X : Alphabet.T) = struct 5 | (** A cell. *) 6 | (* Note: we suppose that generators are whiskered (by identities if necessary) 7 | all the way down. *) 8 | type cell = 9 | | C of whisker * cell (** a composite *) 10 | | I of cell (** an identity *) 11 | 12 | (** A whiskered generator. *) 13 | and whisker = 14 | | G of X.t (** a generator *) 15 | | W of cell * whisker * cell (** a whisker context *) 16 | 17 | type t = cell 18 | 19 | (** String representation of a cell. *) 20 | let to_string c = 21 | let rec list = function 22 | | C (w,c) -> w::(list c) 23 | | I _ -> [] 24 | in 25 | let rec cell = function 26 | | C _ as c -> "[" ^ String.concat "|" (List.map whisker (list c)) ^ "]" 27 | | I c -> "[" ^ cell c ^ "]" 28 | and whisker = function 29 | | G g -> X.to_string g 30 | | W (c1,w,c2) -> cell c1 ^ whisker w ^ cell c2 31 | in 32 | cell c 33 | 34 | (** Dimension of a cell. *) 35 | let dim c = 36 | let rec cell = function 37 | | C (w,_) -> whisker w 38 | | I c -> cell c + 1 39 | and whisker = function 40 | | G g -> 0 41 | | W (_,w,_) -> whisker w + 1 42 | in 43 | cell c 44 | 45 | (** Composition of two cells on the boundary of maximal dimension. *) 46 | let rec compose c d = 47 | if dim c = dim d then 48 | let rec aux = function 49 | | C (w,c) -> C (w, aux c) 50 | | I _ -> d 51 | in 52 | aux c 53 | else if dim c > dim d then 54 | let rec aux = function 55 | | C (w,c) -> 56 | let w = 57 | match w with 58 | | W (c1,w,c2) -> W (c1,w,compose c2 d) 59 | | G _ -> assert false 60 | in 61 | let c = aux c in 62 | C (w,c) 63 | | I c -> I (compose c d) 64 | in 65 | aux c 66 | else 67 | (* 68 | let rec aux = function 69 | | C (w,d) -> 70 | let w = 71 | match w with 72 | | W (d1,w,d2) -> W 73 | in 74 | let d = aux d in 75 | C (w,d) 76 | | I d -> I (compose c d) 77 | in 78 | aux d 79 | *) 80 | failwith "TODO" 81 | 82 | (** Presentation of a precategory: a "pre-polygraph". *) 83 | module Pres = struct 84 | module E = Map.Make(X) 85 | 86 | (* By convention, a zero cell has (physically) itself as source and target. *) 87 | type t = (cell * cell) E.t 88 | 89 | (** Empty signature. *) 90 | let empty = E.empty 91 | 92 | (** Does a generator belong the signature? *) 93 | let mem s g = 94 | E.mem g s 95 | 96 | let boundary s g = 97 | let x,y = E.find g s in 98 | assert (x != g && y != g); 99 | x,y 100 | 101 | (** Source of a generator. *) 102 | let source s g = 103 | fst (boundary s g) 104 | 105 | (** Target of a generator. *) 106 | let target s g = 107 | snd (boundary s g) 108 | 109 | (** Operations on cells in a presentation. *) 110 | module Cell = struct 111 | (** Ensure that a cell uses only generators defined in the signature. *) 112 | let mem s c = 113 | let rec cell = function 114 | | C (w,c) -> whisker w && cell c 115 | | I c -> cell c 116 | and whisker = function 117 | | W (c1,w,c2) -> cell c1 && whisker w && cell c2 118 | | G g -> mem s g 119 | in 120 | cell c 121 | 122 | (** Dimension of a cell. *) 123 | let dim s c = dim c 124 | 125 | (* let source s c = *) 126 | (* let rec cell = function *) 127 | (* | C (w,c) -> whisker w *) 128 | (* | I c -> c *) 129 | (* and whisker = function *) 130 | (* | W (c1,w,c2) -> *) 131 | (* cell *) 132 | (* | G g -> *) 133 | (* in *) 134 | end 135 | end 136 | end 137 | -------------------------------------------------------------------------------- /src/precubical.ml: -------------------------------------------------------------------------------- 1 | (** Precubical sets. *) 2 | 3 | (** Direction for taking faces. *) 4 | type dir = [`Src | `Tgt] 5 | 6 | (** A Precubical set. *) 7 | module type T = sig 8 | (** A cube. *) 9 | type t 10 | 11 | val to_string : t -> string 12 | 13 | (** Dimension of a simplex. *) 14 | val dim : t -> int 15 | 16 | (** Faces of a cube. *) 17 | val face : t -> int -> dir -> t 18 | end 19 | 20 | (** Presentation of a precubical set. *) 21 | module Pres (X : Alphabet.T) = struct 22 | (** Relations. *) 23 | module Relation = struct 24 | (** A relation formally identifies two faces of cubes. *) 25 | type t = (X.t * int * dir) * (X.t * int * dir) 26 | end 27 | 28 | (** Presentation of a precubical sets. *) 29 | type t = 30 | { 31 | generators : X.t list; (** generating cubes *) 32 | relations : Relation.t list; (** face identifications *) 33 | } 34 | end 35 | -------------------------------------------------------------------------------- /src/ring.ml: -------------------------------------------------------------------------------- 1 | (** Rings. *) 2 | 3 | (** A ring. *) 4 | module type T = sig 5 | type t 6 | 7 | val eq : t -> t -> bool 8 | 9 | val add : t -> t -> t 10 | 11 | val zero : t 12 | 13 | val neg : t -> t 14 | 15 | val mul : t -> t -> t 16 | 17 | val one : t 18 | 19 | val to_string : t -> string 20 | end 21 | 22 | (** An euclidean domain. *) 23 | module type Euclidean = sig 24 | include T 25 | 26 | val div : t -> t -> (t * t) 27 | end 28 | 29 | (** The ring of booleans. *) 30 | module Bool : (T with type t = bool) = struct 31 | type t = bool 32 | 33 | let eq x y = (x:bool) = (y:bool) 34 | 35 | let add x y = (x || y) && not (x && y) 36 | 37 | let zero = false 38 | 39 | let neg x = x 40 | 41 | let mul x y = x && y 42 | 43 | let one = true 44 | 45 | let to_string x = 46 | if x then "T" else "F" 47 | end 48 | 49 | (** The ring of integers. *) 50 | module Int : (T with type t = int) = struct 51 | type t = int 52 | 53 | let eq x y = (x:int) = (y:int) 54 | 55 | let add = ( + ) 56 | 57 | let zero = 0 58 | 59 | let neg x = - x 60 | 61 | let mul = ( * ) 62 | 63 | let one = 1 64 | 65 | let to_string = string_of_int 66 | end 67 | 68 | (** The ring of floats. *) 69 | module Float : (T with type t = float) = struct 70 | type t = float 71 | 72 | let eq (x:t) (y:t) = x = y 73 | 74 | let add = ( +. ) 75 | 76 | let zero = 0. 77 | 78 | let neg x = -. x 79 | 80 | let mul = ( *. ) 81 | 82 | let one = 1. 83 | 84 | let to_string = string_of_float 85 | end 86 | 87 | (** Polynomial ring over a ring. *) 88 | module Polynomial (R : T) = struct 89 | (** A polynomial. *) 90 | type t = R.t array 91 | 92 | let length (p:t) = Array.length p 93 | 94 | (** Degree of a polynomial. *) 95 | let degree (p:t) = 96 | let ans = ref 0 in 97 | try 98 | for i = length p - 1 downto 0 do 99 | if not (R.eq R.zero p.(i)) then 100 | ( 101 | ans := i; 102 | raise Exit 103 | ) 104 | done; 105 | min_int 106 | with 107 | | Exit -> !ans 108 | 109 | let eq (p:t) (q:t) = 110 | let dp = degree p in 111 | let dq = degree q in 112 | try 113 | if dp <> dq then raise Exit; 114 | for i = 0 to dp - 1 do 115 | if not (R.eq p.(i) q.(i)) then raise Exit 116 | done; 117 | true 118 | with 119 | | Exit -> false 120 | 121 | let compact p : t = 122 | Array.init (degree p) (fun i -> p.(i)) 123 | 124 | let coeff p i = 125 | if i < length p then p.(i) else R.zero 126 | 127 | let init n f : t = 128 | Array.init n f 129 | 130 | let rec add p q = 131 | let pl = length p in 132 | let ql = length q in 133 | if pl > ql then add q p else 134 | init ql (fun i -> if i < pl then R.add p.(i) q.(i) else q.(i)) 135 | 136 | let zero = [||] 137 | 138 | let cmul a (p:t) : t = 139 | Array.map (R.mul a) p 140 | 141 | let neg p = cmul (R.neg R.one) p 142 | 143 | let sub p q = 144 | add p (neg q) 145 | 146 | let mul p q = 147 | init (degree p + degree q) (fun n -> 148 | let ans = ref R.zero in 149 | for i = 0 to n do 150 | ans := R.add !ans (R.mul (coeff p i) (coeff q (n-i))) 151 | done; 152 | !ans 153 | ) 154 | 155 | let one = [|R.one|] 156 | 157 | let to_string (p:t) = 158 | let ans = ref "" in 159 | for i = 0 to length p - 1 do 160 | ans := !ans 161 | ^ (if i <> 0 then "+" else "") 162 | ^ (if R.eq R.zero p.(i) then "" else R.to_string p.(i) ^ if i = 0 then "" else ("X^" ^ string_of_int i)) 163 | done; 164 | !ans 165 | 166 | let monomial c n = 167 | let ans = Array.make (n+1) R.zero in 168 | ans.(n) <- c; 169 | ans 170 | end 171 | module PolynomialRing (R : T) = (Polynomial(R) : T) 172 | 173 | (** Opposite ring. *) 174 | module Op (R : T) : (T with type t = R.t) = struct 175 | include R 176 | 177 | let mul x y = mul y x 178 | end 179 | -------------------------------------------------------------------------------- /src/series.ml: -------------------------------------------------------------------------------- 1 | (** Formal series. *) 2 | 3 | (** Formal series over a given field. *) 4 | module Make (K : Field.T) = struct 5 | (** A formal series. *) 6 | type t = (K.t Weak.t ref * (int -> K.t)) 7 | 8 | (** Equality. *) 9 | let eq (a:t) (b:t) = failwith "Cannot implement this." 10 | 11 | (** Get a coefficient. *) 12 | let get (a:t) n = 13 | let aw, af = a in 14 | let awl = Weak.length !aw in 15 | let x = if n < awl then Weak.get !aw n else None in 16 | match x with 17 | | Some x -> x 18 | | None -> 19 | let x = af n in 20 | if n >= awl then 21 | ( 22 | let aw' = Weak.create (n+1) in 23 | Weak.blit aw' 0 !aw 0 awl; 24 | aw := aw' 25 | ); 26 | Weak.set !aw n (Some x); 27 | x 28 | 29 | let coeff = get 30 | 31 | let to_string a = 32 | let ans = ref (K.to_string (get a 0)) in 33 | for i = 1 to 8 do 34 | let ai = get a i in 35 | if not (K.eq ai K.zero) then 36 | ans := 37 | !ans 38 | ^ "+" 39 | ^ (if K.eq ai K.one then "" else K.to_string ai) 40 | ^ (if i = 1 then "z" else "z^" ^ string_of_int i) 41 | done; 42 | ans := !ans ^ "+..."; 43 | !ans 44 | 45 | let make f : t = (ref (Weak.create 0), f) 46 | 47 | (** Zero. *) 48 | let zero = make (fun _ -> K.zero) 49 | 50 | (** One. *) 51 | let one = make (fun n -> if n = 0 then K.one else K.zero) 52 | 53 | let var = make (fun n -> if n = 1 then K.one else K.zero) 54 | 55 | (** Addition. *) 56 | let add a b = make (fun n -> K.add (get a n) (get b n)) 57 | 58 | (** Subtraction. *) 59 | let sub a b = make (fun n -> K.add (get a n) (K.mul (K.neg K.one) (get b n))) 60 | 61 | (** Multiplication. *) 62 | let mul a b = 63 | let f n = 64 | let ans = ref K.zero in 65 | for i = 0 to n do 66 | ans := K.add !ans (K.mul (get a i) (get b (n-i))) 67 | done; 68 | !ans 69 | in 70 | make f 71 | 72 | (** Integer exponential. *) 73 | let rec expn a n = 74 | assert (n >= 0); 75 | if n = 0 then one 76 | else if n = 1 then a else 77 | mul a (expn a (n-1)) 78 | 79 | (** Hadamard product. *) 80 | let hadamard a b = make (fun n -> K.mul (get a n) (get b n)) 81 | 82 | (** Multiplication by a constant. *) 83 | let cmul a b = make (fun n -> K.mul a (get b n)) 84 | 85 | (** Negation. *) 86 | let neg a = make (fun n -> K.neg (get a n)) 87 | 88 | let star a = 89 | (* TODO *) 90 | assert (K.eq (get a 0) K.zero); 91 | (* add the exponents from 0 to n *) 92 | let rec aux n = 93 | if n = 0 then expn a 0 94 | else add (expn a n) (aux (n-1)) 95 | in 96 | make (fun n -> get (aux n) n) 97 | 98 | (** Inverse. *) 99 | let inv a = star (sub one a) 100 | 101 | module Polynomial = Ring.Polynomial(K) 102 | 103 | (** Canonical injection of polynomials. *) 104 | let polynomial (p : Polynomial.t) = 105 | make (fun n -> Polynomial.coeff p n) 106 | 107 | module RationalFractions = Field.RationalFractions(K) 108 | 109 | (** Canonical injection of rational fractions. *) 110 | let rational (r : RationalFractions.t) = 111 | let p, q = r in 112 | let p = polynomial p in 113 | let q = polynomial q in 114 | mul p (inv q) 115 | end 116 | 117 | (** The field of series. *) 118 | module Field (K : Field.T) : Ring.T = Make(K) 119 | -------------------------------------------------------------------------------- /src/simplicial.ml: -------------------------------------------------------------------------------- 1 | (** Simplicial sets. *) 2 | 3 | (** A simplicial set. *) 4 | module type T = sig 5 | (** A simplex. *) 6 | type t 7 | 8 | val to_string : t -> string 9 | 10 | (** Dimension of a simplex. *) 11 | val dim : t -> int 12 | 13 | (** Faces of a simplex. *) 14 | val face : t -> int -> int 15 | end 16 | 17 | module Pres (X : Alphabet.T) = struct 18 | end 19 | -------------------------------------------------------------------------------- /src/test/test.ml: -------------------------------------------------------------------------------- 1 | (* Testing Squier completion *) 2 | 3 | open Alg 4 | open Extlib 5 | open Term 6 | 7 | let ts_m a = Printf.sprintf "m(%s,%s)" (List.nth a 0) (List.nth a 1) 8 | let ts_e a = "e()" 9 | let ts_i a = Printf.sprintf "i(%s)" (List.hd a) 10 | 11 | let ts_m a = Printf.sprintf "(%s\\times %s)" (List.nth a 0) (List.nth a 1) 12 | let ts_m a = Printf.sprintf "%s\\times %s" (List.nth a 0) (List.nth a 1) 13 | let ts_e a = "1" 14 | let ts_i a = Printf.sprintf "\\overline{%s}" (List.hd a) 15 | 16 | let m = Op.make ~to_string:ts_m "m" 2 17 | let e = Op.make ~to_string:ts_e "e" 0 18 | let i = Op.make ~to_string:ts_i "i" 1 19 | let ops = [m; e; i] 20 | let e = app e [] 21 | let x = var () 22 | let y = var () 23 | let z = var () 24 | (* 25 | let assoc_l = app m [|app m [|x;y|];z|] 26 | let assoc_r = app m [|x; app m [|y;z|]|] 27 | let unit_l = app m [|e; x|] 28 | let unit_c = x 29 | let unit_r = app m [|x; e|] 30 | let rs = [ 31 | RS.Rule.make "assoc" assoc_l assoc_r; 32 | RS.Rule.make "unit-l" unit_l unit_c; 33 | RS.Rule.make "unit-r" unit_r unit_c 34 | ] 35 | let () = 36 | let t = app m [|app m [|app m [|x; y|]; z|]; var ()|] 37 | Printf.printf "t: %s\n%!" (to_string t); 38 | Printf.printf "t^: %s\n\n%!" (RS.Path.to_string (RS.normalize rs t)); 39 | *) 40 | 41 | let () = 42 | let t = Term.parse ops "m(m(x,y),z)" in 43 | Printf.printf "term: %s\n%!" (Term.to_string t) 44 | 45 | let m x y = app m [x;y] 46 | let i x = app i [x] 47 | let groups = 48 | RS.make ops 49 | [ 50 | RS.Rule.make "A" (m (m x y) z) (m x (m y z)); 51 | RS.Rule.make "L" (m e x) x; 52 | RS.Rule.make "R" (m x e) x; 53 | RS.Rule.make "E" (i e) e; 54 | RS.Rule.make "I" (m (i x) x) e; 55 | RS.Rule.make "J" (m x (i x)) e; 56 | RS.Rule.make "N" (i (i x)) x; 57 | RS.Rule.make "T" (m (i x) (m x y)) y; 58 | RS.Rule.make "U" (m x (m (i x) y)) y; 59 | RS.Rule.make "H" (i (m x y)) (m (i y) (i x)) 60 | ] 61 | 62 | let () = 63 | Printf.printf "%s\n\n%!" (RS.to_string groups) 64 | 65 | let hdef' = RS.Zigzag.parse groups "H(x,y)" 66 | let hdef = 67 | RS.Zigzag.parse groups 68 | "R(i(m(x,y)))-.\ 69 | m(i(m(x,y)),J(x))-.\ 70 | A(i(m(x,y)),x,i(x))-.\ 71 | m(m(i(m(x,y)),x),L(i(x)))-.\ 72 | m(m(i(m(x,y)),x),m(J(y),i(x)))-.\ 73 | A(m(i(m(x,y)),x),m(y,i(y)),i(x))-.\ 74 | m(A(m(i(m(x,y)),x),y,i(y)),i(x))-.\ 75 | m(m(A(i(m(x,y)),x,y),i(y)),i(x)).\ 76 | m(m(I(m(x,y)),i(y)),i(x)).\ 77 | m(L(i(y)),i(x)) 78 | " 79 | 80 | let () = 81 | let var = Var.namer_natural() in 82 | Printf.printf "H = %s : %s -> %s\n%!" (RS.Zigzag.to_string ~var hdef) (to_string ~var (RS.Zigzag.source hdef)) (to_string ~var (RS.Zigzag.target hdef)) 83 | 84 | let rule_name = Utils.namer (fun (s1,s2) (s1',s2') -> RS.Path.eq s1 s1' && RS.Path.eq s2 s2') 85 | let coherence = RS.squier groups 86 | 87 | let () = 88 | List.iter 89 | (fun (s1,s2) -> 90 | let n = rule_name (s1,s2) in 91 | let var = Term.Var.namer_natural () in 92 | let s1 = RS.Path.to_string ~var s1 in 93 | let s2 = RS.Path.to_string ~var s2 in 94 | Printf.printf "%02d: %s\n %s\n\n%!" (n+1) s1 s2 95 | ) coherence 96 | 97 | let rule_name = Utils.namer RS.Zigzag.eq 98 | (* let rule_name = Utils.namer (=) *) 99 | 100 | let coherence = List.map (fun (p1,p2) -> RS.Loop.of_cell (RS.Zigzag.of_path p1) (RS.Zigzag.of_path p2)) coherence 101 | 102 | let () = 103 | Printf.printf "\n****** zigzag *****\n\n%!"; 104 | List.iter 105 | (fun p -> 106 | let n = rule_name p in 107 | let var = Term.Var.namer_natural () in 108 | let p = RS.Zigzag.to_string ~var p in 109 | Printf.printf "%02d: %s\n\n%!" (n+1) p 110 | ) coherence 111 | 112 | let () = 113 | let cpres = 114 | let coherence = List.mapi (fun i p -> RS.Coherence.make ("C"^string_of_int (i+1)) p) coherence in 115 | RS.Coherent.make groups coherence 116 | in 117 | let cpres = RS.Coherent.add_coherence cpres "CH" (RS.Loop.of_cell hdef' hdef) in 118 | (* 119 | let cpres = RS.Coherent.elim_rule cpres "E" "C12" in 120 | let cpres = RS.Coherent.elim_rule cpres "N" "C30" in 121 | let cpres = RS.Coherent.elim_rule cpres "T" "C5" in 122 | let cpres = RS.Coherent.elim_rule cpres "U" "C7" in 123 | let cpres = RS.Coherent.elim_rule cpres "H" "CH" in 124 | Printf.printf "================ eliminated:\n%s\n%!" (RS.Coherent.to_string ~var:Var.namer_natural cpres); 125 | let rotations = ["C6", 7; "C8", 1; "C9", 8; "C10", 1; "C17", -2; "C18", 9; "C19", 9; "C21", -2; "C22", 9; "C23", 1; "C25", -12; "C26", -7; "C32", -2; "C33", -2; "C35", -7; "C36", -7; "C38", 1; "C40", 1; "C41", 3; "C42", -2; "C44", 3; "C45", -7; "C47", 6; "C48", 5; "C49", 6; "C50", 6; "C51", 13; "C52", 10] in 126 | let cpres = List.fold_left (fun cpres (c,n) -> RS.Coherent.rotate cpres c n) cpres rotations in 127 | *) 128 | RS.Coherent.view_pdf cpres 129 | 130 | (* for Im: 131 | add K36 : i(m(x62,x63)) -> m(i(x63),i(x62)) 132 | m(i(m(i(m(i(m(x61,i(x62))),x61)),m(x62,x63))),i(m(i(m(x61,i(x62))),x61))) -K35(i(m(i(m(x61,i(x62))),x61)),m(x62,x63))-> i(m(x62,x63)) 133 | m(i(m(i(m(i(m(x61,i(x62))),x61)),m(x62,x63))),i(m(i(m(x61,i(x62))),x61))) -m(i(K7(x61,x62,x63)),i(m(i(m(x61,i(x62))),x61)))-> m(i(x63),i(m(i(m(x61,i(x62))),x61))) -m(i(x63),i(K35(x61,i(x62))))-> m(i(x63),i(i(i(x62)))) -m(i(x63),i(K23(x62)))-> m(i(x63),i(x62)) 134 | *) 135 | -------------------------------------------------------------------------------- /src/utils.ml: -------------------------------------------------------------------------------- 1 | (** Various utility functions. *) 2 | 3 | (** Give integer names from elements with a notion of equality. *) 4 | let namer eq = 5 | let n = ref 0 in 6 | let names = ref [] in 7 | fun e -> 8 | if not (List.exists (fun (e',_) -> eq e e') !names) then 9 | ( 10 | names := (e,!n) :: !names; 11 | incr n 12 | ); 13 | snd (List.find (fun (e',_) -> eq e e') !names) 14 | 15 | -------------------------------------------------------------------------------- /test/.gitignore: -------------------------------------------------------------------------------- 1 | *.tex -------------------------------------------------------------------------------- /test/2group/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | @dune build 3 | -------------------------------------------------------------------------------- /test/2group/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name groups2) 3 | (modules groups2) 4 | (libraries alg) 5 | ) 6 | -------------------------------------------------------------------------------- /test/2group/groups.ml: -------------------------------------------------------------------------------- 1 | (* Testing Squier completion *) 2 | 3 | open Extlib 4 | open Term 5 | 6 | let ts_m a = Printf.sprintf "m(%s,%s)" (List.nth a 0) (List.nth a 1) 7 | let ts_e a = "e()" 8 | let ts_i a = Printf.sprintf "i(%s)" (List.hd a) 9 | 10 | let ts_m a = Printf.sprintf "(%s%s)" (List.nth a 0) (List.nth a 1) 11 | (* let ts_m a = Printf.sprintf "%s\\times %s" (List.nth a 0) (List.nth a 1) *) 12 | let ts_e a = "1" 13 | let ts_i a = Printf.sprintf "\\overline{%s}" (List.hd a) 14 | 15 | let m = Op.make ~to_string:ts_m "m" 2 16 | let e = Op.make ~to_string:ts_e "e" 0 17 | let i = Op.make ~to_string:ts_i "i" 1 18 | let ops = [m; e; i] 19 | let e = app e [] 20 | let x = var () 21 | let y = var () 22 | let z = var () 23 | 24 | let () = 25 | let t = Term.parse ops "m(m(x,y),z)" in 26 | Printf.printf "term: %s\n%!" (Term.to_string t) 27 | 28 | let m x y = app m [x;y] 29 | let i x = app i [x] 30 | let groups = 31 | RS.make ops 32 | [ 33 | RS.Rule.make "A" (m (m x y) z) (m x (m y z)); 34 | RS.Rule.make "L" (m e x) x; 35 | RS.Rule.make "R" (m x e) x; 36 | RS.Rule.make "E" (i e) e; 37 | RS.Rule.make "I" (m (i x) x) e; 38 | RS.Rule.make "J" (m x (i x)) e; 39 | RS.Rule.make "N" (i (i x)) x; 40 | RS.Rule.make "T" (m (i x) (m x y)) y; 41 | RS.Rule.make "U" (m x (m (i x) y)) y; 42 | RS.Rule.make "H" (i (m x y)) (m (i y) (i x)) 43 | ] 44 | 45 | let () = 46 | Printf.printf "%s\n\n%!" (RS.to_string groups) 47 | 48 | let rule_name = Utils.namer (fun (s1,s2) (s1',s2') -> RS.Path.eq s1 s1' && RS.Path.eq s2 s2') 49 | let coherence = RS.squier groups 50 | 51 | let () = 52 | List.iter 53 | (fun (s1,s2) -> 54 | let n = rule_name (s1,s2) in 55 | let var = Term.Var.namer_natural () in 56 | let s1 = RS.Path.to_string ~var s1 in 57 | let s2 = RS.Path.to_string ~var s2 in 58 | Printf.printf "%02d: %s\n %s\n\n%!" (n+1) s1 s2 59 | ) coherence 60 | 61 | let rule_name = Utils.namer RS.Zigzag.eq 62 | (* let rule_name = Utils.namer (=) *) 63 | 64 | let coherence = List.map (fun (p1,p2) -> RS.Loop.of_cell (RS.Zigzag.of_path p1) (RS.Zigzag.of_path p2)) coherence 65 | 66 | let () = 67 | Printf.printf "\n****** zigzag *****\n\n%!"; 68 | List.iter 69 | (fun p -> 70 | let n = rule_name p in 71 | let var = Term.Var.namer_natural () in 72 | let p = RS.Zigzag.to_string ~var p in 73 | Printf.printf "%02d: %s\n\n%!" (n+1) p 74 | ) coherence 75 | 76 | let () = 77 | let cpres = 78 | let coherence = List.mapi (fun i p -> RS.Coherence.make ("C"^string_of_int (i+1)) p) coherence in 79 | RS.Coherent.make groups coherence 80 | in 81 | (* 82 | let cpres = RS.Coherent.elim_rule cpres "E" "C12" in 83 | let cpres = RS.Coherent.elim_rule cpres "N" "C30" in 84 | let cpres = RS.Coherent.elim_rule cpres "T" "C5" in 85 | let cpres = RS.Coherent.elim_rule cpres "U" "C7" in 86 | let cpres = RS.Coherent.elim_rule cpres "H" "CH" in 87 | Printf.printf "================ eliminated:\n%s\n%!" (RS.Coherent.to_string ~var:Var.namer_natural cpres); 88 | let rotations = ["C6", 7; "C8", 1; "C9", 8; "C10", 1; "C17", -2; "C18", 9; "C19", 9; "C21", -2; "C22", 9; "C23", 1; "C25", -12; "C26", -7; "C32", -2; "C33", -2; "C35", -7; "C36", -7; "C38", 1; "C40", 1; "C41", 3; "C42", -2; "C44", 3; "C45", -7; "C47", 6; "C48", 5; "C49", 6; "C50", 6; "C51", 13; "C52", 10] in 89 | let cpres = List.fold_left (fun cpres (c,n) -> RS.Coherent.rotate cpres c n) cpres rotations in 90 | *) 91 | RS.Coherent.view_pdf cpres 92 | 93 | (* for Im: 94 | add K36 : i(m(x62,x63)) -> m(i(x63),i(x62)) 95 | m(i(m(i(m(i(m(x61,i(x62))),x61)),m(x62,x63))),i(m(i(m(x61,i(x62))),x61))) -K35(i(m(i(m(x61,i(x62))),x61)),m(x62,x63))-> i(m(x62,x63)) 96 | m(i(m(i(m(i(m(x61,i(x62))),x61)),m(x62,x63))),i(m(i(m(x61,i(x62))),x61))) -m(i(K7(x61,x62,x63)),i(m(i(m(x61,i(x62))),x61)))-> m(i(x63),i(m(i(m(x61,i(x62))),x61))) -m(i(x63),i(K35(x61,i(x62))))-> m(i(x63),i(i(i(x62)))) -m(i(x63),i(K23(x62)))-> m(i(x63),i(x62)) 97 | *) 98 | -------------------------------------------------------------------------------- /test/2group/groups2.ml: -------------------------------------------------------------------------------- 1 | (* Testing Squier completion *) 2 | 3 | open Alg 4 | open Extlib 5 | open Term 6 | 7 | let ts_m a = Printf.sprintf "m(%s,%s)" (List.nth a 0) (List.nth a 1) 8 | let ts_e _ = "e()" 9 | let ts_i a = Printf.sprintf "i(%s)" (List.hd a) 10 | let ts_j a = Printf.sprintf "j(%s)" (List.hd a) 11 | 12 | (* let ts_m a = Printf.sprintf "(%s%s)" (List.nth a 0) (List.nth a 1) *) 13 | (* let ts_e a = "1" *) 14 | (* let ts_i a = Printf.sprintf "\\overline{%s}" (List.hd a) *) 15 | (* let ts_j a = Printf.sprintf "\\underline{%s}" (List.hd a) *) 16 | 17 | let m = Op.make ~to_string:ts_m "m" 2 18 | let e = Op.make ~to_string:ts_e "e" 0 19 | let i = Op.make ~to_string:ts_i "i" 1 20 | let j = Op.make ~to_string:ts_j "j" 1 21 | let ops = [m; e; i] 22 | let e = app e [] 23 | let x = var () 24 | let y = var () 25 | let z = var () 26 | 27 | let m x y = app m [x;y] 28 | let i x = app i [x] 29 | let j x = app j [x] 30 | let groups = 31 | RS.make ops 32 | [ 33 | RS.Rule.make "A" (m (m x y) z) (m x (m y z)); 34 | RS.Rule.make "L" (m e x) x; 35 | RS.Rule.make "R" (m x e) x; 36 | RS.Rule.make "I" (m (i x) x) e; 37 | RS.Rule.make "J" (m x (j x)) e; 38 | RS.Rule.make "E" (i e) e; 39 | RS.Rule.make "F" (j e) e; 40 | RS.Rule.make "N" (i (i x)) x; 41 | RS.Rule.make "O" (j (j x)) x; 42 | RS.Rule.make "T" (m (i x) (m x y)) y; 43 | RS.Rule.make "U" (m x (m (j x) y)) y; 44 | RS.Rule.make "G" (i (m x y)) (m (i y) (i x)); 45 | RS.Rule.make "H" (j (m x y)) (m (j y) (j x)) 46 | ] 47 | 48 | let () = 49 | Printf.printf "presentation:\n%s\n\n%!" (RS.to_string groups) 50 | 51 | (* let () = *) 52 | (* let groups = RS.knuth_bendix groups in *) 53 | (* Printf.printf "completion:\n%s\n\n%!" (RS.to_string groups); *) 54 | 55 | let rule_name = Utils.namer (fun (s1,s2) (s1',s2') -> RS.Path.eq s1 s1' && RS.Path.eq s2 s2') 56 | let coherence = RS.squier groups 57 | 58 | let () = 59 | List.iter 60 | (fun (s1,s2) -> 61 | let n = rule_name (s1,s2) in 62 | let var = Term.Var.namer_natural () in 63 | let s1 = RS.Path.to_string ~var s1 in 64 | let s2 = RS.Path.to_string ~var s2 in 65 | Printf.printf "%02d: %s\n %s\n\n%!" (n+1) s1 s2 66 | ) coherence 67 | 68 | (* 69 | let rule_name = Utils.namer RS.Zigzag.eq 70 | (* let rule_name = Utils.namer (=) *) 71 | 72 | let coherence = List.map (fun (p1,p2) -> RS.Loop.of_cell (RS.Zigzag.of_path p1) (RS.Zigzag.of_path p2)) coherence 73 | 74 | let () = 75 | Printf.printf "\n****** zigzag *****\n\n%!"; 76 | List.iter 77 | (fun p -> 78 | let n = rule_name p in 79 | let var = Term.Var.namer_natural () in 80 | let p = RS.Zigzag.to_string ~var p in 81 | Printf.printf "%02d: %s\n\n%!" (n+1) p 82 | ) coherence 83 | 84 | let () = 85 | let cpres = 86 | let coherence = List.mapi (fun i p -> RS.Coherence.make ("C"^string_of_int (i+1)) p) coherence in 87 | RS.Coherent.make groups coherence 88 | in 89 | (* 90 | let cpres = RS.Coherent.elim_rule cpres "E" "C12" in 91 | let cpres = RS.Coherent.elim_rule cpres "N" "C30" in 92 | let cpres = RS.Coherent.elim_rule cpres "T" "C5" in 93 | let cpres = RS.Coherent.elim_rule cpres "U" "C7" in 94 | let cpres = RS.Coherent.elim_rule cpres "H" "CH" in 95 | Printf.printf "================ eliminated:\n%s\n%!" (RS.Coherent.to_string ~var:Var.namer_natural cpres); 96 | let rotations = ["C6", 7; "C8", 1; "C9", 8; "C10", 1; "C17", -2; "C18", 9; "C19", 9; "C21", -2; "C22", 9; "C23", 1; "C25", -12; "C26", -7; "C32", -2; "C33", -2; "C35", -7; "C36", -7; "C38", 1; "C40", 1; "C41", 3; "C42", -2; "C44", 3; "C45", -7; "C47", 6; "C48", 5; "C49", 6; "C50", 6; "C51", 13; "C52", 10] in 97 | let cpres = List.fold_left (fun cpres (c,n) -> RS.Coherent.rotate cpres c n) cpres rotations in 98 | *) 99 | RS.Coherent.view_pdf cpres 100 | 101 | (* for Im: 102 | add K36 : i(m(x62,x63)) -> m(i(x63),i(x62)) 103 | m(i(m(i(m(i(m(x61,i(x62))),x61)),m(x62,x63))),i(m(i(m(x61,i(x62))),x61))) -K35(i(m(i(m(x61,i(x62))),x61)),m(x62,x63))-> i(m(x62,x63)) 104 | m(i(m(i(m(i(m(x61,i(x62))),x61)),m(x62,x63))),i(m(i(m(x61,i(x62))),x61))) -m(i(K7(x61,x62,x63)),i(m(i(m(x61,i(x62))),x61)))-> m(i(x63),i(m(i(m(x61,i(x62))),x61))) -m(i(x63),i(K35(x61,i(x62))))-> m(i(x63),i(i(i(x62)))) -m(i(x63),i(K23(x62)))-> m(i(x63),i(x62)) 105 | *) 106 | *) 107 | -------------------------------------------------------------------------------- /test/Makefile: -------------------------------------------------------------------------------- 1 | ML = $(wildcard *.ml) 2 | PROG = $(ML:.ml=) 3 | 4 | all: 5 | @dune build 6 | 7 | runtest: 8 | @dune runtest 9 | 10 | braids: 11 | @dune exec ./braids.exe 12 | 13 | quaternion: 14 | @dune exec ./quaternion.exe 15 | 16 | qgroup: 17 | @dune exec ./qgroup.exe 18 | 19 | rig: 20 | @dune exec ./rig.exe 21 | 22 | dihedral: 23 | @dune exec ./dihedral.exe 24 | 25 | monoid: 26 | @dune exec ./squierMonoid.exe 27 | 28 | stl: 29 | @dune exec ./stl.exe 30 | 31 | stl2: 32 | @dune exec ./stl2.exe 33 | 34 | gen: 35 | @dune exec ./gen.exe 36 | 37 | uatao2: 38 | @dune exec ./uatao2.exe 39 | 40 | test: 41 | @for p in $(PROG); do echo "\n\n##### Running $$p #####\n"; dune exec ./$$p.exe || exit 1; done 42 | 43 | pdf: 44 | @dune exec ./squierGroup.exe 45 | pdflatex squierGroupFull.tex 46 | -------------------------------------------------------------------------------- /test/anick0.ml: -------------------------------------------------------------------------------- 1 | open Alg 2 | 3 | module X = struct 4 | include Alphabet.Int 5 | let to_string n = String.make 1 (char_of_int (int_of_char 'a' + n)) 6 | end 7 | module M = Monoid.Free(X) 8 | module K = Field.Int 9 | module P = Algebra.Pres(K)(X) 10 | module Gen = Algebra.Generate(K)(X) 11 | 12 | let () = 13 | let leq = M.Order.deglex X.leq in 14 | (* let pres = Gen.symmetric leq 6 in *) 15 | let pres = Gen.exterior leq 3 in 16 | Printf.printf "%s\n\n%!" (P.to_string pres); 17 | let pres = P.buchberger pres in 18 | Printf.printf "%s\n\n%!" (P.to_string pres); 19 | let n = 10 in 20 | (* let augmentation = P.Augmentation.monoid pres in *) 21 | let augmentation = P.Augmentation.graded pres in 22 | let d = P.Anick.resolution ~augmentation pres n in 23 | Printf.printf "%s\n%!" (P.Anick.AMod.Pres.Complex.to_string d); 24 | let d = P.Anick.complex ~augmentation pres (n+1) in 25 | Printf.printf "%s\n%!" (P.Anick.KMod.Pres.Complex.to_string d); 26 | assert (P.Anick.KMod.Pres.Complex.valid d); 27 | let h = P.Anick.betti ~augmentation pres (n-1) in 28 | Array.iteri (fun i n -> Printf.printf "H%d = %d\n" i n) h 29 | -------------------------------------------------------------------------------- /test/anick1.ml: -------------------------------------------------------------------------------- 1 | open Alg 2 | 3 | module M = struct 4 | include Monoid.Free(Alphabet.Char) 5 | 6 | let s s : t = 7 | Array.init (String.length s) (fun i -> s.[i]) 8 | end 9 | module K = Field.Int 10 | module P = Algebra.Pres(K)(Alphabet.Char) 11 | module A = P.A 12 | 13 | let () = 14 | Printexc.record_backtrace true; 15 | let alphabet = ['a'; 'b' (*; 'c'; 'd'; 'e'*)] in 16 | let l = [M.s "aaa"] in 17 | let cc = M.Anick.singletons alphabet in 18 | let cc = ref cc in 19 | for _ = 0 to 6 do 20 | Printf.printf "%s\n%!" (String.concat " " (List.map M.Anick.to_string !cc)); 21 | cc := M.Anick.extend l !cc 22 | done 23 | -------------------------------------------------------------------------------- /test/anick2.ml: -------------------------------------------------------------------------------- 1 | open Alg 2 | 3 | module M = struct 4 | include Monoid.Free(Alphabet.Char) 5 | 6 | let s s : t = 7 | Array.init (String.length s) (fun i -> s.[i]) 8 | end 9 | module K = Field.Int 10 | module P = Algebra.Pres(K)(Alphabet.Char) 11 | module A = P.A 12 | 13 | (* 14 | let () = 15 | Printexc.record_backtrace true; 16 | let alphabet = ['a'; 'b' (*; 'c'; 'd'; 'e'*)] in 17 | (* 18 | let l = [M.s "ab"; M.s "bb"] in 19 | let cc = M.Anick.singletons alphabet in 20 | let cc = ref cc in 21 | for i = 0 to 5 do 22 | Printf.printf "%s\n%!" (String.concat_map " " M.Anick.to_string !cc); 23 | cc := M.Anick.extend l !cc 24 | done; 25 | *) 26 | let relations = [ 27 | A.sub (A.inj (M.s "ab")) (A.inj (M.s "e")); 28 | A.sub (A.inj (M.s "bc")) (A.inj (M.s "d")); 29 | A.sub (A.inj (M.s "ad")) (A.inj (M.s "ec")) 30 | ] in 31 | let relations = [ A.sub (A.inj (M.s "aa")) (A.inj (M.s "a")) ] in 32 | let relations = [ 33 | A.sub (A.inj (M.s "aa")) (A.inj (M.s "a")); 34 | A.sub (A.inj (M.s "bb")) (A.inj (M.s "b")); 35 | A.sub (A.inj (M.s "aba")) (A.inj (M.s "bab")); 36 | ] 37 | in 38 | let pres = P.make (M.Order.deglex Alphabet.Char.leq) alphabet relations in 39 | Printf.printf "%s\n\n%!" (P.to_string pres); 40 | let n = 2 in 41 | let d = P.Anick.resolution pres n in 42 | Printf.printf "%s\n%!" (P.Anick.AMod.Pres.Complex.to_string d); 43 | let h = P.Anick.homology pres n in 44 | Array.iteri (fun i n -> Printf.printf "H%d = %d\n" i n) h; 45 | () 46 | *) 47 | 48 | let () = 49 | (* let alphabet = ['a'; 'b' ; 'c'; 'd'; 'e'] in *) 50 | (* 51 | let relations = [ 52 | A.sub (A.inj (M.s "ab")) (A.inj (M.s "e")); 53 | A.sub (A.inj (M.s "bc")) (A.inj (M.s "d")); 54 | (* A.sub (A.inj (M.s "ad")) (A.inj (M.s "ec")) *) 55 | ] in 56 | *) 57 | (* let relations = [ *) 58 | (* A.sub (A.inj (M.s "ab")) (A.inj (M.s "ee")); *) 59 | (* A.sub (A.inj (M.s "bc")) (A.inj (M.s "ed")); *) 60 | (* ] in *) 61 | let alphabet = ['x'; 'y'; 'z'] in 62 | let relations = [ 63 | A.sub 64 | (A.add (A.add (A.inj (M.s "xxx")) (A.inj (M.s "yyy"))) (A.inj (M.s "zzz"))) 65 | (A.inj (M.s "xyz")) 66 | ] in 67 | let pres = P.make (M.Order.deglex Alphabet.Char.leq) alphabet relations in 68 | Printf.printf "%s\n\n%!" (P.to_string pres); 69 | Printf.printf "Completing...\n%!"; 70 | let pres = P.buchberger pres in 71 | Printf.printf "%s\n\n%!" (P.to_string pres); 72 | Printf.printf "Reducing...\n%!"; 73 | let pres = P.reduce pres in 74 | Printf.printf "%s\n\n%!" (P.to_string pres); 75 | Printf.printf "Resolving...\n%!"; 76 | let n = 5 in 77 | let d = P.Anick.resolution pres n in 78 | Printf.printf "%s\n%!" (P.Anick.AMod.Pres.Complex.to_string d); 79 | Printf.printf "Building complex...\n%!"; 80 | let d = P.Anick.complex pres n in 81 | assert (P.Anick.KMod.Pres.Complex.valid d); 82 | Printf.printf "%s\n%!" (P.Anick.KMod.Pres.Complex.to_string d); 83 | Printf.printf "Computing homology...\n%!"; 84 | let h = P.Anick.betti pres n in 85 | Array.iteri (fun i n -> Printf.printf "H%d = %d\n" i n) h 86 | -------------------------------------------------------------------------------- /test/anick3.ml: -------------------------------------------------------------------------------- 1 | open Alg 2 | 3 | module M = struct 4 | include Monoid.Free(Alphabet.Char) 5 | 6 | let s s : t = 7 | Array.init (String.length s) (fun i -> s.[i]) 8 | end 9 | module K = Field.Int 10 | module P = Algebra.Pres(K)(Alphabet.Char) 11 | module A = P.A 12 | 13 | let () = 14 | let alphabet = ['x'; 'y'] in 15 | let relations = [ 16 | A.add 17 | (A.add (A.inj (M.s "xx")) (A.inj (M.s "xy"))) 18 | (A.add (A.inj (M.s "yx")) (A.inj (M.s "yy"))) 19 | ] in 20 | ignore relations; 21 | (* 22 | let relations = [ 23 | A.add (A.inj (M.s "xx")) 24 | (A.neg 25 | (A.add 26 | (A.inj (M.s "xy")) 27 | (A.add (A.inj (M.s "yx")) (A.inj (M.s "yy")))) 28 | ) 29 | ] in 30 | *) 31 | (* let relations = [ *) 32 | (* A.sub (A.inj (M.s "xx")) (A.inj (M.s "yy")) *) 33 | (* ] in *) 34 | let relations = [ 35 | A.sub (A.inj (M.s "xx")) A.one 36 | ] 37 | in 38 | let pres = P.make (M.Order.deglex Alphabet.Char.geq) alphabet relations in 39 | Printf.printf "%s\n\n%!" (P.to_string pres); 40 | let augmentation = P.Augmentation.monoid pres in 41 | let pres = P.buchberger pres in 42 | Printf.printf "%s\n\n%!" (P.to_string pres); 43 | let n = 10 in 44 | let d = P.Anick.resolution ~augmentation pres (n+1) in 45 | Printf.printf "%s\n%!" (P.Anick.AMod.Pres.Complex.to_string d); 46 | let d = P.Anick.complex ~augmentation pres (n+1) in 47 | Printf.printf "%s\n%!" (P.Anick.KMod.Pres.Complex.to_string d); 48 | assert (P.Anick.KMod.Pres.Complex.valid d); 49 | let h = P.Anick.betti ~augmentation pres n in 50 | Array.iteri (fun i n -> Printf.printf "H%d = %d\n" i n) h; 51 | () 52 | -------------------------------------------------------------------------------- /test/braids.ml: -------------------------------------------------------------------------------- 1 | open Alg 2 | 3 | module X = struct 4 | include Alphabet.Int 5 | let to_string n = String.make 1 (char_of_int (int_of_char 'a' + n)) 6 | end 7 | module P = Monoid.Pres(X) 8 | 9 | let () = 10 | let a = 0 in 11 | let b = 1 in 12 | let c = 2 in 13 | let pres = 14 | P.make [a;b;c] [ 15 | "",[|a;b;a|],[|b;a;b|]; 16 | "",[|b;a|],[|c|]; 17 | ] 18 | in 19 | let leq = P.W.Order.deglex X.geq in 20 | print_endline ("presentation: " ^ P.to_string pres); 21 | let pres = P.orient leq pres in 22 | print_endline ("oriented presentation: " ^ P.to_string pres); 23 | let pres = P.complete leq pres in 24 | print_endline ("completed: " ^ P.to_string pres); 25 | let pres = P.reduce pres in 26 | print_endline ("reduced: " ^ P.to_string pres); 27 | -------------------------------------------------------------------------------- /test/catpres.ml: -------------------------------------------------------------------------------- 1 | open Alg 2 | 3 | module X = Alphabet.String 4 | module CP = Category.Pres(X)(X) 5 | 6 | let () = 7 | let p = CP.empty in 8 | let p = CP.add_object p "x" in 9 | let p = CP.add_object p "y" in 10 | let p = CP.add_object p "z" in 11 | let p = CP.add_morphism p "f" "x" "y" in 12 | let p = CP.add_morphism p "g" "y" "z" in 13 | let p = CP.add_morphism p "h" "x" "z" in 14 | let p = CP.add_relation p (CP.Free.comp (CP.morphism p "f") (CP.morphism p "g")) (CP.morphism p "h") in 15 | Printf.printf "%s\n%!" (CP.to_string p) 16 | -------------------------------------------------------------------------------- /test/cl.ml: -------------------------------------------------------------------------------- 1 | (** Test combinatory logic. *) 2 | 3 | open Alg 4 | open CombinatoryLogic 5 | 6 | let () = 7 | print_endline (to_string (App (App (S, K), I))); 8 | print_endline (to_string (App (S, App (K, I)))); 9 | let test s = s |> of_string |> to_string |> print_endline in 10 | test "S K I"; 11 | test "(S K) I"; 12 | test "S (K I)"; 13 | let normalize s = s |> of_string |> normalize |> to_string |> print_endline in 14 | normalize "S I I I"; 15 | normalize "S(S(K S) I)(K I)"; 16 | normalize "S(K(S(K S)(S(K K)(S(K S) K)))) K" 17 | -------------------------------------------------------------------------------- /test/dihedral.ml: -------------------------------------------------------------------------------- 1 | open Alg 2 | 3 | module X = struct 4 | include Alphabet.Int 5 | let to_string = function 6 | | 0 -> "r" 7 | | 1 -> "s" 8 | | _ -> assert false 9 | end 10 | module P = Monoid.Pres(X) 11 | module W = P.W 12 | module G = Monoid.Generate(X) 13 | 14 | let () = 15 | let presentation = G.dihedral in 16 | let pres = presentation 6 in 17 | print_endline ("presentation: " ^ P.to_string pres); 18 | let pres = P.complete (P.W.Order.deglex X.leq) pres in 19 | print_endline ("completed: " ^ P.to_string pres); 20 | let pres = P.reduce pres in 21 | print_endline ("reduced: " ^ P.to_string pres); 22 | print_endline ("branchings: " ^ (P.critical_branchings pres |> List.length |> string_of_int)); 23 | List.iter 24 | (fun (p,q) -> 25 | print_endline (" - " ^ P.Path.to_string p); 26 | print_endline (" " ^ P.Path.to_string q) 27 | ) (P.coherence pres); 28 | print_newline (); 29 | for i = 1 to 10 do 30 | presentation i 31 | |> P.complete (P.W.Order.deglex X.leq) 32 | |> P.reduce 33 | |> P.to_string 34 | |> Printf.printf "D%02d: %s\n%!" i 35 | done 36 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name anick0) 3 | (modules anick0) 4 | (libraries alg) 5 | ) 6 | 7 | (executable 8 | (name anick1) 9 | (modules anick1) 10 | (libraries alg) 11 | ) 12 | 13 | (executable 14 | (name anick2) 15 | (modules anick2) 16 | (libraries alg) 17 | ) 18 | 19 | (executable 20 | (name anick3) 21 | (modules anick3) 22 | (libraries alg) 23 | ) 24 | 25 | (executable 26 | (name catpres) 27 | (modules catpres) 28 | (libraries alg) 29 | ) 30 | 31 | (executable 32 | (name jordan) 33 | (modules jordan) 34 | (libraries alg) 35 | ) 36 | 37 | (executable 38 | (name kb) 39 | (modules kb) 40 | (libraries alg) 41 | ) 42 | 43 | (executable 44 | (name kleene) 45 | (modules kleene) 46 | (libraries alg) 47 | ) 48 | 49 | (executable 50 | (name mon) 51 | (modules mon) 52 | (libraries alg) 53 | ) 54 | 55 | (rule 56 | (alias runtest) 57 | (action (run ./mon.exe)) 58 | ) 59 | 60 | (executable 61 | (name moni) 62 | (modules moni) 63 | (libraries alg) 64 | ) 65 | 66 | (executable 67 | (name mone) 68 | (modules mone) 69 | (libraries alg) 70 | ) 71 | 72 | (executable 73 | (name rig) 74 | (modules rig) 75 | (libraries alg) 76 | ) 77 | 78 | (executable 79 | (name squierGroup) 80 | (modules squierGroup) 81 | (libraries alg) 82 | ) 83 | 84 | (executable 85 | (name squierMonoid) 86 | (modules squierMonoid) 87 | (libraries alg) 88 | ) 89 | 90 | (rule 91 | (alias runtest) 92 | (action (run ./anick0.exe)) 93 | ) 94 | 95 | (rule 96 | (alias runtest) 97 | (action (run ./anick1.exe)) 98 | ) 99 | 100 | (rule 101 | (alias runtest) 102 | (action (run ./anick2.exe)) 103 | ) 104 | 105 | (rule 106 | (alias runtest) 107 | (action (run ./anick3.exe)) 108 | ) 109 | 110 | (rule 111 | (alias runtest) 112 | (action (run ./catpres.exe)) 113 | ) 114 | 115 | (rule 116 | (alias runtest) 117 | (action (run ./jordan.exe)) 118 | ) 119 | 120 | (rule 121 | (alias runtest) 122 | (action (run ./kb.exe)) 123 | ) 124 | 125 | (rule 126 | (alias runtest) 127 | (action (run ./kleene.exe)) 128 | ) 129 | 130 | (rule 131 | (alias runtest) 132 | (action (run ./rig.exe)) 133 | ) 134 | 135 | (rule 136 | (alias runtest) 137 | (action (run ./squierGroup.exe)) 138 | ) 139 | 140 | (rule 141 | (alias runtest) 142 | (action (run ./squierMonoid.exe)) 143 | ) 144 | 145 | (executable 146 | (name quaternion) 147 | (modules quaternion) 148 | (libraries alg) 149 | ) 150 | 151 | (rule 152 | (alias runtest) 153 | (action (run ./quaternion.exe)) 154 | ) 155 | 156 | (executable 157 | (name braids) 158 | (modules braids) 159 | (libraries alg) 160 | ) 161 | 162 | (rule 163 | (alias runtest) 164 | (action (run ./braids.exe)) 165 | ) 166 | 167 | (executable 168 | (name mirai) 169 | (modules mirai) 170 | (libraries alg) 171 | ) 172 | 173 | (rule 174 | (alias runtest) 175 | (action (run ./mirai.exe)) 176 | ) 177 | 178 | (executable 179 | (name dihedral) 180 | (modules dihedral) 181 | (libraries alg) 182 | ) 183 | 184 | (rule 185 | (alias runtest) 186 | (action (run ./dihedral.exe)) 187 | ) 188 | 189 | (executable 190 | (name stl) 191 | (modules stl) 192 | (libraries alg) 193 | ) 194 | 195 | (rule 196 | (alias runtest) 197 | (action (run ./stl.exe)) 198 | ) 199 | 200 | (executable 201 | (name stl2) 202 | (modules stl2) 203 | (libraries alg) 204 | ) 205 | 206 | (rule 207 | (alias runtest) 208 | (action (run ./stl2.exe)) 209 | ) 210 | 211 | (executable 212 | (name uatao) 213 | (modules uatao) 214 | (libraries alg) 215 | ) 216 | 217 | (executable 218 | (name uatao2) 219 | (modules uatao2) 220 | (libraries alg) 221 | ) 222 | 223 | (executable 224 | (name gen) 225 | (modules gen) 226 | (libraries alg) 227 | ) 228 | 229 | (rule 230 | (alias runtest) 231 | (action (run ./gen.exe)) 232 | ) 233 | 234 | (executable 235 | (name cl) 236 | (modules cl) 237 | (libraries alg) 238 | ) 239 | 240 | (rule 241 | (alias runtest) 242 | (action (run ./cl.exe)) 243 | ) 244 | 245 | (executable 246 | (name qgroup) 247 | (modules qgroup) 248 | (libraries alg) 249 | ) 250 | 251 | (rule 252 | (alias runtest) 253 | (action (run ./qgroup.exe)) 254 | ) 255 | -------------------------------------------------------------------------------- /test/gen.ml: -------------------------------------------------------------------------------- 1 | (** Try generating terms. *) 2 | 3 | open Alg 4 | open Term 5 | 6 | let m = Op.make "m" 2 7 | let ops = [m] 8 | 9 | let () = 10 | List.iter 11 | (fun t -> 12 | print_endline (Term.to_string t) 13 | ) (Term.generate_ops ops 3) 14 | 15 | (* 16 | let () = 17 | let x = var () in 18 | let y = var () in 19 | let m x y = app m [x;y] in 20 | let s = Renaming.unify_opt [] (m x y) (m x x) in 21 | Printf.printf "unifiable: %b\n%!" (s <> None) 22 | *) 23 | -------------------------------------------------------------------------------- /test/jordan.ml: -------------------------------------------------------------------------------- 1 | (* Testing non-commutative Jordan algebras. *) 2 | 3 | open Alg 4 | open Term 5 | 6 | let mm = Op.make "m" 2 7 | let x = var () 8 | let y = var () 9 | 10 | let m x y = app mm [x;y] 11 | 12 | let ja = 13 | RS.make [mm] 14 | [ 15 | RS.Rule.make "A" (m (m x y) (m x x)) (m x (m y (m x x))); 16 | ] 17 | let () = Printf.printf "Jordan algebras\n\n%s\n\n%!" (RS.to_string ja) 18 | (* let ja = RS.knuth_bendix ja *) 19 | (* let () = Printf.printf "completion\n\n%s\n\n%!" (RS.to_string ja) *) 20 | -------------------------------------------------------------------------------- /test/kb.ml: -------------------------------------------------------------------------------- 1 | (* Testing Knuth-Bendix completion. *) 2 | 3 | open Alg 4 | open Term 5 | 6 | let mm = Op.make "m" 2 7 | let ee = Op.make "e" 0 8 | let ii = Op.make ~weight:1 "i" 1 9 | let x = var () 10 | let y = var () 11 | let z = var () 12 | 13 | let m x y = app mm [x;y] 14 | let e = app ee [] 15 | let i x = app ii [x] 16 | 17 | let monoids = 18 | RS.make [mm; ee] 19 | [ 20 | RS.Rule.make "El" (m e x) x; 21 | RS.Rule.make "Er" (m x e) x; 22 | RS.Rule.make "A" (m (m x y) z) (m x (m y z)); 23 | ] 24 | let () = Printf.printf "monoids\n\n%s\n\n%!" (RS.to_string monoids) 25 | let monoids = RS.knuth_bendix monoids 26 | let () = Printf.printf "completion\n\n%s\n\n%!" (RS.to_string monoids) 27 | 28 | 29 | let groups = 30 | RS.make [mm; ee; ii] 31 | [ 32 | RS.Rule.make "E" (m e x) x; 33 | RS.Rule.make "I" (m (i x) x) e; 34 | RS.Rule.make "A" (m (m x y) z) (m x (m y z)); 35 | ] 36 | let () = Printf.printf "groups\n\n%s\n\n%!" (RS.to_string groups) 37 | let groups = RS.knuth_bendix groups 38 | let () = Printf.printf "completion\n\n%s\n\n%!" (RS.to_string groups) 39 | 40 | (* Tarski's presentations of groups with one rule. *) 41 | (* 42 | let dd = Op.make "d" 2 43 | let d x y = app dd [x;y] 44 | let x = var () 45 | let y = var () 46 | let z = var () 47 | let groups = 48 | RS.make [dd] 49 | [ 50 | RS.Rule.make "D" 51 | (d 52 | x 53 | (d 54 | (d 55 | (d (d x x) y) 56 | z 57 | ) 58 | (d 59 | (d 60 | (d x x) 61 | x 62 | ) 63 | z 64 | ) 65 | ) 66 | ) 67 | y 68 | ] 69 | let () = Printf.printf "groups\n\n%s\n\n%!" (RS.to_string groups) 70 | let groups = RS.knuth_bendix groups 71 | let () = Printf.printf "completion\n\n%s\n\n%!" (RS.to_string groups) 72 | *) 73 | -------------------------------------------------------------------------------- /test/kleene.ml: -------------------------------------------------------------------------------- 1 | open Alg 2 | 3 | module A = Automaton.Make(Alphabet.Char) 4 | module R = A.Regexp 5 | module S = A.Regexp.Series 6 | 7 | let () = 8 | (* bba as factor *) 9 | let trans = [ 10 | 0, 'a', 0; 11 | 0, 'b', 1; 12 | 1, 'a', 0; 13 | 1, 'b', 2; 14 | 2, 'a', 3; 15 | 2, 'b', 2; 16 | 3, 'a', 3; 17 | 3, 'b', 3 18 | ] 19 | in 20 | let aut = A.create 4 0 [3] trans in 21 | (* 22 | (* bb as factor *) 23 | let trans = [ 24 | 0, 'a', 0; 25 | 0, 'b', 1; 26 | 1, 'a', 0; 27 | 1, 'b', 2; 28 | 2, 'a', 2; 29 | 2, 'b', 2; 30 | ] 31 | in 32 | let aut = A.create 3 0 [2] trans in 33 | *) 34 | (* 35 | (* a as factor *) 36 | let trans = [ 37 | 0, 'a', 1; 38 | 1, 'b', 0; 39 | 1, 'a', 1; 40 | 1, 'b', 1; 41 | ] 42 | in 43 | let aut = A.create 2 0 [1] trans in 44 | *) 45 | let r = A.kleene aut in 46 | let r = A.Regexp.simpl r in 47 | Printf.printf "%s\n%!" (A.Regexp.to_string r); 48 | let g = (A.Regexp.series r) in 49 | Printf.printf "%s\n%!" (A.Regexp.Series.to_string g) 50 | -------------------------------------------------------------------------------- /test/mirai.ml: -------------------------------------------------------------------------------- 1 | open Alg 2 | 3 | module M = struct 4 | include Monoid.Free(Alphabet.Char) 5 | 6 | let s s : t = 7 | Array.init (String.length s) (fun i -> s.[i]) 8 | end 9 | module K = Field.Int 10 | module P = Algebra.Pres(K)(Alphabet.Char) 11 | module A = P.A 12 | 13 | let () = 14 | let alphabet = ['a'; 'b'; 'c'; 'd'; 'e'; 'g'; 'f'] in 15 | let relations = [ 16 | A.add 17 | (A.inj (M.s "aab")) 18 | (A.neg (A.inj (M.s "acc"))) 19 | ; 20 | A.add 21 | (A.inj (M.s "ccd")) 22 | (A.neg (A.inj (M.s "f"))) 23 | ; 24 | A.add 25 | (A.inj (M.s "cce")) 26 | (A.neg (A.inj (M.s "g"))) 27 | ; 28 | A.add 29 | (A.inj (M.s "cg")) 30 | (A.neg (A.inj (M.s "fe"))) 31 | ] in 32 | let pres = P.make (M.Order.deglex Alphabet.Char.geq) alphabet relations in 33 | Printf.printf "%s\n\n%!" (P.to_string pres); 34 | let augmentation = P.Augmentation.monoid pres in 35 | let pres = P.buchberger pres in 36 | Printf.printf "%s\n\n%!" (P.to_string pres); 37 | let d,s = P.Anick.resolution_ch ~augmentation pres 4 in 38 | Printf.printf "%s\n%!" (P.Anick.AMod.Pres.Complex.to_string d); 39 | let x = P.Anick.AMod.cinj (M.Anick.singleton 'a') (A.inj (M.s "bcd")) in 40 | Printf.printf "s(%s) = %s\n%!" (P.Anick.AMod.to_string x) (P.Anick.AMod.to_string (s.(1) x)) 41 | -------------------------------------------------------------------------------- /test/mon.ml: -------------------------------------------------------------------------------- 1 | (** Completion of the theory of monoids. *) 2 | 3 | open Alg 4 | open Term 5 | 6 | let m = Op.make "m" 2 7 | let e = Op.make "e" 0 8 | let ops = [m; e] 9 | let x = var () 10 | let y = var () 11 | let z = var () 12 | 13 | let m x y = app m [x;y] 14 | let e = app e [] 15 | let mon = 16 | RS.make ops 17 | [ 18 | RS.Rule.make "A" (m (m x y) z) (m x (m y z)); 19 | RS.Rule.make "L" (m e x) x; 20 | RS.Rule.make "R" (m x e) x; 21 | ] 22 | 23 | let gt = LPO.gt (<=) 24 | 25 | let mon = RS.orient ~gt mon 26 | 27 | let () = Printf.printf "# Theory\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural mon) 28 | 29 | let mon = RS.knuth_bendix ~gt 30 | (* ~callback:(fun rs -> Printf.printf "## KB\n\n%s\n\n" (RS.to_string ~var:Var.namer_natural rs)) *) 31 | mon 32 | 33 | let () = Printf.printf "# Completion\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural mon) 34 | 35 | let () = 36 | let branchings = 37 | RS.critical mon |> List.map fst |> List.map RS.Step.source |> List.map Term.to_string |> String.concat "\n" 38 | in 39 | Printf.printf "# Branchings\n\n%s\n\n%!" branchings 40 | 41 | let () = 42 | Printf.printf "# Coherent completion\n\n%!"; 43 | let coh = RS.squier mon in 44 | List.iter 45 | (fun (s1,s2) -> 46 | let var = Term.Var.namer_natural () in 47 | let s1 = RS.Path.to_string ~var s1 in 48 | let s2 = RS.Path.to_string ~var s2 in 49 | Printf.printf "%s\n%s\n\n%!" s1 s2 50 | ) coh 51 | 52 | -------------------------------------------------------------------------------- /test/mone.ml: -------------------------------------------------------------------------------- 1 | (** Completion of the theory involutive monoids, ie x*x=1. *) 2 | 3 | open Alg 4 | open Term 5 | 6 | let m = Op.make "m" 2 7 | let e = Op.make "e" 0 8 | let ops = [m; e] 9 | let x = var () 10 | let y = var () 11 | let z = var () 12 | 13 | let m x y = app m [x;y] 14 | let e = app e [] 15 | let mon = 16 | RS.make ops 17 | [ 18 | RS.Rule.make "A" (m (m x y) z) (m x (m y z)); 19 | RS.Rule.make "L" (m e x) x; 20 | RS.Rule.make "R" (m x e) x; 21 | RS.Rule.make "E" (m x x) e; 22 | (* RS.Rule.make "C1" (m x (m x y)) y; *) 23 | ] 24 | 25 | let gt = LPO.gt (>=) 26 | 27 | let mon = RS.orient ~gt mon 28 | 29 | let () = Printf.printf "# Theory\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural mon) 30 | 31 | let mon = RS.knuth_bendix ~gt 32 | (* ~callback:(fun rs -> Printf.printf "## KB\n\n%s\n\n" (RS.to_string ~var:Var.namer_natural rs)) *) 33 | mon 34 | 35 | let () = Printf.printf "# Completion\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural mon) 36 | 37 | let () = 38 | Printf.printf "# Coherent completion\n\n%!"; 39 | let coh = RS.squier mon in 40 | List.iter 41 | (fun (s1,s2) -> 42 | let var = Term.Var.namer_natural () in 43 | let s1 = RS.Path.to_string ~var s1 in 44 | let s2 = RS.Path.to_string ~var s2 in 45 | Printf.printf "%s\n%s\n\n%!" s1 s2 46 | ) coh 47 | 48 | -------------------------------------------------------------------------------- /test/moni.ml: -------------------------------------------------------------------------------- 1 | (** Completion of the theory of idempotent monoids. *) 2 | 3 | open Alg 4 | open Term 5 | 6 | let m = Op.make "m" 2 7 | let e = Op.make "e" 0 8 | let ops = [m; e] 9 | let x = var () 10 | let y = var () 11 | let z = var () 12 | 13 | let m x y = app m [x;y] 14 | let e = app e [] 15 | let mon = 16 | RS.make ops 17 | [ 18 | RS.Rule.make "A" (m (m x y) z) (m x (m y z)); 19 | RS.Rule.make "L" (m e x) x; 20 | RS.Rule.make "R" (m x e) x; 21 | RS.Rule.make "I" (m x x) x; 22 | ] 23 | 24 | let gt = LPO.gt (<=) 25 | 26 | let mon = RS.orient ~gt mon 27 | 28 | let () = Printf.printf "# Theory\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural mon) 29 | 30 | let mon = RS.knuth_bendix ~gt 31 | (* ~callback:(fun rs -> Printf.printf "## KB\n\n%s\n\n" (RS.to_string ~var:Var.namer_natural rs)) *) 32 | mon 33 | 34 | let () = Printf.printf "# Completion\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural mon) 35 | 36 | let () = 37 | Printf.printf "# Coherent completion\n\n%!"; 38 | let coh = RS.squier mon in 39 | List.iter 40 | (fun (s1,s2) -> 41 | let var = Term.Var.namer_natural () in 42 | let s1 = RS.Path.to_string ~var s1 in 43 | let s2 = RS.Path.to_string ~var s2 in 44 | Printf.printf "%s\n%s\n\n%!" s1 s2 45 | ) coh 46 | 47 | -------------------------------------------------------------------------------- /test/qgroup.ml: -------------------------------------------------------------------------------- 1 | (** The quaternion group. *) 2 | 3 | open Alg 4 | module List = struct 5 | include List 6 | 7 | let map_pairs f l1 l2 = 8 | List.flatten @@ List.map (fun x -> List.map (f x) l2) l1 9 | end 10 | 11 | let () = 12 | let module Q = Group.Quaternion in 13 | Q.elements 14 | |> List.map Q.to_string 15 | |> String.concat " " 16 | |> Printf.printf "- elements: %s\n%!"; 17 | List.map_pairs (fun x y -> Printf.sprintf "%s*%s=%s" (Q.to_string x) (Q.to_string y) (Q.to_string (Q.mul x y))) Q.elements Q.elements 18 | |> String.concat "\n" 19 | |> Printf.printf "- products:\n%s\n%!"; 20 | print_newline () 21 | 22 | module Q = struct 23 | include Group.Quaternion 24 | 25 | let to_string x = 26 | if is_negative x then to_string (neg x) ^ "^-" else to_string x 27 | end 28 | 29 | module Edge = struct 30 | type t = X | Y | Z | W 31 | 32 | let to_string = function 33 | | X -> "x" 34 | | Y -> "y" 35 | | Z -> "z" 36 | | W -> "w" 37 | 38 | let elements = [X;Y;Z;W] 39 | 40 | let phi = function 41 | | X -> Q.i 42 | | Y -> Q.j 43 | | Z -> Q.neg Q.k 44 | | W -> Q.one 45 | end 46 | 47 | let () = 48 | List.iter 49 | (fun n -> 50 | List.iter 51 | (fun e -> 52 | let n' = Q.neg n in 53 | Printf.printf {|%s%s&:a%s\to b%s&%s%s&:a%s\to b%s\\|} 54 | (Edge.to_string e) 55 | (Q.to_string n) 56 | (Q.to_string n) 57 | (Q.to_string (Q.mul n (Edge.phi e))) 58 | (Edge.to_string e) 59 | (Q.to_string n') 60 | (Q.to_string n') 61 | (Q.to_string (Q.mul n' (Edge.phi e))) 62 | ; 63 | print_newline () 64 | ) Edge.elements 65 | ) [Q.one;Q.i;Q.j;Q.k]; 66 | print_newline () 67 | 68 | (* 69 | let () = 70 | List.iter 71 | (fun q -> 72 | Printf.printf {|\begin{tikzcd}[sep=small] 73 | (b,%s)&\ar[l,"{(z,%s)}"']\ar[d,"{(w,%s)}"](a,%s)\\ 74 | (a,%s)\ar[u,"{(y,%s)}"]\ar[r,"{(x,%s)}"']&(b,%s) 75 | \end{tikzcd} 76 | \qquad 77 | |} 78 | (Q.to_string (Q.mul q Q.j)) 79 | (Q.to_string (Q.mul q Q.i)) 80 | (Q.to_string (Q.mul q Q.i)) 81 | (Q.to_string (Q.mul q Q.i)) 82 | (Q.to_string q) 83 | (Q.to_string q) 84 | (Q.to_string q) 85 | (Q.to_string (Q.mul q Q.i)) 86 | ) Q.elements 87 | *) 88 | 89 | (* 90 | let () = 91 | List.iter 92 | (fun q -> 93 | Printf.printf {|\begin{tikzcd}[sep=small] 94 | (b,%s)&\ar[l,"{(w,%s)}"']\ar[d,"{(x,%s)}"](a,%s)\\ 95 | (a,%s)\ar[u,"{(y,%s)}"]\ar[r,"{(z,%s)}"']&(b,%s) 96 | \end{tikzcd} 97 | \qquad 98 | |} 99 | (Q.to_string (Q.mul q Q.j)) 100 | (Q.to_string (Q.mul q Q.j)) 101 | (Q.to_string (Q.mul q Q.j)) 102 | (Q.to_string (Q.mul (Q.mul q (Q.neg Q.k)) (Q.neg Q.i))) 103 | (Q.to_string q) 104 | (Q.to_string q) 105 | (Q.to_string q) 106 | (Q.to_string (Q.mul q (Q.neg Q.k))) 107 | ) Q.elements 108 | *) 109 | 110 | let () = 111 | List.iter 112 | (fun q -> 113 | Printf.printf {|\begin{tikzcd}[sep=small] 114 | (b,%s)&\ar[l,"{(w,%s)}"']\ar[d,"{(y,%s)}"](a,%s)\\ 115 | (a,%s)\ar[u,"{(z,%s)}"]\ar[r,"{(x,%s)}"']&(b,%s) 116 | \end{tikzcd} 117 | \qquad 118 | |} 119 | (Q.to_string (Q.mul q (Q.neg Q.k))) 120 | (Q.to_string (Q.mul q (Q.neg Q.k))) 121 | (Q.to_string (Q.mul q (Q.neg Q.k))) 122 | (Q.to_string (Q.mul q (Q.neg Q.k))) 123 | (Q.to_string q) 124 | (Q.to_string q) 125 | (Q.to_string q) 126 | (Q.to_string (Q.mul q Q.i)) 127 | ) Q.elements 128 | -------------------------------------------------------------------------------- /test/quaternion.ml: -------------------------------------------------------------------------------- 1 | open Alg 2 | 3 | module X = struct 4 | include Alphabet.Int 5 | let to_string n = String.make 1 (char_of_int (int_of_char 'a' + n)) 6 | end 7 | module P = Monoid.Pres(X) 8 | 9 | let print fmt = Printf.printf fmt 10 | 11 | let string_of_branching (u1,((_,u,u'):P.Rule.t),u2) (v1,((_,_v,v'):P.Rule.t),v2) = 12 | let to_string u = if P.W.is_one u then "" else P.W.to_string u in 13 | let u1 = to_string u1 in 14 | let u = to_string u in 15 | let u' = to_string u' in 16 | let u2 = to_string u2 in 17 | let v1 = to_string v1 in 18 | let v' = to_string v' in 19 | let v2 = to_string v2 in 20 | Printf.sprintf "%s%s%s ←%s_%s- %s%s%s -%s_%s→ %s%s%s" u1 u' u2 u1 u2 u1 u u2 v1 v2 v1 v' v2 21 | 22 | let string_of_branching (r,s) = string_of_branching r s 23 | 24 | let study pres = 25 | print "# Presentation\n\n"; 26 | print "Original: %s\n\n" (P.to_string pres); 27 | let pres = P.complete (P.W.Order.deglex X.leq) pres in 28 | print "Completion: %s\n\n" (P.to_string pres); 29 | let pres = P.reduce pres in 30 | print "Reduction: %s\n\n" (P.to_string pres); 31 | let cb = P.critical_branchings pres in 32 | print "Branchings (%d):\n\n- %s\n\n" (List.length cb) (cb |> List.map string_of_branching |> String.concat "\n- ") 33 | 34 | let () = 35 | let a = 0 in 36 | let b = 1 in 37 | let pres = 38 | P.make [a;b] [ 39 | "",[|a;a;a;a|],[||]; 40 | "",[|a;a|],[|b;b|]; 41 | "",[|a;b;a|],[|b|] 42 | ] 43 | in 44 | study pres 45 | 46 | let () = 47 | let i = 0 in 48 | let j = 1 in 49 | let pres = 50 | P.make [i;j] [ 51 | "",[|i;j;i|],[|j|]; 52 | "",[|j;i;j|],[|i|] 53 | ] 54 | in 55 | study pres 56 | 57 | let () = 58 | let i = 0 in 59 | let j = 1 in 60 | let k = 2 in 61 | let e = 3 in 62 | let pres = 63 | P.make [i;j;k;e] [ 64 | "",[|i;i|],[|e|]; 65 | "",[|j;j|],[|e|]; 66 | "",[|k;k|],[|e|]; 67 | "",[|i;j;k|],[|e|]; 68 | "",[|e;e|],[||] 69 | ] 70 | in 71 | study pres 72 | 73 | let () = 74 | let r = 0 in 75 | let g = 1 in 76 | let b = 2 in 77 | let pres = 78 | P.make [r;g;b] [ 79 | "",[|b|],[|r;g|]; 80 | "",[|b;g;r|],[||]; 81 | "",[|g;b|],[|r|]; 82 | ] 83 | in 84 | study pres 85 | -------------------------------------------------------------------------------- /test/rig.ml: -------------------------------------------------------------------------------- 1 | (** Completion of the theory of RIGs. *) 2 | 3 | open Alg 4 | open Term 5 | 6 | let m = Op.make "m" 2 7 | let e = Op.make "e" 0 8 | let p = Op.make "p" 2 9 | let u = Op.make "u" 0 10 | let ops = [m; e; p; u] 11 | let x = var () 12 | let y = var () 13 | let z = var () 14 | 15 | let m x y = app m [x;y] 16 | let e = app e [] 17 | let p x y = app p [x;y] 18 | let u = app u [] 19 | let rigs = 20 | RS.make ops 21 | [ 22 | RS.Rule.make "A" (m (m x y) z) (m x (m y z)); 23 | RS.Rule.make "L" (m e x) x; 24 | RS.Rule.make "R" (m x e) x; 25 | RS.Rule.make "A+" (p (p x y) z) (p x (p y z)); 26 | RS.Rule.make "L+" (p u x) x; 27 | RS.Rule.make "R+" (p x u) x; 28 | RS.Rule.make "D" (m x (p y z)) (p (m x y) (m x z)); 29 | RS.Rule.make "D'" (m (p x y) z) (p (m x z) (m y z)); 30 | RS.Rule.make "N" (m x u) u; 31 | RS.Rule.make "N'" (m u x) u; 32 | ] 33 | 34 | let com = RS.Rule .make "C" (p x y) (p y x) 35 | 36 | module X = struct 37 | include Alphabet.Int 38 | let to_string n = Printf.sprintf "x%d" n 39 | end 40 | module M = Algebra.Free(Field.Float)(Monoid.Free(X)) 41 | 42 | let () = 43 | let module P = Interpretation.Polynomial in 44 | let op f x = 45 | let x i = P.var x.(i) in 46 | let (+) = P.add in 47 | let ( * ) = P.mul in 48 | let ( *~ ) = P.cmul in 49 | match Op.name f with 50 | | "p" -> P.add (2 *~ x 0 + x 1) P.one 51 | | "u" -> P.one 52 | | "m" -> x 0 * x 1 53 | | "e" -> P.one 54 | | _ -> assert false 55 | in 56 | Printf.printf "# Interpretation of generators\n\n%!"; 57 | List.iter (fun t -> Printf.printf "%s : %s\n%!" (Term.to_string t) (P.to_string (P.interpretation op t))) [m x y; e; p x y; u]; 58 | Printf.printf "\n# Interpretation of rules\n\n%!"; 59 | List.iter 60 | (fun r -> 61 | let s = RS.Rule.source r in 62 | let t = RS.Rule.target r in 63 | let s' = P.interpretation op s in 64 | let t' = P.interpretation op t in 65 | Printf.printf "%s => %s : %s => %s\n %s\n%!" (Term.to_string s) (Term.to_string t) (P.to_string s') (P.to_string t') (P.to_string (P.sub s' t')) 66 | ) ((RS.rules rigs)@[com]); 67 | Printf.printf "\n%!" 68 | 69 | let () = Printf.printf "# Theory\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural rigs) 70 | 71 | let gt = LPO.gt (<=) 72 | 73 | let rigs = RS.orient ~gt rigs 74 | 75 | let () = Printf.printf "# Oriented theory\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural rigs) 76 | 77 | (* Now, semi-rigs *) 78 | 79 | let rigs = RS.filter (fun r -> RS.Rule.name r <> "D") rigs 80 | 81 | let rigs = RS.knuth_bendix ~gt ~callback:(fun rs -> Printf.printf "## KB\n\n%s\n\n" (RS.to_string ~var:Var.namer_natural rs)) rigs 82 | 83 | let () = Printf.printf "# Completion\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural rigs) 84 | 85 | let () = 86 | let s = RS.squier rigs in 87 | Printf.printf "# Coherence\n\n"; 88 | List.iter 89 | (fun (p,q) -> 90 | Printf.printf "%s\n%s\n\n" (RS.Path.to_string p) (RS.Path.to_string q) 91 | ) s; 92 | Printf.printf "\n" 93 | -------------------------------------------------------------------------------- /test/squierGroup.ml: -------------------------------------------------------------------------------- 1 | (** Squier's coherent completion of the theory of groups. *) 2 | 3 | open Alg 4 | open Term 5 | 6 | let m = Op.make "m" 2 7 | let e = Op.make "e" 0 8 | let i = Op.make "i" 1 9 | let ops = [m; e; i] 10 | let x = var () 11 | let y = var () 12 | let z = var () 13 | 14 | let m x y = app m [x;y] 15 | let e = app e [] 16 | let i x = app i [x] 17 | let groups = 18 | RS.make ops 19 | [ 20 | RS.Rule.make "A" (m (m x y) z) (m x (m y z)); 21 | RS.Rule.make "E_l" (m e x) x; 22 | RS.Rule.make "E_r" (m x e) x; 23 | RS.Rule.make "E" (i e) e; 24 | RS.Rule.make "I_l" (m (i x) x) e; 25 | RS.Rule.make "I_r" (m x (i x)) e; 26 | RS.Rule.make "I_i" (i (i x)) x; 27 | RS.Rule.make "I_1" (m (i x) (m x y)) y; 28 | RS.Rule.make "I_2" (m x (m (i x) y)) y; 29 | RS.Rule.make "I_m" (i (m x y)) (m (i y) (i x)) 30 | ] 31 | 32 | let () = 33 | Printf.printf "%s\n\n%!" (RS.to_string ~var:Var.namer_natural groups) 34 | 35 | (* let () = *) 36 | (* let r = RS.Rule.make "r1" (m e x) x in *) 37 | (* let r' = RS.Rule.refresh r in *) 38 | (* assert (RS.Rule.eq r r') *) 39 | 40 | let rule_name = Utils.namer (fun (s1,s2) (s1',s2') -> RS.Path.eq s1 s1' && RS.Path.eq s2 s2') 41 | 42 | let coherence = RS.squier groups 43 | 44 | let () = 45 | List.iter 46 | (fun (s1,s2) -> 47 | let n = rule_name (s1,s2) in 48 | let var = Term.Var.namer_natural () in 49 | let s1 = RS.Path.to_string ~var s1 in 50 | let s2 = RS.Path.to_string ~var s2 in 51 | Printf.printf "%02d: %s\n %s\n\n%!" n s1 s2 52 | ) coherence 53 | 54 | (* 55 | let () = 56 | Printf.printf "Possible homotopical reductions:\n\n"; 57 | List.iter 58 | (fun (s1,s2) -> 59 | let tr = (RS.Path.toplevel_rules s1)@(RS.Path.toplevel_rules s2) in 60 | if tr <> [] then 61 | let tr = String.concat " " (List.map RS.Rule.to_string tr) in 62 | let rr1 = RS.Path.rules s1 in 63 | let rr2 = RS.Path.rules s2 in 64 | let rr1 = String.concat ", " (List.map RS.Rule.name rr1) in 65 | let rr2 = String.concat ", " (List.map RS.Rule.name rr2) in 66 | Printf.printf "%02d: %s\n %s / %s\n %s\n %s\n\n%!" (rule_name (s1,s2)) tr rr1 rr2 (RS.Path.to_string s1) (RS.Path.to_string s2) 67 | ) (RS.squier groups) 68 | *) 69 | 70 | let rs = groups 71 | 72 | let () = 73 | Printf.printf "\n***** LaTeX *****\n\n%!"; 74 | let oc = open_out "squierGroup.tex" in 75 | let print s = Printf.ksprintf (fun s -> (* print_string s; *) output_string oc s) s; in 76 | let namer = Term.Var.namer_natural in 77 | let rules = 78 | List.map 79 | (fun r -> 80 | let var = namer () in 81 | let s = Term.to_string ~var (RS.Rule.source r) in 82 | let t = Term.to_string ~var (RS.Rule.target r) in 83 | Printf.sprintf "%s &: %s \\to %s\\\\" 84 | (RS.Rule.name r) s t 85 | ) (RS.rules rs) 86 | in 87 | let rules = String.concat "\n" rules in 88 | print "\\section{Rules}\n\n\\begin{align*}\n%s\n\\end{align*}\n\n" rules; 89 | print "\\section{Coherence}\n\n"; 90 | let rulen = ref 0 in 91 | List.iter 92 | (fun (p1,p2) -> 93 | let p1,p2 = 94 | if RS.Path.length p1 > RS.Path.length p2 then p2,p1 else p1,p2 95 | in 96 | let var = namer () in 97 | let st n p = "{" ^ RS.Step.label ~var (RS.Path.nth_step n p) ^ "}" in 98 | let tm n p = Term.to_string ~var (RS.Path.nth_term n p) in 99 | let cd = 100 | match RS.Path.length p1, RS.Path.length p2 with 101 | | 1, 1 -> 102 | Printf.sprintf "%s\\ar[d,bend right,\"%s\"']\\ar[d,bend left,\"%s\"]\\\\\n%s" 103 | (tm 0 p1) (st 0 p1) (st 0 p2) (tm 1 p1) 104 | | 1, 2 -> 105 | Printf.sprintf "%s\\ar[dr,\"%s\"']\\ar[r,\"%s\"]&%s\\ar[d,\"%s\"]\\\\\n&%s" 106 | (tm 0 p1) (st 0 p1) (st 0 p2) (tm 1 p2) (st 1 p2) (tm 2 p2) 107 | | 1, 3 -> 108 | Printf.sprintf "%s\\ar[drr,\"%s\"']\\ar[r,\"%s\"]&%s\\ar[r,\"%s\"]&%s\\ar[d,\"%s\"]\\\\\n&&%s" 109 | (tm 0 p1) (st 0 p1) (st 0 p2) (tm 1 p2) (st 1 p2) (tm 2 p2) (st 2 p2) (tm 3 p2) 110 | (* 111 | | 1, 4 -> 112 | Printf.sprintf "%s\\ar[drrr,\"%s\"']\\ar[r,\"%s\"]&%s\\ar[r,\"%s\"]&%s\\ar[r,\"%s\"]&%s\\ar[d,\"%s\"]\\\\\n&&&%s" 113 | (tm 0 p1) (st 0 p1) (st 0 p2) (tm 1 p2) (st 1 p2) (tm 2 p2) (st 2 p2) (tm 3 p2) (st 3 p2) (tm 4 p2) 114 | | 1, 5 -> 115 | Printf.sprintf "%s\\ar[ddrrr,\"%s\"']\\ar[r,\"%s\"]&%s\\ar[r,\"%s\"]&%s\\ar[r,\"%s\"]&%s\\ar[d,\"%s\"]\\\\\n&&&%s\\ar[d,\"%s\"]\\\\\n&&&%s" 116 | (tm 0 p1) (st 0 p1) (st 0 p2) (tm 1 p2) (st 1 p2) (tm 2 p2) (st 2 p2) (tm 3 p2) (st 3 p2) (tm 4 p2) (st 4 p2) (tm 5 p2) 117 | *) 118 | | 1, 4 -> 119 | Printf.sprintf "%s\\ar[ddrr,\"%s\"']\\ar[r,\"%s\"]&%s\\ar[r,\"%s\"]&%s\\ar[d,\"%s\"]\\\\\n&&%s\\ar[d,\"%s\"]\\\\\n&&%s" 120 | (tm 0 p1) (st 0 p1) (st 0 p2) (tm 1 p2) (st 1 p2) (tm 2 p2) (st 2 p2) (tm 3 p2) (st 3 p2) (tm 4 p2) 121 | | 1, 5 -> 122 | Printf.sprintf "%s\\ar[dddrr,\"%s\"']\\ar[r,\"%s\"]&%s\\ar[r,\"%s\"]&%s\\ar[d,\"%s\"]\\\\\n&&%s\\ar[d,\"%s\"]\\\\\n&&%s\\ar[d,\"%s\"]\\\\\n&&%s" 123 | (tm 0 p1) (st 0 p1) (st 0 p2) (tm 1 p2) (st 1 p2) (tm 2 p2) (st 2 p2) (tm 3 p2) (st 3 p2) (tm 4 p2) (st 4 p2) (tm 5 p2) 124 | | 1, 6 -> 125 | Printf.sprintf "%s\\ar[ddddrr,\"%s\"']\\ar[r,\"%s\"]&%s\\ar[r,\"%s\"]&%s\\ar[d,\"%s\"]\\\\\n&&%s\\ar[d,\"%s\"]\\\\\n&&%s\\ar[d,\"%s\"]\\\\\n&&%s\\ar[d,\"%s\"]\\\\\n&&%s" 126 | (tm 0 p1) (st 0 p1) (st 0 p2) (tm 1 p2) (st 1 p2) (tm 2 p2) (st 2 p2) (tm 3 p2) (st 3 p2) (tm 4 p2) (st 4 p2) (tm 5 p2) (st 5 p2) (tm 6 p2) 127 | (* 128 | | 2, 1 -> 129 | Printf.sprintf "%s\\ar[d,\"%s\"']\\ar[dr,\"%s\"]\\\\\n%s\\ar[r,\"%s\"']&%s" 130 | (tm 0 p1) (st 0 p1) (st 0 p2) (tm 1 p1) (st 1 p1) (tm 2 p1) 131 | *) 132 | | 2, 2 -> 133 | Printf.sprintf "%s\\ar[d,\"%s\"']\\ar[r,\"%s\"]&%s\\ar[d,\"%s\"]\\\\\n%s\\ar[r,\"%s\"']&%s" 134 | (tm 0 p1) (st 0 p1) (st 0 p2) (tm 1 p2) (st 1 p2) (tm 1 p1) (st 1 p1) (tm 2 p1) 135 | | 2, 3 -> 136 | Printf.sprintf "%s\\ar[d,\"%s\"']\\ar[r,\"%s\"]&%s\\ar[r,\"%s\"]&%s\\ar[d,\"%s\"]\\\\\n%s\\ar[rr,\"%s\"']&&%s" 137 | (tm 0 p1) (st 0 p1) (st 0 p2) (tm 1 p2) (st 1 p2) (tm 2 p2) (st 2 p2) (tm 1 p1) (st 1 p1) (tm 2 p1) 138 | | 2, 4 -> 139 | Printf.sprintf "%s\\ar[d,\"%s\"']\\ar[r,\"%s\"]&%s\\ar[r,\"%s\"]&%s\\ar[r,\"%s\"]&%s\\ar[d,\"%s\"]\\\\\n%s\\ar[rrr,\"%s\"']&&&%s" 140 | (tm 0 p1) (st 0 p1) (st 0 p2) (tm 1 p2) (st 1 p2) (tm 2 p2) (st 2 p2) (tm 3 p2) (st 3 p2) (tm 1 p1) (st 1 p1) (tm 2 p1) 141 | | l1, l2 -> Printf.sprintf "TODO: %d, %d" l1 l2 142 | in 143 | incr rulen; 144 | print "\\noindent\nRule %d:\n" !rulen; 145 | print "\\[\n\\begin{tikzcd}\n%s\n\\end{tikzcd}\n\\]\n\n" cd 146 | ) coherence; 147 | Printf.printf "Done.\n%!" 148 | -------------------------------------------------------------------------------- /test/squierGroupFull.tex: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | \usepackage[utf8x]{inputenc} 3 | \usepackage{amsmath} 4 | \usepackage{tikz-cd} 5 | \usepackage{a4wide} 6 | 7 | \title{Coherent presentation of the theory of groups} 8 | \author{The machine} 9 | 10 | \begin{document} 11 | \maketitle 12 | 13 | \input{squierGroup} 14 | \end{document} 15 | -------------------------------------------------------------------------------- /test/squierMonoid.ml: -------------------------------------------------------------------------------- 1 | (** Squier's coherent completion of the theory of monoids. *) 2 | 3 | open Alg 4 | open Term 5 | 6 | let m = Op.make "m" 2 7 | let e = Op.make "e" 0 8 | let ops = [m; e] 9 | let x = var () 10 | let y = var () 11 | let z = var () 12 | 13 | let m x y = app m [x;y] 14 | let e = app e [] 15 | let monoid = 16 | RS.make ops 17 | [ 18 | RS.Rule.make "A" (m (m x y) z) (m x (m y z)); 19 | RS.Rule.make "L" (m e x) x; 20 | RS.Rule.make "R" (m x e) x; 21 | ] 22 | 23 | let () = 24 | Printf.printf "%s\n\n%!" (RS.to_string ~var:Var.namer_natural monoid) 25 | 26 | let rule_name = Utils.namer (fun (s1,s2) (s1',s2') -> RS.Path.eq s1 s1' && RS.Path.eq s2 s2') 27 | 28 | let coherence = RS.squier monoid 29 | 30 | let () = 31 | List.iter 32 | (fun (s1,s2) -> 33 | let n = rule_name (s1,s2) in 34 | let var = Term.Var.namer_natural () in 35 | let s1 = RS.Path.to_string ~var s1 in 36 | let s2 = RS.Path.to_string ~var s2 in 37 | Printf.printf "%02d: %s\n %s\n\n%!" n s1 s2 38 | ) coherence 39 | 40 | let cpres = 41 | let coherence = List.map (fun (p1,p2) -> RS.Loop.of_cell (RS.Zigzag.of_path p1) (RS.Zigzag.of_path p2)) coherence in 42 | let coherence = List.mapi (fun i p -> RS.Coherence.make ("C"^string_of_int (i+1)) p) coherence in 43 | RS.Coherent.make monoid coherence 44 | 45 | (* let () = RS.Coherent.view_pdf cpres *) 46 | -------------------------------------------------------------------------------- /test/stl.ml: -------------------------------------------------------------------------------- 1 | (** Normalization of types in simply typed lambda-calculus, without associativity and unitality. *) 2 | 3 | open Alg 4 | open Term 5 | 6 | let a = Op.make "→" 2 (* Arrow *) 7 | let p = Op.make "×" 2 (* Product *) 8 | let e = Op.make "1" 0 (* Terminal object *) 9 | let ops = [a; p; e] 10 | let x = var () 11 | let y = var () 12 | let z = var () 13 | 14 | let a x y = app a [x;y] 15 | let p x y = app p [x;y] 16 | let e = app e [] 17 | 18 | let stl = 19 | RS.make ops 20 | [ 21 | RS.Rule.make "L" (a (p x y) z) (a x (a y z)); 22 | RS.Rule.make "R" (a x (p y z)) (p (a x y) (a x z)); 23 | RS.Rule.make "L1" (a e x) x; 24 | RS.Rule.make "R1" (a x e) e; 25 | ] 26 | 27 | let () = Printf.printf "# Theory\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural stl) 28 | 29 | let gt = LPO.gt (>=) 30 | 31 | let stl = RS.orient ~gt stl 32 | 33 | let () = Printf.printf "# Oriented\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural stl) 34 | 35 | let stl = RS.knuth_bendix ~gt 36 | (* ~callback:(fun rs -> Printf.printf "## KB\n\n%s\n\n" (RS.to_string ~var:Var.namer_natural rs)) *) 37 | stl 38 | 39 | let () = Printf.printf "# Completion\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural stl) 40 | 41 | let () = 42 | let branchings = 43 | RS.critical stl |> List.map fst |> List.map RS.Step.source |> List.map Term.to_string |> String.concat "\n" 44 | in 45 | Printf.printf "# Branchings\n\n%s\n\n%!" branchings 46 | 47 | let () = 48 | Printf.printf "# Coherent completion\n\n%!"; 49 | let coh = RS.squier stl in 50 | List.iter 51 | (fun (s1,s2) -> 52 | let var = Term.Var.namer_natural () in 53 | let s1 = RS.Path.to_string ~var s1 in 54 | let s2 = RS.Path.to_string ~var s2 in 55 | Printf.printf "%s\n%s\n\n%!" s1 s2 56 | ) coh 57 | 58 | -------------------------------------------------------------------------------- /test/stl2.ml: -------------------------------------------------------------------------------- 1 | (** Normalization of types in simply typed lambda-calculus, with associativity and unitality. *) 2 | 3 | open Alg 4 | open Term 5 | 6 | let a = Op.make "→" 2 (* Arrow *) 7 | let p = Op.make "×" 2 (* Product *) 8 | let e = Op.make "1" 0 (* Terminal object *) 9 | let ops = [a; p; e] 10 | let x = var () 11 | let y = var () 12 | let z = var () 13 | 14 | let a x y = app a [x;y] 15 | let p x y = app p [x;y] 16 | let e = app e [] 17 | 18 | let stl = 19 | RS.make ops 20 | [ 21 | RS.Rule.make "L" (a (p x y) z) (a x (a y z)); 22 | RS.Rule.make "R" (a x (p y z)) (p (a x y) (a x z)); 23 | RS.Rule.make "L1" (a e x) x; 24 | RS.Rule.make "R1" (a x e) e; 25 | RS.Rule.make "A" (p (p x y) z) (p x (p y z)); 26 | RS.Rule.make "PL" (p e x) x; 27 | RS.Rule.make "PR" (p x e) x; 28 | ] 29 | 30 | let () = Printf.printf "# Theory\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural stl) 31 | 32 | let gt = LPO.gt (>=) 33 | 34 | let stl = RS.orient ~gt stl 35 | 36 | let () = Printf.printf "# Oriented\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural stl) 37 | 38 | let stl = RS.knuth_bendix ~gt 39 | (* ~callback:(fun rs -> Printf.printf "## KB\n\n%s\n\n" (RS.to_string ~var:Var.namer_natural rs)) *) 40 | stl 41 | 42 | let () = Printf.printf "# Completion\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural stl) 43 | 44 | let () = 45 | let branchings = 46 | RS.critical stl |> List.map fst |> List.map RS.Step.source |> List.map Term.to_string |> String.concat "\n" 47 | in 48 | Printf.printf "# Branchings\n\n%s\n\n%!" branchings 49 | 50 | let () = 51 | Printf.printf "# Coherent completion\n\n%!"; 52 | let coh = RS.squier stl in 53 | List.iter 54 | (fun (s1,s2) -> 55 | let var = Term.Var.namer_natural () in 56 | let s1 = RS.Path.to_string ~var s1 in 57 | let s2 = RS.Path.to_string ~var s2 in 58 | Printf.printf "%s\n%s\n\n%!" s1 s2 59 | ) coh 60 | 61 | -------------------------------------------------------------------------------- /test/uatao.ml: -------------------------------------------------------------------------------- 1 | (* Example from 2 | https://terrytao.wordpress.com/2024/09/25/a-pilot-project-in-universal-algebra-to-explore-new-ways-to-collaborate-and-use-machine-assistance/ 3 | and 4 | https://mathoverflow.net/questions/450890/is-there-an-identity-between-the-commutative-identity-and-the-constant-identity/450905#450905 5 | *) 6 | 7 | open Alg 8 | open Term 9 | 10 | let m = Op.make "m" 2 11 | 12 | let ops = [m] 13 | 14 | let m x y = app m [x;y] 15 | 16 | let x = var () 17 | let y = var () 18 | 19 | let rs = 20 | RS.make ops 21 | [ 22 | RS.Rule.make "R" (m (m x x) y) (m y x); 23 | ] 24 | 25 | let var = Var.namer_natural 26 | 27 | let () = Printf.printf "# Theory\n\n%s\n\n%!" (RS.to_string ~var rs) 28 | 29 | let gt = LPO.gt (>=) 30 | 31 | let rs = RS.orient ~gt rs 32 | 33 | let () = Printf.printf "# Oriented\n\n%s\n\n%!" (RS.to_string ~var rs) 34 | 35 | let rs = 36 | let n = ref 0 in 37 | let callback rs = 38 | incr n; 39 | if !n = 2 then 40 | ( 41 | Printf.printf "%s\n\n%!" (RS.to_string ~var rs); 42 | exit 0 43 | ) 44 | in 45 | RS.knuth_bendix ~gt ~callback rs 46 | 47 | let () = Printf.printf "# Completion\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural rs) 48 | -------------------------------------------------------------------------------- /test/uatao2.ml: -------------------------------------------------------------------------------- 1 | (* Example from 2 | https://terrytao.wordpress.com/2024/09/25/a-pilot-project-in-universal-algebra-to-explore-new-ways-to-collaborate-and-use-machine-assistance/ 3 | *) 4 | 5 | open Alg 6 | open Term 7 | 8 | let m = Op.make "m" 2 9 | let ops = [m] 10 | let nops = 3 11 | let r = 12 | List.init (nops+1) 13 | (fun i -> 14 | let l = Term.generate_ops ops i in 15 | List.map (fun t -> 16 | let vars = Term.vars t in 17 | List.map (fun u -> t, u) (Term.generate_ops ~vars ops (nops - i)) 18 | ) l |> List.flatten 19 | ) |> List.flatten 20 | 21 | let () = 22 | List.iter 23 | (fun (t,u) -> 24 | let var = Var.namer_natural () in 25 | Printf.printf "%s = %s\n%!" (Term.to_string ~var t) (Term.to_string ~var u) 26 | ) r 27 | 28 | let r = 29 | let convertible (t1,t2) (u1,u2) = 30 | match Renaming.unify_opt [] t1 u1 with 31 | | None -> false 32 | | Some s -> Renaming.unify_opt s t2 u2 <> None 33 | in 34 | let op (t1,t2) = (t2,t1) in 35 | let rec filter = function 36 | | r::l -> 37 | let l = List.filter (fun r' -> not (convertible r r') && not (convertible (op r) r')) l in 38 | r::(filter l) 39 | | [] -> [] 40 | in 41 | let r = List.filter (fun (t,u) -> not (Term.eq t u)) r in 42 | filter r 43 | 44 | let () = 45 | Printf.printf "\n# Filtered\n\n"; 46 | List.iter 47 | (fun (t,u) -> 48 | let var = Var.namer_natural () in 49 | Printf.printf "%s = %s\n%!" (Term.to_string ~var t) (Term.to_string ~var u) 50 | ) r; 51 | Printf.printf "\n%d equations\n%!" (List.length r) 52 | 53 | let r = Array.of_list r 54 | 55 | let () = 56 | let completed = ref 0 in 57 | for i = 0 to Array.length r - 1 do 58 | try 59 | Printf.printf "\n# Try %d\n\n%!" i; 60 | let a = r.(i) in 61 | (* let b = r.(j) in *) 62 | let rs = RS.make ops [RS.Rule.make "A" (fst a) (snd a)] in 63 | Printf.printf "- rs : %s\n%!" (RS.to_string ~var:Var.namer_natural rs); 64 | let gt = LPO.gt (>=) in 65 | let rs = RS.orient ~gt rs in 66 | Printf.printf "- oriented : %s\n%!" (RS.to_string ~var:Var.namer_natural rs); 67 | let callback_add r = 68 | let t = RS.Rule.source r in 69 | let u = RS.Rule.target r in 70 | let n = count_ops t + count_ops u in 71 | if n > 20 then raise RS.Abort 72 | in 73 | let rs = RS.knuth_bendix ~limit:100 ~callback_add ~gt rs in 74 | incr completed; 75 | Printf.printf "- completed %d : %s\n%!" !completed (RS.to_string ~var:Var.namer_natural rs); 76 | with 77 | | RS.Abort -> Printf.printf "aborted\n" 78 | done 79 | 80 | (* 81 | 82 | let m x y = app m [x;y] 83 | 84 | let x = var () 85 | let y = var () 86 | 87 | let rs = 88 | RS.make ops 89 | [ 90 | RS.Rule.make "R" (m (m x x) y) (m y x); 91 | ] 92 | 93 | let var = Var.namer_natural 94 | 95 | let () = Printf.printf "# Theory\n\n%s\n\n%!" (RS.to_string ~var rs) 96 | 97 | let gt = LPO.gt (>=) 98 | 99 | let rs = RS.orient ~gt rs 100 | 101 | let () = Printf.printf "# Oriented\n\n%s\n\n%!" (RS.to_string ~var rs) 102 | 103 | let rs = 104 | let n = ref 0 in 105 | let callback rs = 106 | incr n; 107 | if !n = 2 then 108 | ( 109 | Printf.printf "%s\n\n%!" (RS.to_string ~var rs); 110 | exit 0 111 | ) 112 | in 113 | RS.knuth_bendix ~gt ~callback rs 114 | 115 | let () = Printf.printf "# Completion\n\n%s\n\n%!" (RS.to_string ~var:Var.namer_natural rs) 116 | 117 | *) 118 | -------------------------------------------------------------------------------- /tools/Makefile: -------------------------------------------------------------------------------- 1 | all clean: 2 | $(MAKE) -C bergman $@ 3 | $(MAKE) -C kb $@ 4 | $(MAKE) -C rewr2 $@ 5 | -------------------------------------------------------------------------------- /tools/bergman/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | @dune build 3 | 4 | test: 5 | ./bergman --variables x,y,z x^3+y^3+z^3-xyz 6 | # ./bergman --variables x,y,z x^2,z^2,xz+zx,xy-yx-y^2,zy-yz-yt,xt-tx-ty,zt-tz-t^2 7 | 8 | conflicts: 9 | menhir --explain parser.mly && less parser.conflicts && rm parser.ml parser.mli parser.conflicts 10 | 11 | -------------------------------------------------------------------------------- /tools/bergman/bergman: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | dune exec --display=quiet --no-print-directory ./bergman.exe -- $@ 4 | -------------------------------------------------------------------------------- /tools/bergman/bergman.css: -------------------------------------------------------------------------------- 1 | body { 2 | background-color: rgb(204, 255, 255); 3 | } 4 | 5 | h1 { 6 | text-align: center; 7 | } 8 | 9 | .output { 10 | font-family: monospace; 11 | } 12 | -------------------------------------------------------------------------------- /tools/bergman/bergman.ml: -------------------------------------------------------------------------------- 1 | open Alg 2 | 3 | module M = Monoid.Free(Alphabet.Char) 4 | module K = Field.Int 5 | module P = Algebra.Pres(K)(Alphabet.Char) 6 | module A = P.A 7 | 8 | let char_of_string s = 9 | assert (String.length s = 1); 10 | s.[0] 11 | 12 | let parse_pol s = 13 | Parser.main Lexer.token (Lexing.from_string s) 14 | 15 | let eval_pol p = 16 | let rec aux = function 17 | | Pol.Mul (p,q) -> A.mul (aux p) (aux q) 18 | | One -> A.one 19 | | Zero -> A.zero 20 | | Gen c -> A.inj (M.inj c) 21 | | Add (p,q) -> A.add (aux p) (aux q) 22 | | Sub (p,q) -> A.sub (aux p) (aux q) 23 | | Neg p -> A.neg (aux p) 24 | in 25 | aux p 26 | 27 | let () = 28 | let order = ref "deglex" in 29 | let variables = ref "" in 30 | let relations = ref "" in 31 | Arg.parse [ 32 | "--variables", Arg.Set_string variables, "Used variables." 33 | ] (fun s -> relations := s) "Usage: bergman [options]"; 34 | let variables = !variables |> String.split_on_char ',' |> List.map (fun s -> s |> String.trim |> char_of_string) in 35 | let relations = !relations |> String.split_on_char ',' |> List.map (fun s -> s |> String.trim |> parse_pol |> eval_pol) in 36 | let order = 37 | match !order with 38 | | "deglex" -> M.Order.deglex Alphabet.Char.leq 39 | | "revdeglex" -> M.Order.deglex Alphabet.Char.geq 40 | | _ -> assert false 41 | in 42 | let pres = P.make order variables relations in 43 | Printf.printf "# Computing Gröbner basis\n\n%!"; 44 | let pres = P.buchberger pres in 45 | let pres = P.reduce pres in 46 | Printf.printf "%s\n\n%!" (P.to_string pres) 47 | -------------------------------------------------------------------------------- /tools/bergman/bergmanjs.ml: -------------------------------------------------------------------------------- 1 | open Js_of_ocaml 2 | open Alg 3 | 4 | module Html = Dom_html 5 | 6 | let doc = Html.document 7 | let button txt action = 8 | let button_type = Js.string "button" in 9 | let b = Html.createInput ~_type:button_type doc in 10 | b##.value := Js.string txt; 11 | b##.onclick := Dom_html.handler (fun _ -> action (); Js._true); 12 | b 13 | 14 | let debug s = 15 | Firebug.console##debug (Js.string s) 16 | 17 | let jsget x = Js.Opt.get x (fun () -> assert false) 18 | 19 | exception Parsing 20 | 21 | let parse_pol s = 22 | Parser.main Lexer.token (Lexing.from_string s) 23 | 24 | let char_of_string s = 25 | assert (String.length s = 1); 26 | s.[0] 27 | 28 | module M = struct 29 | include Monoid.Free(Alphabet.Char) 30 | 31 | let s s : t = 32 | Array.init (String.length s) (fun i -> s.[i]) 33 | end 34 | module K = Field.Float 35 | module P = Algebra.Pres(K)(Alphabet.Char) 36 | module A = P.A 37 | 38 | let eval_pol p = 39 | let rec aux = function 40 | | Pol.Mul (p,q) -> A.mul (aux p) (aux q) 41 | | One -> A.one 42 | | Zero -> A.zero 43 | | Gen c -> A.inj (M.inj c) 44 | | Add (p,q) -> A.add (aux p) (aux q) 45 | | Sub (p,q) -> A.sub (aux p) (aux q) 46 | | Neg p -> A.neg (aux p) 47 | in 48 | aux p 49 | 50 | (** Replace [c] by [t] in [s]. *) 51 | let rec replace c t s = 52 | try 53 | let n = String.index s c in 54 | replace c t (String.sub s 0 n ^ t ^ String.sub s (n+1) (String.length s-(n+1))) 55 | with 56 | | Not_found -> s 57 | 58 | let run _ = 59 | let vars = jsget (Html.CoerceTo.textarea (jsget (doc##getElementById(Js.string "vars")))) in 60 | let relations = jsget (Html.CoerceTo.textarea (jsget (doc##getElementById(Js.string "relations")))) in 61 | let order = jsget (Html.CoerceTo.select (jsget (doc##getElementById(Js.string "order")))) in 62 | let generate = jsget (Html.CoerceTo.select (jsget (doc##getElementById(Js.string "generate")))) in 63 | let generaten = jsget (Html.CoerceTo.input (jsget (doc##getElementById(Js.string "generaten")))) in 64 | let augmentation = jsget (Html.CoerceTo.select (jsget (doc##getElementById(Js.string "augmentation")))) in 65 | let maxdeg = jsget (Html.CoerceTo.input (jsget (doc##getElementById(Js.string "maxdeg")))) in 66 | let grobner = jsget (doc##getElementById(Js.string "grobner")) in 67 | let chains = jsget (doc##getElementById(Js.string "chains")) in 68 | let resolution = jsget (doc##getElementById(Js.string "resolution")) in 69 | let betti = jsget (doc##getElementById(Js.string "betti")) in 70 | let go = jsget (doc##getElementById(Js.string "go")) in 71 | let status = jsget (doc##getElementById(Js.string "status")) in 72 | let status s = status##.innerHTML := Js.string s in 73 | let error s = status ("" ^ s ^ "") in 74 | 75 | go##.onclick := Html.handler (fun _ -> 76 | try 77 | let vars = Js.to_string vars##.value in 78 | let relations = Js.to_string relations##.value in 79 | 80 | grobner##.innerHTML := Js.string ""; 81 | chains##.innerHTML := Js.string ""; 82 | resolution##.innerHTML := Js.string ""; 83 | betti##.innerHTML := Js.string ""; 84 | 85 | status "Parsing variables..."; 86 | let vars = String.split_on_char ',' vars in 87 | let vars = List.map String.trim vars in 88 | let vars = List.map char_of_string vars in 89 | 90 | status "Parsing relations..."; 91 | let relations = String.split_on_char ',' relations in 92 | let relations = List.map String.trim relations in 93 | let relations = 94 | try 95 | List.map parse_pol relations 96 | with 97 | | e -> error ("Parsing error: " ^ Printexc.to_string e); raise Exit 98 | in 99 | grobner##.innerHTML := Js.string ("Relations: " ^ String.concat " , " (List.map Pol.to_string relations)); 100 | let relations = List.map eval_pol relations in 101 | let order = 102 | match Js.to_string order##.value with 103 | | "deglex" -> M.Order.deglex Alphabet.Char.leq 104 | | "revdeglex" -> M.Order.deglex Alphabet.Char.geq 105 | | _ -> assert false 106 | in 107 | let pres = P.make order vars relations in 108 | let augmentation = 109 | try 110 | match Js.to_string augmentation##.value with 111 | | "algebra" -> P.Augmentation.graded pres 112 | | "monoid" -> P.Augmentation.monoid pres 113 | | _ -> assert false 114 | with 115 | | P.Augmentation.Invalid -> 116 | error "Invalid augmentation!"; 117 | raise Exit 118 | in 119 | 120 | status "Computing Gröbner basis..."; 121 | let pres = P.reduce (P.buchberger pres) in 122 | grobner##.innerHTML := Js.string (P.to_string pres); 123 | 124 | status "Computing Anick chains..."; 125 | let heads = P.heads pres in 126 | let cc = M.Anick.singletons vars in 127 | let cc = ref cc in 128 | let s = ref "" in 129 | for i = 0 to 6 do 130 | s := !s ^ string_of_int i ^ " chains: " ^ String.concat " " (List.map M.Anick.to_string !cc) ^ "
"; 131 | chains##.innerHTML := Js.string !s; 132 | cc := M.Anick.extend heads !cc 133 | done; 134 | 135 | status "Computing resolution..."; 136 | let maxdeg = int_of_string (Js.to_string maxdeg##.value) in 137 | let d = P.Anick.resolution ~augmentation pres (maxdeg+1) in 138 | resolution##.innerHTML := Js.string (replace '\n' "
" (P.Anick.AMod.Pres.Complex.to_string d)); 139 | 140 | status "Computing Betti numbers..."; 141 | let s = ref "" in 142 | let h = P.Anick.betti ~augmentation pres maxdeg in 143 | Array.iteri (fun i n -> s := !s ^ "H" ^ string_of_int i ^ " = " ^ string_of_int n ^ "
") h; 144 | betti##.innerHTML := Js.string !s; 145 | 146 | status "Done."; 147 | Js._true 148 | with 149 | | Exit -> 150 | Js._false 151 | | Failure s -> 152 | error ("Error: " ^ s); 153 | Js._false 154 | | Not_found -> 155 | error "Not_found..."; 156 | Js._false 157 | ); 158 | 159 | let generate_handler _ = 160 | let list_init n f = 161 | let rec aux k = if k >= n then [] else (f k)::(aux (k+1)) in 162 | aux 0 163 | in 164 | let set v r = 165 | vars##.value := Js.string v; 166 | relations##.value := Js.string r 167 | in 168 | let gen n = String.make 1 (char_of_int (n + int_of_char 'a')) in 169 | (* let gen' n = String.make 1 (char_of_int (n + int_of_char 'A')) in *) 170 | let sym n = 171 | let v = String.concat "," (list_init n gen) in 172 | let rel = ref [] in 173 | for i = 0 to n-1 do 174 | for j = i+1 to n-1 do 175 | rel := (gen i^gen j^"-"^gen j^gen i) :: !rel 176 | done 177 | done; 178 | let rel = String.concat "," (List.rev !rel) in 179 | set v rel 180 | in 181 | let ext n = 182 | let v = String.concat "," (list_init n gen) in 183 | let rel = ref [] in 184 | for i = 0 to n-1 do 185 | rel := (gen i^gen i) :: !rel; 186 | for j = (i+1) to n-1 do 187 | rel := (gen i^gen j^"+"^gen j^gen i) :: !rel 188 | done 189 | done; 190 | let rel = String.concat "," (List.rev !rel) in 191 | set v rel 192 | in 193 | let symg n = 194 | let v = String.concat "," (list_init n gen) in 195 | let rel = ref [] in 196 | for i = 0 to n-2 do 197 | rel := (gen i^gen i^"-1") :: !rel; 198 | rel := (gen i^gen (i+1)^gen i^"-"^gen (i+1)^gen i^gen (i+1)) :: !rel 199 | done; 200 | for i = 0 to n-1 do 201 | for j = i+2 to n-1 do 202 | rel := (gen i^gen j^"-"^gen j^gen i) :: !rel 203 | done 204 | done; 205 | let rel = String.concat "," (List.rev !rel) in 206 | set v rel 207 | in 208 | let sklyanin n = 209 | let v = String.concat "," (list_init n gen) in 210 | let rel = ref "" in 211 | for i = 0 to n-1 do 212 | rel := !rel ^ (if !rel = "" then "" else "+") ^ gen i ^ "^" ^ string_of_int n 213 | done; 214 | rel := !rel ^ "+"; 215 | for i = 0 to n-1 do 216 | rel := !rel ^ gen i 217 | done; 218 | set v !rel 219 | in 220 | let pow n = 221 | let v = "x,y" in 222 | let rel = ref [] in 223 | for i = 0 to n-1 do 224 | let s = ref "x" in 225 | for _ = 0 to i-1 do 226 | s := !s ^ "y" 227 | done; 228 | s := !s ^ "x"; 229 | rel := !s :: !rel 230 | done; 231 | let rel = String.concat "," (List.rev !rel) in 232 | set v rel 233 | in 234 | let plactic n = 235 | let v = list_init n gen in 236 | let v = String.concat "," v in 237 | let rel = ref [] in 238 | for x = 0 to n-1 do 239 | for y = x+1 to n-1 do 240 | for z = y to n-1 do 241 | let x = gen x in 242 | let y = gen y in 243 | let z = gen z in 244 | rel := (y^z^x^"-"^y^x^z) :: !rel 245 | done 246 | done 247 | done; 248 | for x = 0 to n-1 do 249 | for y = x to n-1 do 250 | for z = y+1 to n-1 do 251 | let x = gen x in 252 | let y = gen y in 253 | let z = gen z in 254 | rel := (x^z^y^"-"^z^x^y) :: !rel 255 | done 256 | done 257 | done; 258 | let rel = String.concat "," (List.rev !rel) in 259 | set v rel 260 | in 261 | let n = int_of_string (Js.to_string generaten##.value) in 262 | ( 263 | match Js.to_string generate##.value with 264 | | "sym" -> sym n 265 | | "ext" -> ext n 266 | | "symg" -> symg n 267 | | "sklyanin" -> sklyanin n 268 | | "pow" -> pow n 269 | | "plactic" -> plactic n 270 | | _ -> assert false 271 | ); 272 | Js._true 273 | in 274 | 275 | generate##.oninput := Html.handler generate_handler; 276 | generaten##.onchange := Html.handler generate_handler; 277 | Js._true 278 | 279 | let () = 280 | Html.window##.onload := Html.handler run 281 | -------------------------------------------------------------------------------- /tools/bergman/dune: -------------------------------------------------------------------------------- 1 | (ocamlyacc parser) 2 | 3 | (ocamllex lexer) 4 | 5 | (library 6 | (name bergmanlib) 7 | (wrapped false) 8 | (libraries alg) 9 | (modules pol lexer parser) 10 | ) 11 | 12 | (executable 13 | (name bergmanjs) 14 | (modes js) 15 | (preprocess (pps js_of_ocaml-ppx)) 16 | (libraries bergmanlib js_of_ocaml) 17 | (modules bergmanjs) 18 | ) 19 | 20 | (executable 21 | (name bergman) 22 | (libraries bergmanlib) 23 | (modules bergman) 24 | ) 25 | -------------------------------------------------------------------------------- /tools/bergman/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Bergman 2 5 | 6 | 7 | 8 | 9 | 10 |

Bergman 2

11 |

12 | This is a new Gröbner basis calculator inspired of bergman (which seems not to work anymore unfortunately). It only handles non-commutative algebras for now. The source code is available. 13 |

14 | 15 |

Presentation

16 |

17 | Generate: 18 | 26 | with n = 27 | 28 |

29 | 30 |

Variables

31 |

32 | Please enter variable names (lowercase letters only) separated by 33 | commas. 34 |

35 |

36 | 37 |

38 | 39 |

Relations

40 |

41 | Please enter (possibly non-homogeneous) relations separated by commas. 42 |

43 | 44 |

45 | 46 |

47 | 48 |

Options

49 |

50 | Order: 51 | 55 |

56 |

57 | Augmentation: 58 | 62 |

63 |

64 | Maximum degree: 65 |

66 | 67 |

68 | 69 |

70 | 71 |

Computations

72 |

73 | 74 |

Gröbner basis

75 |

76 |

77 | 78 |

Betti numbers

79 |

80 |

81 | 82 |

Anick chains

83 |

84 |

85 | 86 |

Anick resolution

87 |

88 |

89 | 90 | 91 | -------------------------------------------------------------------------------- /tools/bergman/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | } 4 | 5 | let space = ' ' | '\t' | '\r' 6 | 7 | rule token = parse 8 | | "+" { ADD } 9 | | "-" { SUB } 10 | | "*" { MUL } 11 | | "^" { POW } 12 | | "(" { LPAR } 13 | | ")" { RPAR } 14 | | (['0'-'9']+ as n) { INT (int_of_string n) } 15 | | (['a'-'z''A'-'Z'] as c) { CHAR c } 16 | | space+ { token lexbuf } 17 | | eof { EOF } 18 | -------------------------------------------------------------------------------- /tools/bergman/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Pol 3 | 4 | let rec muls = function 5 | | [] -> One 6 | | [x] -> x 7 | | x::l -> Mul (x, muls l) 8 | 9 | let rec pow p = function 10 | | 0 -> One 11 | | 1 -> p 12 | | n -> Mul (p, pow p (n-1)) 13 | %} 14 | 15 | %token INT 16 | %token ADD SUB MUL POW 17 | %token LPAR RPAR 18 | %token CHAR 19 | %token EOF 20 | 21 | %left ADD SUB 22 | %left MUL 23 | %nonassoc POW 24 | %nonassoc UMINUS 25 | 26 | %start main 27 | %type main 28 | %% 29 | 30 | main: 31 | | expr EOF { $1 } 32 | 33 | expr: 34 | | expr ADD expr { Add ($1, $3) } 35 | | expr MUL expr { Mul ($1, $3) } 36 | | expr SUB expr { Sub ($1, $3) } 37 | | expr POW INT { pow $1 $3 } 38 | | chars { muls $1 } 39 | | INT { if $1 = 0 then Zero else if $1 = 1 then One else failwith "unexpected number" } 40 | | SUB expr %prec UMINUS { Neg $2 } 41 | | LPAR expr RPAR { $2 } 42 | ; 43 | 44 | chars: 45 | | CHAR chars { (Gen $1)::$2 } 46 | | CHAR { [Gen $1] } 47 | ; 48 | -------------------------------------------------------------------------------- /tools/bergman/pol.ml: -------------------------------------------------------------------------------- 1 | (** Polynomial expressions. *) 2 | type t = 3 | | Mul of t * t 4 | | One 5 | | Zero 6 | | Gen of char 7 | | Add of t * t 8 | | Sub of t * t 9 | | Neg of t 10 | 11 | let to_string p = 12 | let rec aux = function 13 | | Mul (p,q) -> aux p ^ "*" ^ aux q 14 | | One -> "1" 15 | | Zero -> "0" 16 | | Gen c -> String.make 1 c 17 | | Add (p,q) -> aux p ^ "+" ^ aux q 18 | | Sub (p,q) -> aux p ^ "-" ^ aux q 19 | | Neg p -> "-" ^ aux p 20 | in 21 | aux p 22 | -------------------------------------------------------------------------------- /tools/kb/.merlin: -------------------------------------------------------------------------------- 1 | B ../../src 2 | S ../../src 3 | PKG js_of_ocaml -------------------------------------------------------------------------------- /tools/kb/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | @dune build 3 | 4 | conflicts: 5 | menhir --explain parser.mly && less parser.conflicts && rm parser.ml parser.mli parser.conflicts 6 | -------------------------------------------------------------------------------- /tools/kb/dune: -------------------------------------------------------------------------------- 1 | (ocamlyacc parser) 2 | 3 | (ocamllex lexer) 4 | 5 | (executable 6 | (name kb) 7 | (modes js) 8 | (preprocess (pps js_of_ocaml-ppx)) 9 | (libraries alg js_of_ocaml) 10 | ) 11 | -------------------------------------------------------------------------------- /tools/kb/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Knuth-Bendix 5 | 6 | 7 | 11 | 12 | 13 | 14 |
15 |
16 |
17 |
Knuth-Bendix completion
18 |
19 |
20 | github 21 | completion 22 |
23 | 42 |
43 | 44 |

Knuth-Bendix completion

45 |

46 | This page provides an online implementation 47 | of Knuth-Bendix 48 | completion algorithm. 49 |

50 | 51 |

Theory

52 |

Symbols

53 |

54 | Please enter function names (lowercase letters only) with arities 55 | separated by commas. First symbols have higher weight (we currently 56 | use lexicographic 57 | path order). 58 |

59 |

60 | 61 |

Rules

62 |

Please enter the rules.

63 |

66 | 67 |

68 | 69 |

70 | 71 | 72 |

Results

73 |

74 | 75 |

Knuth-Bendix completion

76 |

77 | 78 |

Squier completion

79 |

80 | 81 |
82 |
83 |
84 | 85 | 86 | -------------------------------------------------------------------------------- /tools/kb/kb.css: -------------------------------------------------------------------------------- 1 | /*@import url(reset.css);*/ 2 | /* check for post commit hook - can be removed */ 3 | 4 | 5 | h1, h2, h3, h4, h5, .subtitle { 6 | font-family: "Lucida Grande",Verdana,Lucida,Helvetica,Arial,sans-serif; 7 | } 8 | body { 9 | color: #666; 10 | font-family: Arial, Helvetica, sans-serif; 11 | font-size: 10pt; 12 | margin: 0; 13 | padding: 0; 14 | background: #eee; 15 | text-align: center; 16 | } 17 | .all { 18 | width: 1100px; 19 | /*width: 1050px;*/ 20 | /*width: 1200px;*/ 21 | /*width: 950px;*/ 22 | height: 100%; 23 | min-height: 100%; 24 | margin: 0 auto 20px; 25 | background: url('http://cl-informatik.uibk.ac.at/images/seal2.gif') no-repeat right bottom #fff; 26 | text-align: left; 27 | -moz-border-radius: 15px; 28 | border-radius: 15px; 29 | box-shadow: 5px 10px 20px #888; 30 | -moz-box-shadow: 5px 10px 20px #888; 31 | } 32 | .lang_sel { 33 | margin: 2px auto 2px auto; 34 | width: 1040px; 35 | /*width: 1190px;*/ 36 | /*width: 940px;*/ 37 | height: 15px; 38 | text-align: right; 39 | font-size: 8pt; 40 | } 41 | .lang_sel a { 42 | color: #666; 43 | } 44 | .lang_sel a:hover { 45 | color: #f29400; 46 | } 47 | .header { 48 | height: 79px; 49 | background: #f29400; 50 | -moz-border-radius-topright: 15px; 51 | -moz-border-radius-topleft: 15px; 52 | border-top-right-radius: 15px; 53 | border-top-left-radius: 15px; 54 | } 55 | .header a:hover { 56 | text-decoration: none; 57 | } 58 | .subtitle { 59 | color: #fff; 60 | float: left; 61 | width: 742px; 62 | /*width: 892px;*/ 63 | /*width: 642px;*/ 64 | height: 79px; 65 | text-align: right; 66 | font-weight: bold; 67 | font-size: 12pt; 68 | line-height: 16pt; 69 | } 70 | .subtitle a { 71 | color: #fff; 72 | font-size: 12pt; 73 | text-decoration: none; 74 | } 75 | .logo { 76 | float: left; 77 | margin-left: 10px; 78 | width: 198px; 79 | height: 79px; 80 | background-image: url(cllogo.gif); 81 | background-image: none, url(cllogo.svgz), url(cllogo.gif); 82 | background-size: 198px 79px; 83 | } 84 | .logo a { 85 | display: block; 86 | width: 100%; 87 | height: 100%; 88 | text-decoration: none; 89 | } 90 | .main_menu { 91 | clear: both; 92 | margin-top: 15px; 93 | padding: 5px 0 5px 0; 94 | background: #2b5573; /* griff slide blau, much more eayfriendly */ 95 | /*background: #003362;*/ /* uni-logo blau */ 96 | border-bottom: 5px solid #799bb3; 97 | } 98 | .main_menu a { 99 | color: #fff; 100 | padding: 5px 4px 5px 4px; 101 | } 102 | .main_menu a:hover { 103 | color: #fff; 104 | text-decoration: none; 105 | background: #799bb3; 106 | -moz-border-radius-topright: 10px; 107 | -moz-border-radius-topleft: 10px; 108 | border-top-right-radius: 10px; 109 | border-top-left-radius: 10px; 110 | } 111 | .main_menu .active { 112 | background: #799bb3; 113 | color: #fff; 114 | font-weight: bold; 115 | -moz-border-radius-topright: 10px; 116 | -moz-border-radius-topleft: 10px; 117 | border-top-right-radius: 10px; 118 | border-top-left-radius: 10px; 119 | } 120 | .bread_crumbs { 121 | width: 998px; 122 | padding-top: 15px; 123 | padding-left: 2px; 124 | display: none; 125 | } 126 | .sub_menu { 127 | padding: 0 0 10px 0; 128 | text-align: right; 129 | width: 200px; 130 | margin: 45px 15px 0 0; 131 | background: #eeeedd; 132 | -moz-border-radius-topright: 15px; 133 | -moz-border-radius-bottomright: 15px; 134 | border-top-right-radius: 15px; 135 | border-bottom-right-radius: 15px; 136 | } 137 | .sub_menu > a { 138 | display: block; 139 | color: #666; 140 | text-decoration: none; 141 | padding: 3px 10px 3px 5px; 142 | border-bottom: 2px solid #eeeedd; 143 | border-top: 2px solid #eeeedd; 144 | } 145 | .sub_menu > a:hover { 146 | text-decoration: none; 147 | background: #f8f8f0; 148 | } 149 | .sub_menu .active { 150 | border-bottom: 2px solid #eeeedd; 151 | border-top: 2px solid #eeeedd; 152 | display: block; 153 | text-decoration: none; 154 | padding: 3px 10px 3px 5px; 155 | background: #fff; 156 | font-weight: bold; 157 | } 158 | .sub_menu div { 159 | color: #fff; 160 | padding: 5px 10px 5px 5px; 161 | background: #2b5573; 162 | border-bottom: 4px solid #F29400; 163 | border-top-right-radius: 15px; 164 | -moz-border-radius-topright: 15px; 165 | } 166 | /* 167 | .sub_menu div:hover { 168 | background: #799BB3; 169 | } 170 | */ 171 | .sub_menu div a { 172 | color: inherit; 173 | display: block; 174 | text-decoration: none; 175 | } 176 | .sub_menu div a:hover { 177 | color: inherit; 178 | text-decoration: none; 179 | font-weight: bold; 180 | } 181 | .license { 182 | font-size: 8pt; 183 | } 184 | .side_bar { 185 | float: left; 186 | height: 100%; 187 | } 188 | .content, .content-wide { 189 | /*width: 776px;*/ 190 | min-height: 540px; 191 | line-height: 15pt; 192 | margin: 45px 0 0 219px; 193 | padding: 0 10px 0 0; 194 | } 195 | .content:after, .content-wide:after { 196 | clear: both; 197 | content: "."; 198 | display: block; 199 | height: 0; 200 | visibility: hidden; 201 | } 202 | .footer { 203 | /*width: 716px;*/ 204 | font-size: 8pt; 205 | margin: 15px 0 0 219px; 206 | padding: 0 0 10px 0; 207 | } 208 | a { 209 | color: #f29400; 210 | text-decoration: none; 211 | } 212 | a:hover { 213 | text-decoration: underline; 214 | } 215 | .structure { 216 | color: #6060D4; 217 | } 218 | hr { 219 | border: 0; 220 | border-bottom: 2px solid #F29400; 221 | } 222 | .lecture-header { 223 | text-align: center; 224 | } 225 | .lecture-header > * { 226 | margin: 0.66em 0; 227 | } 228 | h1, h2, h3, h4, h5 { 229 | color: #2b5573; 230 | margin: 0.5em 0 0.25em; 231 | } 232 | h1 { 233 | font-size: 14pt; 234 | } 235 | h2 { 236 | font-size: 13pt; 237 | } 238 | h3 { 239 | font-size: 12pt; 240 | } 241 | h4 { 242 | font-size: 11pt; 243 | } 244 | h3.homenews { 245 | font-size: 12pt; 246 | } 247 | h4.homenews { 248 | font-size: 9pt; 249 | margin-top: 0.5em; 250 | margin-right: 0px; 251 | margin-bottom: 0.25em; 252 | } 253 | a.homenews { 254 | font-size: 8pt; 255 | } 256 | div.news-container { 257 | float: right; 258 | width: 450px; 259 | } 260 | div.info { 261 | float: left; 262 | width: 250px; 263 | } 264 | .print { 265 | float: right; 266 | margin: 0 10px 0 0; 267 | } 268 | p { 269 | line-height: 15pt; 270 | } 271 | th { 272 | color: #2b5573; 273 | font-weight: normal; 274 | text-align: left; 275 | padding-left: 5px; 276 | } 277 | tr { 278 | line-height: 18pt; 279 | } 280 | table { 281 | border-collapse: collapse; 282 | } 283 | table.colors-w-heading, 284 | table.colors-wo-heading { 285 | margin: 0.4ex 0 0.65ex; 286 | } 287 | table.colors-w-heading td, 288 | table.colors-wo-heading td { 289 | padding-right: 8px; 290 | } 291 | table.colors-w-heading td[align="right"], 292 | table.colors-wo-heading td[align="right"] { 293 | padding-right: 0px; 294 | } 295 | table.colors-w-heading tr:nth-child(2n), 296 | table.colors-wo-heading tr:nth-child(2n+1), 297 | .odd_tr { 298 | background: #eeeedd; 299 | background-color: rgba(200,200,145,0.3); 300 | } 301 | td.r { 302 | text-align: right; 303 | } 304 | td { 305 | padding-left: 5px; 306 | } 307 | .td_np { 308 | padding-left: 0px; 309 | } 310 | ul { 311 | list-style: url(/images/bullet.gif) outside; 312 | } 313 | li { 314 | margin-left: -10px; 315 | } 316 | div.dt { 317 | text-align: left; 318 | padding-left: 5px; 319 | position: relative; 320 | left: 0px; 321 | clear: none; 322 | width: 160px; 323 | text-transform: lowercase 324 | } 325 | div.dd { 326 | float: right; 327 | text-align: right; 328 | } 329 | div.dl { 330 | width: 500px; 331 | } 332 | hr.separator { 333 | border: 0; 334 | border-bottom: 2px solid #F29400; 335 | } 336 | span.bold { 337 | font-weight: bold; 338 | } 339 | .menulecture { 340 | background: #eeeedd; 341 | margin: 5px; 342 | } 343 | .menulecture a { 344 | font-weight: bold; 345 | padding: 5px; 346 | text-decoration: none; 347 | } 348 | 349 | .odd { 350 | margin-left: -5px; 351 | padding: 5px; 352 | background: #eeeedd; 353 | background-color: rgba(200,200,145,0.3); 354 | } 355 | .oddp { 356 | background: #eeeedd; 357 | background-color: rgba(200,200,145,0.3); 358 | } 359 | .even { 360 | margin-left: -5px; 361 | padding: 5px; 362 | } 363 | 364 | span.error input { 365 | background: #E6E6FF; 366 | } 367 | 368 | span.required, .error { 369 | font-weight: bold; 370 | color: #F00; 371 | } 372 | 373 | .inputbox { 374 | font-weight: bold; 375 | color: #666666; 376 | background: #FFFFFF; 377 | border: 1px solid; 378 | padding-left: 2px; 379 | width: 200px; 380 | margin-left: 2px; 381 | } 382 | .inputboxsmall { 383 | font-weight: bold; 384 | color: #666666; 385 | background: #FFFFFF; 386 | border: 1px solid; 387 | padding-left: 2px; 388 | width: 30px; 389 | margin-left: 2px; 390 | } 391 | .inputboxsmallrequired { 392 | font-weight: bold; 393 | color: #666666; 394 | background: #E6E6FF; 395 | border: 1px solid; 396 | padding-left: 2px; 397 | width: 30px; 398 | margin-left: 2px; 399 | } 400 | .textbox { 401 | color: #666666; 402 | background: #FFFFFF; 403 | border: 1px solid; 404 | padding-left: 2px; 405 | width: 200px; 406 | margin-left: 2px; 407 | } 408 | .disabledbox { 409 | font-weight: bold; 410 | color: #666666; 411 | background: #CCCCCC; 412 | border: 1px solid; 413 | padding-left: 2px; 414 | width: 200px; 415 | margin-left: 2px; 416 | } 417 | .disabledboxsmall { 418 | font-weight: bold; 419 | color: #666666; 420 | background: #CCCCCC; 421 | border: 1px solid; 422 | padding-left: 2px; 423 | width: 30px; 424 | margin-left: 2px; 425 | } 426 | .disabledtextbox { 427 | color: #666666; 428 | background: #CCCCCC; 429 | border: 1px solid; 430 | padding-left: 2px; 431 | width: 200px; 432 | margin-left: 2px; 433 | } 434 | td.form select { 435 | color: #666666; 436 | background: #FFFFFF; 437 | border: 1px solid; 438 | padding: 2px; 439 | margin-left: 2px; 440 | } 441 | .copyright { 442 | font-size: 8pt; 443 | } 444 | 445 | .copyright a { 446 | font-size: 8pt; 447 | color: #666; 448 | text-decoration: none; 449 | } 450 | 451 | .copyright a:hover { 452 | color: #f29400; 453 | text-decoration: underline; 454 | } 455 | 456 | .news-red, .news-blue { 457 | -moz-border-radius: 10px; 458 | border-radius: 10px; 459 | margin: 0px -9px 0.5em; 460 | margin-right: 5px; 461 | padding: 5px 15px 10px 15px; 462 | text-align: left; 463 | color: #FFF; 464 | font-weight: bold; 465 | font-size: 14px; 466 | height: 14px; 467 | vertical-align: middle; 468 | white-space: nowrap; 469 | } 470 | .news-blue { 471 | background-color: #2b5573; 472 | } 473 | .news-red { 474 | background-color: #d91a1a; 475 | } 476 | .news-box { 477 | margin: 0px 15px 15px 15px; 478 | } 479 | 480 | .image a:link { 481 | color: #FFFFFF; 482 | } 483 | 484 | .image a:visited { 485 | color: #FFFFFF; 486 | } 487 | 488 | em { 489 | color: #2B5573; 490 | font-style: inherit; 491 | font-weight: inherit; 492 | } 493 | 494 | ul, ol, p { 495 | margin: 0; 496 | } 497 | 498 | .lightbox { 499 | left: -999em; 500 | position: absolute; 501 | } 502 | .lightbox:target { 503 | bottom: 0; 504 | left: 0; 505 | right: 0; 506 | top: 0; 507 | position: absolute; 508 | } 509 | .lightbox:target div { 510 | background: #FFFFFF; 511 | position: absolute; 512 | left: 50%; 513 | top: 50%; 514 | z-index: 99; 515 | padding: 2em; 516 | border-radius: 15px; 517 | } 518 | .lightbox:target .close a { 519 | background: rgba(0, 0, 0, 0.75); 520 | bottom: 0; 521 | left: 0; 522 | right: 0; 523 | top: 0; 524 | position: absolute; 525 | z-index: 1; 526 | } 527 | .close { 528 | text-indent: -999em; 529 | } 530 | .w60p { 531 | margin-left: -30%; 532 | width: 60%; 533 | } 534 | .w300 { 535 | margin-left: -150px; 536 | width: 300px; 537 | } 538 | .w480 { 539 | margin-left: -240px; 540 | width: 480px; 541 | } 542 | .w640 { 543 | margin-left: -320px; 544 | width: 640px; 545 | } 546 | .h60 { 547 | height: 60px; 548 | margin-top: -30px; 549 | } 550 | .h400 { 551 | height: 400px; 552 | margin-top: -200px; 553 | } 554 | .h386 { 555 | height: 386px; 556 | margin-top: -193px; 557 | } 558 | .scroll { 559 | overflow-y: scroll; 560 | padding: 0 1em; 561 | } 562 | .lightbox h3 { 563 | margin: 0.5em 0 1em; 564 | } 565 | table.horizontal th, table.horizontal td { 566 | padding: 0 1em; 567 | } 568 | table.booktabs { 569 | margin: 0.4ex 0 0.65ex; 570 | } 571 | table.booktabs tr:first-child th, 572 | table.booktabs tr:first-child td { 573 | border-top: #666 1px solid; /*0.08em*/ 574 | } 575 | table.booktabs tr th, 576 | table.booktabs tr td { 577 | border-bottom: #CCC 1px solid; /*0.05em*/ 578 | } 579 | table.booktabs tr:last-child th, 580 | table.booktabs tr:last-child td { 581 | border-bottom: #666 1px solid; /*0.08em*/ 582 | } 583 | ol.alternating li, 584 | ul.alternating li { 585 | margin-left: -5px; 586 | padding: 5px; 587 | } 588 | ol.alternating li:nth-child(2n+1), 589 | ul.alternating li:nth-child(2n+1), 590 | .odd_li { 591 | background: #eeeedd; 592 | background-color: rgba(200, 200, 145, 0.3); 593 | } 594 | s.hide { 595 | visibility: hidden; 596 | } 597 | 598 | .reflection { 599 | display: none; 600 | } 601 | 602 | /* styles for smb page */ 603 | #theses .tags a { 604 | color: inherit; 605 | opacity: 0.5; 606 | } 607 | #theses .thesis * { 608 | background: transparent !important; 609 | line-height: 15pt; 610 | } 611 | #theses .thesis td, .thesis th { 612 | padding: 0 1em 0 0 !important; 613 | vertical-align: top; 614 | } 615 | #theses { 616 | width: 100%; 617 | } 618 | #theses td { 619 | padding: 0 1em 0.5em; 620 | } 621 | #theses td h4 { 622 | margin-top: 0.75em; 623 | } 624 | #theses .abstract { 625 | display: block; 626 | /*height: auto;*/ 627 | overflow: hidden; 628 | height: 5.5ex; 629 | /*-moz-transition-property: height;*/ 630 | -moz-transition-duration: 0.4s; 631 | -moz-transition-delay: 0.2s; 632 | } 633 | #theses td:hover .abstract { 634 | height: auto; 635 | -moz-transition-property: height; 636 | -moz-transition-duration: 0.4s; 637 | -moz-transition-delay: 0.2s; 638 | } 639 | 640 | .search { 641 | box-shadow: 1px 1px 2px 0 #888888 inset; 642 | border-radius: 5px 5px 5px 5px; 643 | outline: 0pt none; 644 | width: 300px; 645 | background-repeat: no-repeat; 646 | padding: 3px 3px 3px 20px; 647 | background-position: 4px 4px; 648 | border: 0px solid rgba(200, 200, 145, 0.5); 649 | background-image: url(data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAA4AAAAPCAMAAADjyg5GAAAAUVBMVEX///82a5D+/v41ao83bJHT4+9Qkb78/f7J3eulxt01aY34+vxBga2ixNzW5fBypsrf6/Nrocc9eKFjncV/rs/e6vLo8PbF2unG2+rr8vfg7PStvQk/AAAAcUlEQVR4XnXJRw4CQRQD0bJ/p8nkdP+DQoPYwdtYVvFDHSSVTGemWYoUaaBjr8OS1y1F71w0NlzZxgKmpeJuDRm7jUe6rIBKTkG36LMpygTtEIPBD4V0LKG5gs96CUXaT0B/O/L1dreBk4Ivw+7EH8ZPWWwDGFpkb5cAAAAASUVORK5CYII=); 650 | } 651 | 652 | .alert { 653 | color: #d91a1a; 654 | font-weight: bold; 655 | } 656 | 657 | .kbcv-news-box { 658 | margin-left: -5px; 659 | padding: 5px; 660 | border-radius: 10px; 661 | background: #eeeedd; 662 | background-color: rgba(200,200,145,0.3); 663 | } 664 | 665 | .kbcv-news-span { 666 | color: red; 667 | } 668 | 669 | @media print { 670 | .side_bar, .main_menu, .subtitle, .search, .lang_sel { 671 | display: none; 672 | } 673 | .content, .content-wide { 674 | margin: 0; 675 | } 676 | body { 677 | font-family: "Latin Modern Roman", Arial, Helvetica, sans-serif; 678 | color: black; 679 | } 680 | .all { 681 | box-shadow: none; 682 | width: auto; 683 | } 684 | a { 685 | color: inherit; 686 | } 687 | .logo { 688 | display: list-item; 689 | list-style-image: url(/images/logonew.gif); 690 | list-style-position: inside; 691 | margin: 0 !important; 692 | padding: 0 !important; 693 | height: 50pt; 694 | } 695 | #theses .abstract { 696 | height: auto; 697 | } 698 | #theses td { 699 | page-break-inside: avoid; 700 | } 701 | } 702 | 703 | -------------------------------------------------------------------------------- /tools/kb/kb.ml: -------------------------------------------------------------------------------- 1 | open Js_of_ocaml 2 | open Alg 3 | open Term 4 | 5 | module Html = Dom_html 6 | 7 | let doc = Html.document 8 | let button txt action = 9 | let button_type = Js.string "button" in 10 | let b = Html.createInput ~_type:button_type doc in 11 | b##.value := Js.string txt; 12 | b##.onclick := Dom_html.handler (fun _ -> action (); Js._true); 13 | b 14 | 15 | let debug s = Firebug.console##debug (Js.string s) 16 | 17 | let jsget x = Js.Opt.get x (fun () -> assert false) 18 | 19 | let parse_rs syms rules = 20 | let s = syms in 21 | let s = String.split_on_char ',' s in 22 | let s = List.map String.trim s in 23 | let s = List.map (fun s -> String.split_on_char ':' s) s in 24 | let w = ref 0 in 25 | let s = List.map (function (f::n::_) -> decr w; Op.make ~weight:(!w) f (int_of_string n) | _ -> failwith "unknown arity") s in 26 | ParserRefs.syms := s; 27 | let rs = Parser.main Lexer.token (Lexing.from_string rules) in 28 | let name = 29 | let n = ref 0 in 30 | fun () -> incr n; "R" ^ string_of_int !n ^ "" 31 | in 32 | let rs = List.map (fun (s,t) -> RS.Rule.make (name ()) s t) rs in 33 | RS.make s rs 34 | 35 | (** Replace [c] by [t] in [s]. *) 36 | let rec replace c t s = 37 | try 38 | let n = String.index s c in 39 | replace c t (String.sub s 0 n ^ t ^ String.sub s (n+1) (String.length s-(n+1))) 40 | with 41 | | Not_found -> s 42 | 43 | let run _ = 44 | let syms = jsget (Html.CoerceTo.textarea (jsget (doc##getElementById(Js.string "symbols")))) in 45 | let rules = jsget (Html.CoerceTo.textarea (jsget (doc##getElementById(Js.string "rules")))) in 46 | let completion = jsget (doc##getElementById(Js.string "completion")) in 47 | let squier = jsget (doc##getElementById(Js.string "squier")) in 48 | let go = jsget (doc##getElementById(Js.string "go")) in 49 | let status = jsget (doc##getElementById(Js.string "status")) in 50 | let status s = status##.innerHTML := Js.string s in 51 | let error s = status ("" ^ s ^ "") in 52 | 53 | go##.onclick := 54 | Html.handler 55 | (fun _ -> 56 | try 57 | status "Started computation..."; 58 | let syms = Js.to_string syms##.value in 59 | let rules = Js.to_string rules##.value in 60 | 61 | status "Parsing rewriting system..."; 62 | let rs = parse_rs syms rules in 63 | status ("Parsed: " ^ RS.to_string rs); 64 | 65 | status "Computing Knuth-Bendix completion..."; 66 | let display rs = 67 | completion##.innerHTML := Js.string (replace '\n' "
" (RS.to_string ~var:Var.namer_natural rs)) 68 | in 69 | let namer = 70 | let n = ref 0 in 71 | fun () -> incr n; Printf.sprintf "K%d" !n 72 | in 73 | let rs = RS.knuth_bendix ~namer ~callback:display rs in 74 | display rs; 75 | 76 | status "Computing Squier completion..."; 77 | let sq = RS.squier rs in 78 | let sqs = 79 | let rule_name = Utils.namer (fun (s1,s2) (s1',s2') -> RS.Path.eq s1 s1' && RS.Path.eq s2 s2') in 80 | let ans = ref "" in 81 | List.iter 82 | (fun (s1,s2) -> 83 | let n = rule_name (s1,s2) + 1 in 84 | let var = Var.namer_natural () in 85 | ans := Printf.sprintf "%s

C%d

%s
%s

%!" !ans n (RS.Path.to_string ~var s1) (RS.Path.to_string ~var s2) 86 | ) sq; 87 | !ans 88 | in 89 | squier##.innerHTML := Js.string sqs; 90 | 91 | status "Done."; 92 | Js._true 93 | with 94 | | Exit -> 95 | Js._false 96 | | Failure s -> 97 | error ("Error: " ^ s); 98 | Js._false 99 | | e -> 100 | error (Printexc.to_string e); 101 | Js._false 102 | ); 103 | 104 | Js._true 105 | 106 | let () = 107 | Html.window##.onload := Html.handler run 108 | -------------------------------------------------------------------------------- /tools/kb/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | } 4 | 5 | let space = ' ' | '\t' | '\r' | '\n' 6 | 7 | rule token = parse 8 | | "=" { EQ } 9 | | "(" { LPAR } 10 | | ")" { RPAR } 11 | | "," { COMMA } 12 | | (['a'-'z']+ as s) { IDENT s } 13 | | space+ { token lexbuf } 14 | | eof { EOF } 15 | -------------------------------------------------------------------------------- /tools/kb/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Alg 3 | open Term 4 | 5 | let vars = ref [] 6 | 7 | let var x = 8 | if not (List.mem_assoc x !vars) then vars := (x, Term.var ()) :: !vars; 9 | List.assoc x !vars 10 | 11 | let is_sym f = List.exists (fun g -> Op.name g = f) !ParserRefs.syms 12 | let sym f = List.find (fun g -> Op.name g = f) !ParserRefs.syms 13 | 14 | let app f args = 15 | let f = sym f in 16 | if List.length args <> Op.arity f then failwith ("arity mismatch for " ^ Op.name f); 17 | app f args 18 | %} 19 | 20 | %token IDENT 21 | %token LPAR RPAR COMMA EQ 22 | %token EOF 23 | 24 | %start main 25 | %type <(Alg.Term.t * Alg.Term.t) list> main 26 | %% 27 | 28 | main: 29 | | rules EOF { $1 } 30 | 31 | rules: 32 | | { [] } 33 | | rule rules { $1 :: $2 } 34 | 35 | rule: 36 | | term EQ term { $1, $3 } 37 | 38 | term: 39 | | IDENT LPAR terms RPAR { app $1 $3 } 40 | | IDENT { if is_sym $1 then app $1 [] else var $1 } 41 | ; 42 | 43 | terms: 44 | | term COMMA terms { $1::$3 } 45 | | term { [$1] } 46 | | { [] } 47 | -------------------------------------------------------------------------------- /tools/kb/parserRefs.ml: -------------------------------------------------------------------------------- 1 | open Alg 2 | 3 | let syms = ref ([] : Term.Op.t list) 4 | 5 | -------------------------------------------------------------------------------- /tools/rewr2/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | @dune build 3 | -------------------------------------------------------------------------------- /tools/rewr2/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name rewr2) 3 | (modes js) 4 | (preprocess (pps js_of_ocaml-ppx)) 5 | (libraries alg str js_of_ocaml) 6 | ) 7 | -------------------------------------------------------------------------------- /tools/rewr2/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | String rewriting 5 | 6 | 19 | 20 | 21 | 22 |

String rewriting

23 | 24 |

25 | This webpage allows you to compute the Knuth-Bendix completion of a string 26 | rewriting system (according to the deglex order). It is based 27 | on ocaml-alg, a generic 28 | library for manipulating algebraic data structures. A previous version 29 | (with more features but not maintained anymore) was 30 | called rewr. 31 |

32 | 33 |

Presentation

34 |

35 | Classical: 36 | 41 | with n = 42 | 43 |

44 |

Generators:

45 | 46 |

Rules:

47 | 49 |

50 | Order: 51 | 55 |

56 |

57 | 58 |

59 | 60 |

Results

61 |

62 | 63 |

Parsed presentation

64 |

65 | 66 |

Knuth-Bendix completion

67 |

68 | 69 |

Reduced completion

70 |

71 | 72 |

Coherence cells

73 |

74 | 75 | 76 | -------------------------------------------------------------------------------- /tools/rewr2/rewr2.ml: -------------------------------------------------------------------------------- 1 | open Js_of_ocaml 2 | open Alg 3 | 4 | module Array = struct 5 | include Array 6 | 7 | let index_opt x a = 8 | let ans = ref (-1) in 9 | for i = 0 to Array.length a - 1 do 10 | if x = a.(i) then ans := i 11 | done; 12 | if !ans = -1 then None else Some !ans 13 | end 14 | module String = struct 15 | include String 16 | 17 | let split_on_first_char c s = 18 | let i = String.index s c in 19 | String.sub s 0 i, 20 | String.sub s (i+1) (String.length s - (i+1)) 21 | 22 | (** Replace [c] by [t] in [s]. *) 23 | let rec replace c t s = 24 | try 25 | let n = String.index s c in 26 | replace c t (String.sub s 0 n ^ t ^ String.sub s (n+1) (String.length s-(n+1))) 27 | with Not_found -> s 28 | end 29 | 30 | module Str = struct 31 | include Str 32 | 33 | let split_first r s = 34 | let i = Str.search_forward r s 0 in 35 | let l = String.length (Str.matched_string s) in 36 | String.sub s 0 i, 37 | String.sub s (i+l) (String.length s - (i+l)) 38 | end 39 | 40 | module Html = Dom_html 41 | 42 | let doc = Html.document 43 | let button txt action = 44 | let button_type = Js.string "button" in 45 | let b = Html.createInput ~_type:button_type doc in 46 | b##.value := Js.string txt; 47 | b##.onclick := Dom_html.handler (fun _ -> action (); Js._true); 48 | b 49 | 50 | let debug s = Firebug.console##debug (Js.string s) 51 | 52 | let jsget x = Js.Opt.get x (fun () -> assert false) 53 | 54 | let run _ = 55 | let get_element_by_id x = doc##getElementById (Js.string x) |> jsget in 56 | let generate = get_element_by_id "generate" |> Html.CoerceTo.select |> jsget in 57 | let generaten = get_element_by_id "generaten" |> Html.CoerceTo.input |> jsget in 58 | let syms = get_element_by_id "symbols" |> Html.CoerceTo.textarea |> jsget in 59 | let rules = get_element_by_id "rules" |> Html.CoerceTo.textarea |> jsget in 60 | let order = get_element_by_id "order" |> Html.CoerceTo.select |> jsget in 61 | let parsed_presentation = get_element_by_id "presentation" in 62 | let completion = get_element_by_id "completion" in 63 | let reduced = get_element_by_id "reduced" in 64 | let coherence = get_element_by_id "coherence" in 65 | let go = get_element_by_id "go" in 66 | let status = get_element_by_id "status" in 67 | let status s = status##.innerHTML := Js.string s in 68 | let error s = status ("" ^ s ^ "") in 69 | 70 | go##.onclick := 71 | Html.handler 72 | (fun _ -> 73 | try 74 | status "Started computation..."; 75 | let syms = 76 | Js.to_string syms##.value 77 | |> String.split_on_char ',' 78 | |> List.map String.trim 79 | |> Array.of_list 80 | in 81 | let rules = 82 | Js.to_string rules##.value 83 | |> String.split_on_char ',' 84 | |> List.map (String.split_on_char '\n') 85 | |> List.flatten 86 | |> List.map String.trim 87 | |> List.filter (fun s -> s <> "") 88 | |> List.map (Str.split_first (Str.regexp "\\(=\\|→\\)")) 89 | |> List.map (fun (u,v) -> String.trim u, String.trim v) 90 | in 91 | 92 | let module X = struct 93 | include Alphabet.Int 94 | let to_string n = syms.(n) 95 | let of_char c = 96 | match Array.index_opt (String.make 1 c) syms with 97 | | Some i -> i 98 | | None -> failwith ("Unknown letter "^String.make 1 c) 99 | end in 100 | let module P = Monoid.Pres(X) in 101 | let string_of_rs rs = 102 | P.to_string rs 103 | |> Str.global_replace (Str.regexp "->") "→" 104 | |> Str.global_replace (Str.regexp "<") "⟨" 105 | |> Str.global_replace (Str.regexp ">") "⟩" 106 | in 107 | let string_of_coh coh = 108 | List.map 109 | (fun (p,q) -> 110 | "
  • " ^ 111 | P.Path.to_string p ^ 112 | "
    " ^ 113 | P.Path.to_string q ^ 114 | "
    • " 115 | ) coh 116 | |> String.concat "\n" 117 | |> (fun s -> "
      " ^ s ^ "
    ") 118 | in 119 | 120 | status "Parsing rewriting system..."; 121 | let rules = 122 | let word u = if u = "1" || u = "ε" then [||] else Array.init (String.length u) (fun i -> X.of_char u.[i]) in 123 | List.map (fun (u,v) -> "", word u, word v) rules 124 | in 125 | let rs = P.make (List.init (Array.length syms) Fun.id) rules in 126 | parsed_presentation##.innerHTML := Js.string (string_of_rs rs); 127 | status ("Parsed: " ^ P.to_string rs); 128 | 129 | status "Computing Knuth-Bendix completion..."; 130 | let leq = 131 | match Js.to_string order##.value with 132 | | "deglex" -> P.W.Order.deglex X.leq 133 | | "revdeglex" -> P.W.Order.deglex X.geq 134 | | _ -> assert false 135 | in 136 | let rs = P.complete ~namer:P.Rule.Namer.none leq rs in 137 | completion##.innerHTML := Js.string (string_of_rs rs); 138 | 139 | status "Reducing presentation..."; 140 | let rs = P.reduce rs in 141 | reduced##.innerHTML := Js.string (string_of_rs rs); 142 | 143 | status "Computing coherence cells..."; 144 | let coh = P.coherence rs in 145 | coherence##.innerHTML := Js.string (string_of_coh coh); 146 | 147 | status "Done."; 148 | Js._true 149 | with 150 | | Exit -> 151 | Js._false 152 | | Failure s -> 153 | error ("Error: " ^ s); 154 | Js._false 155 | | e -> 156 | error (Printexc.to_string e); 157 | Js._false 158 | ); 159 | 160 | let generate_handler _ = 161 | let set v r = 162 | let v = String.concat "," v in 163 | let r = List.map (fun (u,v) -> u^"="^v) r |> String.concat "," in 164 | syms##.value := Js.string v; 165 | rules##.value := Js.string r 166 | in 167 | let gen n = String.make 1 (char_of_int (n + int_of_char 'a')) in 168 | let dihedral n = 169 | let v = ["r";"s"] in 170 | let r = 171 | [ 172 | String.make n 'r', "1"; 173 | "ss", "1"; 174 | "rs", "s" ^ String.make (n-1) 'r' 175 | ] 176 | in 177 | set v r 178 | in 179 | let quaternion n = 180 | let v = ["a";"b"] in 181 | let r = 182 | [ 183 | String.make (1 lsl n) 'a',"1"; 184 | "bbbb","1"; 185 | String.make (1 lsl (n-1)) 'a',"bb"; 186 | "aba","b" 187 | ] 188 | in 189 | set v r 190 | in 191 | let sym n = 192 | let v = List.init n gen in 193 | let rel = ref [] in 194 | for i = 0 to n-2 do 195 | rel := (gen i^gen (i+1)^gen i, gen (i+1)^gen i^gen (i+1)) :: !rel 196 | done; 197 | for i = 0 to n-1 do 198 | for j = i+2 to n-1 do 199 | rel := (gen i^gen j, gen j^gen i) :: !rel 200 | done 201 | done; 202 | for i = 0 to n-1 do 203 | rel := (gen i^gen i, "1") :: !rel 204 | done; 205 | set v !rel 206 | in 207 | let n = int_of_string (Js.to_string generaten##.value) in 208 | ( 209 | match Js.to_string generate##.value with 210 | | "dihedral" -> dihedral n 211 | | "quaternion" -> quaternion n 212 | | "sym" -> sym n 213 | | _ -> assert false 214 | ); 215 | Js._true 216 | in 217 | 218 | generate##.oninput := Html.handler generate_handler; 219 | generaten##.onchange := Html.handler generate_handler; 220 | Js._true 221 | 222 | let () = 223 | Html.window##.onload := Html.handler run 224 | --------------------------------------------------------------------------------