/// unit obsahujuci rozne tabulky pouzivane v programe (hlavne tabulku pravidiel)
unit tables;

interface

uses
  constants, hashmap;

type
  /// trieda implementujuca znakovu mnozinu a operacie v nej
  TCharSet = class
    name: xString;
    s: array[0..CHAR_HIGH] of byte;
  private
  public
    constructor create(CharSetName: xString);
    procedure addCharSet(CharSet: TCharSet);
    procedure subCharSet(CharSet: TCharSet);
    procedure invert;
    procedure clear;
    procedure add(ch: char);
    procedure sub(ch: char);
    procedure addString(x: xString);
    procedure subString(x: xString);
    function hasChar(ch: char): boolean;
    function toString(bFull: Boolean = false): xString;
  end;

  /// trieda implementujuca tabulku znakovych mnozin a operacie v nej
  TSetTable = class
    count: Integer;
    allocated: Integer;
    a: array of TCharSet;
  public
    constructor create;
    destructor Destroy; override;
    function add(CharSet: TCharSet): Integer;
    function getByIndex(x: Integer): TCharSet;
    function findIndexByName(s: xString): Integer;
    function getByName(s: xString): TCharSet;
    function toString: xString;
  end;

  //record popisujuci jeden zaznam v tabulke vlastnosti (premennych)
  TProperty = record
    name: xString;
    value: xString;
  end;

  /// trieda implementujuca tabulku vlastnosti (premennych) definovanych v subore s gramatikou
  TPropertyTable = class
    count: Integer;
    allocated: Integer;
    a: array of TProperty;
  public
    constructor create;
    destructor Destroy; override;
    procedure add(name: xString; value: xString); overload;
    procedure add(x: TProperty); overload;
    function getByIndex(x: Integer): TProperty;
    function findIndexByName(s: xString): Integer;
    function getByName(s: xString): TProperty;
    function toString: xString;
  end;

  /// record popisujuci pravidlo
  TRule = record
    symbols: array of Integer;  //[0] - left side, [1..Pred(length)] - right side
    length: Integer;
    pos: Integer;  //position in the grammar file
  end;

  /// trieda implementujuca tabulku pravidiel
  TRuleTable = class
    rules: array of TRule;
    count: Integer;
    allocated: Integer;
    headrules: TIntIntHashSet;
    FWSTerminal: Integer;
    FEOLNWSTerminal: Integer;
//    FEOLN0WSTerminal: Integer;
    FCaseSensitivity: Boolean;
    FC1,FC2,FC3,FC4,FC5,FC6: Integer;
    FCommentLine,FComment1,FComment2: Integer;
    FParseComments: Boolean;
    FLineEndChar: char;
  private
  public
    FEquivalenceSets: TIntIntHashSet;
    FSimilaritySets: TIntIntHashSet;
    FEquivalentIndices: TIntIntHashSet;
    FSimilarIndices: TIntIntHashSet;
    FDefEqScore,FDefEqScore2,FDefSimScore: Integer;
    constructor create;
    destructor Destroy; override;
    function addRule(rule: TRule): Integer; //returns index of inserted item
    function replaceRuleAtIndex(index: Integer; newrule: TRule): Boolean;
    function removeRule(index: Integer): Integer;  //returns number of rules left
    function getRuleByIndex(index: Integer): TRule;
    function getRulesByHead(head: Integer): TIntHashSet;  //direct pointer - not clone
    function getSize: Integer;
    function toString(bComplex: Boolean = false; tnametable: TStrIntHashMap = nil; snametable: TStrIntHashMap = nil; startpos: Integer = -1; endpos: Integer = -1): xString;
    procedure setWSTerminal(id: Integer);
    function getWSTerminal: Integer;
    procedure setLEC(c: char);
    function getLEC: char;
    procedure setCommentTerminals(c1,c2,c3,c4,c5,c6: Integer);
    procedure getCommentTerminals(var c1,c2,c3,c4,c5,c6: Integer);
    function getEOLNWSTerminal: Integer;
    procedure setEOLNWSTerminal(id: Integer);
    function getCaseSensitivity: Boolean;
    procedure setCaseSensitivity(bCaseSensitive: Boolean);
