
       (* ******************************************************** *)
       (*                                                          *)
       (*                          FRAKTUR                         *)
       (*                                                          *)
       (*   A program to convert regular German text to Fraktur.   *)
       (*                                                          *)
       (*   It proved virtually impossible to duplicate the        *)
       (*   fine filligree of this font in an 8 x 8 character.     *)
       (*   The result is only mildly suggestive of the original.  *)
       (*                                                          *)
       (*                 (c)  Donald L. Pavia                     *)
       (*                      1488 Lahti Drive                    *)
       (*                      Bellingham, Wa 98226                *)
       (*                      November 1986                       *)
       (*                                                          *)
       (* ******************************************************** *)

program Fraktur;

type str80 = string[80];
     CharSet = set of char;

var  Wait : char;

{----------------------------------------------------------------------------}
const Fraktur : array[1..1024] of byte =
   ( 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     234,164,164,164,36,76,118,0,76,178,162,172,162,34,124,128,
     58,76,144,144,144,98,60,0,120,132,162,34,34,68,184,128,
     58,76,144,156,144,98,60,0,102,156,144,28,80,144,224,0,
     58,76,144,148,154,98,60,0,112,128,220,118,34,34,204,0,
     122,132,136,74,4,36,24,0,122,132,136,74,4,100,152,0,
     124,152,164,228,56,164,70,0,56,68,68,38,16,80,188,0,
     84,170,106,42,42,42,210,0,88,164,100,36,36,36,196,0,
     120,132,132,68,68,68,184,0,108,146,156,18,18,60,16,16,
     120,132,132,68,68,70,186,0,88,164,100,40,36,36,198,0,
     58,68,128,172,146,66,60,0,98,156,144,80,16,52,72,0,
     204,68,68,68,68,76,54,0,76,178,162,164,162,34,124,128,
     98,170,170,234,42,42,212,0,104,148,16,56,16,82,44,0,
     88,164,98,34,38,26,100,24,112,136,8,48,8,132,120,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,
     56,68,68,68,68,68,56,0,16,48,16,16,16,16,56,0,
     56,68,4,8,16,32,124,0,56,68,4,24,4,68,56,0,
     8,24,40,72,252,8,8,0,124,64,64,120,4,68,56,0,
     56,68,64,120,68,68,56,0,124,4,4,8,16,32,32,0,
     56,68,68,56,68,68,56,0,56,68,68,60,4,68,56,0,
     0,0,48,72,72,72,52,0,64,64,112,72,72,72,48,0,
     0,0,48,72,64,64,48,0,48,8,56,72,72,72,48,0,
     0,0,48,72,112,64,48,0,16,40,32,112,32,32,32,0,
     0,0,48,72,72,56,8,112,32,64,80,104,72,72,72,0,
     32,0,32,32,32,32,16,0,32,0,32,32,32,32,32,64,
     88,32,112,32,32,32,32,0,32,32,32,32,32,32,16,0,
     0,0,168,84,84,84,84,0,0,0,176,72,72,72,72,0,
     0,0,48,72,72,72,48,0,0,128,112,72,72,112,64,64,
     0,0,48,72,72,56,8,8,0,0,176,72,64,64,64,0,
     24,36,32,96,32,32,32,0,32,32,112,32,32,32,16,0,
     0,0,72,72,72,72,52,0,0,128,72,72,72,80,32,0,
     0,128,84,84,84,84,40,0,0,0,80,40,32,48,64,48,
     0,128,72,72,72,56,8,16,0,0,24,4,8,36,68,56,
     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,
     72,0,48,72,72,72,52,0,36,0,228,164,36,76,118,0,
     72,0,48,72,72,72,48,0,72,0,120,132,68,68,184,0,
     72,0,72,72,72,72,52,0,72,0,204,68,68,76,54,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,
     4,8,8,108,154,138,106,2,6,24,12,104,152,136,104,0,
     0,4,56,64,56,68,184,0,48,64,92,196,72,68,68,24,
     64,64,252,68,72,68,68,40,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,80,80,80,80,10,10,10,10,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 );
{----------------------------------------------------------------------------}
procedure UseFrakturFonts;

begin
     memw[$0000:$007E] := seg(Fraktur);
     memw[$0000:$007C] := ofs(Fraktur);

