unit rpltablecreator;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, stdctrls;

type
  TRPLTableCreator = class(TComponent)
  protected
    st:tstrings;
    fn:string;
    cv,cr:boolean;
    moy:string;
    procedure sst(s:tstrings);
    procedure wcv(b:boolean);
    procedure wcr(b:boolean);
  public
    constructor create(aowner:tcomponent); override;
    destructor destroy; override;
  published
    property liste:tstrings read st write sst;
    property FileName:TFileName read fn write fn;
    property convert:boolean read cv write wcv;
    property load:boolean read cr write wcr;
    property moyenne:string read moy write moy;
  end;

procedure Register;

implementation

procedure TRPLTableCreator.sst(s:tstrings);
begin
  st.assign(s);
End;















/////////////////////////////////////////////////////////////////////////////////////////////
var inp:tstringList;

function SortAdr(Item1, Item2: Pointer):integer;
var i,j:integer;
begin
  i:=integer(inp.objects[integer(item1)]);
  j:=integer(inp.objects[integer(item2)]);
  if i=j then
    result:=0
  else
    if i<j then
      result:=-1
    else
      result:=1;
end;

function SortStr(Item1, Item2: Pointer):integer;
  function rev(s:string):string;
    function min(i,j:integer):integer;
    begin
      if i<j then
        result:=i
      else
        result:=j;
    end;
  var i:integer;
  begin
    result:='';
    for i:=Min(8,length(s)) downto 1 do
      result:=result+s[i];
  end;
var s1,s2:string;
begin
  s1:=inp[integer(item1)];
  s2:=inp[integer(item2)];
  if length(s1)=length(s2) then
  begin
    s1:=rev(s1);
    s2:=rev(s2);
    if s1=s2 then
      result:=0
    else
      if s1<s2 then
       result:=-1
      else
        result:=1;
  end else
    if Length(s1)<Length(s2) then
      result:=-1
    else
      result:=1;
end;

procedure TRPLTableCreator.wcv(b:boolean);

  function RevIntToHex(i,s:integer):string;
  var j:integer;
      t:char;
  begin
    result:=IntToHex(i,s);
    for j:=1 to s div 2 do
    begin
      t:=Result[s-j+1];
      result[s-j+1]:=result[j];
      result[j]:=t;
    end;
  end;

  function GetText(s:string):string;
  var i:integer;
  begin
    result:='';
    i:=Pos('=',s);
    if i<>0 then
    begin
      inc(i);
      while (i<=Length(s)) and (not (s[i] in [' ',chr(9)])) do
      begin
        result:=result+s[i];
        inc(i);
      end;
    end;
  end;

  Function GetHexValue(c:char):integer;
  begin
    if c in ['0'..'9'] then
      result:=ord(upcase(c))-ord('0')
    else
      result:=ord(upcase(c))-ord('A')+10;
  end;

  function GetAdr(s:string):integer;
  var i:integer;
  begin
    result:=0;
    i:=pos('EQU #',s);
    if i<>0 then
    begin
      i:=i+5;
      while upcase(s[i]) in ['0'..'9','A'..'F'] do
      begin
        result:=result shl 4+GetHexValue(s[i]);
        inc(i);
      end;
    end;
  end;

  function StrToHex(s:string):string;
  var i:integer;
  Begin
    result:='';
    for i:=1 to length(s) do
      result:=result+RevIntToHex(ord(s[i]),2);
  End;

  function GetCrc(s:string):integer;
  var i,a,b:integer;
  begin
    result:=0;
    for i:=1 to length(s) do
    begin
      a:=((result xor (ord(s[i]) and $F)) and $F) * $1081;
      b:=result div 16;
      result:=(a xor b) and $FFFF;

      a:=((result xor ((ord(s[i]) div 16) and $F)) and $F) * $1081;
      b:=result div 16;
      result:=(a xor b) and $FFFF;
    end;
  end;

var ar:array[0..131071] of char;
  Procedure PStr(s:string; pos:integer);
  var i:integer;
  begin
    for i:=1 to length(s) do
      ar[i+pos-1]:=s[i];
  end;

var i,j,k:integer;
    al:array[0..63] of tList;
    l2:tlist;
    padr:tlist;
    s,s2:string;
    f:file;

    Hachage,TextPtr,AdrPtr,Text,NbExt,v,Size:integer;
