unit DMRProtocol;

{
  Small, allocation-free DMR burst protocol layer.

  The CACH interleave and Hamming/Golay generator matrices are derived from
  dsd-fme (src/dmr_bs.c and src/fec.c). The original code is distributed
  under the ISC licence; see the dsd-fme source tree for its full notice.
}

{$IFDEF FPC}
  {$MODE Delphi}
{$ENDIF}

interface

uses
  SysUtils;

const
  DMR_PROTOCOL_BURST_DIBITS = 144;

type
  TDMRDibitBurst = array[0..DMR_PROTOCOL_BURST_DIBITS - 1] of Byte;
  TDMRBit7 = array[0..6] of Byte;
  TDMRBit20 = array[0..19] of Byte;
  TDMRBit96 = array[0..95] of Byte;

  TDMRCACH = record
    Valid: Boolean;
    CorrectedBits: Integer;
    AccessType: Boolean;
    Slot: Integer;
    LCSS: Integer;
  end;

  TDMRSlotType = record
    Valid: Boolean;
    CorrectedBits: Integer;
    ColorCode: Integer;
    DataType: Integer;
  end;

  TDMRLinkControl = record
    Decoded: Boolean;
    CRCValid: Boolean;
    RSCorrectedBytes: Integer;
    ProtectedFlag: Boolean;
    Reserved: Boolean;
    Opcode: Integer;
    FeatureSetID: Integer;
    ServiceOptions: Integer;
    TargetID: LongWord;
    SourceID: LongWord;
  end;

  TDMRBurstInfo = record
    CACH: TDMRCACH;
    SlotType: TDMRSlotType;
    BPTCValid: Boolean;
    BPTCIrrecoverableErrors: Integer;
    Payload96: TDMRBit96;
    LinkControl: TDMRLinkControl;
  end;

function DMRHamming74Encode(Value: Byte): TDMRBit7;
function DMRGolay208Encode(Value: Byte): TDMRBit20;
procedure DMRBPTC19696Encode(const Payload: TDMRBit96;
  out Burst: TDMRDibitBurst);
procedure DMRFullLCSetParity(var Payload: TDMRBit96; DataType: Integer);
function DMRDecodeCACH(const Burst: TDMRDibitBurst; out CACH: TDMRCACH): Boolean;
function DMRDecodeSlotType(const Burst: TDMRDibitBurst;
  out SlotType: TDMRSlotType): Boolean;
function DMRDecodeBPTC19696(const Burst: TDMRDibitBurst;
  out Payload: TDMRBit96; out IrrecoverableErrors: Integer): Boolean;
procedure DMRParseBurst(const Burst: TDMRDibitBurst; out Info: TDMRBurstInfo);
function DMRDataTypeName(DataType: Integer): string;

implementation

const
  CACH_INTERLEAVE: array[0..23] of Byte = (
     0,  7,  8,  9,  1, 10,
    11, 12,  2, 13, 14, 15,
     3, 16,  4, 17, 18, 19,
     5, 20, 21, 22,  6, 23
  );

  HAMMING_7_4_G: array[0..3, 0..6] of Byte = (
    (1, 0, 0, 0, 1, 0, 1),
    (0, 1, 0, 0, 1, 1, 1),
    (0, 0, 1, 0, 1, 1, 0),
    (0, 0, 0, 1, 0, 1, 1)
  );

  GOLAY_20_8_G: array[0..7, 0..19] of Byte = (
    (1,0,0,0,0,0,0,0, 0,0,1,1,1,1,0,1,1,0,1,0),
    (0,1,0,0,0,0,0,0, 1,1,0,1,1,0,0,1,1,0,0,1),
    (0,0,1,0,0,0,0,0, 0,1,1,0,1,1,0,0,1,1,0,1),
    (0,0,0,1,0,0,0,0, 0,0,1,1,0,1,1,0,0,1,1,1),
    (0,0,0,0,1,0,0,0, 1,1,0,1,1,1,0,0,0,1,1,0),
    (0,0,0,0,0,1,0,0, 1,0,1,0,1,0,0,1,0,1,1,1),
    (0,0,0,0,0,0,1,0, 1,0,0,1,0,0,1,1,1,1,1,0),
    (0,0,0,0,0,0,0,1, 1,0,0,0,1,1,1,0,1,0,1,1)
  );

  // Syndrome values for bit positions of the systematic Hamming codewords.
  HAMMING_13_9_SYNDROME: array[0..12] of Byte =
    (15,14,7,10,5,11,12,6,3, 8,4,2,1);
  HAMMING_15_11_SYNDROME: array[0..14] of Byte =
    (9,13,15,14,7,10,5,11,12,6,3, 8,4,2,1);

