ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/GRAPHICS/MISC/POSTOGRF.ZIP/COPYBLOC.INC

Text File | 1990-06-04 | 33.5 KB | 918 lines

{ program CopyBlock.inc
  written by Thomas B. Passin in Turbo Pascal 4.0.
   For use in POSTogrf/LIPSogrf.  Shows, resizes, and moves an open
   rectangle.  This represents the allowed size of the graph when printed
   (e.g., 8 X 6.25 in for a MITRE report).  When the box is located in
   the upper left corner of the screen, the box represents the copybox
   as located at the printer margin.  If the box is moved away from the
   corner, it shows whether the graph can be cropped to fit inside the box.

  22 May 90 Other sections of code have also been moved here:
         procedures Repaint1, MoveLabel, Attributes.

 27 Apr 89 Now XOR's the box when moving.
 18 Oct 88 v1.0x4.  Added var noshow to toggle rectangle on or off:
         modified CopyBlock, CopyBlockMenu.
 20 Sept 88. v1.0x3.  Surounded each readln by textcolor(white),
         textcolor(black) pairs.  Needed to overcome BGI bug.
         Changed type colors to word to avoid collision with
         CRT unit.
 14 Sept 88.  v1.0x2.  Added HOME key to MoveCopyBlock: takes box to upper
         left corner. Added HOME to set of Movers in CopyBlockMenu.
 13 Sept 88.  v1.0x1.  Works.
 }

(*{$DEFINE test}*)
{$IFDEF test}
uses graph, CRT;
type videocolors = (color, mono);
     {mcolors = (yellow, white, black);}
     colors = word;
     string80 = string[80];
const  ESC = #27;  BS  = #8; CR = #13;  LF = #10;
       Uparrow  = #72;     Downarrow  = #80;
       Leftarrow  = #75;   Rightarrow  = #77;
       Del  = #83;         Ins  = #82;
       Home  = #71;        En  = #79;
       PF1 = #59;   PF2 = #60;   PF3 = #61;   PF4 = #62;   PF5 = #63;
       PF6 = #64;   PF7 = #65;   PF8 = #66;   PF9 = #67;   PF10 = #68;
var VidCol :videocolors;
    key :char;
procedure ScrConv(x,y:integer); begin end;  { dummy procedures for debugging }
procedure SetColor(cc:colors); begin end;
procedure repaint; begin end;
{$ENDIF}

{ ---------------------------------------------------------------------
                     Part of the RePaint procedure
  --------------------------------------------------------------------- }
Procedure RePaint1;
var savePrtSize: integer;
    t1: integer;
begin
     here := JimFileStart;
     SavePrtSize := TempText.PrtSize;
     SetColor(white);
     t1:= 10; SetPrtFontSize(t1);
     SetTextStyle(SansSerifFont,Horizdir,UserCHarSize);
     done := false;
     if count > 0 then Repeat DrawJimFile until done ;
     if VidCol = color then SetColor(yellow) else SetColor(white);
     Line(0,GetMaxY - 3*LinesPerChar,GetMaxX,GetMaxY-3*LinesPerChar);
     if head = nil then exit;
     cp := head;
     repeat
           showLabel(cp, white);
           cp := cp^.link;
     until cp = nil;
     if select <> nil then HighLight(select);
     if LConfig.DoBar then DoVGBar;
     RestorePrtFontSize(SavePrtSize);
     TempText := select^;
     SetUpLabel(select);
end;

{ ------------------------------------------------------------------------
                 Size the copyblock to fit the graph
  ------------------------------------------------------------------------ }
