{-------------------------------------------------------------------------------
 
 Copyright (c) 1999-2021 Ralf Junker, Yunqa
 Internet: https://www.yunqa.de
 E-Mail:   delphi@yunqa.de

-------------------------------------------------------------------------------}

unit YuUtf;

{$I DICompilers.inc}

interface

uses
  DISystemCompat;

function U16_UCP_COUNT(
  const p: PWideChar;
  const l: NativeInt): NativeInt; overload;

function U16_UCP_COUNT(
  const s: UnicodeString): NativeInt; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function Utf8Bytes(
  const p: PUtf8Char;
  const l: NativeInt): ShortInt; overload;

function Utf8Bytes(
  const p: PUtf8Char;
  const l: NativeInt;
  n: NativeInt): NativeInt; overload;

procedure Utf8Inc(
  var p: PUtf8Char;
  var l: Integer;
  n: Integer); overload;

procedure Utf8Inc(
  var p: PUtf8Char;
  var l: Cardinal;
  n: Cardinal); overload;

procedure Utf8Inc(
  var p: PUtf8Char;
  var l: Int64;
  n: Int64); overload;

{$IFDEF COMPILER_9_UP}

procedure Utf8Inc(
  var p: PUtf8Char;
  var l: UInt64;
  n: UInt64); overload;
{$ENDIF COMPILER_9_UP}

{$IFDEF COMPILER_12_UP}

procedure Utf8Inc(
  var p: PUtf8Char;
  var l: NativeInt;
  n: NativeInt); overload;

{$ENDIF COMPILER_12_UP}

function Utf8Len(
  p: Pointer;
  l: NativeInt): NativeInt;

function Utf8Pos(
  const s: Utf8String;
  const Search: Utf8String;
  const Offset: NativeInt = 1): NativeInt; overload;

function Utf8Pos(
  p: PUtf8Char; l: NativeInt;
  pSearch: PUtf8Char; lSearch: NativeInt;
  const Offset: NativeInt = 0): NativeInt; overload;

function ReadUcs4_Utf8(
  p: Pointer;
  out c: UCS4Char): ShortInt; overload;

function ReadUcs4_Utf8(
  p: Pointer;
  l: NativeInt;
  out c: UCS4Char): ShortInt; overload;

const

  UCHAR_MIN_VALUE = 0;

  UCHAR_MAX_BMP_VALUE = $FFFF;

  UCHAR_MAX_VALUE = $10FFFF;

function U_IS_UNICODE_NONCHAR(
  const c: UCS4Char): Boolean; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U_IS_UNICODE_CHAR(
  const c: UCS4Char): Boolean; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U_IS_BMP(
  const c: UCS4Char): Boolean; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U_IS_SUPPLEMENTARY(
  const c: UCS4Char): Boolean; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U_IS_LEAD(
  const c: UCS4Char): Boolean; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U_IS_TRAIL(
  const c: UCS4Char): Boolean; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U_IS_SURROGATE(
  const c: UCS4Char): Boolean; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U8_LENGTH(
  const c: UCS4Char): ShortInt;

procedure U8_APPEND_UNSAFE(
  const s: PUtf8Char;
  var i: NativeInt;
  const c: UCS4Char);

procedure U8_APPEND(
  const s: PUtf8Char;
  var i: NativeInt;
  const Capacity: NativeInt;
  const c: UCS4Char;
  var isError: Boolean);

const

  U16_SURROGATE_OFFSET = $D800 shl 10 + $DC00 - $10000;

function U16_GET_SUPPLEMENTARY(
  const lead: WideChar;
  const trail: UCS4Char): UCS4Char; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_GET_SUPPLEMENTARY(
  const lead: UCS4Char;
  const trail: WideChar): UCS4Char; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_GET_SUPPLEMENTARY(
  const lead: UCS4Char;
  const trail: UCS4Char): UCS4Char; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_IS_LEAD(
  const c: WideChar): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_IS_LEAD(
  const c: UCS4Char): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_IS_TRAIL(
  const c: WideChar): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_IS_TRAIL(
  const c: UCS4Char): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_IS_SURROGATE(
  const c: WideChar): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_IS_SURROGATE(
  const c: UCS4Char): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_IS_SURROGATE_LEAD(
  const c: WideChar): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_IS_SURROGATE_LEAD(
  const c: UCS4Char): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_IS_SURROGATE_TRAIL(
  const c: WideChar): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_IS_SURROGATE_TRAIL(
  const c: UCS4Char): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_LENGTH(
  const c: UCS4Char): ShortInt; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_LENGTH_OR_FFFD(
  const c: UCS4Char): ShortInt; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

