first working version of new AutomoprhismGroups

src/Groups.jl

@@ -5,6 +5,7 @@ using LinearAlgebra
 using ThreadsX
 
 import AbstractAlgebra
+import KnuthBendix
 
 export gens, FreeGroup, Aut, SAut
 
@@ -22,12 +23,16 @@ include("arithmetic.jl")
 include("findreplace.jl")
 
 module New
+import Groups: AutSymbol, GSymbol, λ, ϱ, RTransvect, LTransvect
 using DataStructures
 
 include("new_types.jl")
 include("new_hashing.jl")
 include("normalform.jl")
 
+include("gersten_relations.jl")
+include("new_autgroups.jl")
+
 end # module New
 
 ###############################################################################

src/gersten_relations.jl

@@ -0,0 +1,108 @@
+function gersten_alphabet(n::Integer; commutative::Bool = true)
+    indexing = [[i, j] for i in 1:n for j in 1:n if i ≠ j]
+    rmuls = [ϱ(i, j) for (i, j) in indexing]
+
+    S = if commutative
+        Vector{AutSymbol}(rmuls)
+    else
+        lmuls = [λ(i, j) for (i, j) in indexing]
+        AutSymbol[rmuls; lmuls]
+    end
+
+    return Alphabet(S)
+end
+
+function _commutation_rule(
+    ::Type{W},
+    A::Alphabet,
+    x::S,
+    y::S,
+) where {S,T,W<:AbstractWord{T}}
+    return W(T[A[x], A[y]]) => W(T[A[y], A[x]])
+end
+
+function _pentagonal_rule(
+    ::Type{W},
+    A::Alphabet,
+    x::S,
+    y::S,
+    z::S,
+) where {S,T,W<:AbstractWord{T}}
+    # x·y·x⁻¹·y⁻¹ => z, i.e. z·y·x => x·y
+    return W(T[A[z], A[y], A[x]]) => W(T[A[x], A[y]])
+end
+function _hexagonal_rule(
+    ::Type{W},
+    A::Alphabet,
+    x::S,
+    y::S,
+    z::S,
+    w::S,
+) where {S,T,W<:AbstractWord{T}}
+    # x·y⁻¹·z => z·w⁻¹·x
+    return W(T[A[x], A[inv(y)], A[z]]) => W(T[A[z], A[w^-1], A[x]])
+end
+
+gersten_relations(n::Integer; commutative) =
+    gersten_relations(Word{UInt8}, n, commutative = commutative)
+
+function gersten_relations(::Type{W}, n::Integer; commutative) where {W<:AbstractWord}
+    @assert n > 1 "Gersten relations are defined only for n>1, got n=$n"
+    A = gersten_alphabet(n, commutative = commutative)
+    @assert length(A) <= KnuthBendix._max_alphabet_length(W) "Type $W can not represent words over alphabet with $(length(A)) letters."
+
+    rels = Pair{W,W}[]
+
+    for (i, j, k, l) in Iterators.product(1:n, 1:n, 1:n, 1:n)
+        if i ≠ j && k ≠ l && k ≠ i && k ≠ j && l ≠ i
+            push!(rels, _commutation_rule(W, A, ϱ(i, j), ϱ(k, l)))
+
+            commutative && continue
+
+            push!(rels, _commutation_rule(W, A, λ(i, j), λ(k, l)))
+        end
+    end
+
+    if !commutative
+        for (i, j, k, l) in Iterators.product(1:n, 1:n, 1:n, 1:n)
+            if (i ≠ j && k ≠ l && k ≠ j && l ≠ i)
+                push!(rels, _commutation_rule(W, A, ϱ(i, j), λ(k, l)))
+                push!(rels, _commutation_rule(W, A, λ(i, j), ϱ(k, l)))
+            end
+        end
+    end
+
+    # pentagonal rule:
+    # x*y*inv(x)*inv(y)=>z
+
+    for (i, j, k) in Iterators.product(1:n, 1:n, 1:n)
+        if (i ≠ j && k ≠ i && k ≠ j)
+            push!(rels, _pentagonal_rule(W, A, ϱ(i, j)^-1, ϱ(j, k)^-1, ϱ(i, k)^-1))
+            push!(rels, _pentagonal_rule(W, A, ϱ(i, j)^-1, ϱ(j, k), ϱ(i, k)))
+
+            commutative && continue
+
+            push!(rels, _pentagonal_rule(W, A, ϱ(i, j), λ(j, k), ϱ(i, k)^-1))
+            push!(rels, _pentagonal_rule(W, A, ϱ(i, j), λ(j, k)^-1, ϱ(i, k)))
+
+            # the same as above, but with ϱ ↔ λ:
+            push!(rels, _pentagonal_rule(W, A, λ(i, j)^-1, λ(j, k)^-1, λ(i, k)^-1))
+            push!(rels, _pentagonal_rule(W, A, λ(i, j)^-1, λ(j, k), λ(i, k)))
+
+            push!(rels, _pentagonal_rule(W, A, λ(i, j), ϱ(j, k), λ(i, k)^-1))
+            push!(rels, _pentagonal_rule(W, A, λ(i, j), ϱ(j, k)^-1, λ(i, k)))
+        end
+    end
+
+    if !commutative
+        for (i, j) in Iterators.product(1:n, 1:n)
+            if i ≠ j
+                push!(rels, _hexagonal_rule(W, A, ϱ(i, j), ϱ(j, i), λ(i, j), λ(j, i)))
+                w = W([A[ϱ(i, j)], A[ϱ(j, i)^-1], A[λ(i, j)]])
+                push!(rels, w^2 => inv(A, w)^2)
+            end
+        end
+    end
+
+    return A, rels
+end

