Gedichte Musik Bilder Quellcodebibliothek Diashow Normaldarstellung
Quellcodebibliothek Statistik Leitseite products/sources/formale Sprachen/GAP/pkg/semigroups/src/   (Algebra von RWTH Aachen Version 4.15.1©)  Datei vom 29.7.2025 mit Größe 16 kB image not shown  

Quelle  froidure-pin-fallback.cpp   Sprache: C

 
//
// Semigroups package for GAP
// Copyright (C) 2016-2022 James D. Mitchell
//
// This program is free software: you can redistribute it and/or modify
// it under the terms of the GNU General Public License as published by
// the Free Software Foundation, either version 3 of the License, or
// (at your option) any later version.
//
// This program is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
// GNU General Public License for more details.
//
// You should have received a copy of the GNU General Public License
// along with this program.  If not, see <https://www.gnu.org/licenses/>.
//

#include "froidure-pin-fallback.hpp"

#include <string.h>  // for size_t, memcpy

#include <algorithm>  // for max
#include <iostream>   // for operator<<, cout, ostream
#include <string>     // for string

// GAP headers
#include "gap_all.h"  // for RNamName etc

// Semigroups package for GAP headers
#include "pkg.hpp"               // for HTAdd, HTValue, IsSemigroup, SEMIGROUPS
#include "semigroups-debug.hpp"  // for SEMIGROUPS_ASSERT

// libsemigroups headers
#include "libsemigroups/report.hpp"  // for REPORTER, Reporter
#include "libsemigroups/timer.hpp"   // for Timer

using libsemigroups::detail::Timer;

// Macros for the GAP version of the algorithm

#define INT_PLIST(plist, i) INT_INTOBJ(ELM_PLIST(plist, i))
#define INT_PLIST2(plist, i, j) INT_INTOBJ(ELM_PLIST2(plist, i, j))
#define ELM_PLIST2(plist, i, j) ELM_PLIST(ELM_PLIST(plist, i), j)

static Int RNam_batch_size        = 0;
static Int RNam_DefaultOptionsRec = 0;
static Int RNam_opts              = 0;

static inline void initRNams() {
  if (!RNam_batch_size) {
    RNam_batch_size        = RNamName("batch_size");
    RNam_DefaultOptionsRec = RNamName("DefaultOptionsRec");
    RNam_opts              = RNamName("opts");
  }
}

inline void SET_ELM_PLIST2(Obj plist, UInt i, UInt j, Obj val) {
  Obj inner = ELM_PLIST(plist, i);
  SET_ELM_PLIST(inner, j, val);
  SET_LEN_PLIST(inner, j);
  CHANGED_BAG(inner);
}

// Semigroups

static Obj get_default_value(Int rnam) {
  initRNams();
  Obj opts = ElmPRec(SEMIGROUPS, RNam_DefaultOptionsRec);
  return ElmPRec(opts, rnam);
}

static inline size_t get_batch_size(Obj so) {
  initRNams();
  UInt i;
  if (FindPRec(so, RNam_opts, &i, 1)) {
    Obj opts = GET_ELM_PREC(so, i);
    if (FindPRec(opts, RNam_batch_size, &i, 1)) {
      return INT_INTOBJ(GET_ELM_PREC(opts, i));
    }
  }
  return INT_INTOBJ(get_default_value(RNam_batch_size));
}

// GAP kernel version of the algorithm for other types of semigroups.
//
// Assumes the length of data!.elts is at most 2 ^ 28.