//    function getEOLN0WSTerminal: Integer;
//    procedure setEOLN0WSTerminal(id: Integer);
    procedure setComments(cl,c1,c2: Integer);
    procedure getComments(var cl,c1,c2: Integer);
    procedure setParseComments(b: Boolean);
    procedure getParseComments(var b: Boolean);
//    function toString(bComplex: Boolean = false): xString;
//    procedure removeRule(rule: TRule);
  end;

implementation

uses
  SysUtils;

{ TCharSet }

/// konstruktor vytvarajuci objekt type TCharSet (znakovu mnozinu)
constructor TCharSet.create(CharSetName: xString);
begin
  inherited create;
  clear;
  name := CharSetName;
end;

/// procedura na zlucenie znakovej mnoziny so vstupnou znakovou mnozinou
procedure TCharSet.addCharSet(CharSet: TCharSet);
var i: integer;
begin
  if (CharSet <> nil) then begin
    for i := 0 to Pred(Length(s)) do
      s[i] := s[i] or CharSet.s[i];
  end;
end;

/// procedura na prienik znakovej mnoziny so vstupnou znakovou mnozinou
procedure TCharSet.subCharSet(CharSet: TCharSet);
var i: integer;
begin
  if (CharSet <> nil) then begin
    for i := 0 to Pred(Length(s)) do
      if (CharSet.s[i] = 1) then
        s[i] := 0;
  end;
end;

/// procedura na vypraznenie znakovej mnoziny
procedure TCharSet.clear;
var i: integer;
begin
  for i := 0 to Pred(Length(s)) do
    s[i] := 0;
end;

/// procedura na komplement znakovej mnoziny (vzhladom na vsetky mozne znaky v danom kodovani)
procedure TCharSet.invert;
var i: integer;
begin
  for i := 0 to Pred(Length(s)) do
    if (s[i] = 1) then
      s[i] := 0
    else
      s[i] := 1;
end;

/// procedura na pridanie znaku ch do mnoziny
procedure TCharSet.add(ch: char);
begin
  s[Ord(ch)] := 1;
end;

/// procedura na vynatie znaku ch z mnoziny
procedure TCharSet.sub(ch: char);
begin
  s[Ord(ch)] := 0;
end;

/// procedura na pridanie vsetkych znakov v stringu x do mnoziny
procedure TCharSet.addString(x: xString);
var i: integer;
begin
  for i := 1 to Length(x) do
    s[Ord(x[i])] := 1;
end;

/// procedura na vynatie vsetkych znakov v stringu x z mnoziny
procedure TCharSet.subString(x: xString);
var i: integer;
begin
  for i := 1 to Length(x) do
    s[Ord(x[i])] := 0;
end;

/// funkcia na zistenie, ci dana znakova mnozina obsahuje znak ch
function TCharSet.hasChar(ch: char): boolean;
begin
  result := (s[Ord(ch)] = 1);
end;

/// funckia vypisujuca znakovu mnozinu do stringu
function TCharSet.toString(bFull: Boolean = false): xString;
var i: integer;
begin
  result := '';
  for i := 0 to Pred(Length(s)) do
    if (s[i] = 1) then begin
      result := result + Char(i);
      if (not bFull) then begin
        if Length(result) > 255*CHAR_SIZE then begin
          result := result + '...';
          exit;
        end;
      end;
    end;
end;

{ TSetTable }

/// konstruktor na vytvorenie tabulky znakovych mnozin
constructor TSetTable.create;
begin
  inherited create;
  SetLength(a,8);
  count := 0;
  allocated := 8;
end;

/// konstruktor uvolnujuci tabulku znakovych mnozin z pamate
destructor TSetTable.Destroy;
var i: Integer;
begin
  for i := 0 to Pred(count) do begin
    a[i].Free;
  end;
//  Finalize(a);
  a := nil;
  inherited Destroy;
end;