begin
  if b=false then exit;
  NbExt:=st.Count;
  Hachage:=10+5+1;
  TextPtr:=Hachage+4*64;
  AdrPtr:=TextPtr+NbExt*5+64*5;
  Text:=AdrPtr+NbExt*5;

  for i:=0 to 63 do
    al[i]:=TList.Create;
  inp:=TStringList.Create;
  l2:=tlist.create;
  padr:=tlist.create;

  PStr('EEB20000002',0);
  pstr(RevIntToHex(NbExt,5),11);
  pstr('0',Text);

  k:=1;
  for i:=0 to NbExt-1 do
  begin
    s:=st[i];
    s2:=GetText(s);
    v:=GetAdr(s);
    inp.objects[inp.add(s2)]:=pointer(v);
    padr.add(pointer(k));
    PStr(RevIntToHex(v,5)+RevIntToHex(Length(s2),2)+StrToHex(s2),k+Text);
    k:=k+7+length(s2)*2;
    al[(GetCRC(s2)) and $3F].add(pointer(i));
    l2.Add(pointer(i));
  end;

  l2.sort(sortAdr);
  for i:=0 to 63 do
    al[i].sort(SortStr);

  Size:=k+Text;
  PStr(RevIntToHex(Size-5,5),5);

  k:=TextPtr;
  for i:=0 to 63 do
  Begin
    PStr(RevIntToHex(k-(Hachage+i*4),4),Hachage+i*4);
    for j:=0 to al[i].count-1 do
    begin
      PStr(RevIntToHex(integer(padr[integer(al[i][j])]),5),k);
      k:=k+5;
    end;
    PStr('00000',k);
    k:=k+5;
  end;

  k:=AdrPtr;
  for i:=0 to l2.count-1 do
  begin
    PStr(RevIntToHex(integer(padr[integer(l2[i])]),5),k);
    k:=k+5;
  end;

  for i:=0 to (Size div 2+1)-1 do
    ar[i]:=chr(GetHexValue(ar[i*2])+GetHexValue(ar[i*2+1])*16);

  assignFile(f,fn);
  rewrite(f,1);
  BlockWrite(f,'HPHP48-S',8);
  blockWrite(f,ar,Size div 2 +1);
  closeFile(f);

  moy:='';
  for i:=0 to 63 do
    moy:=moy+' '+inttostr(al[i].Count);

  for i:=0 to 63 do
    al[i].free;
  inp.Free;
  l2.Free;
  padr.Free;
end;




/////////////////////////////////////////////////////////////////////////////////////////////
procedure TRPLTableCreator.wcr(b:boolean);
var ar:array[0..131071] of char;
    function getvalue(adr,size:integer):integer;
    var i,j:integer;
    begin
      result:=0;
      j:=1;
      for i:=adr to adr+size-1 do
      begin
        if ord(ar[i])<=ord('9') then
          result:=result+(ord(ar[i])-ord('0'))*j
        else
          result:=result+(ord(ar[i])-ord('A')+10)*j;
        j:=j*16;
      end;
    end;

var i,j,k:integer;
    s:string;
    f:file;
    NbExt,Hachage,TextPtr,AdrPtr,Text:integer;
begin
  if b=false then
    exit;
  Liste.clear;
  Assignfile(f,fn);
  reset(f,1);
  j:=FileSize(f);
  BlockRead(f,ar,j);
  closeFile(f);

  for i:=j-1 downto 0 do
  begin
    ar[i*2+1]  :=inttohex(ord(ar[i]) div 16,1)[1];
    ar[i*2]:=inttohex(ord(ar[i]) mod 16,1)[1];
  end;

  NbExt:=getvalue(11+16,5);
  Hachage:=10+5+1+16;
  TextPtr:=Hachage+4*64;
  AdrPtr:=TextPtr+NbExt*5+64*5;
  Text:=AdrPtr+NbExt*5;

  for i:=0 to nbExt-1 do
  begin
    j:=Text+GetValue(AdrPtr+i*5,5);
    s:=chr(9)+'EQU #'+IntToHex(getvalue(j,5),5)+' *';
    for k:=getValue(j+5,2) downto 1 do
      s:=chr(getvalue(j+5+k*2,2))+s;
    s:='='+s;
    Liste.add(s);
  end;
end;





/////////////////////////////////////////////////////////////////////////////////////////////
constructor TRPLTableCreator.create(aowner:tcomponent);
Begin
  inherited create(aowner);
  st:=TStringList.Create;
  cv:=FALSE;
  cr:=false;
End;

destructor TRPLTableCreator.destroy;
Begin
  st.free;
  inherited destroy;
End;

procedure Register;
begin
  RegisterComponents('RPL', [TRPLTableCreator]);
end;

end.