Obj RUN_FROIDURE_PIN(Obj self, Obj obj, Obj limit, Obj report) {
  Obj found, elts, gens, genslookup, right, left, first, final, prefix, suffix,
      reduced, words, ht, rules, lenindex, newElt, newword, objval, newrule,
      empty, oldword, x, data, parent, stopper;
  UInt i, nr, len, stopper_int, nrrules, b, s, r, p, j, k, int_limit, nrgens,
      intval, stop, one;

  if (!IS_PREC(obj)) {
    ErrorQuit("expected a plain record as 1st argument, found %s",
              (Int) TNAM_OBJ(obj),
              0L);
  }  // TODO(later) other checks

  initRNams();

  parent = ElmPRec(obj, RNamName("parent"));
  SEMIGROUPS_ASSERT(CALL_1ARGS(IsSemigroup, parent) == True);
  data              = obj;
  size_t batch_size = get_batch_size(parent);

  i  = INT_INTOBJ(ElmPRec(data, RNamName("pos")));
  nr = INT_INTOBJ(ElmPRec(data, RNamName("nr")));

  if (i > nr || static_cast<size_t>(INT_INTOBJ(limit)) <= nr) {
    CHANGED_BAG(parent);
    return data;
  }
  int_limit = std::max(static_cast<UInt>(INT_INTOBJ(limit)), nr + batch_size);
  if (report == True) {
    std::cout << "#I limit = " << int_limit << std::endl;
  }

  Timer timer;

  // get everything out of <data>

  // lists of integers, objects
  elts = ElmPRec(data, RNamName("elts"));
  // the so far enumerated elements
  gens = ElmPRec(data, RNamName("gens"));
  // the generators
  genslookup = ElmPRec(data, RNamName("genslookup"));
  // genslookup[i]=Position(elts, gens[i],
  // this is not always <i+1>!
  lenindex = ElmPRec(data, RNamName("lenindex"));
  // lenindex[len]=position in <words> and
  // <elts> of first element of length <len>
  first = ElmPRec(data, RNamName("first"));
  // elts[i]=gens[first[i]]*elts[suffix[i]],
  // first letter
  final = ElmPRec(data, RNamName("final"));
  // elts[i]=elts[prefix[i]]*gens[final[i]]
  prefix = ElmPRec(data, RNamName("prefix"));
  // see final, 0 if prefix is empty i.e.
  // elts[i] is a gen
  suffix = ElmPRec(data, RNamName("suffix"));
  // see first, 0 if suffix is empty i.e.
  // elts[i] is a gen

  // lists of lists
  right = ElmPRec(data, RNamName("right"));
  // elts[right[i][j]]=elts[i]*gens[j],
  // right Cayley graph
  left = ElmPRec(data, RNamName("left"));
  // elts[left[i][j]]=gens[j]*elts[i], left
  // Cayley graph
  reduced = ElmPRec(data, RNamName("reduced"));
  // words[right[i][j]] is reduced if
  // reduced[i][j]=true
  words = ElmPRec(data, RNamName("words"));
  // words[i] is a word in the gens equal to
  // elts[i]
  rules = ElmPRec(data, RNamName("rules"));
  if (TNUM_OBJ(rules) == T_PLIST_EMPTY) {
    RetypeBag(rules, T_PLIST_CYC);
  }

  // hash table
  ht = ElmPRec(data, RNamName("ht"));

  // current word length
  len = INT_INTOBJ(ElmPRec(data, RNamName("len")));

  // <elts[one]> is the mult. neutral
  // element
  if (IS_INTOBJ(ElmPRec(data, RNamName("one")))) {
    one = INT_INTOBJ(ElmPRec(data, RNamName("one")));
  } else {
    one = 0;
  }

  // stop when we have applied generators to
  // elts[stopper_int]
  stopper = ElmPRec(data, RNamName("stopper"));
  if (!IS_INTOBJ(stopper)) {
    stopper_int = -1;
  } else {
    stopper_int = INT_INTOBJ(stopper);
  }

  nrrules = INT_INTOBJ(ElmPRec(data, RNamName("nrrules")));

  nrgens = LEN_PLIST(gens);
  stop   = 0;
  found  = False;

  while (i <= nr && !stop) {
    while (i <= nr && (UInt) LEN_PLIST(ELM_PLIST(words, i)) == len && !stop) {
      b = INT_INTOBJ(ELM_PLIST(first, i));
      s = INT_INTOBJ(ELM_PLIST(suffix, i));
      RetypeBag(ELM_PLIST(right, i),
                T_PLIST_CYC);  // from T_PLIST_EMPTY
      for (j = 1; j <= nrgens; j++) {
        if (s != 0 && ELM_PLIST2(reduced, s, j) == False) {
          r = INT_PLIST2(right, s, j);
          if (INT_PLIST(prefix, r) != 0) {
            intval = INT_PLIST2(left, INT_PLIST(prefix, r), b);
            SET_ELM_PLIST2(
                right, i, j, ELM_PLIST2(right, intval, INT_PLIST(final, r)));
            SET_ELM_PLIST2(reduced, i, j, False);
          } else if (r == one) {
            SET_ELM_PLIST2(right, i, j, ELM_PLIST(genslookup, b));
            SET_ELM_PLIST2(reduced, i, j, False);
          } else {
            SET_ELM_PLIST2(right,
                           i,
                           j,
                           ELM_PLIST2(right,
                                      INT_PLIST(genslookup, b),
                                      INT_PLIST(final, r)));
            SET_ELM_PLIST2(reduced, i, j, False);
          }
        } else {
          newElt  = PROD(ELM_PLIST(elts, i), ELM_PLIST(gens, j));
          oldword = ELM_PLIST(words, i);
          len     = LEN_PLIST(oldword);
          newword = NEW_PLIST(T_PLIST_CYC, len + 1);

          memcpy(ADDR_OBJ(newword) + 1,
                 CONST_ADDR_OBJ(oldword) + 1,
                 static_cast<size_t>(len * sizeof(Obj)));
          SET_ELM_PLIST(newword, len + 1, INTOBJ_INT(j));
          SET_LEN_PLIST(newword, len + 1);

          objval = CALL_2ARGS(HTValue, ht, newElt);
          if (objval != Fail) {
            newrule = NEW_PLIST(T_PLIST, 2);
            SET_ELM_PLIST(newrule, 1, newword);
            SET_ELM_PLIST(newrule, 2, ELM_PLIST(words, INT_INTOBJ(objval)));
            SET_LEN_PLIST(newrule, 2);
            CHANGED_BAG(newrule);
            nrrules++;
            AssPlist(rules, nrrules, newrule);
            SET_ELM_PLIST2(right, i, j, objval);
          } else {
            nr++;

            CALL_3ARGS(HTAdd, ht, newElt, INTOBJ_INT(nr));

            if (one == 0) {
              one = nr;
              for (k = 1; k <= nrgens; k++) {
                x = ELM_PLIST(gens, k);
                if (!EQ(PROD(newElt, x), x)) {
                  one = 0;
                  break;
                }
                if (!EQ(PROD(x, newElt), x)) {
                  one = 0;
                  break;
                }
              }
            }

            if (s != 0) {
              AssPlist(suffix, nr, ELM_PLIST2(right, s, j));
            } else {
              AssPlist(suffix, nr, ELM_PLIST(genslookup, j));
            }

            AssPlist(elts, nr, newElt);
            AssPlist(words, nr, newword);
            AssPlist(first, nr, INTOBJ_INT(b));
            AssPlist(final, nr, INTOBJ_INT(j));
            AssPlist(prefix, nr, INTOBJ_INT(i));

            empty = NEW_PLIST(T_PLIST_EMPTY, nrgens);
            SET_LEN_PLIST(empty, 0);
            AssPlist(right, nr, empty);

            empty = NEW_PLIST(T_PLIST_EMPTY, nrgens);
            SET_LEN_PLIST(empty, 0);
            AssPlist(left, nr, empty);

            empty = NEW_PLIST(T_PLIST_CYC, nrgens);
            for (k = 1; k <= nrgens; k++) {
              SET_ELM_PLIST(empty, k, False);
            }
            SET_LEN_PLIST(empty, nrgens);
            AssPlist(reduced, nr, empty);

            SET_ELM_PLIST2(reduced, i, j, True);
            SET_ELM_PLIST2(right, i, j, INTOBJ_INT(nr));
            stop = (nr >= int_limit);
          }
        }
      }  // finished applying gens to
         // <elts[i]>
      stop = (stop || i == stopper_int);
      i++;
    }  // finished words of length <len> or
       // <stop>
    if (i > nr || (UInt) LEN_PLIST(ELM_PLIST(words, i)) != len) {
      if (len > 1) {
        for (j = INT_INTOBJ(ELM_PLIST(lenindex, len)); j <= i - 1; j++) {
          RetypeBag(ELM_PLIST(left, j),
                    T_PLIST_CYC);  // from
                                   // T_PLIST_EMPTY
          p = INT_INTOBJ(ELM_PLIST(prefix, j));
          b = INT_INTOBJ(ELM_PLIST(final, j));
          for (k = 1; k <= nrgens; k++) {
            SET_ELM_PLIST2(
                left, j, k, ELM_PLIST2(right, INT_PLIST2(left, p, k), b));
          }
        }
      } else if (len == 1) {
        for (j = INT_INTOBJ(ELM_PLIST(lenindex, len)); j <= i - 1; j++) {
          RetypeBag(ELM_PLIST(left, j),
                    T_PLIST_CYC);  // from
                                   // T_PLIST_EMPTY
          b = INT_INTOBJ(ELM_PLIST(final, j));
          for (k = 1; k <= nrgens; k++) {
            SET_ELM_PLIST2(
                left, j, k, ELM_PLIST2(right, INT_PLIST(genslookup, k), b));
          }
        }
      }
      len++;
      AssPlist(lenindex, len, INTOBJ_INT(i));
    }
    if (report == True) {
      std::cout << "#I found " << nr << " elements, " << nrrules
                << " rules, max word length " << len - 1 << ", ";
      if (i <= nr) {
        std::cout << "so far";
      } else {
        std::cout << "finished!";
      }
      std::cout << std::endl;
    }
  }

  if (report == True) {
    std::cout << "#I elapsed time: " << timer << std::endl;
  }
  AssPRec(data, RNamName("nr"), INTOBJ_INT(nr));
  AssPRec(data, RNamName("nrrules"), INTOBJ_INT(nrrules));
  AssPRec(data, RNamName("one"), ((one != 0) ? INTOBJ_INT(one) : False));
  AssPRec(data, RNamName("pos"), INTOBJ_INT(i));
  AssPRec(data, RNamName("len"), INTOBJ_INT(len));

  CHANGED_BAG(parent);

  return data;
}