/// funkcia na pridanie znakovej mnoziny CharSet do tabulky, vrati index tejto mnoziny,
/// ak sa tam uz mnozina s rovnakym nazvom nachadzala, tak vrati index tejto mnoziny
function TSetTable.add(CharSet: TCharSet): Integer;
var i: Integer;
begin
  if (CharSet <> nil) then begin
    i := findIndexByName(CharSet.name);
    if i = -1 then begin
      a[count] := CharSet;
      result := count;
      count := count + 1;
      if (count = allocated) then begin
        allocated := allocated * 2;
        SetLength(a,allocated);
      end;
    end
    else begin
      a[i].Free;
      a[i] := CharSet;
      result := i;
    end;
  end
  else
    result := -1;
end;

/// funkcia vrati znakovu mnozinu s indexom x v tabulke
function TSetTable.getByIndex(x: Integer): TCharSet;
begin
  if (x >= 0) and (x < allocated) then begin
    result := a[x];
  end
  else
    result := nil;
end;

/// funkcia vrati index v tabulka, podla mena znakovej mnoziny
function TSetTable.findIndexByName(s: xString): Integer;
var i: Integer;
begin
  result := -1;
  for i := 0 to Pred(count) do begin
    if (a[i].name = s) then begin
      result := i;
      exit;
    end;
  end;
end;

/// funkcia vrati znakovu mnozinu podla vstupneho mena
function TSetTable.getByName(s: xString): TCharSet;
begin
  result := getByIndex(findIndexByName(s));
end;

/// funkcia na vypis tabulky znakovych mnozin do stringu
function TSetTable.toString: xString;
var i: Integer;
begin
  result := '';
  for i := 0 to Pred(count) do begin
    result := result + IntToStr(i) + '. ' + '[' + a[i].name + '] ' + a[i].toString + EOL;
  end;
end;

{ TPropertyTable }

/// konstruktor tabulky vlastnosti (premennych)
constructor TPropertyTable.create;
begin
  inherited create;
  SetLength(a,8);
  count := 0;
  allocated := 8;
end;

/// destruktor uvolnujuci tuto tabulku z pamate
destructor TPropertyTable.Destroy;
var i: Integer;
begin
  for i := 0 to Pred(count) do begin
//    a[i].Free;
  end;
  Finalize(a);
  inherited Destroy;
end;

/// procedura pridava dvojice (meno - name,hodnota - value) do tabulky
procedure TPropertyTable.add(name: xString; value: xString);
var i: Integer;
begin
  i := findIndexByName(name);
  if i = -1 then begin
    a[count].name := name;
    a[count].value := value;
    count := count + 1;
    if (count = allocated) then begin
      allocated := allocated * 2;
      SetLength(a,allocated);
    end;
  end
  else begin
    a[i].value := value;
  end;
end;

/// procedura pridava record obsahujuci dvojicu meno,hodnota do tabulky
procedure TPropertyTable.add(x: TProperty);
begin
  add(x.name,x.value);
end;

/// funkcia vracajuca record obsahujuci dvojicu meno,hodnota podla vstupneho indexu v tabulke
function TPropertyTable.getByIndex(x: Integer): TProperty;
begin
  if (x >= 0) and (x < allocated) then begin
    result := a[x];
  end
  else begin
    result.name := '';
    result.value := '';
  end;
end;

/// funkcia vracajuca index v tabulke, podla vstupneho mena vlastnosti
function TPropertyTable.findIndexByName(s: xString): Integer;
var i: Integer;
begin
  result := -1;
  for i := 0 to Pred(count) do begin
    if (a[i].name = s) then begin
      result := i;
      exit;
    end;
  end;
end;

/// funkcia vracajuca record obsahujuci dvojicu meno,hodnota podla vstupneho mena vlastnosti
function TPropertyTable.getByName(s: xString): TProperty;
begin
  result := getByIndex(findIndexByName(s));
end;