const

  U16_MAX_LENGTH = 2;

function U16_GET_OR_FFFD(
  const s: PWideChar;
  const Start: NativeInt;
  const i: NativeInt;
  const Length: NativeInt): UCS4Char;

function U16_NEXT_INC(
  const s: PWideChar;
  var i: NativeInt;
  const Length: NativeInt): UCS4Char;

function U16_NEXT_OR_FFFD_INC(
  const s: PWideChar;
  var i: NativeInt;
  const Length: NativeInt): UCS4Char; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_NEXT_OR_FFFD(
  const s: PWideChar;
  const i: NativeInt;
  const Length: NativeInt;
  out c: UCS4Char): ShortInt; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_NEXT_OR_FFFD(
  const s: PWideChar;
  const i: NativeInt;
  const Length: NativeInt): UCS4Char; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

procedure U16_APPEND_INC_UNSAFE(
  const s: PWideChar;
  var i: NativeInt;
  const c: UCS4Char); {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_APPEND_UNSAFE(
  const s: PWideChar;
  const i: NativeInt;
  const c: UCS4Char): ShortInt;

function U16_APPEND_OR_FFFD_UNSAFE(
  const s: PWideChar;
  const i: NativeInt;
  const c: UCS4Char): ShortInt;

procedure U16_APPEND_OR_FFFD_INC_UNSAFE(
  const s: PWideChar;
  var i: NativeInt;
  const c: UCS4Char);

procedure U16_PUT_UNSAFE(
  const s: PWideChar;
  const i: NativeInt;
  const c: UCS4Char);

procedure U16_FWD_1(
  const s: PWideChar;
  var i: NativeInt;
  const Length: NativeInt);

procedure U16_SET_CP_START(
  const s: PWideChar;
  const Start: NativeInt;
  var i: NativeInt);

function U16_PREV_OR_FFFD_DEC(
  const s: PWideChar;
  const Start: NativeInt;
  var i: NativeInt): UCS4Char; overload; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF}

function U16_PREV_OR_FFFD(
  const s: PWideChar;
  const Start: NativeInt;
  const i: NativeInt): UCS4Char; overload;

function U16_PREV_OR_FFFD(
  const s: PWideChar;
  const Start: NativeInt;
  const i: NativeInt;
  out c: UCS4Char): ShortInt; overload;

procedure U16_BACK_1(
  const s: PWideChar;
  const Start: NativeInt;
  var i: NativeInt);

procedure U16_SET_CP_LIMIT(
  const s: PWideChar;
  const Start: NativeInt;
  var i: NativeInt;
  const Length: NativeInt);

function ReadUcs4_Utf16_LE(
  p: Pointer;
  l: NativeInt;
  out c: UCS4Char): ShortInt;

function UcpToUnicodeString(
  const c: UCS4Char): UnicodeString;

function WriteUcs4_Utf8(
  c: UCS4Char;
  p: Pointer;
  l: NativeInt): ShortInt;

function WriteUcs4_Utf16_LE(
  c: UCS4Char;
  p: Pointer;
  l: NativeInt): ShortInt;

implementation

function U16_UCP_COUNT(const s: UnicodeString): NativeInt;
begin
  Result := U16_UCP_COUNT(Pointer(s), Length(s));
end;

function U16_UCP_COUNT(const p: PWideChar; const l: NativeInt): NativeInt;
var
  c: WideChar;
  i: NativeInt;
begin
  Result := 0;
  i := 0;
  while i < l do
    begin
      Inc(Result);
      c := p[i];
      Inc(i);
      if U16_IS_LEAD(c) and (i < l) and U16_IS_TRAIL(p[i]) then
        Inc(i);
    end;
end;

type
  TBytes = packed record b1, b2, b3, b4{$IFNDEF RFC_3629}, b5, b6{$ENDIF}: Byte; end;
  PBytes = ^TBytes;

  TWords = packed record w1, w2, w3, w4: Word; end;
  PWords = ^TWords;