procedure AutoSizeCopyBlock;
var maxMinRect: rect;        {accumulate max, min corners}
    x1, x2, y1, y2: integer;
    cpx, cpy      : integer; {current point in Postscript coords}

    procedure DoRectMaxMin(x,y: integer; var r: rect);
    begin
       with r do begin
           if x < LLx then LLx := x else
              if x > URx then URx := x;
           if y < LLy then LLy := y else
              if y > URy then URy := y;
        end;
    end;

    procedure SizeJimFile;
    var XPos, Ypos, error, temp  : integer;
        PenDia                   : word;
        n1                       : word;
        str                      : string80;
        sFlag                    : boolean;
    begin
        GetAWord(str);
        case GraphFile of
            GRAPHL, LIPSGRF: begin
               (*if str = 'EXIT' then begin done := true; exit ; end ELSE
               if str = 'MAP' then   { move to position }
                  begin GetAWord(str); Val(str,Xpos,error);
                  GetAWord(str); Val(str,Ypos,error);
                  ScrConv(XPos, YPos);
                  MoveTo(Xpos,YPos);
                end ELSE
                  if str = 'DAP' then   { draw to position }
                  begin GetAWord(str); Val(str,Xpos,error);
                  GetAWord(str); Val(str,Ypos,error);
                  ScrConv(XPos,YPos);
                  LineTo(Xpos,YPos);
               end ELSE
                  if str = 'SPD' then  {set pen diameter - only an approximation }
                  begin GetAWord(str); Val(str,PenDia, error);
                  PenDia := word(round(10 * PenDia/VPrtScale)) div 3;
                  SetLineStyle(0,0,PenDia);
               end ELSE
                  if str = 'FONT' then {he asks for internal landscape font - fake it }
                    begin GetAWord(str);
                       if str = '3' then  begin
                          temp:= 12; SetPrtFontSize(temp);
                        end; {else;}
               end ELSE
                  if str = 'TEXT' then begin {write the following text string }
                     GetAQuote(str); OutText(str);
                  end ELSE {nothing} *)
             end; {case GRAPHL, LIPSGRF}
            POSTSCRIPT: begin
           temp := 13; SetPrtFontSize(temp);
           if str[1] = 's' then sFlag := true else sFlag := false;
               if str[1] = '%' then
           repeat
                  inc(here)
                until (JimFile^[here] = CR) or (JimFile^[here] = LF);
               if str[1] = '(' then begin       {found a label}
                  ParsePSstring(str,mark);
                  x1 := textwidth(str);
                  y1 := textheight(str);
                  x1 := round(x1/Hscale);
                  y1 := round(y1/VScale);
                  doRectMaxMin(cpx - 50, cpy, maxMinRect);
                  doRectmaxMin(cpx + x1 ,cpy +50 + y1 + y1 div 2, maxMinRect);
                  here := mark;
                end ELSE
                if (str[1] = 'm') then begin
                  if ((str = 'm') or (str = 'moveto')) then begin
                    n1 := here - 1;
                    GetAWordBack(str,n1); GetAWordBack(str, n1);
                    Val(str, YPos, error);
                    if error <> 0 then exit;
                    GetAWordBack(str,n1);
                    Val(str,XPos,error);
                    if error <> 0 then exit;
                    cpx := Xpos; cpy := Ypos;
                    doRectMaxMin(cpx, cpy, maxMinRect);
                   end;
                end ELSE
                if (str[1] = 'l') then begin
                   if ((str = 'l') or (str = 'lineto')) then begin
                      n1 := here - 1;
                      GetAWordBack(str,n1); GetAWordBack(str, n1);
                      Val(str, YPos, error);
                      GetAWordBack(str,n1);
                      Val(str,XPos,error);
                      cpx := Xpos; cpy := Ypos;
                      doRectMaxMin(cpx, cpy, maxMinRect);
                    end;
                end ELSE if
                   (sflag) and (str = 'setlinewidth') then begin
                   {n1 := here -1; GetAWordBack(str,n1); GetAWordBack(str, n1);
                   Val(str,PenDia,error);
                   if error = 0 then
                      PenDia := word(round(PenDia)) div 10;
                      else PenDia := 1;
                   SetLineStyle(0,0,PenDia);}
                end ELSE if (sFlag) and (str = 'sf') then begin
                      {set active font size}
                      {any labels here are default 13 pt labels}
                   temp := 13; SetPrtFontSize(temp);
                end ELSE if (sFlag) and (str = 'setfont') then begin
                   {temp := 13; SetPrtFontSize(temp);}
                end ELSE if (sFlag) and (str = 'showpage') then begin
                   done := true; exit ;
            end; {if..ELSE}
         end; {POSTSCRIPT}
      end; {case}
    end; {SizeJimFile}

    procedure SizeLabels;
    var x1, y1, cpx, cpy: integer;
    begin
       if head = nil then exit;
       cp := head;
       repeat
           SetUpLabel(cp);
           x1 := textwidth(cp^.tstr);
           y1 := textheight(cp^.tstr);
           with cp^.Currtext do begin
             cpx := Horiz ;
             cpy := Vert;
            end;
          cpx := round(cpx / HScale) - 1000;
          cpy := 6360 - round(cpy / VScale);
           x1 := round(x1/Hscale);
           y1 := round(y1/VScale);
          if cp^.Currtext.Direction = Horizdir then begin
              doRectMaxMin(cpx - 50, cpy, maxMinRect);
              doRectmaxMin(cpx + x1 ,cpy +50 + y1 + y1 div 2, maxMinRect);
           end else begin
              doRectMaxMin(cpx, cpy, maxMinRect);
              doRectmaxMin(cpx + y1 +25, cpy + 50 + x1 + y1 div 2, maxMinRect);
           end;
          cp := cp^.link;
        until cp = nil;
        TempText := select^;
        SetUpLabel(select);
    end; {SizeLabels}