// Using the output of DigraphStronglyConnectedComponents on the right and left
// Cayley graphs of a semigroup, the following function calculates the strongly
// connected components of the union of these two graphs.

Obj SCC_UNION_LEFT_RIGHT_CAYLEY_GRAPHS(Obj self, Obj scc1, Obj scc2) {
  UInt* ptr;
  Int   i, n, len, nr, j, k, l;
  Obj   comps1, id2, comps2, id, comps, seen, comp1, comp2, new_comp, x, out;

  n = LEN_PLIST(ElmPRec(scc1, RNamName("id")));

  if (n == 0) {
    out = NEW_PREC(2);
    AssPRec(out, RNamName("id"), NEW_PLIST_IMM(T_PLIST_EMPTY, 0));
    AssPRec(out, RNamName("comps"), NEW_PLIST_IMM(T_PLIST_EMPTY, 0));
    return out;
  }

  comps1 = ElmPRec(scc1, RNamName("comps"));
  comps2 = ElmPRec(scc2, RNamName("comps"));
  id2    = ElmPRec(scc2, RNamName("id"));

  id = NEW_PLIST_IMM(T_PLIST_CYC, n);
  SET_LEN_PLIST(id, n);
  // init id
  for (i = 1; i <= n; i++) {
    SET_ELM_PLIST(id, i, INTOBJ_INT(0));
  }

  seen = NewBag(T_DATOBJ, (LEN_PLIST(comps2) + 1) * sizeof(UInt));
  ptr  = reinterpret_cast<UInt*>(ADDR_OBJ(seen));
  for (i = 0; i < LEN_PLIST(comps2) + 1; i++) {
    ptr[i] = 0;
  }

  comps = NEW_PLIST_IMM(T_PLIST_TAB, LEN_PLIST(comps1));
  SET_LEN_PLIST(comps, 0);

  nr = 0;

  for (i = 1; i <= LEN_PLIST(comps1); i++) {
    comp1 = ELM_PLIST(comps1, i);
    if (INT_INTOBJ(ELM_PLIST(id, INT_INTOBJ(ELM_PLIST(comp1, 1)))) == 0) {
      nr++;
      new_comp = NEW_PLIST_IMM(T_PLIST_CYC, LEN_PLIST(comp1));
      SET_LEN_PLIST(new_comp, 0);
      for (j = 1; j <= LEN_PLIST(comp1); j++) {
        k = INT_INTOBJ(ELM_PLIST(id2, INT_INTOBJ(ELM_PLIST(comp1, j))));
        if (reinterpret_cast<UInt*>(ADDR_OBJ(seen))[k] == 0) {
          reinterpret_cast<UInt*>(ADDR_OBJ(seen))[k] = 1;
          comp2                                      = ELM_PLIST(comps2, k);
          for (l = 1; l <= LEN_PLIST(comp2); l++) {
            x = ELM_PLIST(comp2, l);
            SET_ELM_PLIST(id, INT_INTOBJ(x), INTOBJ_INT(nr));
            len = LEN_PLIST(new_comp);
            AssPlist(new_comp, len + 1, x);
            SET_LEN_PLIST(new_comp, len + 1);
          }
        }
      }
      SHRINK_PLIST(new_comp, LEN_PLIST(new_comp));
      len = LEN_PLIST(comps) + 1;
      SET_ELM_PLIST(comps, len, new_comp);
      SET_LEN_PLIST(comps, len);
      CHANGED_BAG(comps);
    }
  }

  out = NEW_PREC(2);
  SHRINK_PLIST(comps, LEN_PLIST(comps));
  AssPRec(out, RNamName("id"), id);
  AssPRec(out, RNamName("comps"), comps);
  return out;
}