const
  UTF8_ACCEPT = 0;
  UTF8_REJECT = 12;

  utf8_1: array[0..$FF] of Byte = (
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
    7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
    8, 8, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
    10, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 3, 3, 11, 6, 6, 6, 5, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8);

  utf8_2: array[0..$6B] of Byte = (
    0, 12, 24, 36, 60, 96, 84, 12, 12, 12, 48, 72, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,
    12, 0, 12, 12, 12, 12, 12, 0, 12, 0, 12, 12, 12, 24, 12, 12, 12, 12, 12, 24, 12, 24, 12, 12,
    12, 12, 12, 12, 12, 12, 12, 24, 12, 12, 12, 12, 12, 24, 12, 12, 12, 12, 12, 12, 12, 24, 12, 12,
    12, 12, 12, 12, 12, 12, 12, 36, 12, 36, 12, 12, 12, 36, 12, 12, 12, 12, 12, 36, 12, 36, 12, 12,
    12, 36, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12);

function Decode(const State: Byte; const b: Byte): Byte; overload; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}
begin
  Result := utf8_2[State + utf8_1[b]];
end;

function Decode(const State: Byte; const b: Byte; var c: UCS4Char): Byte; overload; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}
var
  t: Byte;
begin
  t := utf8_1[b];
  if State <> UTF8_ACCEPT then
    c := (b and $3F) or (c shl 6)
  else
    c := ($FF shr t) and b;
  Result := utf8_2[State + t];
end;

function Utf8Bytes(const p: PUtf8Char; const l: NativeInt): ShortInt;
var
  State: Byte;
begin
  Assert(Assigned(p) and (l > 0));

  Result := 0;
  State := UTF8_ACCEPT;
  repeat
    State := Decode(State, Ord(p[Result]));
    Inc(Result);
    case State of
      UTF8_ACCEPT: Exit;
      UTF8_REJECT: Break;
    end;
  until Result >= l;
  Result := -Result;
end;

function Utf8Bytes(const p: PUtf8Char; const l: NativeInt; n: NativeInt): NativeInt;
var
  State: Byte;
begin
  Result := 0;
  if Assigned(p) and (l > 0) and (n > 0) then
    repeat
      State := UTF8_ACCEPT;
      repeat
        State := Decode(State, Ord(p[Result]));
        Inc(Result);
        case State of
          UTF8_ACCEPT, UTF8_REJECT:
            begin Dec(n); Break; end;
        end;
      until Result >= l
    until (Result >= l) or (n <= 0);
end;

procedure Utf8Inc(var p: PUtf8Char; var l: Integer; n: Integer);
var
  State: Byte;
begin
  if Assigned(p) and (l > 0) and (n > 0) then
    repeat
      State := UTF8_ACCEPT;
      repeat
        State := Decode(State, Ord(p^));
        Inc(p); Dec(l);
        case State of
          UTF8_ACCEPT, UTF8_REJECT:
            begin Dec(n); Break; end;
        end;
      until l <= 0;
    until (l <= 0) or (n <= 0);
end;

procedure Utf8Inc(var p: PUtf8Char; var l: Cardinal; n: Cardinal);
var
  State: Byte;
begin
  if Assigned(p) and (l > 0) and (n > 0) then
    repeat
      State := UTF8_ACCEPT;
      repeat
        State := Decode(State, Ord(p^));
        Inc(p); Dec(l);
        case State of
          UTF8_ACCEPT, UTF8_REJECT:
            begin Dec(n); Break; end;
        end;
      until l <= 0;
    until (l <= 0) or (n <= 0);
end;

procedure Utf8Inc(var p: PUtf8Char; var l: Int64; n: Int64);
var
  State: Byte;
begin
  if Assigned(p) and (l > 0) and (n > 0) then
    repeat
      State := UTF8_ACCEPT;
      repeat
        State := Decode(State, Ord(p^));
        Inc(p); Dec(l);
        case State of
          UTF8_ACCEPT, UTF8_REJECT:
            begin Dec(n); Break; end;
        end;
      until l <= 0;
    until (l <= 0) or (n <= 0);
end;

{$IFDEF COMPILER_9_UP}
procedure Utf8Inc(var p: PUtf8Char; var l: UInt64; n: UInt64);
var
  State: Byte;
begin
  if Assigned(p) and (l > 0) and (n > 0) then
    repeat
      State := UTF8_ACCEPT;
      repeat
        State := Decode(State, Ord(p^));
        Inc(p); Dec(l);
        case State of
          UTF8_ACCEPT, UTF8_REJECT:
            begin Dec(n); Break; end;
        end;
      until l <= 0;
    until (l <= 0) or (n <= 0);
end;
{$ENDIF COMPILER_9_UP}

{$IFDEF COMPILER_12_UP}
procedure Utf8Inc(var p: PUtf8Char; var l: NativeInt; n: NativeInt);
var
  State: Byte;
