home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 8 / CDASC08.ISO / NEWS / 554 / AVRIL / UPSDOWN.PAS < prev    next >
Pascal/Delphi Source File  |  1993-10-07  |  3KB  |  102 lines
  1. {─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─
  2. Msg  : 580 of 708
  3. From : David Drzyzga                       1:3612/220.0         25 Apr 93  07:28
  4. To   : Dustin Nulf                         1:124/6304.0
  5. Subj : User defined Character S
  6. ────────────────────────────────────────────────────────────────────────────────
  7.  DN> Is there any way to create or use your own fonts in
  8.  DN> regular text mode with Pascal?
  9.  
  10. Yep. Here's a demo of a routine originally posted by Bernie P and revised by me:}
  11.  
  12. program UpsideDown;
  13. {-upsidedown and backwards text aka redefining the text mode font}
  14. var
  15.   newcharset, oldcharset : array[0..255,1..16] of byte;
  16.   
  17. procedure getoldcharset;
  18. var
  19.   b:byte;
  20.   w:word;
  21. begin
  22.   for b := 0 to 255 do begin
  23.     w := b * 32;
  24.     inline($FA);
  25.     PortW[$3C4] := $0402;
  26.     PortW[$3C4] := $0704;
  27.     PortW[$3CE] := $0204;
  28.     PortW[$3CE] := $0005;
  29.     PortW[$3CE] := $0006;
  30.     Move(Ptr($A000, w)^, oldcharset[b,1], 16);
  31.     PortW[$3C4] := $0302;
  32.     PortW[$3C4] := $0304;
  33.     PortW[$3CE] := $0004;
  34.     PortW[$3CE] := $1005;
  35.     PortW[$3CE] := $0E06;
  36.     inline($FB);
  37.   end;
  38. end;
  39.  
  40. procedure restoreoldcharset;
  41. var
  42.   b:byte;
  43.   w:word;
  44. begin
  45.   for b := 0 to 255 do begin
  46.     w := b * 32;
  47.     inline($FA);
  48.     PortW[$3C4] := $0402;
  49.     PortW[$3C4] := $0704;
  50.     PortW[$3CE] := $0204;
  51.     PortW[$3CE] := $0005;
  52.     PortW[$3CE] := $0006;
  53.     Move(oldcharset[b,1], Ptr($A000, w)^, 16);
  54.     PortW[$3C4] := $0302;
  55.     PortW[$3C4] := $0304;
  56.     PortW[$3CE] := $0004;
  57.     PortW[$3CE] := $1005;
  58.     PortW[$3CE] := $0E06;
  59.     inline($FB);
  60.   end;
  61. end;
  62.  
  63. procedure setasciichar(charnum : byte; var data);
  64. var
  65.    offset : Word;
  66. begin
  67.   offset := charNum * 32;
  68.   inline($FA);
  69.   PortW[$3C4] := $0402;
  70.   PortW[$3C4] := $0704;
  71.   PortW[$3CE] := $0204;
  72.   PortW[$3CE] := $0005;
  73.   PortW[$3CE] := $0006;
  74.   Move(data, Ptr($A000, offset)^, 16);
  75.   PortW[$3C4] := $0302;
  76.   PortW[$3C4] := $0304;
  77.   PortW[$3CE] := $0004;
  78.   PortW[$3CE] := $1005;
  79.   PortW[$3CE] := $0E06;
  80.   inline($FB);
  81. end;
  82.  
  83. procedure newwriteln(s:string);
  84.  {- Reverses order of characters written}
  85. var
  86.   b : byte;
  87. begin
  88.   for b := length(s) downto 1 do write(s[b]);writeln;
  89. end;
  90.  
  91. var
  92.   b,c : byte;
  93.  
  94. begin
  95.   getoldcharset;
  96.   for b := 0 to 255 do
  97.     for c := 1 to 16 do newcharset[b, c] := oldcharset[b,(17-c)];
  98.   for b := 0 to 255 do setasciichar(b,newcharset[b,1]);
  99.   newwriteln('Hello World!');
  100.   readln;
  101.   restoreoldcharset;
  102. end.