Eine aufbereitete Darstellung der Quelle

 
     
 
 
Anforderungen  |   Konzepte  |   Entwurf  |   Entwicklung  |   Qualitätssicherung  |   Lebenszyklus  |   Steuerung
 
 
 
 

Benutzer

Quelle  schur.gi   Sprache: Shell

 

         
#############################################################################
##
## 
##
BindGlobal( "FindNiceElm", function( units, elms )
    local d, m, u, p, a;

    p := IndeterminateByName("p");

    # catch the easy case
    if 1 in elms or p^0 in elms then return [p^0, true]; fi;
    if -1 in elms or -p^0 in elms then return [-p^0, true]; fi;

    # go 
    while true do

        d := List(elms, PDegree);
        m := Minimum(d);
        elms := Filtered(elms, x -> PDegree(x)=m);

        d := List(elms, FDegree);
        m := Minimum(d);
        elms := Filtered(elms, x -> FDegree(x)=m);

        for u in elms do
            a := LeadingUnit(u);
            if IsLiePUnit(units, a) then return [u, true]; fi;
        od;

        d := List(elms, FSummands);
        m := Minimum(d);
        elms := Filtered(elms, x -> FSummands(x)=m);
        
        #return [Random(elms), false];
        return [elms[1], false];
    od;

end );

#############################################################################
##
## Next pivot in matrix
##
BindGlobal( "FindPivot", function( R, m, i )
    local j, k, f, d, g, n, u;

    # reduce entries in m with zeros and filter non-zero elms
    f := [];
    for j in [i..Length(m)] do
       for k in [i..Length(m[j])] do
           m[j][k] := ReduceCoeffsByZeros(R!.zeros, m[j][k]);
           if m[j][k] <> 0*m[j][k] then Add(f, m[j][k]); fi;
       od;
    od;
    f := Unique(f);

    # check 
    if Length(f) = 0 then return 0; fi;

    # loop over degrees
    d := 0;
    while true do
        g := Filtered(f, x -> PValue(x)=d);
        if Length(g) > 0 then 

            # choose minimal element
            u := FindNiceElm( R!.units, g);
            if u[2] = true then 
                return MatPos(m,i,u[1]);
            else
                return u[1];
            fi;

        fi;
        d := d+1;
    od;
end );

#############################################################################
##
## SNF for the matrix determined by L - use units and zeros
##
BindGlobal( "GenericSNF", function(R, m)
    local n, d, p, u, i, e, j, k, w, a, A;

    # catch arguments
    p := IndeterminateByName("p");
    n := Length(m);
    d := Length(m[1]);
 
    # extend by 0-rows
    for i in [n+1..d] do Add(m, 0*[1..d]); od;

    for i in [1..d] do

        e := FindPivot(R, m, i );
#Print("  ",i," has pivot ",e,"\n");

        if e = 0*e then 
            m := List([1..d], x -> m[x][x]);
            m := Filtered(m, x -> x <> 0*x);
            m := Filtered(m, x -> x <> x^0);
            return rec( norm := m );
        elif not IsList(e) then 
            return e;
        else
            j := e[1]; k := e[2];

            # swap
            if j <> i then 
                w := m[i]; m[i] := m[j]; m[j] := w;
            fi;
            if k <> i then 
                m := TransposedMatMutable(m);
                w := m[i]; m[i] := m[k]; m[k] := w;
                m := TransposedMatMutable(m);
            fi;

            # norm
            a := LeadingUnit( m[i][i] );
            m[i] := m[i] * a^-1;

            # clear
            for j in [i+1..n] do
                m[j] := m[j] - (m[j][i]/m[i][i])*m[i];
            od;
            m := TransposedMatMutable(m);
            for k in [i+1..d] do
                m[k] := m[k] - (m[k][i]/m[i][i])*m[i];
            od;
            m := TransposedMatMutable(m);
        fi;
    od;
    m := List([1..Length(m[1])], x -> m[x][x]);
    m := Filtered(m, x -> x <> 0*x);
    m := Filtered(m, x -> x <> x^0);
    return rec(norm := m);
end );
    
#############################################################################
##
## Some helpers
##
BindGlobal( "MakeIntPoly", function(R, vec)
    local p, i, u, e, f, uni;

    # set up
    p := IndeterminateByName("p");
    vec := p^0 * vec;
    uni := R!.units;

    # eliminate poly denominators
    for i in [1..Length(vec)] do
        u := DenominatorOfRationalFunction(vec[i]);
        if not IsLiePUnit(uni, u) then Error("no unit"); fi;
        vec := u*vec;
    od;

    # eliminate coeff denominators
    for i in [1..Length(vec)] do
        if vec[i] <> 0*vec[i] then 
            e := ExtRepPolynomialRatFun(vec[i]);
            e := Lcm(List([2,4..Length(e)], x -> DenominatorRat(x)));
            if e < 0 then e := (-1)*e; fi;
            f := Set(Factors(e));
            if ForAny(f, x -> x > 2) then Error("big units"); fi;
            vec := e*vec;
        fi;
    od;

    return vec;
end );