// <right> and <left> should be scc data structures for the right and left
// Cayley graphs of a semigroup, as produced by
// DigraphStronglyConnectedComponents. This function find the H-classes of the
// semigroup from <right> and <left>. The method used is that described in:
// https://www.irif.fr/~jep//PDF/Exposes/StAndrews.pdf

Obj FIND_HCLASSES(Obj self, Obj right, Obj left) {
  UInt *nextpos, *sorted, *lookup, init;
  Int   n, nrcomps, i, hindex, rindex, j, k, len;
  Obj   rightid, leftid, comps, buf, id, out, comp;

  rightid = ElmPRec(right, RNamName("id"));
  leftid  = ElmPRec(left, RNamName("id"));
  n       = LEN_PLIST(rightid);

  if (n == 0) {
    out = NEW_PREC(2);
    AssPRec(out, RNamName("id"), NEW_PLIST_IMM(T_PLIST_EMPTY, 0));
    AssPRec(out, RNamName("comps"), NEW_PLIST_IMM(T_PLIST_EMPTY, 0));
    return out;
  }
  comps   = ElmPRec(right, RNamName("comps"));
  nrcomps = LEN_PLIST(comps);

  buf     = NewBag(T_DATOBJ, (2 * n + nrcomps + 1) * sizeof(UInt));
  nextpos = reinterpret_cast<UInt*>(ADDR_OBJ(buf));

  nextpos[1] = 1;
  for (i = 2; i <= nrcomps; i++) {
    nextpos[i] = nextpos[i - 1] + LEN_PLIST(ELM_PLIST(comps, i - 1));
  }

  sorted = reinterpret_cast<UInt*>(ADDR_OBJ(buf)) + nrcomps;
  lookup = reinterpret_cast<UInt*>(ADDR_OBJ(buf)) + nrcomps + n;
  for (i = 1; i <= n; i++) {
    j                  = INT_INTOBJ(ELM_PLIST(rightid, i));
    sorted[nextpos[j]] = i;
    nextpos[j]++;
    lookup[i] = 0;
  }

  id = NEW_PLIST_IMM(T_PLIST_CYC, n);
  SET_LEN_PLIST(id, n);
  comps = NEW_PLIST_IMM(T_PLIST_TAB, n);
  SET_LEN_PLIST(comps, 0);

  hindex = 0;
  rindex = 0;
  init   = 0;

  for (i = 1; i <= n; i++) {
    sorted = reinterpret_cast<UInt*>(ADDR_OBJ(buf)) + nrcomps;
    lookup = reinterpret_cast<UInt*>(ADDR_OBJ(buf)) + nrcomps + n;
    j      = sorted[i];
    k      = INT_INTOBJ(ELM_PLIST(rightid, j));
    if (k > rindex) {
      rindex = k;
      init   = hindex;
    }
    k = INT_INTOBJ(ELM_PLIST(leftid, j));
    if (lookup[k] <= init) {
      hindex++;
      lookup[k] = hindex;

      comp = NEW_PLIST_IMM(T_PLIST_CYC, 1);
      SET_LEN_PLIST(comp, 0);
      SET_ELM_PLIST(comps, hindex, comp);
      SET_LEN_PLIST(comps, hindex);
      CHANGED_BAG(comps);

      sorted = reinterpret_cast<UInt*>(ADDR_OBJ(buf)) + nrcomps;
      lookup = reinterpret_cast<UInt*>(ADDR_OBJ(buf)) + nrcomps + n;
    }
    k    = lookup[k];
    comp = ELM_PLIST(comps, k);
    len  = LEN_PLIST(comp) + 1;
    AssPlist(comp, len, INTOBJ_INT(j));
    SET_LEN_PLIST(comp, len);

    SET_ELM_PLIST(id, j, INTOBJ_INT(k));
  }

  SHRINK_PLIST(comps, LEN_PLIST(comps));
  for (i = 1; i <= LEN_PLIST(comps); i++) {
    comp = ELM_PLIST(comps, i);
    SHRINK_PLIST(comp, LEN_PLIST(comp));
  }

  out = NEW_PREC(2);
  AssPRec(out, RNamName("id"), id);
  AssPRec(out, RNamName("comps"), comps);

  return out;
}

90%


¤ Dauer der Verarbeitung: 0.2 Sekunden  (vorverarbeitet)  ¤

*© Formatika GbR, Deutschland




Wurzel

Suchen

Beweissystem der NASA

Beweissystem Isabelle

NIST Cobol Testsuite

Cephes Mathematical Library

Wiener Entwicklungsmethode

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 ist noch experimentell.