Power-Programmierung/CD1.mdf/pascal/library/dos/grafik/tpmac/showmcpt.pas

Pascal/Delphi Source File | 1994-04-15 | 8.6 KB | 256 lines

Program ShowMacPaint;
{ Display a MacPaint file on the CGA/EGA and hp laserjet .
 Richard Fritzson
 P.O. Box 4033
 Madison WI  53711
 [phone]
 Fido: 121/90 }
{ 5-Minuten-Übertragung nach Turbo7 /jb '94 }

Uses Crt, Dos, Printer, Graph3;

Procedure Document;
Begin
  WriteLn('This program will display a Macintosh MacPaint file on an IBM color');
  WriteLn('graphics adapter in high resolution mode, or, more usefully, on an');
  WriteLn('IBM Enhanced color graphics display/monitor combination and on a');
  WriteLn('Hewlett Packard LaserJet printer.');
  WriteLn('');
  WriteLn('Because of the rectagular aspect ration of the IBM displays, especially');
  WriteLn('the standard CGA, the image will be stretched vertically, but it should');
  WriteLn('give you some idea of what it looks like. The image printed by the');
  WriteLn('HP Laserjet is typically of excellent quality, with a sqaure aspect');
  WriteLn('ratio and superb resolution of fine lines and single dots.');
  WriteLn;
  WriteLn('To just display:       ShowMcPt  <filename>');
  WriteLn('To display and print:  ShowMcPt  <filename> <HP> <dpi>');
  WriteLn('   where HP is just the literal "HP" and <dpi> is the density');
  WriteLn('   desired: 75, 150 or 300 dpi. Default is 75 dpi.');
  WriteLn;
  WriteLn('Richard Fritzson');
  WriteLn('Madison, WI');
  WriteLn('Fidonet: 121/90');
End;


Const
    PathLength = 65;
    BufSize    = 32639;          {This buffer size can be reduced,
                                   to as little as 1023, but it must
                                   remain N*128-1}
    PicStart   = 640;            {Where in the macpaint file does the
                                  raster image begin. In Macbinary
                                  format files, it is 640. In straight files
                                  it is 512. Most BBS posted pictures are
                                  Macbinary.}
Type
    FileName= String[PathLength];

Var
    InFile     : file;           {Input File}
    InFileName : FileName;
                                 {Input File Buffer}
    Picture    : Array[0..BufSize] of byte;
    BytePtr    : Integer;
    ScreenOf   : Word;           {Base of screen bitmap}
    ScreenPtr  : Word;
    Ega        : Boolean;        {Color display type}
    Hp         : Boolean;        {Write to HP or not}
    Offset     : Integer;

{--------------------------------------------------------------------}
Function IMin(X:Integer; Y:Integer): Integer;
Begin
     If X < Y Then IMin := X
     Else          IMin := Y;
End;

{--------------------------------------------------------------------}
Function Crtmode : Integer;      {Return current CRT mode}
Var
   Regs       : Registers;
Begin
     With Regs Do Begin
       Ax := $0F00;
       Intr($10,Regs);
       Crtmode := Lo(Ax);
       End;
End;

{--------------------------------------------------------------------}
Function NextByte: Byte;        {Get next byte from input file}
Var I : Integer;
Begin
     NextByte := Picture[BytePtr];
     BytePtr := BytePtr + 1;
     If BytePtr > BufSize Then Begin
        BytePtr := 0;
        I := imin((BufSize+1) div 128,filesize(infile)-filepos(infile));
        Blockread(infile,Picture,I);
     End;
End;


{--------------------------------------------------------------------}
Procedure CleanUp;
Begin
     TextMode(LastMode);                       {Reset Screen}
     If Hp Then                                {Reset Printer}
        Write(Lst, Chr(27), '*rB', Chr(27), 'E');
     Halt;
End;

{--------------------------------------------------------------------}
Procedure Openfile;
Var I : Integer;
Begin
     InFileName := Paramstr(1);
     Assign(InFile, InFileName);
     {$I-}
     Reset(InFile);
     {$I+}
     If IOresult <> 0 Then Begin
         Writeln('Can not open file: '+InFileName);
         Close(InFile);
         CleanUp;
     End Else Begin
         BytePtr := BufSize;
         I := NextByte;
         BytePtr := PicStart;                     {Skip lead bytes}
     End;
End;

{--------------------------------------------------------------------}
Procedure SetupDisplay;
Var
   Regs       : Registers;
   Dpi        : String[10];
Begin
     Regs.Ax := $0010;    {Make it very high res}
     intr($10,regs);
     If CrtMode = 16 Then Begin
        ScreenOf := $A000;
        Ega := True;
     End Else Begin
          Ega := False;
          HiRes;
          OffSet := 0;
          palette(2);
          hirescolor(0);
          ScreenOf := $B800;
     End;
     If Paramstr(2) <> '' Then Begin
        Hp := True;
        Write(Lst,#27'E');              {Reset Hp}
        Write(Lst,#27'&l1E');           {One line top margin}
        Write(Lst,#27'&l1H');           {Automatic feed}
        Write(Lst,#27'&a50H');          {Offset 50 pixels from}
        Write(Lst,#27'&a+50V');         { both margins}
                                        {Graphics/dpi}
        Dpi := '75';
        If ParamCount > 2 then Dpi := Paramstr(3);
        Write(Lst,#27'*t'+Dpi+'R'#27'*r1A');
     End Else
        Hp := False;
End;

{--------------------------------------------------------------------}
Procedure PaintLine;
  Var
    I          : Integer;
    CharCnt    : Integer;
    Cnt        : Integer;
    B          : Byte;

    Procedure SendByte(X:Byte);
    {This is the procedure to modify for other printers/displays.
     You can direct the output to another disk file if you have a particular
     format in mind, or to other printers.

     I can supply a driver for the XEROX 4045 laser printer, but the quality
     of graphic images on that printer is distinctly inferior to the HP
     Laserjet. For the eight line at a time dot matrix printers you would
     need to buffer bytes here until a full eight lines was available, then
     reorganize and print them.}

    Begin
      If Ega Then Begin                      {Display on screen.}
         Mem[ScreenOf:ScreenPtr] := not X;
         ScreenPtr := ScreenPtr + 1;
      End Else Begin
         Mem[ScreenOf:Offset + ScreenPtr] :=  not X;
         ScreenPtr := ScreenPtr + 1;
         If (screenptr mod 80) = 0 Then Begin
            If Offset = 0 Then begin
               offset := offset + 8192;
               screenptr := screenptr - 80;
            End else begin
               offset := 0;
            End;
         End;
      End;
      If Hp Then Write(Lst,Chr(X));          {Display on hp.}
    End;

    Procedure InitLine;
    Begin
         If Hp Then Write(Lst, chr(27), '*b80W');
    End;

Begin
   {This is the code that deciphers the MacPaint format.}
   If Keypressed Then CleanUp;             {Bailout}
   InitLine;
   Charcnt := 0;                           {MacPaint stores 72 bytes per line}
   While Charcnt < 72 do Begin
      B := NextByte;
      If B > 127 Then Begin                {Repeating Byte Pattern}
         Cnt := 257 - B;
         B := NextByte;
         for I := 1 to Cnt do
             SendByte(B);
      End Else Begin                       {Sequence of Bytes}
         Cnt := B + 1;
         for I := 1 to Cnt do
             SendByte(NextByte);
      End;                                 {End of chunk}
      Charcnt := Charcnt + Cnt;
  End; {of while}
  For I := 1 to 8 Do SendByte(0);          {Fill in 80 column screen}
End;

{--------------------------------------------------------------------}
Var
    I,J        : Integer;
Begin
 If ParamCount = 0 Then Begin
    Document;
    Halt;
 End;
 SetUpDisplay;                                  {EGA Hi Res Mode}
 OpenFile;
 ScreenPtr := 0;
 If Ega Then Begin
        For J := 1 to 350 Do PaintLine;         {Draw first half}
        For J := 1 to  92 Do Begin              {Scroll and draw the rest.
                                                 EGA scroll is 4 lines at
                                                 at time for speed.}
              Move(Mem[ScreenOf:320],Mem[ScreenOf:0],28000-320);
              ScreenPtr := ScreenPtr - 320;
              For I := 1 to 4 Do PaintLine;
        End;
 End Else Begin
        For J := 1 to 200 Do PaintLine;         {Draw first half}
        For J := 1 to 260 Do Begin              {Scroll and draw the rest}
              Move(Mem[ScreenOf:80],Mem[ScreenOf:0],8192-80);
              Move(Mem[ScreenOf:8192+80],Mem[ScreenOf:8192],8192-80);
              ScreenPtr := ScreenPtr - 80;
              PaintLine;
              PaintLine;
        End;
 End;
 Close(Infile);                          {Close file}
 ReadLn;                                 {Wait for CR}
 CleanUp;
End.