begin
  if Assigned(p) and (l > 0) and (n > 0) then
    repeat
      State := UTF8_ACCEPT;
      repeat
        State := Decode(State, Ord(p^));
        Inc(p); Dec(l);
        case State of
          UTF8_ACCEPT, UTF8_REJECT:
            begin Dec(n); Break; end;
        end;
      until l <= 0;
    until (l <= 0) or (n <= 0);
end;
{$ENDIF COMPILER_12_UP}

function Utf8Len(p: Pointer; l: NativeInt): NativeInt;
var
  State: Byte;
begin
  Result := 0;
  if Assigned(p) and (l > 0) then
    repeat
      State := UTF8_ACCEPT;
      repeat
        State := Decode(State, PByte(p)^);
        case State of
          UTF8_ACCEPT, UTF8_REJECT: Inc(Result);
        end;
        Inc(PByte(p)); Dec(l);
      until l <= 0;
    until l <= 0;
end;

function Utf8Pos(const s: Utf8String; const Search: Utf8String; const Offset: NativeInt = 1): NativeInt;
begin
  Result := Utf8Pos(Pointer(s), Length(s), Pointer(Search), Length(Search), Offset - 1) + 1;
end;

function Utf8Pos(p: PUtf8Char; l: NativeInt; pSearch: PUtf8Char; lSearch: NativeInt; const Offset: NativeInt = 0): NativeInt;
var
  c, cSearch, cSearchRun: UCS4Char;
  pSearchRun, pSrcRun: PUtf8Char;
  lSearchRun, lSrcRun: NativeInt;
  n: ShortInt;
begin
  Result := -1;
  if not Assigned(p) or (l <= 0) then Exit;
  if not Assigned(pSearch) or (lSearch <= 0) then Exit;

  Utf8Inc(p, l, Offset);
  if not Assigned(p) or (l <= 0) then Exit;

  n := ReadUcs4_Utf8(pSearch, lSearch, cSearch);
  if n < 0 then Exit;
  Inc(pSearch, n); Dec(lSearch, n);

  Result := Offset;
  while l > 0 do
    begin
      n := ReadUcs4_Utf8(p, l, c);
      Inc(p, n); Dec(l, n);

      if c = cSearch then
        begin
          if lSearch <= 0 then Exit;
          if l > 0 then
            begin
              pSrcRun := p; lSrcRun := l;
              pSearchRun := pSearch; lSearchRun := lSearch;
              repeat
                n := ReadUcs4_Utf8(pSrcRun, lSrcRun, c);
                if n < 1 then n := 1;
                Inc(pSrcRun, n); Dec(lSrcRun, n);

                n := ReadUcs4_Utf8(pSearchRun, lSearchRun, cSearchRun);
                if c <> cSearchRun then Break;
                if n < 1 then n := 1;
                Inc(pSearchRun, n); Dec(lSearchRun, n);
                if lSearchRun <= 0 then Exit;
              until lSrcRun <= 0;
            end;
        end;
      Inc(Result);
    end;

  Result := -1;
end;

function ReadUcs4_Utf8(p: Pointer; out c: UCS4Char): ShortInt;
var
  State: Byte;
begin
  Assert(Assigned(p) and (PBytes(p)^.b1 <> 0));
  Result := 1;
  c := 0;
  State := UTF8_ACCEPT;
  repeat
    State := Decode(State, PBytes(p)^.b1, c);
    case State of
      UTF8_ACCEPT: Exit;
      UTF8_REJECT: Break;
    end;
    Inc(Result); Inc(PAnsiChar(p));
  until PBytes(p)^.b1 = 0;
  Result := -Result;
  Assert(Result <> 0);
end;

function ReadUcs4_Utf8(p: Pointer; l: NativeInt; out c: UCS4Char): ShortInt;
var
  State: Byte;
begin
  Assert(Assigned(p) and (l > 0));

  Result := 1;
  c := 0;
  State := UTF8_ACCEPT;
  repeat
    State := Decode(State, PBytes(p)^.b1, c);
    case State of
      UTF8_ACCEPT: Exit;
      UTF8_REJECT: Break;
    end;
    Inc(Result); Inc(PAnsiChar(p)); Dec(l);
  until l <= 0;
  Result := -Result;
  Assert(Result <> 0);
end;

function U_IS_UNICODE_NONCHAR(const c: UCS4Char): Boolean;
begin
  Result := (c >= $FDD0) and ((c <= $FDEF) or (c and $FFFE = $FFFE)) and (c <= UCHAR_MAX_VALUE);
end;