function DMRHamming74Encode(Value: Byte): TDMRBit7;
var
  i, j: Integer;
begin
  FillChar(Result, SizeOf(Result), 0);
  for i := 0 to 3 do
    if ((Value shr (3 - i)) and 1) <> 0 then
      for j := 0 to 6 do Result[j] := Result[j] xor HAMMING_7_4_G[i, j];
end;

function DMRGolay208Encode(Value: Byte): TDMRBit20;
var
  i, j: Integer;
begin
  FillChar(Result, SizeOf(Result), 0);
  for i := 0 to 7 do
    if ((Value shr (7 - i)) and 1) <> 0 then
      for j := 0 to 19 do Result[j] := Result[j] xor GOLAY_20_8_G[i, j];
end;

procedure EncodeHamming(var Codeword: array of Byte; DataBits: Integer;
  const Syndromes: array of Byte);
var
  i, Syndrome: Integer;
begin
  Syndrome := 0;
  for i := 0 to DataBits - 1 do
    if (Codeword[i] and 1) <> 0 then Syndrome := Syndrome xor Syndromes[i];
  // The final four systematic parity positions have syndromes 8,4,2,1.
  for i := 0 to 3 do Codeword[DataBits + i] := (Syndrome shr (3 - i)) and 1;
end;

function CorrectHamming(var Codeword: array of Byte;
  const Syndromes: array of Byte): Boolean;
var
  i, Syndrome, Position: Integer;
begin
  Syndrome := 0;
  for i := 0 to High(Codeword) do
    if (Codeword[i] and 1) <> 0 then Syndrome := Syndrome xor Syndromes[i];
  if Syndrome = 0 then Exit(True);
  Position := -1;
  for i := 0 to High(Codeword) do
    if Syndromes[i] = Syndrome then begin Position := i; Break; end;
  Result := Position >= 0;
  if Result then Codeword[Position] := Codeword[Position] xor 1;
end;

procedure DMRBPTC19696Encode(const Payload: TDMRBit96;
  out Burst: TDMRDibitBurst);
var
  Matrix: array[0..12, 0..14] of Byte;
  Deinterleaved, Air: array[0..195] of Byte;
  Row: array[0..14] of Byte;
  Column: array[0..12] of Byte;
  i, j, k: Integer;
begin
  FillChar(Burst, SizeOf(Burst), 0);
  FillChar(Matrix, SizeOf(Matrix), 0);
  k := 0;
  for j := 3 to 10 do begin Matrix[0, j] := Payload[k] and 1; Inc(k); end;
  for i := 1 to 8 do
    for j := 0 to 10 do begin Matrix[i, j] := Payload[k] and 1; Inc(k); end;

  for i := 0 to 8 do
  begin
    for j := 0 to 14 do Row[j] := Matrix[i, j];
    EncodeHamming(Row, 11, HAMMING_15_11_SYNDROME);
    for j := 0 to 14 do Matrix[i, j] := Row[j];
  end;
  for j := 0 to 14 do
  begin
    for i := 0 to 12 do Column[i] := Matrix[i, j];
    EncodeHamming(Column, 9, HAMMING_13_9_SYNDROME);
    for i := 0 to 12 do Matrix[i, j] := Column[i];
  end;

  Deinterleaved[0] := 0; // R(3)
  k := 1;
  for i := 0 to 12 do
    for j := 0 to 14 do begin Deinterleaved[k] := Matrix[i, j]; Inc(k); end;
  for i := 0 to 195 do Air[i] := Deinterleaved[(i * 13) mod 196];
  k := 0;
  for i := 12 to 60 do
  begin
    Burst[i] := (Air[k] shl 1) or Air[k + 1]; Inc(k, 2);
  end;
  for i := 95 to 143 do
  begin
    Burst[i] := (Air[k] shl 1) or Air[k + 1]; Inc(k, 2);
  end;
end;

function DecodeHamming74(const Received: TDMRBit7; out Value: Byte;
  out Corrected: Integer): Boolean;