end;
{----------------------------------------------------------------------------}
procedure WriteF (x,y,Colr : integer; Strg : str80);
                                                        { WriteFraktur }
const  Punctuation :
       CharSet =  [' ','.',',',';',':',')',']','-','?','}','/','!','>','_'];

var    i,j : integer; Ch,NextChar : char;

begin  gotoxy (x,y); TextColor (Colr);
       i := 1; j := length(Strg);
       while i <= j do
          begin
              Ch := Strg[i]; if (i <> j) then NextChar := Strg[i+1];

              case Ch of

                 'a' : if (i <> j) and (NextChar = 'e') then     { check for }
                          begin write (#210); i := i+1 end       {  umlauts  }
                       else write (chr(ord('a') + 73));
                 'A' : if (i <> j) and (NextChar = 'e') then
                          begin write (#211); i := i+1 end
                       else write (chr(ord('A') + 65));
                 'o' : if (i <> j) and (NextChar = 'e') then
                          begin write (#212); i := i+1 end
                       else write (chr(ord('o') + 73));
                 'O' : if (i <> j) and (NextChar = 'e') then
                          begin write (#213); i := i+1 end
                       else write (chr(ord('O') + 65));
                 'u' : if (i <> j) and (NextChar = 'e') then
                          begin write (#214); i := i+1 end
                       else write (chr(ord('u') + 73));
                 'U' : if (i <> j) and (NextChar = 'e') then
                          begin write (#215); i := i+1 end
                       else write (chr(ord('U') + 65));

                 'c' : if (i <> j) then                      { special chars }
                         begin
                            if (NextChar = 'h') then                   { ch }
                                  begin write (#220); i := i+1 end
                            else if (NextChar = 'k') then              { ck }
                                  begin write (#221); i := i+1 end
                            else write (chr(ord('c') + 73))
                         end
                       else write (chr(ord('c') + 73));

                 't' : if (i <> j) and (NextChar = 'z') then           { tz }
                          begin write (#224); i := i+1 end
                       else write (chr(ord('t') + 73));
                                                               { ss and ---s }
                 's' : if (i <= j-1) and (Strg[i+1] = 's')
                                       and (Strg[i+2] in Punctuation)
                               then  begin write (#223); i := i + 1  end
                       else if (i < j) and (Strg[i+1] in Punctuation)
                               then write (#222)
                       else if (i <> 1) and (i <> j) and (Strg[i+1] = 's')
                               then begin write (#223); i := i + 1  end
                       else write (chr(ord('s') + 73));

                '"' : if ((i <> j) and (NextChar = '"')) then  { leading      }
                             begin write (#240); i := i+1 end  { quote lowered}
                      else write (#241);                       { signal = ""  }

                else if (Strg[i] in ['a'..'z']) then           { normal chars }
                               write (chr(ord(Strg[i]) + 73))
                else if (Strg[i] in ['A'..'Z'])  then
                             write (chr(ord(Strg[i]) + 65))
                else if (Strg[i] in ['0'..'9'])  then
                             write (chr(ord(Strg[i]) + 112))
                else write (Strg[i]);
              end;

              i := i + 1;
          end;                                              { Whew !!! }
end;
{----------------------------------------------------------------------------}
                                            { a leading quote must be double }
                                            { ae oe ue are umlauted vowels   }
BEGIN  UseFrakturFonts;                     { ch and ck and tz are special   }
       GraphColorMode; Palette (2);         { as are ss and ---s (final)     }

       WriteF (2, 5,1,'Ich moechte dem Badezimmer finden.');
       WriteF (2, 7,1,'Das ist fuer Sie.');
       writeF (2, 9,1,'Die Aeppfeln sind gut.');
       WriteF (2,11,1,'Mein Vater heisst Bill.');
       WriteF (2,13,1,'Sehr gut. Vieviel ist fuenf and zwoelf?');
       WriteF (2,15,1,'""Ja, ja aber iss nicht zuviel!"');
       WriteF (2,17,1,'Eins and sechs sind sieben.');
       WriteF (2,19,1,'Das ist ein Ross');
       WriteF (2,21,1,'Das ist ein Ross.');
       WriteF (2,23,1,'das Essen / fuenf Personen / Satz ');

       read (Kbd,Wait);
       TextMode (c80);
END.