function U_IS_UNICODE_CHAR(const c: UCS4Char): Boolean;
begin
  Result := (c < $D800) or ($DFFF < c) and (c <= UCHAR_MAX_VALUE) and not U_IS_UNICODE_NONCHAR(c);
end;

function U_IS_BMP(const c: UCS4Char): Boolean;
begin
  Result := c <= UCHAR_MAX_BMP_VALUE;
end;

function U_IS_SUPPLEMENTARY(const c: UCS4Char): Boolean;
begin
  Result := c - $10000 <= $FFFFF;
end;

function U_IS_LEAD(const c: UCS4Char): Boolean;
begin
  Result := c and $FFFFFC00 = $D800;
end;

function U_IS_TRAIL(const c: UCS4Char): Boolean;
begin
  Result := c and $FFFFFC00 = $DC00;
end;

function U_IS_SURROGATE(const c: UCS4Char): Boolean;
begin
  Result := c and $FFFFF800 = $D800;
end;

function U8_LENGTH(const c: UCS4Char): ShortInt;
begin
  if c <= $7F then Result := 1
  else if c <= $7FF then Result := 2
  else if c <= $D7FF then Result := 3
  else if (c <= $DFFF) or (c > $10FFFF) then Result := 0
  else if c <= $FFFF then Result := 3
  else Result := 4;
end;

procedure U8_APPEND_UNSAFE(const s: PUtf8Char; var i: NativeInt; const c: UCS4Char);
begin
  if c <= $7F then
    begin s[i] := AnsiChar(c); Inc(i); end
  else
    begin
      if c <= $7FF then
        begin s[i] := AnsiChar(c shr 6 or $C0); Inc(i); end
      else
        begin
          if c <= $FFFF then
            begin s[i] := AnsiChar(c shr 12 or $E0); Inc(i); end
          else
            begin
              s[i] := AnsiChar(c shr 18 or $F0); Inc(i);
              s[i] := AnsiChar(c shr 12 and $3F or $80); Inc(i);
            end;
          s[i] := AnsiChar(c shr 6 and $3F or $80); Inc(i);
        end;
      s[i] := AnsiChar(c and $3F or $80); Inc(i);
    end;
end;

procedure U8_APPEND(const s: PUtf8Char; var i: NativeInt; const Capacity: NativeInt; const c: UCS4Char; var isError: Boolean);
begin
  if c <= $7F then
    begin
      s[i + 0] := AnsiChar(c);
      Inc(i);
    end
  else if (c <= $7FF) and (i + 1 < Capacity) then
    begin
      s[i + 0] := AnsiChar((c shr 6) or $C0);
      s[i + 1] := AnsiChar((c and $3F) or $80);
      Inc(i, 2);
    end
  else if ((c <= $D7FF) or ($E000 <= c) and (c <= $FFFF)) and (i + 2 < Capacity) then
    begin
      s[i + 0] := AnsiChar((c shr 12) or $E0);
      s[i + 1] := AnsiChar(((c shr 6) and $3F) or $80);
      s[i + 2] := AnsiChar((c and $3F) or $80);
      Inc(i, 3);
    end
  else if ($FFFF < c) and (c <= $10FFFF) and (i + 3 < Capacity) then
    begin
      s[i + 0] := AnsiChar((c shr 18) or $F0);
      s[i + 1] := AnsiChar(((c shr 12) and $3F) or $80);
      s[i + 2] := AnsiChar(((c shr 6) and $3F) or $80);
      s[i + 3] := AnsiChar((c and $3F) or $80);
      Inc(i, 4);
    end
  else
    isError := True;
end;

function U16_IS_SINGLE(const c: UCS4Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}
begin
  Result := not U16_IS_SURROGATE(c);
end;

function U16_IS_LEAD(const c: WideChar): Boolean;
begin
  Result := Ord(c) and $FC00 = $D800;
end;

function U16_IS_LEAD(const c: UCS4Char): Boolean;
begin
  Result := c and $FFFFFC00 = $D800;
end;

function U16_IS_TRAIL(const c: WideChar): Boolean;
begin
  Result := Ord(c) and $FC00 = $DC00;
end;

function U16_IS_TRAIL(const c: UCS4Char): Boolean;
begin
  Result := c and $FFFFFC00 = $DC00;
end;

function U16_IS_SURROGATE(const c: WideChar): Boolean;
begin
  Result := Ord(c) and $F800 = $D800;
end;

function U16_IS_SURROGATE(const c: UCS4Char): Boolean;
begin
  Result := c and $FFFFF800 = $D800;
