home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 December / simtel1292_SIMTEL_1292_Walnut_Creek.iso / msdos / editor / paint.arc / PAINT.PAS < prev    next >
Pascal/Delphi Source File  |  1987-11-18  |  7KB  |  225 lines
  1. {  paint a screen of "cells" of shades.
  2.    The cells correspond to print positions, so the screen
  3.    can be printed on a line printer (Low-res graphics)
  4. }
  5.  
  6. {$V-}    (* Allow small strings to be passed to procedures *)
  7.  
  8. const  RIGHT = 75;     (* "effective" right edge of screen, 80 for good mon *)
  9.        WinWidth = 20;
  10.        WinHite = 19;   (* height of menu window *)
  11.        MAXBRUSH = 15;
  12. type   MenuItem = string [WinWidth];
  13.        prompt = array [1..5] of MenuItem;
  14.        filename = string [14];
  15.        WinID = 1..2;
  16.        PagArr = array [0..80, 0..70] of byte;
  17.        palette = string [MAXBRUSH];
  18. const  OldXlate : palette = ' .oXM';
  19.                        (* translate from brush code to old character *)
  20.        PXlate : palette = ' .:XM    |-+\/X';  (* print translation *)
  21.        SXlate : palette = '123456789|-+\/X';  (* SFile translation *)
  22.        FilMsg1 : prompt = ('fill to','Darker or Lighter','edge?','','');
  23. var    line,page : integer;   (* columns & rows on print page *)
  24.        xcell,ycell: integer;  (* # of pixels in a cell *)
  25.        brush : integer;       (* code for painting a cell *)
  26.                               (*  0 - no permanent effect
  27.                                   1-5 progressively heavier tones
  28.                                   6-9 currently unassigned
  29.                                   10-15 = | - + \ / X
  30.                               *)
  31.        FillFlag : integer;    (* used to indicate the nature of the fill *)
  32.        ErrMsg : MenuItem;
  33.        fname, pname : filename;   (* file name & print device name *)
  34.        x,y : integer;         (* col,row position of cursor *)
  35.        bkgnd, inchar : char;
  36.        screen : PagArr;       (* array of brush values *)
  37.        linecount : array [1..2] of integer;
  38.                               (* line counters for windows *)
  39.  
  40. procedure blink; forward;
  41.  
  42.  
  43. {$I pixel.pas }
  44. {$i ptutils.pas }
  45. {$I ptfile.pas }
  46.  
  47.  
  48.  
  49. procedure blink;   {  blinks the cursor until key is pressed  }
  50.     var   curs : integer;
  51.     begin
  52.         ResetWin (2);
  53.         window (2, ErrMsg); (* print the most recent error message *)
  54.         curs := 5;
  55.         while not KeyPressed do   (* blink until next keystroke *)
  56.         begin
  57.             if curs=5 then curs:=1  else curs:=5;
  58.             dab (x,y, curs);
  59.             delay (60);
  60.         end;
  61.         ErrMsg := '                    ';
  62.     end;
  63.  
  64. {$I ptfancy.pas }
  65.  
  66. procedure MenuDisp;  { displays the menu of commands }
  67.     var    line : integer;
  68.     begin
  69.         linecount[1]:=4;   (* start menu on fourth line *)
  70.         window (1, 'COMMANDS');
  71.         window (1, ' ');
  72.         window (1, 'Quit');
  73.         window (1, 'Save');
  74.         window (1, 'Load');
  75.         window (1, 'Print');
  76.         window (1, 'Mirror');
  77.         window (1, 'Fill');
  78.         window (1, 'Restore screen');
  79.     end;
  80.  
  81. procedure RestorScr;
  82.     var    i,j : integer;
  83.     begin
  84.         HiRes;
  85.         if bkgnd='W' then wpage (xcell*line, ycell*page)
  86.         else            boxpage (xcell*line, ycell*page);
  87.         MenuDisp;
  88.         brush:=0;       (* start with dry brush *)
  89.  
  90.         for j:=0 to (page-1) do
  91.             for i:=0 to (line-1) do
  92.                 if screen [i,j]>1 then dab (i,j, screen [i,j]);
  93.     end;
  94.  
  95. begin
  96. { initialize parameters for the program }
  97.     line:=79;
  98.     page:=66;
  99.     brush:=0;
  100.     bkgnd:='B';
  101.     ErrMsg:='                    ';
  102.     linecount[2] := WinHite + 1;
  103.     fname:='';  pname:='CON:';
  104.  
  105.     xcell:=4; ycell:=3;
  106.     for x:=0 to line do for y:=0 to page do  screen [x,y] := 1;
  107.     x:=line div 2;  (* start in the middle of page *)
  108.     y:=page div 2;
  109.  
  110.     RestorScr;
  111.  
  112. { MAIN WORKING LOOP }
  113.     repeat
  114.         blink;
  115.         read (kbd, inchar);
  116.         case  inchar of
  117.         ^[:  begin   (* ESC is cursor control *)
  118.              if brush>0 then  screen[x,y] := brush;
  119.              dab (x,y, screen[x,y]);   (* paint cell before leaving *)
  120.              read (kbd, inchar);
  121.              case inchar of
  122.              'G':  (* up & left *)
  123.                   if (x-1>=0) and (y-1>=0) then
  124.                   begin  x := x-1;  y := y-1; end;
  125.              'H':  (* up *)
  126.                   if y-1>=0 then
  127.                   y := y-1;
  128.              'I':  (* up & right *)
  129.                   if (x+1<line) and (y-1>=0) then
  130.                   begin  x := x+1;  y := y-1;  end;
  131.              'M':  (* right *)
  132.                   if x+1<line then
  133.                   x := x+1;
  134.              'Q':  (* down & right *)
  135.                   if (x+1<line) and (y+1<page) then
  136.                   begin  x := x+1;  y := y+1;  end;
  137.              'P':  (* down *)
  138.                   if y+1<page then
  139.                   y := y+1;
  140.              'O':  (* down & left *)
  141.                   if (x-1>=0) and (y+1<page) then
  142.                   begin  x := x-1;  y := y+1;  end;
  143.              'K':  (* left *)
  144.                   if x-1>=0 then
  145.                   x := x-1;
  146.              end;
  147.                 inchar := ' ';   (* kill for Quit check *)
  148.                 if brush>0 then  screen[x,y] := brush;
  149.              end;
  150.  
  151.         '0':         (* turn off the brush *)
  152.              brush := 0;
  153.  
  154.         '1'..'9','|','-','+','\','/','X':  (* change the brush *)
  155.              begin
  156.                  brush := pos (inchar, SXlate);
  157.                  screen [x,y] := brush;
  158.              end;
  159.  
  160.          'l','L':   (* load a file from disk *)
  161.              if verify ('LOAD?') then
  162.              begin
  163.                  load (fname, screen, SXlate);
  164.                  RestorScr;
  165.              end;
  166.  
  167.          's','S':   (* save in a file *)
  168.              if verify ('SAVE?') then
  169.              begin
  170.                  fname := getname(fname, 0);
  171.                  save (fname, screen, SXlate);
  172.              end;
  173.  
  174.          'p','P':   (* print on the line printer *)
  175.              if verify ('PRINT?') then
  176.              begin
  177.                  pname := getname(pname, 0);
  178.                  save (pname, screen, PXlate);
  179.                  if pname='CON:' then  RestorScr;
  180.              end;
  181.  
  182.          'r','R':   (* restore a corrupted screen image *)
  183.              RestorScr;
  184.  
  185.          'm','M':   (* mirror the screen about an axis *)
  186.              if verify ('MIRROR?') then
  187.              begin
  188.                  mirror;
  189.              end;
  190.  
  191.          'f','F':   (* fill an area *)
  192.              if verify ('FILL?') then
  193.              begin
  194.                  ClrWin (2);
  195.                  window (2, 'BRUSH value is');
  196.                  window (2, SXlate [brush] );
  197.                  window (2, 'OK?  (Y/N)');
  198.                  read (kbd, inchar);
  199.                  if (inchar='y') or (inchar='Y') then
  200.                  begin
  201.                      inchar := getchar (FilMsg1);
  202.  
  203.                      case inchar of
  204.                       'd','D': FillFlag := 4;
  205.                       'l','L': FillFlag := 3;
  206.                       else  FillFlag := 5;  (* assure that fill never starts *)
  207.                      end;
  208.  
  209.                      if FillFlag<5 then  fill (x,y);
  210.                  end;
  211.                  ClrWin (2);
  212.              end;
  213.  
  214.        { ADD NEW COMMANDS HERE }
  215.  
  216.          'q','Q':   (* looks like QUIT, but let's check *)
  217.              if not (verify ('QUIT???')) then inchar := ' ';
  218.  
  219.          else  ErrMsg:= concat(inchar,': NO SUCH COMMAND');
  220.          end;
  221.  
  222.     until (inchar='Q') or (inchar='q');
  223.  
  224.     Alfa;
  225.