home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / fonts / tpfont / newlores.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-04-24  |  17.4 KB  |  420 lines
  1.  
  2. program CGALoRes;
  3. uses crt, turbo3, graph3;
  4. (*--------------------------------------------------------------------------*)
  5. (*                                                                          *)
  6. (*          This low resolution graphics mode provides resolution           *)
  7. (*          of 160 horizontal by 100 vertical pixels in 16 colors.          *)
  8. (*          This mode is not directly supported by the IBM PC BIOS,         *)
  9. (*          special programming of the CRT registers is required.           *)
  10. (*          The PCjr has a similar 160x200 standard graph mode.             *)
  11. (*                                                                          *)
  12. (*          This new version incorporates the ability to write              *)
  13. (*          alphanumeric text using both the low and high ascii             *)
  14. (*          character maps that are standard in the rom of an IBM           *)
  15. (*          PCjr. The PC does not have the high set in rom and it           *)
  16. (*          must either be hard-coded or read from disk. I created          *)
  17. (*          both disk files ( LO_ASCII.FNT and HI_ASCII.FNT ) by            *)
  18. (*          copying them from the rom of an IBM PCjr. Procedures to         *)
  19. (*          blank the screen and disable blink were also included.          *)
  20. (*                                                                          *)
  21. (*          The plot and draw routines are originally by Philip Burns       *)
  22. (*          ( see PC SIG Turbo Disk No. 7 (#427) for PIBLORES.PAS )         *)
  23. (*          and the CRT controller re-programming comes from an article     *)
  24. (*          (using Basic) by Bernie Lawrence in  PC WORLD (Apr 1985).       *)
  25. (*          Philip asked for a routine to do text - here it is.             *)
  26. (*          I took some liberties in rewriting and shortening the           *)
  27. (*          previous programs. This new program will run on a PCjr.         *)
  28. (*          It will run on a CGA, but not an EGA which does not use a       *)
  29. (*          6845 CRT controller chip. This is not a very portable routine.  *)
  30. (*                                                                          *)
  31. (*    With the Color Graphics Adapter            Donald L. Pavia            *)
  32. (*    a satisfactory solution to the             Dept. of Chemistry - WWU   *)
  33. (*    the problem of snow remains to be          Bellingham, WA.  98225     *)
  34. (*    solved. I used a 2nd graphics              January 1986               *)
  35. (*    page here to avoid the problem.                                       *)
  36. (*    Snow is no problem on the PCjr.                                       *)
  37. (*--------------------------------------------------------------------------*)
  38.  
  39. const ColorSeg  = $B800; ColorOfs  = $0000;
  40.  
  41.       ModeReg    = $3D8; ColorReg  = $3D9;               { control registers }
  42.  
  43.       ModeSave   = $465; ColorSave = $466;       { BIOS saves registers here }
  44.  
  45.       CRTReg     = $3D4; CRTData   = $3D5;   { 6845 CRT controller registers }
  46.  
  47.       RetraceReg = $3DA; PCjrVGA   = $3DA;     {   vertical retrace register }
  48.                                                {   video gate array for PCjr }
  49.       HiResMode  = 1;    VideoMode = 8;        { lores is form of 80x25 text }
  50.  
  51.       OffSet     = 0;
  52.  
  53.       RegData : array[0..11] of integer               { 6845 register data  }
  54.  
  55.              = ( 113,              (* Horizontal total          *)
  56.                  80,               (* Horizontal displayed      *)
  57.                  90,               (* Horizontal sync position  *)
  58.                  10,               (* Horizontal sync width     *)
  59.                  127,              (* Vertical total            *)
  60.                  6,                (* Vertical adjust           *)
  61.                  100,              (* Vertical displayed        *)
  62.                  112,              (* Vertical sync position    *)
  63.                  2,                (* Non-interlace mode        *)
  64.                  1,                (* Maximum scan line address *)
  65.                  32,               (* Disable cursor display    *)
  66.                  0    );           (* Cursor end                *)
  67.  
  68. type  str20 = string[20];
  69.       ScreenType = array[0..16383] of byte;
  70.       ScreenPointer = ^ScreenType;
  71.       ScreenFile = file of ScreenType;
  72.  
  73. var   Register,Mode,Current : integer;
  74.       i,PixCol,Color,X,Y,T  : integer;
  75.       ColorScreen  : ScreenType absolute $B800:$0000;
  76.       ScreenBuffer : ScreenType;
  77.       LoFonts,HiFonts : array[1..1024] of byte;   { in an IBM you could have }
  78.       CRTStatus : byte; Wait : char;              { an absolute address for  }
  79.       Screen : ScreenPointer;                     { LoFonts, rather than     }
  80.                                                   { loading it from disk     }
  81. {----------------------------------------------------------------------------}
  82. procedure SaveScreen (FileName : str20);
  83.  
  84.   var  FileToSave : ScreenFile;
  85.  
  86.   begin
  87.        Screen := ptr (ColorSeg,ColorOfs);
  88.        assign (FileToSave,FileName);
  89.        rewrite (FileToSave);
  90.        write (FileToSave,Screen^);
  91.        close (FileToSave);
  92.   end;
  93. {----------------------------------------------------------------------------}
  94. procedure LoadScreen (FileName : str20);
  95.  
  96.   var  DisplayFile : ScreenFile;
  97.  
  98.   begin
  99.        Screen := ptr (ColorSeg,Offset);
  100.        assign (DisplayFile,FileName);
  101.        reset (DisplayFile);
  102.        read (DisplayFile,Screen^);
  103.        close (DisplayFile);
  104.   end;
  105. {----------------------------------------------------------------------------}
  106. procedure AwaitVRetrace;                         { to eliminate snow on CGA }
  107.  
  108. begin
  109.      repeat CRTStatus := Port[RetraceReg]; until ((CRTStatus and 8) = 0);
  110.  
  111.      while ((CRTStatus and 8) = 0) do CRTStatus := Port[RetraceReg];
  112. end;
  113. {----------------------------------------------------------------------------}
  114. procedure BlankScreen;                                       { turn off CRT }
  115.  
  116. begin  MemW[CSeg : ModeSave] := Mode;  Port[ModeReg] := Mode and $F7;  end;
  117.  
  118. {----------------------------------------------------------------------------}
  119. procedure RestoreScreen;                                     { turn on  CRT }
  120.  
  121. begin  MemW[CSeg : ModeSave] := Mode;  Port[ModeReg] := Mode or $08;   end;
  122.  
  123. {----------------------------------------------------------------------------}
  124. procedure ClrLoResScreen;                   (*   byte = { **B* ***F }   *)
  125.                                             (*    sum of *'s = 222      *)
  126. begin FillChar (ColorScreen ,16383,0);
  127.       for i := 0 to 7999 do ColorScreen[2*i] := 222;
  128. end;
  129. {----------------------------------------------------------------------------}
  130. procedure ClrLoResBuff;                         { clear the screen buffer }
  131.  
  132. begin FillChar (ScreenBuffer,16383,0);
  133.       for i := 0 to 7999 do ScreenBuffer[2*i] := 222;
  134. end;
  135. {----------------------------------------------------------------------------}
  136. procedure Show;               { transfer to screen in bursts to prevent snow }
  137.                               { 50 x 320 + 384 = 16384  might be safer than  }
  138. var   i,k : integer;          { the currently used  40 x 400 + 384  combo    }
  139.  
  140. begin
  141.       if mem[$F000:$FFFE] = $FD then move (ScreenBuffer,ColorScreen,16383)
  142.  
  143.       else
  144.            begin k := 0;
  145.                  for i := 1 to 40 do begin
  146.                     AwaitVRetrace;
  147.                     move (ScreenBuffer[k],ColorScreen[k],400);
  148.                     k := k + 400;
  149.                  end;
  150.                  AwaitVRetrace;
  151.                  move (ScreenBuffer[k],ColorScreen[k],384);
  152.            end;
  153. end;
  154. {----------------------------------------------------------------------------}
  155. procedure DisableBlink;         { the earlier version did NOT have 16 colors }
  156.                                 { the blink bit must be disabled for that.   }
  157.                                 { Enable it again to see the difference.     }
  158. begin
  159.       if mem[$F000:$FFFE] = $FD then                                 { PCjr }
  160.         begin Port[PCjrVGA] := 3; Port[PCjrVGA] := 0; end
  161.       else begin                                                       { PC }
  162.             Current := mem[$0000:$465]; Port[$03D8] := Current and $DF;
  163.       end;
  164. end;
  165. {----------------------------------------------------------------------------}
  166. procedure LoResGraphMode;                         { set lores graphics mode }
  167.  
  168. begin
  169.       Mode := HiResMode + VideoMode;
  170.       MemW[CSeg : ModeSave] := Mode; Port[ModeReg] := Mode;
  171.  
  172.       for Register := 0 TO 11 do                 { reprogram 6845 for lores }
  173.         begin
  174.            Port[CrtReg]  := Register; Port[CrtData] := RegData[Register];
  175.         end;
  176.  
  177.       DisableBlink;
  178.  
  179.       BlankScreen;                          { to prevent display of garbage }
  180.       ClrLoResScreen;
  181.       RestoreScreen;
  182.  
  183. end;  { LoResGraphMode }
  184. {----------------------------------------------------------------------------}
  185. procedure LoResPlot (X,Y,PixCol : integer);        { plots to hidden screen }
  186.                                                    { to avoid snow          }
  187.  
  188.                              { Plots point in low-resolution graphics mode  }
  189.                              { X      -- Horizontal postion (0 through 159) }
  190.                              { Y      -- Vertical position (0 through 119)  }
  191.                              { PixCol -- Color (0 through 15) of point      }
  192.                              {         calls outside range are ignored      }
  193.  
  194. var  Pixel,PixelAddr,Nibble : integer;
  195.      Legal: boolean;
  196.  
  197. begin
  198.      Legal := (x >= 0) and (x <= 159) and (y >= 0) and (y <= 119) and
  199.                                         (PixCol >= 0) and (PixCol <= 15);
  200.      if Legal then
  201.         begin
  202.              Pixel      := X + ( Y * 160 );
  203.              PixelAddr  := ( Pixel and $FFFE ) + 1;
  204.              Nibble     := Pixel mod 2;
  205.  
  206.             { AwaitVRetrace; }     { works great, but really slows output ! }
  207.                                    { to see, remove SHOW's in main program }
  208.                                    { and change ScreenBuffer to ColorScreen }
  209.                                    { in this procedure                      }
  210.              if Nibble = 0 then
  211.                 ScreenBuffer[PixelAddr] :=
  212.                        ( ScreenBuffer[PixelAddr] and $0F ) + PixCol * 16
  213.              else
  214.                 ScreenBuffer[PixelAddr] :=
  215.                        ( ScreenBuffer[PixelAddr] and $F0 ) + PixCol;
  216.         end;
  217.  
  218. end;   { LoResPlot }
  219. {----------------------------------------------------------------------------}
  220. procedure LoResDraw (X1,Y1,X2,Y2,LineCol : integer);
  221.  
  222. var  X,Y,Xinc,Yinc,CorrecInc :  integer;  Dx,Cdx,Dy,Cdy : integer;
  223.      Plotit: boolean;
  224.  
  225. begin
  226.       X  := X1; Y  := Y1;                { starting point }
  227.  
  228.       Dx := X2 - X1; Dy := Y2 - Y1;      { changes in (x,y) directions }
  229.  
  230.                                          { set increments }
  231.  
  232.       if Dx > 0 then Xinc := 1 else  begin Xinc := -1; Dx := -Dx;  end;
  233.       if Dy > 0 then Yinc := 1 else  begin Yinc := -1; Dy := -Dy;  end;
  234.  
  235.                                          { CorrecInc is correction value }
  236.  
  237.       if Dy > Dx then CorrecInc := Dy else CorrecInc := Dx;
  238.  
  239.       Cdx := CorrecInc; Cdy := CorrecInc;
  240.  
  241.       LoResPlot( X, Y, LineCol );           { plot first point }
  242.  
  243.       while ( (X <> X2) and (Y <> Y2)) do   { plot remaining points }
  244.         begin
  245.              PlotIt := false; Cdx := Cdx - Dx;
  246.  
  247.              if Cdx < 0 then
  248.                begin
  249.                     PlotIt := true; X := X + Xinc; Cdx := Cdx + CorrecInc;
  250.                end;
  251.  
  252.              Cdy := Cdy - Dy;
  253.  
  254.              if Cdy < 0 then
  255.                begin
  256.                     PlotIt := true; Y := Y + Yinc; Cdy := Cdy + CorrecInc;
  257.                end;
  258.  
  259.              if PlotIt then LoResPlot( X, Y, LineCol );
  260.         end;
  261.  
  262. end;  { LoResDraw }
  263. {----------------------------------------------------------------------------}
  264. function BitSet (InByte : byte; WhichBit : integer) : boolean;
  265.  
  266. begin if ((InByte div WhichBit) mod 2) = 1 then BitSet := true
  267.                                            else BitSet := false;
  268. end;
  269. {----------------------------------------------------------------------------}
  270. procedure LoResChar (CharNum,x,y,color : integer);
  271.  
  272. var  Index,i,xx,yy : integer; InByte : byte;
  273.  
  274. begin
  275.      if CharNum < 128 then Index := (CharNum * 8)
  276.                       else Index := ((CharNum - 128) * 8);
  277.      xx := x - 8; yy := y - 8;
  278.  
  279.      for i := 1 to 8 do begin
  280.  
  281.           if CharNum < 128 then InByte := LoFonts[Index+i]
  282.                            else InByte := HiFonts[Index+i];
  283.  
  284.           if BitSet (InByte,128) then LoResPlot (xx+1,yy+i,Color);
  285.           if BitSet (InByte, 64) then LoResPlot (xx+2,yy+i,Color);
  286.           if BitSet (InByte, 32) then LoResPlot (xx+3,yy+i,Color);
  287.           if BitSet (InByte, 16) then LoResPlot (xx+4,yy+i,Color);
  288.           if BitSet (InByte,  8) then LoResPlot (xx+5,yy+i,Color);
  289.           if BitSet (InByte,  4) then LoResPlot (xx+6,yy+i,Color);
  290.           if BitSet (InByte,  2) then LoResPlot (xx+7,yy+i,Color);
  291.           if BitSet (InByte,  1) then LoResPlot (xx+8,yy+i,Color);
  292.      end;
  293.  
  294. end;
  295. {----------------------------------------------------------------------------}
  296. procedure LoResString (DisplayString : str20; col,row,color : integer);
  297.  
  298. var  i,x,y,AsciiNum : integer;
  299.      Valid : boolean;
  300.  
  301. begin
  302.      Valid := (col >= 1) and (col <= 20) and (row >= 1) and (row <= 12);
  303.  
  304.      if Valid then begin
  305.        x := (8 * col) ; y := (8 * row) ;
  306.        for i := 1 to length(DisplayString) do
  307.           begin
  308.              AsciiNum := ord(DisplayString[i]);
  309.              LoResChar (AsciiNum,x,y,color);
  310.              x := x + 8;
  311.           end;
  312.      end;
  313.  
  314. end;
  315. {----------------------------------------------------------------------------}
  316. procedure LoadFonts;              { these files have to be on the disk ! }
  317.                                   { or you can read then from rom if you }
  318. var  FontFile : file;             { have a PCjr. Only the first one is   }
  319.                                   { in rom in a PC.                      }
  320. begin
  321.      assign (FontFile,'LO_ASCII.FNT');
  322.      reset  (FontFile);                       { you could have an absolute }
  323.      BlockRead (FontFile,LoFonts,8);          { address for LoFonts if you }
  324.      close (FontFile);                        { if you have an IBM         }
  325.  
  326.      assign (FontFile,'HI_ASCII.FNT');
  327.      reset  (FontFile);
  328.      BlockRead (FontFile,HiFonts,8);
  329.      close (FontFile);
  330. end;
  331. (*--------------------------------------------------------------------------*)
  332. (*                      NewLoRes --- Main Program                           *)
  333. (*--------------------------------------------------------------------------*)
  334.  
  335. BEGIN  (* program NewLoRes *)
  336.  
  337.       ClrScr; LoadFonts;
  338.       gotoxy (5,5);
  339.       write ('Press the <ENTER> key now to see 160x100 LoRes Graphics ');
  340.       gotoxy (5,7);
  341.       write ('Then press it again after each display.');
  342.       gotoxy (5,9);
  343.       write ('After pressing <ENTER> there will be about a 10 sec wait ');
  344.       gotoxy (5,10); write ('while I set up.  ');
  345.       read (Kbd,Wait);
  346.  
  347.       LoResGraphMode; ClrLoResBuff;
  348.  
  349.       LoResDraw (0,0,100,100,5);
  350.       for i := 0 to 159 do LoResPlot   (i,0,6);
  351.       for i := 0 to  99 do LoResPlot (159,i,2);
  352.       for i := 0 to  99 do LoResPlot   (0,i,3);
  353.       for i := 0 to 159 do LoResPlot  (i,99,4);
  354.       SHOW;
  355.  
  356.       for i := 0 to 7 do
  357.                    LoResString ('16 Colors',i+3,i+1,i);
  358.       SHOW;
  359.  
  360.       LoResString ('NEW',1,5,12);
  361.       LoResString ('VIDEO',1,6,11);
  362.       LoResString ('MODE',1,7,14);
  363.       LoResString ('LOW RES',1,8,9);
  364.       LoResString ('16 COLOR',1,9,10);
  365.       LoResString ('GRAPHICS',1,10,15);
  366.       LoResString ('160x100',1,11,13);
  367.       Delay (1500);
  368.       SHOW;
  369.  
  370.       LoResString ('D.Pavia',3,12,8);
  371.       LoResString ('Jan 86',14,1,8);
  372.       LoResString (#240+#241+#242+#243+#244+#245+#246+#247,12,10,3);
  373.       LoResString (#224+#225+#226+#227+#228+#229,14,12,1);
  374.       Delay (2500);
  375.       SHOW;
  376.  
  377.       read (Kbd,Wait);
  378.       BlankScreen; SaveScreen ('LORES.PIC'); RestoreScreen;
  379.       GraphMode; TextMode (c80); clrscr;
  380.  
  381.       gotoxy (5,5);
  382.       write ('This is TextMode (80x25). But I Saved Your Screen in Memory.');
  383.       gotoxy (5,8); write ('Press <ENTER> to See It.. ');
  384.  
  385.       read (Kbd,Wait); LoResGraphMode;
  386.       SHOW;
  387.  
  388.       read (Kbd,Wait); GraphMode; TextMode (c80); clrscr;
  389.  
  390.       gotoxy (5,5);
  391.       write ('While You are Reading This I am Preparing a New Screen. ');
  392.       write ('Wait Please. ');
  393.  
  394.       ClrLoResBuff;
  395.       for i := 1 to 7 do LoResString ('This is New !',i,i+1,i);
  396.       gotoxy (5,8); write ('READY ...... ');
  397.  
  398.       read (Kbd,Wait); LoResGraphMode;
  399.       SHOW;
  400.  
  401.       read (Kbd,Wait); GraphMode; TextMode (c80); clrscr;
  402.  
  403.       gotoxy (5,5); write ('I also Saved Your Screen on Disk !!!');
  404.       gotoxy (5,8); write ('Press <ENTER> to See ...  ');
  405.  
  406.       read (Kbd,Wait); LoResGraphMode;
  407.  
  408.       BlankScreen; LoadScreen ('LORES.PIC'); RestoreScreen;
  409.  
  410.       read (Kbd,Wait); GraphMode; TextMode( C80 ); clrscr;
  411.       gotoxy (15,10); write ('Thank You for Watching the Show !!!');
  412.       gotoxy (40,14); write ('Donald L. Pavia');
  413.       gotoxy (40,15); write ('January 20, 1986');
  414.       gotoxy (30,24); write ('Press <ENTER> to Quit  ');
  415.  
  416.       read (Kbd,Wait);
  417.       GraphMode; TextMode (c80); clrscr;    { exit gracefully, restore 6845 }
  418.  
  419. END.   (* program CGALoRes *)
  420.