unit CRC;

interface

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



type
  TCRCModel = record
    name:string;
    width:integer;
    poly:cardinal;
    init:cardinal;
    refin:boolean;
    refot:boolean;
    xorot:cardinal;
    reg:cardinal;
  end;

Const
  StandartCRCModels:array[0..6] of TCRCModel =
    ((name:'CRC-16 standart';Width:16;poly:$8005;init:$0000;refin:false;refot:false;xorot:$0000;reg:0),
     (name:'LHA';Width:16;poly:$4003;init:$FFFF;refin:false;refot:false;xorot:$0000;reg:0),
     (name:'CRC-16/CITT';Width:16;poly:$1021;init:$FFFF;refin:false;refot:false;xorot:$0000;reg:0),
     (name:'XMODEM';Width:16;poly:$8408;init:$0000;refin:true;refot:true;xorot:$0000;reg:0),
     (name:'ARC';Width:16;poly:$8005;init:$0000;refin:true;refot:true;xorot:$0000;reg:0),
     (name:'CRC-32';Width:32;poly:$04C11DB7;init:$FFFFFFFF;refin:true;refot:true;xorot:$FFFFFFFF;reg:0),
     (name:'CRC-32 reverse';Width:32;poly:$DB710641;init:$FFFFFFFF;refin:true;refot:true;xorot:$FFFFFFFF;reg:0));

type
  TCRCTable = array[0..255] of cardinal;
  TPCRCTable = ^TCRCTable;
  TDArray = array[0..MaxInt-1] of byte;
  PDArray = ^TDarray;

  TCRC = class(TComponent)
  private
    FCRC:TCRCModel;
    PCRCArray:TPCRCTable;

    function Reflect(v:cardinal;b:integer):cardinal;
    function Widmask:cardinal;
  protected
    procedure SetCRC(ACRC:TCRCModel);
  public
    procedure Cm_Ini;
    procedure Cm_Nxt(b:byte);
    procedure Cm_Blk(PBlk:Pointer;Blk_len:integer);
    function  Cm_CRC:cardinal;
    function  Cm_Tab(index:byte):cardinal;
    constructor Create(AOwner: TComponent);override;
    destructor  Destroy;override;
  published
    property CRC:TCRCModel read FCRC write SetCRC;
  end;

procedure Register;

implementation



constructor TCRC.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCRC:=StandartCRCModels[0];
  ReallocMem(PCRCArray, SizeOf(TCRCTable));
end;

{ Получение зеркальной копии переменной V для инверсного варианта алгоритма
}
function TCRC.Reflect(v:cardinal;b:integer):cardinal;
var i:integer;
    t:cardinal;
begin
  t:=v;
  for i:=0 to b-1 do
  begin
    if (t and 1)=1 then
      v:=v or (1 shl ((b-1) -i))
    else
      v:=v and not (1 shl ((b-1) -i));
    t:=t shr 1;
  end;
  result:=v;
end;

{ Получение маски заданной в модели длины
}
function TCRC.Widmask:cardinal;
begin
  result:= ((Cardinal(1 shl (FCRC.width-1))-1) shl 1) or 1;
end;

procedure TCRC.Cm_Ini;
begin
  FCRC.reg:=FCRC.init
end;

{ Расчет CRC для одного байта
}
procedure TCRC.Cm_Nxt(b:byte);
var i:integer;
    lb,topbit:Cardinal;
begin
  lb:=b;
  topbit:=1 shl (FCRC.Width-1);
  if FCRC.refin then lb:=reflect(lb,8);
  FCRC.reg:=FCRC.reg xor (lb shl (FCRC.width-8));
  for i:=0 to 7 do
  begin
    if (FCRC.reg and topbit)<>0 then
      FCRC.reg:=(FCRC.reg shl 1) xor FCRC.poly
    else
      FCRC.reg:=FCRC.reg shl 1;
    FCRC.reg:=FCRC.reg and widmask
  end;
end;

procedure TCRC.Cm_Blk(PBlk:Pointer;Blk_len:integer);
var i:integer;

begin
  for i:=0 to Blk_len-1 do Cm_Nxt(PDarray(PBlk)[i])
end;


function TCRC.Cm_CRC:cardinal;
begin
  if FCRC.refot then
    result:=FCRC.xorot xor reflect(FCRC.reg,FCRC.width)
  else
    result:=FCRC.xorot xor FCRC.reg;
end;

function TCRC.Cm_Tab(index:byte):cardinal;
var i:integer;
    r,topbit,inbyte:cardinal;
begin
  topbit:=1 shl (FCRC.Width-1);
  inbyte:=index;
  if FCRC.refin then inbyte:=reflect(inbyte,8);
  r:=inbyte shl (FCRC.width -8);
  for i:=0 to 7 do
    if (r and topbit)<>0 then
      r:=(r shl 1) xor FCRC.poly
    else
      r:=r shl 1;
  if FCRC.refin then r:=reflect(r,FCRC.width);
  result:=r and widmask;
end;


procedure TCRC.SetCRC(ACRC:TCRCModel );
begin
  FCRC:=ACRC
end;


destructor TCRC.Destroy;
begin
  inherited Destroy;
  FreeMem(PCRCArray);
end;


procedure Register;
begin
  RegisterComponents('Samples', [TCRC]);
end;


end.