/// funkcia vypisujuca tuto tabulku do stringu
function TPropertyTable.toString: xString;
var i: Integer;
begin
  result := '';
  for i := 0 to Pred(count) do begin
    result := result + IntToStr(i) + '. ' + '[' + a[i].name + '] ' + a[i].value + EOL;
  end;
end;

{ TRuleTable }

/// funkcia odstranujuca pravidlo z tabulky pravidiel
function TRuleTable.removeRule(index: Integer): Integer;
var i: Integer;
    h: Integer;
    head: Integer;
    hashSet: TIntHashSet;
begin
  rules[index].symbols := nil;
  for i := index to Pred(Pred(count)) do begin
    rules[i] := rules[i+1];
  end;
//  rules[Pred(count)].symbols := nil;          //!CAUTION! ma to tu byt alebo ne (skor ne, lebo neni memory leak)?
  count := count - 1;
  result := count;

  head := rules[index].symbols[0];
  if headrules.get(head,h) then begin
    hashSet := TIntHashSet(h);
    hashSet.remove(index);
  end
  else begin
    //!TODO! jak to ze neexistuje - bug
  end;
end;

/// konstruktor vytvarajuci tabulku pravidiel
constructor TRuleTable.create;
begin
  inherited create;
  allocated := 16;
  count := 0;
  SetLength(rules,allocated);
  headrules := TIntIntHashSet.create;
  FWSTerminal := -1;
  FC1 := -1;
  FC2 := -1;
  FC3 := -1;
  FC4 := -1;
  FC5 := -1;
  FC6 := -1;
  FLineEndChar := LINE_END_CHAR;
  FEquivalenceSets := nil;
  FSimilaritySets := nil;
  FEquivalentIndices := nil;
  FSimilarIndices := nil;
  FDefEqScore := DEFAULT_EQ_SCORE;
  FDefSimScore := DEFAULT_SIM_SCORE;
//  for i := 0 to Pred(allocated) do begin
//    rules[i].symbols
//  end;
end;

/// funkcia vracajuca pravidlo podla indexu v tabulke
function TRuleTable.getRuleByIndex(index: Integer): TRule;
begin
  if (index >= 0) and (index < count) then begin
    result := rules[index];
  end
  else begin
    result.length := -1;
    result.pos := -1;
    result.symbols := nil;
  end;
end;

/// funkcia pridavajuca pravidlo do tabulky
function TRuleTable.addRule(rule: TRule): Integer;
var h,index,i: Integer;
    head: Integer;
    hashSet: TIntHashSet;
    b: Boolean;
begin
  head := rule.symbols[0];
  if headrules.get(head,h) then begin
    hashSet := TIntHashSet(h);

    b := true;
    hashSet.getNextReset;
    while hashSet.getNext(index) do begin
      if rules[index].length = rule.length then begin
        b := false;
        for i := 1 to rules[index].length do begin
          if rules[index].symbols[i] <> rule.symbols[i] then begin
            b := true;
          end;
          if b then
            Break;
        end;
      end;
    end;
    if not b then begin
      //rule already defined at rule[index].pos in .grm file
      result := index;
      Exit;
    end;

    hashSet.add(count);
  end
  else begin
    hashSet := TIntHashSet.create;
    hashSet.add(count);
    headrules.add(head,Integer(hashSet));
  end;

  rules[count] := rule;

  count := count + 1;
  if count = allocated then begin
    allocated := allocated shl 1;
    SetLength(rules,allocated);
  end;
  result := count;
end;

/// funkcia nahradzujuca pravidlo index v tabulke za nove pravidlo newrule,
/// vracia true, ak operacia prebehla uspesne
function TRuleTable.replaceRuleAtIndex(index: Integer; newrule: TRule): Boolean;
var h: Integer;
    head: Integer;
    hashSet: TIntHashSet;
begin
  result := false;
  if (index < 0) or (index > Pred(count)) then
    Exit;

  head := rules[index].symbols[0];
  if headrules.get(head,h) then begin
    hashSet := TIntHashSet(h);
    hashSet.remove(index);
  end
  else begin
    //!TODO! jak to ze neexistuje - bug
  end;

  rules[index].symbols := nil;
  rules[index] := newrule;

  head := newrule.symbols[0];
  if headrules.get(head,h) then begin
    hashSet := TIntHashSet(h);
    hashSet.add(index);
  end
  else begin
    hashSet := TIntHashSet.create;
    hashSet.add(index);
    headrules.add(head,Integer(hashSet));
  end;

  result := true;
