{  (C) Copr. 1986-92 Numerical Recipes Software .5-28.}

{ Циклическая контрольная сумма }

unit uICR;

interface

type
{$IfDef Seg16}
  integer=longint;
{$EndIf Def Seg16}
  tBufLength=word;
  tCrc=array[1..2] of Char;

function iCrc(var Crc:tCrc; { ??? }
	      var BufPtr; Len:tBufLength; { буфер суммирования }
	      jInit:integer; { начальный символ, 
			     если jInit<0 или jInit>High(char), 
			     то использовать умолчание }
	      jRev:boolean { ??? }
	     ):longint;


implementation

type

  tCharArray4=array[1..4] of Char;

  tReg=record
    case byte of
      0:(c:tCharArray4);
      1:(i:longint);
  end;

type
  tIBTable=array[1..3] of integer;

function icrc1(const Crc:tCharArray4; OneCh:Char; const Ib:tIBTable):integer;
  var
    i,ichr:integer;
    reg:tReg;
begin
  reg.i:=0;
  reg.c[Ib[1]]:=crc[Ib[1]];
  reg.c[Ib[2]]:=char(Ord(crc[Ib[2]]) xor Ord(OneCh));
  for i:=1 to 8 do begin
    ichr:=Ord(reg.c[Ib[2]]);
    reg.i:=reg.i+reg.i;
    reg.c[Ib[3]]:=char(0);
    if(ichr > 127) then reg.i:=(reg.i xor 4129)
  end;
  icrc1:=reg.i;
end;

(* icrc1.for

      FUNCTION icrc1(crc,onech,ib1,ib2,ib3)
      INTEGER icrc1,ib1,ib2,ib3
      INTEGER i,ichr,ireg
      CHARACTER*1 onech,crc(4),creg(4)
      EQUIVALENCE (creg,ireg)
      ireg=0
      creg(ib1)=crc(ib1)
      creg(ib2)=char(ieor(ichar(crc(ib2)),ichar(onech)))
      do 11 i=1,8
	ichr=ichar(creg(ib2))
	ireg=ireg+ireg
	creg(ib3)=char(0)
	if(ichr.gt.127)ireg=ieor(ireg,4129)
11    continue
      icrc1=ireg
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software .5-28.
*)

type
  tIntTable=array[byte] of integer;
  tCharTable=array[byte] of char;

var
  gICrcTb:tIntTable;
  gRChr:tCharTable;
  gIb:tIBTable;

const
  gInit:boolean=FALSE;

procedure InitCRCTables;
  const
    it:array[0..15] of shortint {integer}=(0,8,4,12,2,10,6,14,1,9,5,13,3,11,7,15);
  var
    ich,j:integer;
    reg:tReg;
begin
  gInit:=TRUE;
  reg.i:=(  ( (Ord('3') shl 8)+Ord('2') ) shl 8  )+Ord('1');
  for j:=1 to 4 do begin
    if (reg.c[j] = '1') then gIb[1]:=j;
    if (reg.c[j] = '2') then gIb[2]:=j;
    if (reg.c[j] = '3') then gIb[3]:=j;
  end;
  for j:=0 to 255 do begin
    reg.i:=(j shl 8);
    gICrcTb[j]:=icrc1(reg.c, char(0),gIb);
    ich:=it[j mod 16]*16+it[j div 16];
    gRChr[j]:=char(ich);
  end;
end;

function iCrc;
  type
    tByteArray=array[1..$FFF0] of byte;
    tPtrByteArray=^tByteArray;
  var
    ich,j:integer;
    reg:tReg;
    pBuf:tPtrByteArray;
begin
  if not gInit then InitCRCTables;
  pBuf:=tPtrByteArray(@BufPtr);
  if (jInit>=0) and (jInit<=Ord(High(char))) then begin
    crc[1]:=char(jInit);
    crc[2]:=char(jInit);
  end else if jRev then begin
    ich:=Ord(crc[1]);
    crc[1]:=gRChr[Ord(crc[2])];
    crc[2]:=gRChr[ich];
  end;
  for j:=1 to Len do begin
    ich:=pBuf^[j];
    if jRev then ich:=Ord(gRChr[ich]);
    reg.i:=gICrcTb[(ich xor Ord(crc[2]))];
    crc[2]:=char((Ord(reg.c[gIb[2]]) xor Ord(crc[1])));
    crc[1]:=reg.c[gIb[1]];
  end;
  if jRev then begin
    reg.c[gIb[1]]:=crc[1];
    reg.c[gIb[2]]:=crc[2];
  end else begin
    reg.c[gIb[2]]:=gRChr[Ord(crc[1])];
    reg.c[gIb[1]]:=gRChr[Ord(crc[2])];
    crc[1]:=reg.c[gIb[1]];
    crc[2]:=reg.c[gIb[2]];
  end;
  icrc:=reg.i;
end;

END.
(* icrc.for

      FUNCTION icrc(crc,bufptr,len,jinit,jrev)
      INTEGER icrc,jinit,jrev,len
      CHARACTER*1 bufptr(*),crc(2)
CU    USES icrc1
      INTEGER ich,init,ireg,j,icrctb(0:255),it(0:15),icrc1,ib1,ib2,ib3
      CHARACTER*1 creg(4),rchr(0:255)
      SAVE icrctb,rchr,init,it,ib1,ib2,ib3
      EQUIVALENCE (creg,ireg)
      DATA it/0,8,4,12,2,10,6,14,1,9,5,13,3,11,7,15/, init /0/
      if (init.eq.0) then
	init=1
	ireg=256*(256*ichar('3')+ichar('2'))+ichar('1')
	do 11 j=1,4
	  if (creg(j).eq.'1') ib1=j
	  if (creg(j).eq.'2') ib2=j
	  if (creg(j).eq.'3') ib3=j
11      continue
	do 12 j=0,255
	  ireg=j*256
	  icrctb(j)=icrc1(creg,char(0),ib1,ib2,ib3)
	  ich=it(mod(j,16))*16+it(j/16)
	  rchr(j)=char(ich)
12      continue
      endif
      if (jinit.ge.0) then
	crc(1)=char(jinit)
	crc(2)=char(jinit)
      else if (jrev.lt.0) then
	ich=ichar(crc(1))
	crc(1)=rchr(ichar(crc(2)))
	crc(2)=rchr(ich)
      endif
      do 13 j=1,len
	ich=ichar(bufptr(j))
	if(jrev.lt.0)ich=ichar(rchr(ich))
	ireg=icrctb(ieor(ich,ichar(crc(2))))
	crc(2)=char(ieor(ichar(creg(ib2)),ichar(crc(1))))
	crc(1)=creg(ib1)
13    continue
      if (jrev.ge.0) then
        creg(ib1)=crc(1)
        creg(ib2)=crc(2)
      else
        creg(ib2)=rchr(ichar(crc(1)))
        creg(ib1)=rchr(ichar(crc(2)))
        crc(1)=creg(ib1)
        crc(2)=creg(ib2)
      endif
      icrc=ireg
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software .5-28.
*)