src/new_autgroups.jl

@@ -0,0 +1,129 @@
+function KnuthBendix.Alphabet(S::AbstractVector{<:GSymbol})
+    S = unique!([S; inv.(S)])
+    inversions = [findfirst(==(inv(s)), S) for s in S]
+    return Alphabet(S, inversions)
+end
+
+struct AutomorphismGroup{G<:Group, T, R, S} <: AbstractFPGroup
+    group::G
+    gens::Vector{T}
+    rws::R
+    domain::S
+end
+
+object(G::AutomorphismGroup) = G.group
+
+function SpecialAutomorphismGroup(F::FreeGroup;
+    ordering=KnuthBendix.LenLex, kwargs...)
+
+    n = length(KnuthBendix.alphabet(F))÷2
+    A, rels = gersten_relations(n, commutative=false)
+    S = KnuthBendix.letters(A)[1:2(n^2 - n)]
+
+    rws = KnuthBendix.RewritingSystem(rels, ordering(A))
+    KnuthBendix.knuthbendix!(rws; kwargs...)
+    return AutomorphismGroup(F, S, rws, ntuple(i->gens(F, i), n))
+end
+
+KnuthBendix.alphabet(G::AutomorphismGroup{<:FreeGroup}) = alphabet(rewriting(G))
+rewriting(G::AutomorphismGroup) = G.rws
+
+function relations(G::AutomorphismGroup)
+    n = length(KnuthBendix.alphabet(object(G)))÷2
+    return last(gersten_relations(n, commutative=false))
+end
+
+_hashing_data(f::FPGroupElement{<:AutomorphismGroup}) = normalform!.(evaluate(f))
+
+function Base.:(==)(g::A, h::A) where A<:FPGroupElement{<:AutomorphismGroup}
+    @assert parent(g) === parent(h)
+
+    if _isvalidhash(g) && _isvalidhash(h)
+        hash(g) != hash(h) && return false
+    end
+
+    normalform!(g)
+    normalform!(h)
+    word(g) == word(h) && return true
+
+    @assert isnormalform(g)
+    @assert isnormalform(h)
+
+    img_computed, imh_computed = false, false
+
+    if !_isvalidhash(g)
+        img = _hashing_data(g)
+        _update_savedhash!(g, img)
+        img_computed = true
+    end
+    if !_isvalidhash(h)
+        imh = _hashing_data(h)
+        _update_savedhash!(h, imh)
+        imh_computed = true
+    end
+
+    @assert _isvalidhash(g)
+    @assert _isvalidhash(h)
+
+    hash(g) != hash(h) && return false
+
+    # words are different, but hashes agree
+    if !img_computed
+        img = _hashing_data(g)
+    end
+    if !imh_computed
+        imh = _hashing_data(h)
+    end
+
+    res = img == imh
+    !res && @warn "hash collision in == :" g h
+
+    return res
+end
+
+# eye-candy
+
+Base.show(io::IO, ::Type{<:FPGroupElement{<:AutomorphismGroup{T}}}) where T <: FreeGroup = print(io, "Automorphism{$T}")
+
+## Automorphism Evaluation
+
+domain(f::FPGroupElement{<:AutomorphismGroup}) = deepcopy(parent(f).domain)
+# tuple(gens(object(parent(f)))...)
+
+evaluate(f::FPGroupElement{<:AutomorphismGroup{<:FreeGroup}}) =
+    evaluate!(domain(f), f)
+
+function evaluate!(t::NTuple{N, T}, f::FPGroupElement{<:AutomorphismGroup{<:FreeGroup}}) where {T<:FPGroupElement, N}
+    A = alphabet(f)
+    for idx in word(f)
+        t = evaluate!(t, A[idx])::NTuple{N, T}
+    end
+    return t
+end
+
+function evaluate!(v::NTuple{N, T}, s::AutSymbol) where {N, T}
+    @assert s.pow in (-1, 1)
+    return evaluate!(v, s.fn, isone(s.pow))::NTuple{N, T}
+end
+
+function evaluate!(v, ϱ::RTransvect, flag)
+    if flag
+        append!(New.word(v[ϱ.i]), New.word(v[ϱ.j]   ))
+    else
+        append!(New.word(v[ϱ.i]), New.word(v[ϱ.j]^-1))
+    end
+    _setnormalform!(v[ϱ.i], false)
+    _setvalidhash!(v[ϱ.i], false)
+    return v
+end
+
+function evaluate!(v, λ::LTransvect, flag)
+    if flag
+        prepend!(New.word(v[λ.i]), New.word(v[λ.j]   ))
+    else
+        prepend!(New.word(v[λ.i]), New.word(v[λ.j]^-1))
+    end
+    _setnormalform!(v[λ.i], false)
+    _setvalidhash!(v[λ.i], false)
+    return v
+end