end;

/// funkcia vracajuca pocet pravidiel v tabulke
function TRuleTable.getSize: Integer;
begin
  result := count;
end;

/// destruktor uvolnujuci tabulku pravidiel z pamate
destructor TRuleTable.Destroy;
var i: Integer;
    hashSet: TIntHashSet;
    h: Integer;
    iihashset: TIntIntHashSet;
    key: integer;
begin
  for i := 0 to count - 1 do begin
    rules[i].symbols := nil;
  end;
  rules := nil;

  headrules.getNextReset;
  while headrules.getNext(i,h) do begin
    hashSet := TIntHashSet(h);
    hashSet.Free;
  end;
  headrules.Free;

  if FEquivalenceSets <> nil then begin
    FEquivalenceSets.getNextReset;
    while FEquivalenceSets.getNext(key,Integer(iihashset)) do begin
      iihashset.Free;
    end;
    FEquivalenceSets.Free;
  end;
  if FEquivalentIndices <> nil then
    FEquivalentIndices.Free;
  if FSimilaritySets <> nil then begin
    FSimilaritySets.getNextReset;
    while FSimilaritySets.getNext(key,Integer(iihashset)) do begin
      iihashset.Free;
    end;
    FSimilaritySets.Free;
  end;
  if FSimilarIndices <> nil then
    FSimilarIndices.Free;

  inherited;
end;

/// funkcia vypisujuca tabulku pravidiel do stringu, ak je bComplex true, tak je vypis detailnejsi,
/// tnametable a snametable (tabulky obsahujuce mena terminalov a neterminalov pre dany typ), sluzi iba na konverziu z celociselny typov tokenov na ich nazvy,
/// v pripade ak su nastavene startpos a endpos, tak sa vypisu iba riadky tabulky od indexu startpos po index endpos
function TRuleTable.toString(bComplex: Boolean = false; tnametable: TStrIntHashMap = nil; snametable: TStrIntHashMap = nil; startpos: Integer = -1; endpos: Integer = -1): xString;
var i,j: Integer;
    d: Integer;
    S: xString;
    b: Boolean;
begin
  result := '';
  if startpos < 0 then
    startpos := 0;
  if endpos < startpos then
    endpos := count - 1;
  for i := startpos to endpos do begin
    if bComplex then begin
      if snametable = nil then begin
        result := result + '<' + IntToStr(rules[i].symbols[0]) + '> ::= '
      end
      else begin
        S := snametable.findByValue(rules[i].symbols[0],b);
        if b then
          result := result + '<' + S + '> ::= '
        else
          result := result + '<' + IntToStr(rules[i].symbols[0]) + '> ::= '
      end;
    end
    else
      result := result + IntToStr(rules[i].symbols[0]) + ' ';
    for j := 1 to rules[i].length - 1 do begin
      d := rules[i].symbols[j];
      if d > MAX_TERMINAL then begin
        if bComplex then begin
          if snametable = nil then begin
            result := result + '<' + IntToStr(d) + '> '
          end
          else begin
            S := snametable.findByValue(d,b);
            if b then
              result := result + '<' + S + '> '
            else
              result := result + '<' + IntToStr(d) + '> '
          end;
        end
        else
          result := result + IntToStr(d) + ' ';
      end
      else begin
        if bComplex then begin
          if tnametable = nil then begin
            result := result + '' + IntToStr(d) + ' '
          end
          else begin
            S := tnametable.findByValue(d,b);
            if b then
              result := result + '' + S + ' '
            else
              result := result + '' + IntToStr(d) + ' '
          end;
        end
        else
          result := result + IntToStr(d) + ' ';
      end;
    end;
    result := result + EOL;
  end;
end;