begin
   with maxMinRect do begin
      LLx := 32000; LLy := 32000; URx := -32000; URy := -32000;
      cpx := 0; cpy := 0;
      if GRAPHLIName <> '' then begin
          here := JimFileStart;
          if count > 0 then Repeat
              SizeJimFile;
              if here > EndGraph then done := true;
           until done ;
       end;
      SizeLabels;
      w := URx - LLx; h := URy - LLy;
      if (w <> 0) and (h <> 0) then CopyBlock := maxMinRect;
    end;
end; {AutoSizeCopyBlock}

{ ------------------------------------------------------------------------
     Draw the box on screen.  CopyBlkOffsetX, Y are the upper left
     coordinates.  CopyBlkX,Y are the width, height of the box (scaled
     by a factor 1/3 for historical reasons based on the original LIPS
     conversion factors).
  ------------------------------------------------------------------------ }

procedure markCBCorner;
var x1, x2, y1, y2: integer;
begin
{    if CBMode = size then}
      with CopyBLock do begin
                 setlinestyle(solidln, 0, thickwidth);
                 x1 := LLx; y1 := LLy;
                 x2 := x1 + 1000; y2 := y1 + 1000;
                 PStoScreen(x1, y1);
                 PStoScreen(x2, y2);
                 line(x1, y1, x1, y2);
                 line(x1, y1, x2, y1);
                 setlinestyle(solidln, 0, normwidth);
       end;
end;

Procedure ShowCopyBlock;
var CopyBlockX, CopyBlockY: real;
    x1, x2, y1, y2 : integer;
    TRect: screenRect;
begin if noshow then exit;
     with TRect do begin
         with CopyBlock do begin
              ULx := LLx; ULy := LLy + h;
              LRx := URx; LRy := URy - h;
         PStoScreen(ULx, ULy); PStoScreen(LRx, LRy);
         sw := LRx - ULx; sh := ULy - LRy;
         Rectangle(ULx, ULy, LRx, LRy);
      end; {with copyblock}
     end; {with tRect}
end;

procedure MoveCopyBlock;
var moving, newbox : boolean;
    delX, delY: integer;
    x1, x2, y1, y2: integer;
begin   moving := false; newbox := false;
        {SetWriteMode(XorPut);}
        delX := integer(round(1/(Expand.SF*Hscale)));
        delY := integer(round(1/(Expand.SF*Vscale)));
   repeat
        ShowCopyBlock;
        if CBMode = size then markCBCorner;
        with CopyBlock do begin
             case key of
                  rightarrow : LLx := LLx + delX;
                  leftarrow  : LLx := LLx - delX;
                  uparrow    : LLy := LLy + delY;
                  downarrow  : LLy := LLy - delY;
  (* CNTRL -> *) #116        : LLx := LLx + 10*delX;
  (* CNTRL <- *) #115        : LLx := LLx - 10*delX;
  (* page up  *) #73         : LLy := LLy + 10*delY;
  (* page down *) #81        : LLy := LLy - 10*delY;
                 {Home        : begin
                                 LLx := 0; LLy := 0;
                               end;}
              end; {case}
             if CBMode = move then begin
               URx := LLx + w; URy := LLy + h;
              end else begin
                 w := URx - LLx; h := URy - LLy;
              end;
        end; {with CopyBlock do...}
     ShowCopyBlock;
     if CBMode = size then markCBCorner;
     if keypressed
     then begin repeat key := readkey; until (not keypressed) ;
                moving := true;
          end
     else begin delay(50);
                if keypressed
                then begin key := readkey; moving := true; end
                else moving := false;
          end;
 until not moving ;
 onoff := on;