end;

function U16_IS_SURROGATE_LEAD(const c: WideChar): Boolean;
begin
  Result := Ord(c) and $400 = 0;
end;

function U16_IS_SURROGATE_LEAD(const c: UCS4Char): Boolean;
begin
  Result := c and $400 = 0;
end;

function U16_IS_SURROGATE_TRAIL(const c: WideChar): Boolean;
begin
  Result := Ord(c) and $400 <> 0;
end;

function U16_IS_SURROGATE_TRAIL(const c: UCS4Char): Boolean;
begin
  Result := c and $400 <> 0;
end;

function U16_GET_SUPPLEMENTARY(const lead: WideChar; const trail: UCS4Char): UCS4Char;
begin
  Result := Ord(lead) shl 10 + trail - U16_SURROGATE_OFFSET;
end;

function U16_GET_SUPPLEMENTARY(const lead: UCS4Char; const trail: WideChar): UCS4Char;
begin
  Result := lead shl 10 + Ord(trail) - U16_SURROGATE_OFFSET;
end;

function U16_GET_SUPPLEMENTARY(const lead: UCS4Char; const trail: UCS4Char): UCS4Char;
begin
  Result := lead shl 10 + trail - U16_SURROGATE_OFFSET;
end;

function U16_LENGTH(const c: UCS4Char): ShortInt;
begin
  Result := 1 + Ord(c > UCHAR_MAX_BMP_VALUE);
end;

function U16_LENGTH_OR_FFFD(const c: UCS4Char): ShortInt;
begin
  Result := 1 + Ord((c > UCHAR_MAX_BMP_VALUE) and (c <= UCHAR_MAX_VALUE));
end;

function U16_GET_OR_FFFD(const s: PWideChar; const Start: NativeInt; const i: NativeInt; const Length: NativeInt): UCS4Char;
var
  c2: WideChar;
begin
  Result := Ord(s[i]);
  if U16_IS_SURROGATE(Result) then
    begin
      if U16_IS_SURROGATE_LEAD(Result) then
        begin
          if (i + 1 <> Length) then
            begin
              c2 := s[i + 1];
              if U16_IS_TRAIL(c2) then
                begin Result := U16_GET_SUPPLEMENTARY(Result, c2); Exit; end;
            end;
        end
      else
        if i > Start then
          begin
            c2 := s[i - 1];
            if U16_IS_LEAD(c2) then
              begin Result := U16_GET_SUPPLEMENTARY(c2, Result); Exit; end;
          end;
      Result := $FFFD;
    end;
end;

function U16_NEXT_INC(const s: PWideChar; var i: NativeInt; const Length: NativeInt): UCS4Char;
begin
  Result := Ord(s[i]); Inc(i);
  if U16_IS_LEAD(Result) and (i <> Length) and U16_IS_TRAIL(s[i]) then
    begin
      Result := U16_GET_SUPPLEMENTARY(Result, s[i]);
      Inc(i);
    end;
end;

{$IFOPT Q+}{$DEFINE Q_enabled}{$ENDIF}
{$IFDEF CPUX64}{$Q-}{$ENDIF CPUX64}

function U16_NEXT_OR_FFFD_INC(const s: PWideChar; var i: NativeInt; const Length: NativeInt): UCS4Char;
begin
  Inc(i, U16_NEXT_OR_FFFD(s, i, Length, Result));
end;

{$IFDEF Q_enabled}{$Q+}{$ENDIf}

function U16_NEXT_OR_FFFD(const s: PWideChar; const i: NativeInt; const Length: NativeInt): UCS4Char;
begin
  Result := Ord(s[i]);
  if U16_IS_SURROGATE(Result) then
    begin
      if U16_IS_SURROGATE_LEAD(Result) and (i + 1 <> Length) and U16_IS_TRAIL(s[i + 1]) then
        Result := U16_GET_SUPPLEMENTARY(Result, s[i + 1])
      else
        Result := $FFFD;
    end;
end;

function U16_NEXT_OR_FFFD(const s: PWideChar; const i: NativeInt; const Length: NativeInt; out c: UCS4Char): ShortInt;
begin
  c := Ord(s[i]); Result := 1;
  if U16_IS_SURROGATE(c) then
    begin
      if U16_IS_SURROGATE_LEAD(c) and (i + 1 <> Length) and U16_IS_TRAIL(s[i + 1]) then
        begin
          c := U16_GET_SUPPLEMENTARY(c, s[i + 1]);
          Inc(Result);
        end
      else
        c := $FFFD;
    end;
