home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / GRAPHICS / MISC / POSTOGRF.ZIP / EXTRLABS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-05-21  |  11.7 KB  |  293 lines
  1. { EXTRLABS.pas
  2.   used in POSTOGRF}
  3.  
  4. procedure ExtractLabels;
  5. { types & vars used specifically for Postscript files }
  6. type FontSpec = record
  7.                          TFont: FontList;     {type face - Helv. bold, etc}
  8.                          TSize: integer;      {font size in points}
  9.                          FontNum: string[10]; {font ID number; e.g., 'font3'}
  10.                       end;
  11. var Fonts       : array[0..20] of FontSpec;
  12.     TempFont   : FontSpec;
  13.     FontCounter: word;
  14.  
  15. {LIPSOGRF & general purpose var's}
  16. var counter, Xpos, Ypos, temp, error  : integer;
  17.     s,s1, s2                   : string80;
  18.     done                       : boolean;
  19.     tempstyle                  : Fontlist;
  20.  
  21.     procedure GetFontNum;    { here points to 'FONT' on entry }
  22.     begin if here > JimFileStart
  23.           then begin done := true; exit; end;
  24.           done := false;
  25.           GetaWord(s);
  26.           Val(s,temp,error);
  27.           If temp > FontTotal then FontTotal := temp;
  28.           counter := here;   { save pointer because GetaWord moves it}
  29.     end; {GetFontNum}
  30.  
  31.     procedure GetFontStr(fontnum:integer); { saves & restores here }
  32.     begin if done then exit;
  33.           counter := here; here := 1;
  34.           repeat
  35.                repeat GetaWord(s) until s = 'GENF';
  36.                GetaWord(s);
  37.                Val(s,temp,error);
  38.          until (temp = fontnum) or (here > JimFileStart);
  39.          repeat here := succ(here) until JimFile^[here] in quotes;
  40.          GetaQuote(s);
  41.          str(fontnum, s2);
  42.          Val(s[length(s)],temp,error) ;
  43.          tempstyle := fontlist(temp -1);
  44.                               { convert from CIEFLEX to Postscript font}
  45.          TempText.LIPSFont.LIPSStyle := tempstyle;
  46.          GetaWord(s); Val(s,temp,error);
  47.          if error <>0 then begin GetAWord(s); end;
  48.          TempText.prtSize := temp;
  49.          here := counter;     {restore pointer }
  50.     end; {GetFontStr}
  51.  
  52.     procedure GetLabel ;        { here points to 'FONT' on entry }
  53.     begin if done then exit;     { call this routine right after GetFontNum }
  54.           repeat GetAWord(s) until s = 'MAP';
  55.           GetAWord(s); Val(s,Xpos,error);
  56.           GetAWord(s); Val(s,Ypos,error);
  57.           ScrConv(XPos, YPos);
  58.           TempText.CurrText.Horiz := Xpos;
  59.           TempText.CurrText.Vert := Ypos;
  60.           repeat GetaWord(s) until s = 'TEXT';  { find the label's text }
  61.           GetAQuote(s);                         { get the text }
  62.           TempText.Tstr := s;
  63.           TempText.LabelBkGround := trans;
  64.     end;
  65.  
  66.     (*procedure GetLIPSStyle;       { figure out the CIEFLEX # in TempText }
  67.     var tempstyle: FontList;
  68.     begin tempstyle := SansSerif;
  69.           while LIPSStyleStr[tempstyle] <> s1
  70.                 do tempstyle := succ(tempstyle);
  71.           TempText.LIPSFont.LIPSStyle := tempstyle;
  72.     end;*)
  73.  
  74.    procedure LinkDefaultLabel;      { make label structure & link into list }
  75.    begin AddRec;                    { use this before GetFontNum, etc. }
  76.          SetLabelDefaults(cp);
  77.          SetUpLabel(cp);
  78.          TempText := cp^;           { copy into TempText}
  79.    end;
  80.  
  81.    { ----------------------------------------------------------------------
  82.      Font table format:  an array called Fonts:
  83.                     TFont       (FontList, Helvetica, etc)
  84.        1st font:    TSize       (integer, size in points)
  85.                     FontNum     ('font1', 'font2' , etc)
  86.  
  87.                     TFont
  88.        2nd font:    TSize
  89.                     FontNum
  90.                     ...
  91.      --------------------------------------------------------------------- }
  92.    procedure BuildPSFontTable;      { start with here pointing to font area}
  93.    type fontType = array[1..length('/font')] of char;
  94.         fontTypePtr = ^fontType;
  95.    var f1: fontlist;
  96.        t1, t2, nn: word;
  97.    const fontStrArray : fontType = '/font';
  98.    begin
  99.         s := '';
  100.         font0str := '';
  101.         { ------------------- scan for '/font0' --------------------- }
  102.         while (fontTypePtr(@JimFile^[here])^ <> fontStrArray)
  103.               and (here < EndFonts) do inc(here);
  104.         Getaword(s);
  105.         if s = '/font0' then begin
  106.               t1 := mark;
  107.               repeat GetAWord(s) until s = 'def';
  108.               for nn := t1 to here-1 do font0str := font0str + JimFile^[nn];
  109.               while (font0str[length(font0str)] in [LF, CR]) do
  110.                  delete(font0str,length(font0str),1);
  111.            end
  112.            else begin
  113.               here := mark;
  114.               font0str := defaultFont0str;
  115.            end;
  116.         Fonts[0].FontNum := '0';
  117.         s := font0str; delete(s,1,1);
  118.         delete(s, 1, pos('/',s) );
  119.         f1 := fontlist(0);
  120.            while (s <> POSTStyleStr[f1]) and (f1 <> MitreLogo) do
  121.                  inc(f1);
  122.            if s <> POSTStyleStr[f1] then f1 := HelvBold;
  123.                              {default to HelvBold if not recognized}
  124.         Fonts[0].Tfont := f1;
  125.         t1 := pos(' scalefont',s) ;
  126.         if t1 = 0 then t1 := pos(' sf',s);
  127.         t2 := t1;
  128.         while s[t1] in whitespace do dec(t1); dec(t1);
  129.         while not (s[t1] in whitespace) do dec(t1);
  130.         s := copy(s,t1,t2 - t1);
  131.         val(s, temp, error);
  132.         Fonts[0].Tsize := integer(round(temp*72.0/1000));
  133.  
  134.         FontCounter := 0;
  135.         repeat                        { until '%EndFonts'}
  136.            dec(here); GetaWordBack(s,here);
  137.            while (fontTypePtr(@JimFile^[here])^ <> fontStrArray)
  138.                and (here < EndFonts) do inc(here);
  139.            if here >= EndFonts then exit;
  140.            inc(FontCounter);
  141.            GetaWord(s);               { '/fontxx' }
  142.            Delete(s,1,1);             { change to 'fontxx' }
  143.            Fonts[FontCounter].FontNum := s;
  144.            Repeat GetAWord(s) until s[1] = '/';
  145.                               {should be '/Helvetica-Bold', or similar}
  146.            Delete(s,1,1);
  147.            f1 := fontlist(0);
  148.            while (s <> POSTStyleStr[f1]) and (f1 <> MitreLogo) do
  149.            {repeat}
  150.                  inc(f1);
  151.            {until (s = POSTStyleStr[f1]) or (f1 = MitreLogo);}
  152.            if s <> POSTStyleStr[f1] then f1 := HelvBold;
  153.                              {default to HelvBold if not recognized}
  154.            Fonts[FontCounter].TFont := f1;
  155.            repeat GetAWord(s) until (s = 'scalefont') or (s = 'sf');
  156.            t1 := here-1;
  157.            GetAWordBack(s, t1);
  158.            GetAWordBack(s, t1);       {get font size in 1/1000'2 inch}
  159.            Val(s,temp,error);          {convert to number}
  160.            Fonts[FontCounter].TSize := integer(round(temp*72.0/1000));
  161.            GetAWord(s);
  162.            if s = 'def' then GetAWord(s);
  163.         until here > EndFonts;
  164.    end; {BuildPSFontTable}
  165.  
  166.    { ----------------------------------------------------------------------
  167.      Labels have the following identifying structure:
  168.        fontxx sf                % xx is a number. Might use setfont instead.
  169.        x y m                    % x,y are numbers; could use moveto.
  170.        (text) s                 % text could have embedded or leading spaces,
  171.                                   could use show for s.
  172.  
  173.        If we encounter a label, we can extract the text using
  174.        ParsePSstring(destination, offset), which leaves offset pointing
  175.        just past the string's trailing parenthesis.
  176.      ----------------------------------------------------------------------- }
  177.  
  178.    procedure LookForFontxx;    {gets font style & size}
  179.    type fontType = array[1..length('font')] of char;
  180.         fontTypePtr = ^fontType;
  181.    var t1: word;
  182.    const fontStrArray : fontType = 'font';
  183.    begin
  184.         if here > EndLabels then exit;
  185.         repeat
  186.               GetAWord(s)
  187.         until (s = 'sf') or (s = 'setfont') or (here > EndLabels);
  188.         if here > EndLabels then exit;
  189.         t1 := here-1;
  190.         GetAWordBack(s, t1);
  191.         GetAWordBack(s, t1);
  192.         tempFont.FontNum := s;
  193.         t1 := 0;
  194.         {repeat}
  195.         while (s <> Fonts[t1].FontNum) and (t1 <> FontCounter) do inc(t1);
  196.         {until (s = Fonts[t1].FontNum) or (t1 = FontCounter);}
  197.         tempText.PrtSize := Fonts[t1].TSize;
  198.         tempText.LipsFont.LipsStyle := Fonts[t1].TFont;
  199.    end; {LookForFontxx}
  200.  
  201.    procedure GetPSLabelCoords;
  202.    var t1:word; temphere:word;
  203.    begin
  204.         if here > EndLabels then exit;
  205.         repeat GetAWord(s)
  206.         until (s[1] = '(') or (here > EndLabels);
  207.                             {find start of string to print}
  208.         dec(here);
  209.         repeat GetAWordBack(s,here) until (s = 'm') or (s = 'moveto');
  210.         GetAWordBack(s,here);                  {Y coord}
  211.         val(s,YPos,error);
  212.         if error <> 0 then YPos := 100;       {dumb default if error}
  213.         GetAWordBack(s, here);
  214.         val(s, XPos, error);
  215.         if error <> 0 then XPos := 100;       {same dumb default}
  216.         {convert from Postscript to screen coords }
  217.         PStoScreen(XPos, YPos);
  218.         tempText.CurrText.Horiz := XPos;
  219.         tempText.CurrText.Vert := YPos;
  220.    end; {GetPSLabelCoords}
  221.  
  222.    procedure GetPSLabel;
  223.    var t1:word;
  224.    begin
  225.         if here > EndLabels then exit;
  226.         if s[1] <> '(' then
  227.            repeat                      {find '(' to locate string}
  228.                  GetAWord(s)
  229.            until (s[1] = '(') or (here > EndLabels);
  230.            if here > EndLabels then begin s := ''; exit; end;
  231.         ParsePSstring(s, mark);        {mark points to start of string}
  232.         TempText.Tstr := s;
  233.         here := mark ;
  234.         repeat GetAWord(s) until (s = 's') or (s = 'show')
  235.               or (s = 'rs') or (s = 'rsho');
  236.         if (s = 'show') or (s = 'rsho') then TempText.LabelBkGround := trans
  237.            else TempText.LabelBkGround := opaque;
  238.         if (s = 'rs') or (s = 'rsho')
  239.           then TempText.CurrText.Direction := VertDir
  240.           else TempText.CurrText.Direction := HorizDir;
  241.    end; {GetPSLabel}
  242.  
  243. begin {ExtractLabels}
  244.       if GraphFile = GRAPHL then exit; { no labels to find }
  245.       if GRAPHLIName = '' then exit;
  246.       here := 1;
  247.       cp := nil; head := nil; select := nil; s := '';
  248.       clrscr;
  249.       writeln('looking for existing labels');
  250.       case GraphFile of
  251.          GRAPHL, LIPSGRF:
  252.             while here < JimFileStart do begin
  253.               repeat GetaWord(s) until ((s = 'FONT') or (s = 'EXIT'));
  254.               if here < JimFileStart
  255.               then begin LinkDefaultLabel;
  256.                          GetFontNum;
  257.                          GetLabel;
  258.                          GetFontStr(temp);
  259.                          (*GetLIPSStyle;*)
  260.                          cp^ := TempText;
  261.                    end;
  262.             end; {while}
  263.          POSTSCRIPT: begin
  264.             if FontDefinitions < count then begin
  265.                here := FontDefinitions;
  266.                BuildPSFontTable;
  267.                {here := EndFonts;}
  268.                if (GraphFile = POSTSCRIPT) and (StartLabels < count)
  269.                   then here := StartLabels else here := EndFonts;
  270.                while here <= EndLabels do begin
  271.                   LinkDefaultLabel;
  272.                   LookForFontXX;
  273.                   GetPsLabelCoords;
  274.                   GetPSLabel;
  275.                   if TempText.Tstr <> '' then cp^ := TempText
  276.                   else begin
  277.                      head := head^.link;
  278.                      dispose(cp);
  279.                      cp := nil;
  280.                      with TempText do begin
  281.                           CurrText.horiz := 100;
  282.                           CurrText.Vert := 100;
  283.                      end;
  284.                   end;
  285.                   TempText.Tstr := '';
  286.                end; {while}
  287.             end; {if FontDefinitions < ...}
  288.          end; {POSTSCRIPT}
  289.       end; {case GraphFile of ...}
  290.       select := nil;
  291.       DefaultFSize := 20;
  292. end; {ExtractLabels}
  293.