#############################################################################
##
## Create matrix from structure constants
##
BindGlobal( "SetUpSchurMultSystem", function(L)
    local R, d, p, l, n, a, b, i, j, h, k, v, w, u, s, Pos;

    # catch arguments
    R := RingInvariants(L);
    d := DimensionOfLiePRing(L);
    p := PrimeOfLiePRing(L);
    l := BasisOfLiePRing(L);
    n := d * (d+1)/2;
    b := rec( ppps := [], vecs := [] );

    # a special case
    if d = 1 then return rec( norm := [], unit := []); fi;

    Pos := {i,j} -> i*(i-1)/2 + j;

    # precompute structure constants
    a := NullMat(d,d);
    for i in [1..d] do
        for j in [1..d] do
            if i = j then 
                a[i][i] := ExponentsLPR(L, p*l[i]);
            else
                a[i][j] := ExponentsLPR(L, l[i]*l[j]);
            fi;
        od;
    od;

    # evaluate p-th powers: p [li,lj] = [p li, lj] = [li, p lj]
    for i in [1..d] do
        for j in [1..i-1] do

            # p [li,lj]
            v := 0*[1..n];
            if i <> j then 
                v[Pos(i,j)] := p;
                for k in [1..d] do 
                    if a[i][j][k] <> 0 then 
                        v[Pos(k,k)] := a[i][j][k]; 
                    fi;
                od;
            fi;

            # [p li, lj]
            w := 0*[1..n];
            for k in [1..d] do 
                if a[i][i][k] <> 0 then 
                    w[Pos(k,j)] := a[i][i][k]; 
                fi;
            od;
            if w<>v then Add(b.ppps, MakeIntPoly(R,v-w)); fi;

            # [li, p lj]
            u := 0*[1..n];
            for k in [1..d] do 
                if a[j][j][k] <> 0 and k < i then 
                    u[Pos(i,k)] := a[j][j][k]; 
                elif a[j][j][k] <> 0 and i < k then 
                    u[Pos(k,i)] := -a[j][j][k]; 
                fi;
            od;
            if w<>u then Add(b.vecs, MakeIntPoly(R,w-u)); fi;
        od;

        # [p li,li] = p [li,li] = 0
        w := 0*[1..n];
        for k in [1..d] do
            if a[i][i][k] <> 0 then 
                w[Pos(k,i)] := a[i][i][k]; 
            fi;
        od;
        if w<>0*w then Add(b.vecs, MakeIntPoly(R,w)); fi;
    od;

    # evaluate jacobi
    for i in [1..d] do
        for j in [1..d] do
            for k in [1..d] do
                v := 0*[1..n];
                w := 0*[1..n];
                u := 0*[1..n];
                for h in [1..d] do
                    if j<>k and a[j][k][h] <> 0 and h < i then 
                        v[Pos(i,h)] := a[j][k][h];     
                    elif j<>k and a[j][k][h] <> 0 and i < h then 
                        v[Pos(h,i)] := -a[j][k][h];     
                    fi;
                od;
                for h in [1..d] do
                    if i<>j and a[i][j][h] <> 0 and h < k then 
                        u[Pos(k,h)] := a[i][j][h];     
                    elif i<>j and a[i][j][h] <> 0 and k < h then 
                        u[Pos(h,k)] := -a[i][j][h];     
                    fi;
                od;
                for h in [1..d] do
                    if k<>i and a[k][i][h] <> 0 and h < j then 
                        w[Pos(j,h)] := a[k][i][h];     
                    elif k<>i and a[k][i][h] <> 0 and j < h then 
                        w[Pos(h,j)] := -a[k][i][h];     
                    fi;
                od;
                w := v+w+u;
                if w<>0*w then Add(b.vecs, MakeIntPoly(R,w)); fi;
            od;
        od;
    od;

    # add and return
    return Concatenation(b.vecs, b.ppps);
end );
    
#############################################################################
##
## Main function
##
BindGlobal( "LiePSchurMult", function(L)
    local S, b, c, R, T, i, V, W, h, w, pp;

    # set up
    S := [];
    b := SetUpSchurMultSystem(L);
    R := RingInvariants(L);
    w := IndeterminateByName("w");
    pp := ParametersOfLiePRing(L);

    # loop
    T := [[R.units, R.zeros]];
    i := 1;
    while i <= Length(T) do
#Print("start ",T[i],"\n");
        c := StructuralCopy(b);
        R := rec(units := T[i][1], zeros := T[i][2]);
        h := GenericSNF(R, c);
        if IsRecord(h) then 
            h.units := R.units;
            h.zeros := R.zeros;
            Add(S, h);
        else
            h := SQParts(pp, LeadingUnit(NumeratorOfRationalFunction(h)));
            V := CreateUnits( pp, T[i], h );
            W := CreateZeros( pp, T[i], h);
            if W <> fail and not W in T then Add(T, W); fi;
            if V <> fail and not V in T then Add(T, V); fi;
        fi;
        i := i+1;
    od;
          
    # that's it
    return S;
end );

Messung
CHZG
94989996

¤ Dauer der Verarbeitung: 0.4 Sekunden  ¤

*© Formatika GbR, Deutschland






Wurzel

Suchen

PVS Prover

Isabelle Prover


Cephes Mathematical Library

Vienna Development Method

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung und die Messung sind noch experimentell.






                                                                                                                                                                                                                                                                                                                                                                                                     


Neuigkeiten

     Aktuelles
     Motto des Tages

Open Source Software

     Quellcodebibliothek
     Eigene Quellcodes
     Fremde Quellcodes
     Suchen

Jenseits des Üblichen ....
    

Besucherstatistik

Besucherstatistik

Statistik
#Sources=1104857
#Domains=439162