end;

procedure U16_APPEND_INC_UNSAFE(const s: PWideChar; var i: NativeInt; const c: UCS4Char);
begin
  Inc(i, U16_APPEND_UNSAFE(s, i, c));
end;

function U16_APPEND_UNSAFE(const s: PWideChar; const i: NativeInt; const c: UCS4Char): ShortInt;
begin
  if c <= UCHAR_MAX_BMP_VALUE then
    begin
      s[i] := WideChar(c);
      Result := 1;
    end
  else
    begin
      s[i] := WideChar(c shr 10 + $D7C0);
      s[i + 1] := WideChar(c and $03FF or $0DC00);
      Result := 2;
    end;
end;

function U16_APPEND_OR_FFFD_UNSAFE(const s: PWideChar; const i: NativeInt; const c: UCS4Char): ShortInt;
begin
  if c <= UCHAR_MAX_BMP_VALUE then
    begin
      s[i] := WideChar(c);
      Result := 1;
    end
  else
    if c <= UCHAR_MAX_VALUE then
      begin
        s[i] := WideChar(c shr 10 + $D7C0);
        s[i + 1] := WideChar(c and $03FF or $0DC00);
        Result := 2;
      end
    else
      begin
        s[i] := #$FFFD;
        Result := 1;
      end;
end;

procedure U16_APPEND_OR_FFFD_INC_UNSAFE(const s: PWideChar; var i: NativeInt; const c: UCS4Char);
begin
  Inc(i, U16_APPEND_OR_FFFD_UNSAFE(s, i, c));
end;

procedure U16_PUT_UNSAFE(const s: PWideChar; const i: NativeInt; const c: UCS4Char);
begin
  if c <= UCHAR_MAX_BMP_VALUE then
    s[i] := WideChar(c)
  else
    begin
      s[i] := WideChar(c shr 10 + $D7C0);
      s[i + 1] := WideChar(c and $03FF or $0DC00);
    end;
end;

procedure U16_PUT_OR_FFFD_UNSAFE(const s: PWideChar; const i: NativeInt; const c: UCS4Char);
begin
  if c <= UCHAR_MAX_BMP_VALUE then
    s[i] := WideChar(c)
  else
    if c <= UCHAR_MAX_VALUE then
      begin
        s[i] := WideChar(c shr 10 + $D7C0);
        s[i + 1] := WideChar(c and $03FF or $0DC00);
      end
    else
      s[i] := #$FFFD;
end;

procedure U16_FWD_1(const s: PWideChar; var i: NativeInt; const Length: NativeInt);
var
  c: WideChar;
begin
  c := s[i]; Inc(i);
  if U16_IS_LEAD(c) and (i <> Length) and U16_IS_TRAIL(s[i]) then
    Inc(i);
end;

procedure U16_SET_CP_START(const s: PWideChar; const Start: NativeInt; var i: NativeInt);
begin
  if U16_IS_TRAIL(s[i]) and (i > Start) and U16_IS_LEAD(s[i - 1]) then
    Dec(i);
end;

function U16_PREV_OR_FFFD(const s: PWideChar; const Start: NativeInt; const i: NativeInt): UCS4Char;
begin
  Result := Ord(s[i - 1]);
  if U16_IS_SURROGATE(Result) then
    if U16_IS_SURROGATE_TRAIL(Result) and (i > Start) and U16_IS_LEAD(s[i - 2]) then
      begin Result := U16_GET_SUPPLEMENTARY(s[i - 2], Result); end
    else
      Result := $FFFD;
end;

function U16_PREV_OR_FFFD(const s: PWideChar; const Start: NativeInt; const i: NativeInt; out c: UCS4Char): ShortInt;
begin
  Result := 1;
  c := Ord(s[i - 1]);
  if U16_IS_SURROGATE(c) then
    if U16_IS_SURROGATE_TRAIL(c) and (i > Start) and U16_IS_LEAD(s[i - 2]) then
      begin c := U16_GET_SUPPLEMENTARY(s[i - 2], c); Inc(Result); end
    else
      c := $FFFD;
end;

function U16_PREV_OR_FFFD_DEC(const s: PWideChar; const Start: NativeInt; var i: NativeInt): UCS4Char;
begin
  Dec(i, U16_PREV_OR_FFFD(s, Start, i, Result));
end;

procedure U16_BACK_1(const s: PWideChar; const Start: NativeInt; var i: NativeInt);
begin
  Dec(i);
  if U16_IS_TRAIL(s[i]) and (i > Start) and U16_IS_LEAD(s[i - 1]) then
    Dec(i);
