(* ******************************************************** *) (* *) (* 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.