home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / GRAPHICS / MISC / POSTOGRF.ZIP / WRITEPRT.INC < prev   
Encoding:
Text File  |  1990-05-21  |  8.6 KB  |  222 lines
  1. Procedure WritePrt;
  2. var s:string[10]; i:word;
  3.     XPos, Ypos, error, temp1 : integer;
  4.     PenDia, nn               : word;
  5.     str1                     : string80;
  6.     buffPtr                  : FilePtr;
  7.  
  8.    procedure writeescape(var outdev:text; s:string);
  9.    const escapers : set of char = ['(', ')', '\' ];
  10.    var i1:byte;
  11.    begin for i1 := 1 to length(s)
  12.          do begin if s[i1] in escapers then write(outdev, '\', s[i1])
  13.                   else write(outdev, s[i1]);
  14.              end; {do}
  15.    end; {writeEscape}
  16.  
  17.    { write all font generation commands before }
  18.  
  19.     { ---------------------------------------------------------------------
  20.        Generate fonts without duplication.  Add header code for MITRELogo
  21.        font if it will be used.
  22.       ----------------------------------------------------------------------}
  23.     procedure ScanWriteFonts;
  24.     var i3:byte;
  25.     type FontSpec = record
  26.                          TFont: FontList;     {type face - Helv. bold, etc}
  27.                          TSize: integer;      {font size in points}
  28.                          FontStr: string[80]; {string to make fonts}
  29.                          FontNum: integer;    {font ID number}
  30.                       end;
  31.     var Fonts    : array[0..20] of FontSpec;
  32.         TempFont : FontSpec;
  33.           i1, i2 : byte;
  34.           PointSize, fNumStr: string[7];
  35.  
  36.        procedure MakeFontString(var Text: FontSpec);
  37.        begin
  38.           Str(round(1000*(Text.TSize/72)), PointSize);
  39.           Str(Text.FontNum, fNumStr);
  40.           Text.fontStr :=
  41.             '/font' + fNumStr + ' /' + POSTStyleStr[Text.TFont]
  42.             + ' findfont ' + PointSize + ' scalefont def';
  43.        end; {MakeFontString}
  44.  
  45.     { -----------------------------------------------------------------
  46.       delete redundant fonts by scanning all the fonts & replacing them
  47.       by a previously specified font if the same font was requested
  48.       already.
  49.       array Fonts will end up containing one copy of each font specification
  50.       and descriptor string (up to 20 fonts).
  51.       ----------------------------------------------------------------- }
  52.       procedure ScanFonts(var i1, i2:byte);
  53.       { ----------------------------------------------------------------
  54.         Test for match of font temp^ to an entry in Fonts[].  i1 points to
  55.         last entry in Fonts, i2 points to match on return.  If no match,
  56.         i2 = succ(i1) on return.  Test for MITRELogo font & set flag
  57.         if it is called.
  58.         ---------------------------------------------------------------- }
  59.       begin
  60.            i2 := 0;
  61.            with TempFont do begin
  62.                 TFont := temp^.LipsFont.LipsStyle;
  63.                 Tsize := temp^.PrtSize;
  64.            end; {do}
  65.            { ----- scan until style & size match or end of list ----- }
  66.            repeat inc(i2)
  67.            until (i2 > i1) or ((TempFont.TFont = Fonts[i2].TFont) and
  68.                    (TempFont.TSize = Fonts[i2].TSize));
  69.            With TempFont do begin
  70.               FontNum := i2{temp^.LIPSFont.FontNum};
  71.               MakeFontString(TempFont);
  72.               if Tfont = MitreLogo then Lconfig.writeMitreLogo := true;
  73.            end;
  74.       end; {ScanFonts}
  75.  
  76.       procedure CondenseFonts;
  77.       begin
  78.            {i1 points to end of list of fonts in Fonts}
  79.            temp:= head; i1 := 0;
  80.            with Fonts[0] do begin              {initialize Fonts to include}
  81.                 Tfont := HelvBold; TSize := 13; {font1, which will be used}
  82.                 FontStr := JimDefFontStr;       {for GRAPHLI numeric labels}
  83.                 FontNum := 0;
  84.            end; {with}
  85.            repeat
  86.                  ScanFonts(i1, i2);
  87.                  if i2 > i1                         {didn't find this font}
  88.                  then begin Fonts[i2] := TempFont;  {so add it }
  89.                             inc(i1);                {increment pointer}
  90.                       end;
  91.                  temp^.LIPSFont.fontStr := Fonts[i2].FontStr;
  92.                  temp^.LIPSFont.FontNum := Fonts[i2].FontNum;
  93.                  temp := temp^.link;
  94.           until temp = nil;
  95.      end; {condenseFonts}
  96.  
  97.     begin {ScanWriteFonts}
  98.           writeln(PrtFile, '%FontDefinitions');
  99.           writeln(PrtFile, font0str);
  100.           if head = nil then begin              { omit if no labels }
  101.              writeln(PrtFile, '%EndFonts');
  102.              exit;
  103.            end;
  104.           CondenseFonts;
  105.           if LConfig.writeMitreLogo then WriteMitreLogo;
  106.           LConfig.WriteMitreLogo := false;
  107.           for i3 := 1 to i1 do
  108.                 writeln(PrtFile, Fonts[i3].FONTStr);
  109.           writeln(PrtFile, '%EndFonts');
  110.           end; {ScanWriteFonts}
  111.  
  112.     procedure ScanWriteLabels;   { write my labels before Jim's graph stuff }
  113.     begin if head = nil then exit     { no labels}
  114.           else cp := head;
  115.           repeat
  116.                  writeln(PrtFile, 'font', cp^.LIPSFont.FontNum, ' sf');
  117.                  outprconv(cp);
  118.                  writeln(PrtFile, HorizPrinterDots, ' ' ,
  119.                          VertPrinterDots, ' m');
  120.                  write(PrtFile, '(');
  121.                  writeEscape(prtFile,cp^.tstr);
  122.                  write(PrtFile, ')');
  123.                  if cp^.LabelBkGround = trans then
  124.                        if cp^.CurrText.Direction = HorizDir
  125.                          then writeln(PrtFile,' show') else
  126.                          writeln(PrtFile, ' rsho') else
  127.                     if cp^.CurrText.Direction = HorizDir
  128.                        then writeln(PrtFile, ' s')
  129.                        else writeln(PrtFile, ' rs');
  130.                  cp := cp^.link;
  131.           until cp = nil;
  132.     end; {ScanWriteLabels}
  133.  
  134. begin {WritePrt}
  135.      if PrtFileName = '' then exit ; { no file to write to }
  136.      writeln; write('writing output file ', prtFilename);
  137.      {$I-}
  138.      PostHd2;
  139.      ScanWriteFonts;
  140.      writeln(PrtFile, '%%EndProlog');
  141.      PSSetup;
  142.      done := false;
  143.      here := JimFileStart;
  144.      writeln(PrtFile, '%StartGraph');
  145.  
  146.      if not (JimFileblock = 0) then begin
  147.  
  148.      case GraphFile of
  149.         GRAPHL, LIPSGRF: begin
  150.   writeln(PrtFile, 'font0 sf');
  151.   if count > 0 then
  152.   Repeat
  153.      GetAWord(str1);
  154.      if (str1 = 'EXIT') or (str1 = 'PAGE') then begin
  155.                   done := true;
  156.         end ELSE
  157.      {if str1 = 'PAGE' then  writeln(PrtFile, 'showpage') ELSE}
  158.      if str1 = 'MAP' then   { move to position }
  159.         begin GetAWord(str1); Val(str1,Xpos,error); (* *** ADD ERROR CHECKING *)
  160.               GetAWord(str1); Val(str1,Ypos,error);
  161.               OutPrPos(Xpos, YPos);
  162.               writeln(PrtFile, Xpos,' ', YPos, ' m');
  163.         end ELSE
  164.      if str1 = 'DAP' then   { draw to position }
  165.         begin GetAWord(str1); Val(str1,Xpos,error); (* *** ADD ERROR CHECKING *)
  166.               GetAWord(str1); Val(str1,Ypos,error);
  167.               OutPrPos(XPos,YPos);
  168.               writeln(PrtFile,Xpos,' ', YPos, ' l');
  169.               {writeln(PrtFile, 'cpt st m');}
  170.         end ELSE
  171.      if str1 = 'SPD' then        { set pen diameter - only an approximation }
  172.         begin GetAWord(str1); Val(str1,PenDia, error); (* *** ADD ERROR CHECK *)
  173.               PenDia := PenDia * 10 div 3;
  174.               writeln(PrtFile, 'cpt st m');
  175.               writeln(PrtFile, PenDia, ' setlinewidth');
  176.         end ELSE
  177.      if str1 = 'FONT' then       { use font0 for GRAPH-supplied labels }
  178.         begin
  179.               GetAWord(str1);
  180.               if str1 = '3' then
  181.               writeln(PrtFile, 'font0 sf');
  182.         end ELSE
  183.      if str1 = 'TEXT' then    { write the following text string }
  184.         begin
  185.               writeln(PrtFile, 'cpt st m');
  186.               GetAQuote(str1);
  187.               writeln(PrtFile,'(', str1,')', ' show');
  188.         end ELSE (* nothing *);
  189.   until done = true ;
  190.   writeln(PrtFile, '%EndGraph');
  191.   EndGraph := here;
  192.   if GRAPHLIName <> '' then begin
  193.      writeln(PrtFile, 'stroke');
  194.    end;
  195.   end; {case GRAPHL, LIPSGRF}
  196.   POSTSCRIPT: begin
  197.      for nn := StartGraph to EndGraph - 1 do
  198.          write(PrtFile, JimFile^[nn]);
  199.     end; {case POSTSCRIPT}
  200.   end; {case}
  201.  
  202.   end; {if not (Jimfile = nil)}
  203.  
  204.   writeln(PrtFile, '%EndGraph');
  205.   writeln(PrtFile, '%StartLabels');
  206.   if LConfig.DoBar then begin
  207.      writeln(PrtFile, 'dobar'); Lconfig.DoBar := false;
  208.    end;
  209.   ScanWriteLabels;
  210.   writeln(PrtFile, '%EndLabels');
  211.   writeln(PrtFile, PrtExitStr);
  212.   {$I+}
  213.   error := IOResult;
  214.   if error <> 0 then begin
  215.         beboop;
  216.         gotoXY(1,whereY);
  217.         writeln('couldn''t finish writing file ', GRAPHLIName); clrEOL;
  218.         delay(1000);
  219.         fileOK := false;
  220.      end else fileOK := true;
  221. end; {WritePrt}
  222.