var
  Candidate: TDMRBit7;
  V, i, Distance, BestDistance: Integer;
begin
  Value := 0;
  BestDistance := 8;
  for V := 0 to 15 do
  begin
    Candidate := DMRHamming74Encode(V);
    Distance := 0;
    for i := 0 to 6 do Inc(Distance, Candidate[i] xor (Received[i] and 1));
    if Distance < BestDistance then
    begin
      BestDistance := Distance;
      Value := V;
    end;
  end;
  Corrected := BestDistance;
  Result := BestDistance <= 1;
end;

function DecodeGolay208(const Received: TDMRBit20; out Value: Byte;
  out Corrected: Integer): Boolean;
var
  Candidate: TDMRBit20;
  V, i, Distance, BestDistance: Integer;
begin
  Value := 0;
  BestDistance := 21;
  for V := 0 to 255 do
  begin
    Candidate := DMRGolay208Encode(V);
    Distance := 0;
    for i := 0 to 19 do Inc(Distance, Candidate[i] xor (Received[i] and 1));
    if Distance < BestDistance then
    begin
      BestDistance := Distance;
      Value := V;
      if Distance = 0 then Break;
    end;
  end;
  Corrected := BestDistance;
  Result := BestDistance <= 2;
end;

function DMRDecodeCACH(const Burst: TDMRDibitBurst; out CACH: TDMRCACH): Boolean;
var
  Deinterleaved: array[0..23] of Byte;
  TACT: TDMRBit7;
  Value: Byte;
  i: Integer;
begin
  FillChar(CACH, SizeOf(CACH), 0);
  FillChar(Deinterleaved, SizeOf(Deinterleaved), 0);
  for i := 0 to 11 do
  begin
    Deinterleaved[CACH_INTERLEAVE[2 * i]] := (Burst[i] shr 1) and 1;
    Deinterleaved[CACH_INTERLEAVE[2 * i + 1]] := Burst[i] and 1;
  end;
  for i := 0 to 6 do TACT[i] := Deinterleaved[i];
  CACH.Valid := DecodeHamming74(TACT, Value, CACH.CorrectedBits);
  if CACH.Valid then
  begin
    CACH.AccessType := (Value and 8) <> 0;
    CACH.Slot := (Value shr 2) and 1;
    CACH.LCSS := Value and 3;
  end;
  Result := CACH.Valid;
end;

function DMRDecodeSlotType(const Burst: TDMRDibitBurst;
  out SlotType: TDMRSlotType): Boolean;
var
  Bits: TDMRBit20;
  Value: Byte;
  i, k: Integer;
begin
  FillChar(SlotType, SizeOf(SlotType), 0);
  k := 0;
  for i := 61 to 65 do
  begin
    Bits[k] := (Burst[i] shr 1) and 1; Inc(k);
    Bits[k] := Burst[i] and 1; Inc(k);
  end;
  for i := 90 to 94 do
  begin
    Bits[k] := (Burst[i] shr 1) and 1; Inc(k);
    Bits[k] := Burst[i] and 1; Inc(k);
  end;
  SlotType.Valid := DecodeGolay208(Bits, Value, SlotType.CorrectedBits);
  if SlotType.Valid then
  begin
    SlotType.ColorCode := (Value shr 4) and $0F;
    SlotType.DataType := Value and $0F;
  end;
  Result := SlotType.Valid;
end;

function DMRDecodeBPTC19696(const Burst: TDMRDibitBurst;
  out Payload: TDMRBit96; out IrrecoverableErrors: Integer): Boolean;
var
  Air, Deinterleaved: array[0..195] of Byte;
  Matrix: array[0..12, 0..14] of Byte;
  Row: array[0..14] of Byte;
  Column: array[0..12] of Byte;
  i, j, k, Pass: Integer;