/// funkcia vrati mnozinu pravidiel, ktore maju na lavej strane neterminal head
function TRuleTable.getRulesByHead(head: Integer): TIntHashSet;
var h: Integer;
//    hashSet: TIntHashSet;
begin
  if headrules.get(head,h) then
    result := TIntHashSet(h)
  else
    result := nil;
end;

/// funkcia vrati momentalne nastaveny whitespace terminal (tento sa ignoruje uz pri lexikalnej analyze)
function TRuleTable.getWSTerminal: Integer;
begin
  result := FWSTerminal;
end;

/// procedura nastavi whitespace terminal (tento sa ignoruje uz pri lexikalnej analyze)
procedure TRuleTable.setWSTerminal(id: Integer);
begin
  FWSTerminal := id;
end;

/// funkcia vrati momentalne nastaveny LEC znak (znak konca riadku, aby sme mohli vstup rozkladat na riadky - standardne nastaveny na #10)
function TRuleTable.getLEC: char;
begin
  result := FLineEndChar;
end;

/// procedura nastavi LEC znak (znak konca riadku, aby sme mohli vstup rozkladat na riadky - standardne nastaveny na #10)
procedure TRuleTable.setLEC(c: char);
begin
  FLineEndChar := c;
end;

/// procedura zistenie momentalne nastavenych komentarovych terminalov
procedure TRuleTable.getCommentTerminals(var c1, c2, c3, c4, c5, c6: Integer);
begin
  c1 := FC1;
  c2 := FC2;
  c3 := FC3;
  c4 := FC4;
  c5 := FC5;
  c6 := FC6;
end;

/// procedura na nastavenie komentarovych terminalov
procedure TRuleTable.setCommentTerminals(c1, c2, c3, c4, c5, c6: Integer);
begin
  FC1 := c1;
  FC2 := c2;
  FC3 := c3;
  FC4 := c4;
  FC5 := c5;
  FC6 := c6;
end;

(*
function TRuleTable.getEOLN0WSTerminal: Integer;
begin
  result := FEOLN0WSTerminal;
end;

procedure TRuleTable.setEOLN0WSTerminal(id: Integer);
begin
  FEOLN0WSTerminal := id;
end;
*)

/// funkcia zistujuca nastavenie znaku konca riadku v subore popisujucom gramatiku
function TRuleTable.getEOLNWSTerminal: Integer;
begin
  result := FEOLNWSTerminal;
end;

/// funkcia nastavujuca znak konca riadku v subore popisujucom gramatiku
procedure TRuleTable.setEOLNWSTerminal(id: Integer);
begin
  FEOLNWSTerminal := id;
end;

/// procedura zistenie momentalne nastavenych komentarovych terminalov (CLINE,COMMENT1,COMMENT2)
procedure TRuleTable.setComments(cl, c1, c2: Integer);
begin
  FCommentLine := cl;
  FComment1 := c1;
  FComment2 := c2;
end;

/// procedura na nastavenie komentarovych terminalov (CLINE,COMMENT1,COMMENT2)
procedure TRuleTable.getComments(var cl, c1, c2: Integer);
begin
  cl := FCommentLine;
  c1 := FComment1;
  c2 := FComment2;
end;

/// procedura nastavujuca parsovanie komentarov
procedure TRuleTable.setParseComments(b: Boolean);
begin
  FParseComments := b;
end;

/// procedura zistujuca nastavenie parsovania komentarov
procedure TRuleTable.getParseComments(var b: Boolean);
begin
  b := FParseComments;
end;

/// procedura na nastavanie citlivosti na velke a male pismena (tak ako bolo definovane v subore s gramatikou)
procedure TRuleTable.setCaseSensitivity(bCaseSensitive: Boolean);
begin
  FCaseSensitivity := bCaseSensitive;
end;

/// procedura vracajuca momentalne nastavanie citlivosti na velke a male pismena (tak ako bolo definovane v subore s gramatikou)
function TRuleTable.getCaseSensitivity: Boolean;
begin
  result := FCaseSensitivity;
end;

end.
