Task: UTF-8 encode and decode








VB: Private Function unicode_2_utf8(x As Long) As Byte()
    Dim y() As Byte
    Dim r As Long
    Select Case x
        Case 0 To &H7F
            ReDim y(0)
            y(0) = x
        Case &H80 To &H7FF
            ReDim y(1)
            y(0) = 192 + x \ 64
            y(1) = 128 + x Mod 64
        Case &H800 To &H7FFF
            ReDim y(2)
            y(2) = 128 + x Mod 64
            r = x \ 64
            y(1) = 128 + r Mod 64
            y(0) = 224 + r \ 64
        Case 32768 To 65535 
            ReDim y(2)
            y(2) = 128 + x Mod 64
            r = x \ 64
            y(1) = 128 + r Mod 64
            y(0) = 224 + r \ 64
        Case &H10000 To &H10FFFF
            ReDim y(3)
            y(3) = 128 + x Mod 64
            r = x \ 64
            y(2) = 128 + r Mod 64
            r = r \ 64
            y(1) = 128 + r Mod 64
            y(0) = 240 + r \ 64
        Case Else
            MsgBox "what else?" & x & " " & Hex(x)
    End Select
    unicode_2_utf8 = y
End Function
Private Function utf8_2_unicode(x() As Byte) As Long
    Dim first As Long, second As Long, third As Long, fourth As Long
    Dim total As Long
    Select Case UBound(x) - LBound(x)
        Case 0 
            If x(0) < 128 Then
                total = x(0)
            Else
                MsgBox "highest bit set error"
            End If
        Case 1 
            If x(0) \ 32 = 6 Then
                first = x(0) Mod 32
                If x(1) \ 64 = 2 Then
                    second = x(1) Mod 64
                Else
                    MsgBox "mask error"
                End If
            Else
                MsgBox "leading byte error"
            End If
            total = 64 * first + second
        Case 2 
            If x(0) \ 16 = 14 Then
                first = x(0) Mod 16
                If x(1) \ 64 = 2 Then
                    second = x(1) Mod 64
                    If x(2) \ 64 = 2 Then
                        third = x(2) Mod 64
                    Else
                        MsgBox "mask error last byte"
                    End If
                Else
                    MsgBox "mask error middle byte"
                End If
            Else
                MsgBox "leading byte error"
            End If
                total = 4096 * first + 64 * second + third
        Case 3 
            If x(0) \ 8 = 30 Then
                first = x(0) Mod 8
                If x(1) \ 64 = 2 Then
                    second = x(1) Mod 64
                    If x(2) \ 64 = 2 Then
                        third = x(2) Mod 64
                        If x(3) \ 64 = 2 Then
                            fourth = x(3) Mod 64
                        Else
                            MsgBox "mask error last byte"
                        End If
                    Else
                        MsgBox "mask error third byte"
                    End If
                Else
                    MsgBox "mask error second byte"
                End If
            Else
                MsgBox "mask error leading byte"
            End If
            total = CLng(262144 * first + 4096 * second + 64 * third + fourth)
        Case Else
            MsgBox "more bytes than expected"
        End Select
        utf8_2_unicode = total
End Function
Public Sub program()
    Dim cp As Variant
    Dim r() As Byte, s As String
    cp = [{65, 246, 1046, 8364, 119070}] 
    Debug.Print "ch  unicode  UTF-8 encoded  decoded"
    For Each cpi In cp
        r = unicode_2_utf8(CLng(cpi))
        On Error Resume Next
        s = CStr(Hex(cpi))
        Debug.Print ChrW(cpi); String$(10 - Len(s), " "); s,
        If Err.Number = 5 Then Debug.Print "?"; String$(10 - Len(s), " "); s,
        s = ""
        For Each yz In r
            s = s & CStr(Hex(yz)) & " "
        Next yz
        Debug.Print String$(13 - Len(s), " "); s;
        s = CStr(Hex(utf8_2_unicode(r)))
        Debug.Print String$(8 - Len(s), " "); s
    Next cpi
End Sub




Ada: with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;
with Ada.Integer_Text_IO;
with Ada.Text_IO;
with Ada.Wide_Wide_Text_IO;

procedure UTF8_Encode_And_Decode
is
   package TIO renames Ada.Text_IO;
   package WWTIO renames Ada.Wide_Wide_Text_IO;
   package WWS renames Ada.Strings.UTF_Encoding.Wide_Wide_Strings;

   function To_Hex
     (i : in Integer;
      width : in Natural := 0;
      fill : in Character := '0') return String
   is
      holder : String(1 .. 20);
   begin
      Ada.Integer_Text_IO.Put(holder, i, 16);
      declare
         hex : constant String := holder(Index(holder, "#")+1 .. holder'Last-1);
         filled : String := Natural'Max(width, hex'Length) * fill;
      begin
         filled(filled'Last - hex'Length + 1 .. filled'Last) := hex;
         return filled;
      end;
   end To_Hex;

   input : constant Wide_Wide_String := "AöЖ€𝄞";
begin
   TIO.Put_Line("Character   Unicode    UTF-8 encoding (hex)");
   TIO.Put_Line(43 * '-');
   for WWC of input loop
      WWTIO.Put(WWC & "           ");
      declare
         filled : String := 11 * ' ';
         unicode : constant String := "U+" & To_Hex(Wide_Wide_Character'Pos(WWC), width => 4);
         utf8_string : constant String := WWS.Encode((1 => WWC));
      begin
         filled(filled'First .. filled'First + unicode'Length - 1) := unicode;
         TIO.Put(filled);
         for C of utf8_string loop
            TIO.Put(To_Hex(Character'Pos(C)) & " ");
         end loop;
         TIO.New_Line;
      end;
   end loop;
end UTF8_Encode_And_Decode;