begin
  FillChar(Payload, SizeOf(Payload), 0);
  k := 0;
  for i := 12 to 60 do
  begin
    Air[k] := (Burst[i] shr 1) and 1; Inc(k);
    Air[k] := Burst[i] and 1; Inc(k);
  end;
  for i := 95 to 143 do
  begin
    Air[k] := (Burst[i] shr 1) and 1; Inc(k);
    Air[k] := Burst[i] and 1; Inc(k);
  end;
  for i := 0 to 195 do Deinterleaved[(i * 13) mod 196] := Air[i];
  k := 1; // discard R(3)
  for i := 0 to 12 do
    for j := 0 to 14 do begin Matrix[i, j] := Deinterleaved[k]; Inc(k); end;

  IrrecoverableErrors := 0;
  // Alternating row/column passes allow a correction in one dimension to
  // make a previously ambiguous syndrome correctable in the other.
  for Pass := 0 to 1 do
  begin
    if Pass = 1 then IrrecoverableErrors := 0;
    for i := 0 to 8 do
    begin
      for j := 0 to 14 do Row[j] := Matrix[i, j];
      if not CorrectHamming(Row, HAMMING_15_11_SYNDROME) then
        Inc(IrrecoverableErrors);
      for j := 0 to 10 do Matrix[i, j] := Row[j];
    end;
    for j := 0 to 14 do
    begin
      for i := 0 to 12 do Column[i] := Matrix[i, j];
      if not CorrectHamming(Column, HAMMING_13_9_SYNDROME) then
        Inc(IrrecoverableErrors);
      for i := 0 to 8 do Matrix[i, j] := Column[i];
    end;
  end;

  k := 0;
  for j := 3 to 10 do begin Payload[k] := Matrix[0, j]; Inc(k); end;
  for i := 1 to 8 do
    for j := 0 to 10 do begin Payload[k] := Matrix[i, j]; Inc(k); end;
  Result := IrrecoverableErrors = 0;
end;

function BitsToUInt(const Bits: TDMRBit96; Start, Count: Integer): LongWord;
var
  i: Integer;
begin
  Result := 0;
  for i := 0 to Count - 1 do Result := (Result shl 1) or (Bits[Start + i] and 1);
end;

function GFMul(A, B: Byte): Byte;
var
  Carry: Boolean;
  P: Byte;
  i: Integer;
begin
  P := 0;
  for i := 0 to 7 do
  begin
    if (B and 1) <> 0 then P := P xor A;
    Carry := (A and $80) <> 0;
    A := A shl 1;
    if Carry then A := A xor $1D; // GF(256), primitive polynomial x^8+x^4+x^3+x^2+1
    B := B shr 1;
  end;
  Result := P;
end;

procedure BytesToBits(const Bytes: array of Byte; var Bits: TDMRBit96);
var
  i, j: Integer;
begin
  for i := 0 to 11 do
    for j := 0 to 7 do Bits[i * 8 + j] := (Bytes[i] shr (7 - j)) and 1;
end;

procedure BitsToBytes(const Bits: TDMRBit96; var Bytes: array of Byte);
var
  i, j: Integer;
begin
  for i := 0 to 11 do
  begin
    Bytes[i] := 0;
    for j := 0 to 7 do Bytes[i] := (Bytes[i] shl 1) or (Bits[i * 8 + j] and 1);
  end;
end;

procedure RS129Syndrome(const Codeword: array of Byte; out S0, S1, S2: Byte);
var
  i: Integer;
begin
  S0 := 0; S1 := 0; S2 := 0;
  for i := 0 to 11 do
  begin
    S0 := Codeword[i] xor GFMul(2, S0);
    S1 := Codeword[i] xor GFMul(4, S1);
    S2 := Codeword[i] xor GFMul(8, S2);
  end;
end;

function FullLCMask(DataType: Integer): LongWord;
begin
  if DataType = 1 then Result := $969696
  else if DataType = 2 then Result := $999999
  else Result := 0;
end;

procedure DMRFullLCSetParity(var Payload: TDMRBit96; DataType: Integer);
var
  Bytes: array[0..11] of Byte;
  Feedback: Byte;
  Mask: LongWord;
  i: Integer;
begin
  BitsToBytes(Payload, Bytes);
  Bytes[9] := 0; Bytes[10] := 0; Bytes[11] := 0;
  for i := 0 to 8 do
  begin
    Feedback := Bytes[i] xor Bytes[9];
    Bytes[9] := Bytes[10] xor GFMul($0E, Feedback);
    Bytes[10] := Bytes[11] xor GFMul($38, Feedback);
    Bytes[11] := GFMul($40, Feedback);
  end;
  Mask := FullLCMask(DataType);
  Bytes[9] := Bytes[9] xor Byte(Mask shr 16);
  Bytes[10] := Bytes[10] xor Byte(Mask shr 8);
  Bytes[11] := Bytes[11] xor Byte(Mask);
  BytesToBits(Bytes, Payload);