end;

procedure U16_SET_CP_LIMIT(const s: PWideChar; const Start: NativeInt; var i: NativeInt; const Length: NativeInt);
begin
  if (i > Start) and ((i < Length) or (Length < 0)) and U16_IS_LEAD(s[i - 1]) and U16_IS_TRAIL(s[i]) then
    Inc(i);
end;

function ReadUcs4_Utf16_LE(p: Pointer; l: NativeInt; out c: UCS4Char): ShortInt;
var
  c1, c2: UCS4Char;
begin
  if l >= 2 then
    begin
      c1 := PWords(p)^.w1;
      case c1 of
        $D800..$DBFF:
          if l >= 4 then
            begin
              c2 := PWords(p)^.w2;
              case c2 of
                $DC00..$DFFF:
                  begin
                    c := U16_GET_SUPPLEMENTARY(c1, c2);
                    Result := 4;
                  end;
              else
                Result := -3;
              end;
            end
          else
            Result := -4;
        $DC00..$DFFF:
          Result := -1;
      else
        c := c1;
        Result := 2;
      end;
    end
  else
    Result := -2;
end;

function UcpToUnicodeString(const c: UCS4Char): UnicodeString;
var
  l: ShortInt;
begin
  l := WriteUcs4_Utf16_LE(c, nil, 0);
  if l = 0 then
    begin Result := ''; Exit; end;

  Assert(l < 0);
  l := -l;

  SetString(Result, nil, l div SizeOf(Result[1]));
  {$IFOPT C+}l := {$ENDIF}WriteUcs4_Utf16_LE(c, Pointer(Result), l);
  Assert(l > 0);
end;

function WriteUcs4_Utf8(c: UCS4Char; p: Pointer; l: NativeInt): ShortInt;

{$DEFINE RFC_3629}

label
  1, 2, 3, 4{$IFNDEF RFC_3629}, 5{$ENDIF};
const
  FIRST_BYTE_MARK: array[1..4{$IFNDEF RFC_3629} + 2{$ENDIF}] of Byte = (
    $00, $C0, $E0, $F0{$IFNDEF RFC_3629}, $F8, $FC{$ENDIF});
begin
  Assert(Assigned(p) or (l <= 0));

  if c < $80 then
    Result := 1
  else if c <= $7FF then
    Result := 2
  else if c <= $FFFF then
    Result := 3
  else if c <= {$IFDEF RFC_3629}$10FFFF{$ELSE}$1FFFF{$ENDIF} then
    Result := 4
      {$IFNDEF RFC_3629}
  else if c < $3FFFFFF then
    Result := 5
  else if c <= $7FFFFFFF then
    Result := 6
      {$ENDIF ~RFC_3629}
  else begin Result := 0; Exit; end;

  if Result > l then
    begin Result := -Result; Exit; end;

  case Result of
    1: goto 1; 2: goto 2; 3: goto 3; {$IFNDEF RFC_3629}4: goto 4; 5: goto 5; {$ENDIF}
  end;

  {$IFNDEF RFC_3629}
  PBytes(p)^.b6 := (c or $80) and $BF; c := c shr 6;
  5: PBytes(p)^.b5 := (c or $80) and $BF; c := c shr 6;
  4: {$ENDIF ~RFC_3629}
  PBytes(p)^.b4 := (c or $80) and $BF; c := c shr 6;
  3: PBytes(p)^.b3 := (c or $80) and $BF; c := c shr 6;
  2: PBytes(p)^.b2 := (c or $80) and $BF; c := c shr 6;
  1: PBytes(p)^.b1 := c or FIRST_BYTE_MARK[Result];
end;

function WriteUcs4_Utf16_LE(c: UCS4Char; p: Pointer; l: NativeInt): ShortInt;
begin
  Assert(Assigned(p) or (l = 0));

  if not U_IS_SURROGATE(c) then
    if c <= UCHAR_MAX_BMP_VALUE then
      if l >= 2 then
        begin
          PWords(p).w1 := c;
          Result := 2; Exit;
        end
      else
        begin Result := -2; Exit; end
    else
      if c <= UCHAR_MAX_VALUE then
        if l >= 4 then
          begin
            PWords(p).w1 := c shr 10 + $D7C0;
            PWords(p).w2 := c and $3FF or $DC00;
            Result := 4; Exit;
          end
        else
          begin Result := -4; Exit; end;
  Result := 0;
end;

end.