end;

Procedure GetCopyBlock;
const menustr1 =
'resize copyblock...  F1 move copyblock   F3 autosize   <ESC> quit';
      menustr2 =
'move copyblock...... F1 size copyblock   <ESC> quit';
var tx,ty:real;
    err1, n: integer;
    x1, x2, y1, y2: integer;
    err2, onlyOne, done:boolean;
    str1, str2: string;
    default: string80;
    gkey: char;
begin
   if onoff = on then done := false else done := true;
   with CopyBlock do begin
   tx := w/1000; ty := h/1000;
   clrscr; write(menustr1);
   setwritemode(XORput);
   markCBCorner;
    repeat
     if CBMode = size then begin
         gotoxy(1, 2);
         write('key X,Y dimensions of copyblock (now: ', w/1000:4:2,
           h/1000:5:2, ' inches): ');
       end;
      str1 := ''; str2 := ''; onlyOne := false;
    (*textcolor(white);
    {$I-} readln(tx,ty); {$I+}
      textcolor(black);*)
      if key <> ESC then key := readkey;
      case key of
       '0'..'9', '.': begin
             write(key);
             str1 := str1 + key;
             repeat
                key := readkey;
                case key of
                   '0'..'9', '.', SP: begin
                        write(key);
                        str1 := str1 + key;
                      end;
                    BS: if length(str1) > 0 then begin
                         gotoxy(wherex - 1, wherey); write(' ');
                         gotoxy(wherex-1, wherey);
                         delete(str1, length(str1), 1);
                      end;
                    ESC: str1 := '';
                    #0: key := readkey;   {dump function keys}
                  end; {case}
             until (key = CR) or (key = ESC);
             if str1 = '' then key := ESC else begin
                n := pos(' ', str1);
                str2 := copy(str1, n+1, length(str1) - n + 1);
                if pos(' ', str2) <> 0 then delete(str2, pos(' ', str2), 1);
                if (n > 0) and (n < length(str1)) then begin
                   str1 := copy(str1, 1, n);
                   if pos(' ', str1) <> 0 then delete(str1, pos(' ', str1), 1);
                   onlyOne := false;
                 end else onlyOne := true;
                val(str1, tx, err1);
                if (err1 = 0) and (not onlyOne) then val(str2,ty,err1);
                err2 := (err1 <> 0) or (tx > 11) or (tx < 0.5) or (ty > 8.5)
                    or (ty < 0.5);
                if err2 then begin
           sound(300); delay(50); nosound;
           GoToXY(1, whereY-1); clrEOL;
           writeln('bad number - try again');delay(1000);
                   tx := w/1000; ty := h/1000;
                end else begin
                  ShowCopyBlock;
                  markCBCorner;
                  w := integer(round(1000*tx)); h := integer(round(1000*ty));
                  done := true;
                  URx := LLx + w; URy := LLy + h;
                  if vidcol = color then setcolor(yellow) else setcolor(white);
                  ShowCopyBlock;
                  markCBCorner;
               end; {if str1  ''}
              end; {case numbers of}
          end;
       ESC: done := true;
        #0: begin
              key := readkey;
              case key of
               PF1: begin
                    clrscr;
                    if CBmode = size then begin
                       write(menustr2);
                       CBMode := move;
                       markCBCorner;
                     end else begin
                       clrscr;
                       write(menustr1);
                       CBMode := size;
                       markCBCorner;
                      end;
                 end; {PF1}
               PF3: if CBMode = size then begin
                      clrscr; write('auto-sizing copyblock...');
                      ShowCopyBlock;
                      markCBCorner;
                      if vidcol = color then SetColor(yellow)
                        else SetColor(white);
                      AutosizeCopyBlock;
                      SetWriteMode(XORput);
                      ShowCopyBlock;
                      markCBCorner;
                      clrscr;
                      write(menustr1);
                    end;
               else if key in movers then MoveCopyBlock;
               end; {case key of...}
              end; {#0}
       end; {case}
      until done;
    end; {with Copyblock do...}
    onoff := on;
    saved := false;
    if CBMode = size then markCBCorner;
    CBMode := move;
    key := #200;
end;

procedure CopyBlockMenu;
const HelpStr =
'copyblock: F1 resize  F5 repaint  F7 on/off  ESC quit';
     Helpstr1 = 'copyblock: F7 on/off  ESC quit';
var btemp:boolean;
begin clrscr;
      key := #200;
      if not noshow then begin
          setwritemode(copyput);
          SetColor(black);
          ShowCopyBlock;
       end;
      if vidcol = color then SetColor(yellow);
      setwritemode(XORput);
      if not noshow then ShowCopyBLock;
      CBMode := move;
      repeat
        if key = #200
        then begin
           clrscr;
           if noshow then write(Helpstr1)
           else begin write(Helpstr);
              gotoxy(1,2);
              write('copyblock size is ',
                  CopyBlock.w/1000:4:2, ' X ',
                  CopyBlock.h/1000:5:2,
                  ' inches');
              Gotoxy(1,1);
            end;
         end;
        key := ReadKey;
        if key = #0
        then begin key := readkey;
           case key of      {function keys}
              PF1: if not noshow then begin
                      CBmode := size;
                      GetCopyBlock; key := #200;
                      CBMode := move;
                    end;
              PF5: if not noshow then begin
                      clrscr;
                      setwritemode(copyput);
                      SetColor(Black);
                      ShowCopyBlock;
                      SetColor(white);
                      Repaint1;
                      SetWriteMode(XORPut);
                      ShowCopyBlock;
                      key := #200;
                    end;
              PF7: begin
                      btemp := noshow;
                      if noshow then onoff := on
                       else onoff := off; noshow := false;
                      SetWriteMode(XORPut);
                      ShowCopyBlock;
                      noshow := not btemp;
                      if noshow then key := CR else key := #200;
                    end;
              else if key in movers then MoveCopyBlock;
           end ;{case}
        end;
      until (key = ESC) or (key = CR);
      key := #0;
      setwritemode(copyput);
      ShowCopyBLock;
{      SetColor(white);}
end;

Procedure Repaint;
begin
     SetColor(Black);
     ShowCopyBlock;
     SetColor(white);
     Repaint1;
     if vidcol = color then SetColor(yellow);
     SetWriteMode(XORPut);
     ShowCopyBlock;
     SetWriteMode(CopyPut);
     SetColor(white);
end;

procedure MoveLabel;
var moving, moved, newbox, showing: boolean;
    nn: word;
begin   if select = nil then exit;
        moving := false; newbox := false;
        showlabel(select, black);
        newbox := false;
   repeat
     {if newbox then begin}
        if (vidcol = mono) or (moving and newbox) then BoxLabel(select, white);
        if moving then newbox := true;
     {end;}
     case key of
  (* -> *)       #77: TempText.CurrText.horiz := TempText.CurrText.horiz + 1;
  (* <- *)       #75:  if TempText.CurrText.Horiz > 1 then
                       TempText.CurrText.horiz := TempText.CurrText.horiz - 1;
            uparrow : if TempText.CurrText.vert > 1 then
                      TempText.CurrText.vert := TempText.CurrText.vert - 1;
           downarrow: TempText.CurrText.vert := TempText.CurrText.vert + 1;
  (* CNTRL -> *) #116: TempText.CurrText.horiz := TempText.CurrText.horiz + 10;
  (* CNTRL <- *) #115: if TempText.CurrText.horiz > 10 then
                       TempText.CurrText.horiz := TempText.CurrText.horiz - 10;
  (* page up  *) #73 :if TempText.CurrText.vert > 10 then
                       TempText.CurrText.vert := TempText.CurrText.vert - 10;
  (* page down *) #81 : TempText.CurrText.vert := TempText.CurrText.vert + 10;
     end; {case}
     select^ := TempText;
     if moving or (vidcol = mono) then begin
        Boxlabel(select,white);
     end;
     if keypressed
     then begin repeat key := readkey; until (not keypressed) ;
                moving := true;
          end
     else begin
              nn := 0;
              repeat
                 delay(5);
                 inc(nn);
              until keypressed or (nn = 30);
              if keypressed
              then begin {key := readkey;} moving := true; end
              else moving := false;
          end;
 until not moving ;
    if newbox and (vidcol = color) then BoxLabel(select, white);
    {SetWriteMode(CopyPut);}
    if vidcol = color then highlight(select) else showlabel (select, white);
    saved := false;
end;

procedure Attributes;
const HelpStr: string80 =
'F1  font  F2 size  F3 background <ESC> quit' ;
var ans: char;
    changed: boolean;

  procedure ShowAttrib;
  begin
    gotoxy(1,2);
    Write('font style: ',userStyleNames[TempText.LipsFont.LIPSstyle]);
    write('        point size: ', TempText.PrtSize); write('      ');
    if TempText.LabelBkGround = trans then
       write('transparent ')
       else write('opaque ');
    clrEOL; writeln;
  end;

begin
            if select = nil
            then begin
                      writeln('no label is selected - didn''t do anything');
                      delay(1000);
                      exit;
                  end;
            clrscr;
            write(HelpStr);
            showAttrib;
            repeat key := readkey;
            until (key = #0) or (key = ESC) or (key = CR);
            changed := (key = #0);
            if key = #0 then key := readkey;
        case key of      {function keys}
             PF1: SetLipsFont;
             PF2: begin select^ := TempText;     { update }
                        ShowLabel(Select, black);
                        UnBoxLabel(select);
                        ChangeSize;
                        select^ := TempText;
                        HighLight(select);
                  end;
             PF3: begin
                      gotoxy(1,wherey); clrEOL;
        Write('select label background O)pague or T)ransparent): ');
                         ans := readkey; write(ans);
                      if (upcase(ans) = 'O')
                         then TempText.LabelBkGround := opaque
                        else if (upcase(ans) = 'T')
                         then TempText.LabelBkGround := trans;
                      { --- set paint type for next label --- }
                      defaultPaintType := TempText.LabelBkGround;
                   end; {PF3}
        end; {case}
      key := #0;
      if changed then saved := false;
end;

{ -----------------------------------------------------------------------
               Show & move CopyBlock relative to page.
  ----------------------------------------------------------------------- }
Procedure ChangeLayout;
const menustringL: string =
'F8 change to portrait            <HOME> center graph           <ESC> quit';
      menustringP: string =
'F8 change to landscape           <HOME> center graph           <ESC> quit';

      marginStr: string =
'margins:    left       top      right    bottom' + CR + LF + '(inches)';
var a, b, AA, BB: real;       {conversion constants}
    lmargin, rmargin, tmargin, bmargin: real;
    orgX, orgY: integer;  {PS coords of origin relative to LL of paper}
    tLM, tRM, tTM, tBM: integer;  {for adjusting margins}
    PsPageSize: rect;
    key: char;

    procedure ShowPageBox;
    var tlineInfo: LineSettingsType;
    begin
          Setcolor(white);
          GetLineSettings(tlineInfo);
          with tlineinfo do SetLineStyle(LineStyle, Pattern, thickwidth);
          with PageRect do rectangle(ULx, ULy, LRx, LRy);
          with tlineinfo do SetLineStyle(LineStyle, Pattern, Thickness);
    end; {ShowPageBox}

    procedure SetUp;
    const PSpageSizeLand:rect = (
              LLx:0; LLy:0; URx: 11000; URy: 8500; w:11000; h: 8500);
          PSpageSizePort: rect = (
              LLx: 0; LLy: 0; URx: 8500; URy: 11000; w: 8500; h:11000);
    begin
        ClearViewPort;
        with PageRect do begin
           if Layout.Landscape then begin
                 {ULx := 1;}
                 ULy := 1;
                 ULx := round(0.5*0.1*GetMaxX); {fudge factor for VGA}
                 {sw := GetMaxX-ULx - 1;}
                 sw := round(0.9*GetMaxX);
                 sh := GetMaxY - 3*LinesperChar - 3;
                 LRx := ULx + sw; LRY := ULy + sh;
                 PsPageSize := PSpageSizeLand;
            end else begin
                 sw := integer(round(GetMaxX*sqr(0.9*8.5/11)));
                 sh := GetMaxY - 3*LinesperChar - 3;
                 ULx := (GetMaxX - sw) div 2; ULy := 1;
                 LRx := ULx + sw; LRy := ULy + sh;
                 PSpageSize := PSpageSizePort;
             end;
            a := (LRx - ULx)/PSpageSize.w;
            b := ULx;
            AA := (ULy - LRy)/PSpageSize.h;
            BB := LRy;
         end;
        with Layout.Origin do
           if Layout.Landscape then begin
                 orgX := y;
                 orgY := PSPageSize.h - x;
            end else begin
                 orgX := x;
                 orgY := y;
            end;
        MenuLine;
        setcolor(white);
        {Line(0,GetMaxY - 3*LinesPerChar,GetMaxX,GetMaxY-3*LinesPerChar);}
        SetWriteMode(XORPut);
        ShowPageBox;
        if vidcol = color then setcolor(yellow);
        gotoxy(1,1); clrscr;
        if layout.Landscape then write(menustringL) else write(menustringP);
        gotoxy(1,2);
        write(marginStr);
        gotoxy(1,3);
    end; {SetUp}

    procedure PStoScreenx(PS: integer; var Screen: integer);
    begin
        Screen := integer(round(a*PS+ b));
    end;

    procedure PStoScreenY(PS: integer; var Screen: integer);
    begin
        Screen := integer(round(AA*PS + BB));
    end;

    procedure ShowMargins;
    begin
        gotoxy(10,3);
        with CopyBlock do begin
           write((LLx + OrgX)/1000:8:3);
           gotoxy(wherex + 2, wherey);
           write((PSpageSize.h - (OrgY + URy))/1000:8:3);
           gotoxy(wherex + 2, wherey);
           write((PSpageSize.w - (OrgX + URx))/1000:8:3);
           gotoxy(wherex + 2, wherey);
           write((OrgY + URy - h)/1000:8:3);
         end;
    end; {ShowMargins}

    procedure GetMargins;
    begin
       tLM := OrgX;
       tRM := PSPageSize.w - OrgX;
       tTM := PSPageSize.h - OrgY;
       tBM := OrgY;
    end; {GetMargins}

    { -------------------------------------------------------------------
       Set OrgX, OrgY, and copyblock corners to give specifed position
       of upper left corner of bounding box relative to paper.
      ------------------------------------------------------------------- }
    procedure SetULmargins(lm, tm:integer);
    begin
       OrgX := lm;
       OrgY := PSPagesize.h - tm;
       with Layout.Origin do
          if layout.Landscape then begin
               y := OrgX;
               x := PSPageSize.h - OrgY;
           end else begin
               y := OrgY;
               x := OrgX;
           end;
    end; {SetULmargins}

    procedure ShowBBox;
    var x1, y1, x2, y2: integer;
    begin
       with CopyBlock do begin
            PStoScreenX(LLx + OrgX, x1);
            PStoScreenY(LLy + h + OrgY, y1);
            PStoScreenX(URx + OrgX, x2);
            PStoScreenY(URy - h + OrgY, y2);
        end;
       rectangle(x1, y1, x2, y2);
    end; {ShowBBox}

    procedure CenterBBox;
    var tx, ty: integer;
    begin
        tx := OrgX + CopyBlock.LLx + CopyBlock.w div 2;
        orgX := orgX + (PSPageSize.w div 2 - tx);
        if LConfig.DoBar then begin
             Layout.origin.x := CopyBlock.lly + 7130;
             orgY := PSPageSize.h - Layout.origin.x;
             setWritemode(copyput);
             DeleteLogoLabel;
             AddNewLogo;
             setWriteMode(Xorput);
             barY := Layout.origin.x - 1750;
             if vidcol = color then setcolor(yellow) else setcolor(white);
         end else begin
             ty := OrgY + CopyBlock.LLy + CopyBlock.h div 2;
             orgY := orgY + (PSpageSize.h div 2 - ty);
         end;
    end; {CenterBBox}

    procedure MoveBBox;
    var moving, newbox : boolean;
        delX, delY: integer;
    begin
           moving := false;
           Layout.ChangeLayout := true;
           delX := integer(round(0.5/a));
           delY := -integer(round(0.5/AA));
           repeat
             ShowBBox;
             case key of
                  rightarrow : orgX := OrgX + delX;
                  leftarrow  : orgX := OrgX - delX;
                  uparrow    : OrgY := OrgY + delY;
                  downarrow  : orgY := orgY - delY;
  (* CNTRL -> *) #116        : orgX := orgX + 10*delX;
  (* CNTRL <- *) #115        : orgX := orgX - 10*delX;
  (* page up  *) #73         : orgY := orgY + 10*delY;
  (* page down *) #81        : orgY := orgY - 10*delY;
                 Home        : CenterBBox;
              end; {case}
             ShowBBox;
             ShowMargins;
             if keypressed then begin
                  repeat key := readkey; until (not keypressed) ;
                  moving := true;
                  if key = #0 then key := readkey;
              end else begin
                delay(50);
                if keypressed then begin
                   key := readkey; moving := true;
                   if key = #0 then key := readkey;
                 end else moving := false;
               end;
           until not moving ;
    end; {MoveBBox}

    procedure SaveSettings;
    begin
        with Layout do begin
          if LandScape then begin
               origin.x := PSpageSize.h - OrgY;
               origin.y := orgX;
               with BoundingBox do begin
                 LLx := integer(round(72.0*
                       (PSPageSize.h -(orgY + CopyBlock.LLy)) /1000));
                 LLy := integer(round(72.0*(orgX + CopyBlock.LLx) /1000));
                 URx := integer(round(72.0*
                        (PSpageSize.h -(orgY + CopyBlock.URy)) /1000));
                 URy := integer(round(72.0*(orgX + CopyBlock.URx) /1000));
                end;
            end else begin
               origin.x := orgX;
               origin.Y := orgY;
               with BoundingBox do begin
                 LLx := integer(round(72.0*(origin.x + CopyBlock.LLx) /1000));
                 LLy := integer(round(72.0*(origin.y + CopyBlock.LLy)/1000));
                 URx := integer(round(72.0*(origin.x + CopyBlock.URx)/1000));
                 URy := integer(round(72.0*(origin.y + CopyBlock.URy)/1000));
                end;
            end;
           with BoundingBox do begin
               if (URx < LLx) then begin
                   w := URx; URx := LLx; LLx := w;
                end;
               if (URy < LLy) then begin
                   w := URy; URy := LLy; LLy := w;
                end;
               w := URx - LLx;
               h := URy - LLy;
            end;
         end; {with Layout do...}
         if Layout.Changelayout then saved := false;
    end; {SaveSettings}

    procedure Cleanup;
    begin
        ShowBBox;
        if vidcol = color then setcolor(white);
        ShowPageBox;
        SetWriteMode(Copyput);
    end; {Cleanup}

    procedure UserInterface;
    const movers: set of char = [leftarrow, rightarrow, uparrow, downarrow,
                                 Home, #115, #116, #73, #81];
    var done: boolean;
    begin
      done := false;
      repeat
         key := readkey;
         case key of
            ESC: done := true;
            #0: begin
                   key := readkey;
                   case key of
                      PF8: begin
                             ShowBBox;
                             ShowPageBox;
                             GetMargins;
                             Layout.LandScape := not Layout.LandScape;
                             Layout.ChangeLayout := true;
                             SetUp;
                             SetULMargins(tLM, tTM);
                             MenuLine;
                             ShowBBox;
                             ShowMargins;
                            end;
                     else if key in movers then MoveBBox;
                    end; {case key of}
                  end; {#0}
          end; {case key of...}
       until done;
    end; {UserInterface}

begin
   Setup;
   ShowBBox;
   ShowMargins;
   UserInterface;
   SaveSettings;
   Cleanup;
end; {ChangeLayout}