end;

function ValidateAndCorrectFullLC(var Payload: TDMRBit96; DataType: Integer;
  out CorrectedBytes: Integer): Boolean;
var
  Bytes: array[0..11] of Byte;
  S0, S1, S2: Byte;
  Mask: LongWord;
  Position, Delta: Integer;
begin
  CorrectedBytes := 0;
  BitsToBytes(Payload, Bytes);
  Mask := FullLCMask(DataType);
  Bytes[9] := Bytes[9] xor Byte(Mask shr 16);
  Bytes[10] := Bytes[10] xor Byte(Mask shr 8);
  Bytes[11] := Bytes[11] xor Byte(Mask);
  RS129Syndrome(Bytes, S0, S1, S2);
  if (S0 <> 0) or (S1 <> 0) or (S2 <> 0) then
  begin
    // RS(12,9) has three check symbols and corrects one complete byte. Full
    // Berlekamp-Massey machinery is unnecessary at this block size: search
    // the 12*255 possible one-symbol corrections and require zero syndrome.
    for Position := 0 to 11 do
    begin
      for Delta := 1 to 255 do
      begin
        Bytes[Position] := Bytes[Position] xor Byte(Delta);
        RS129Syndrome(Bytes, S0, S1, S2);
        if (S0 = 0) and (S1 = 0) and (S2 = 0) then
        begin
          CorrectedBytes := 1;
          Break;
        end;
        Bytes[Position] := Bytes[Position] xor Byte(Delta);
      end;
      if CorrectedBytes <> 0 then Break;
    end;
    if CorrectedBytes = 0 then Exit(False);
  end;
  // Payload data may itself have been the corrected RS symbol.
  Bytes[9] := Bytes[9] xor Byte(Mask shr 16);
  Bytes[10] := Bytes[10] xor Byte(Mask shr 8);
  Bytes[11] := Bytes[11] xor Byte(Mask);
  BytesToBits(Bytes, Payload);
  Result := True;
end;

procedure DMRParseBurst(const Burst: TDMRDibitBurst; out Info: TDMRBurstInfo);
begin
  FillChar(Info, SizeOf(Info), 0);
  DMRDecodeCACH(Burst, Info.CACH);
  DMRDecodeSlotType(Burst, Info.SlotType);
  if Info.SlotType.Valid and (Info.SlotType.DataType in [0..7, 9, 11]) then
  begin
    Info.BPTCValid := DMRDecodeBPTC19696(Burst, Info.Payload96,
      Info.BPTCIrrecoverableErrors);
    if Info.BPTCValid and (Info.SlotType.DataType in [1, 2]) then
    begin
      Info.LinkControl.CRCValid := ValidateAndCorrectFullLC(Info.Payload96,
        Info.SlotType.DataType, Info.LinkControl.RSCorrectedBytes);
      Info.LinkControl.Decoded := Info.LinkControl.CRCValid;
      if Info.LinkControl.Decoded then
      begin
        Info.LinkControl.ProtectedFlag := Info.Payload96[0] <> 0;
        Info.LinkControl.Reserved := Info.Payload96[1] <> 0;
        Info.LinkControl.Opcode := BitsToUInt(Info.Payload96, 2, 6);
        Info.LinkControl.FeatureSetID := BitsToUInt(Info.Payload96, 8, 8);
        Info.LinkControl.ServiceOptions := BitsToUInt(Info.Payload96, 16, 8);
        Info.LinkControl.TargetID := BitsToUInt(Info.Payload96, 24, 24);
        Info.LinkControl.SourceID := BitsToUInt(Info.Payload96, 48, 24);
      end;
    end;
  end;
end;

function DMRDataTypeName(DataType: Integer): string;
begin
  case DataType of
    0: Result := 'PI header';
    1: Result := 'voice LC';
    2: Result := 'terminator LC';
    3: Result := 'CSBK';
    4: Result := 'MBC header';
    5: Result := 'MBC continuation';
    6: Result := 'data header';
    7: Result := 'rate 1/2 data';
    8: Result := 'rate 3/4 data';
    9: Result := 'idle';
    10: Result := 'rate 1 data';
    11: Result := 'unified single block';
  else
    Result := 'reserved ' + IntToStr(DataType);
  end;
end;

end.