home *** CD-ROM | disk | FTP | other *** search
/ Hall of Fame / HallofFameCDROM.cdr / prog1 / moustool.lzh / MAPEDIT.PAS < prev    next >
Pascal/Delphi Source File  |  1989-05-08  |  33KB  |  1,167 lines
  1. {****************************************************************************}
  2. {*                               MOUSE TOOLS                                *}
  3. {*                        Version 1.0, April 7, 1989                        *}
  4. {*                                                                          *}
  5. {*    Written by:                   Copyright (C) 1989 by Nels Anderson     *}
  6. {*    Nels Anderson                 All Rights Reserved                     *}
  7. {*    92 Bishop Drive                                                       *}
  8. {*    Framingham, MA 01701          Source code for use by registered       *}
  9. {*                                  owner only.  Not to be distributed      *}
  10. {*                                  without express consent of the writer.  *}
  11. {*                                                                          *}
  12. {****************************************************************************}
  13.  
  14. {Map Square Editor}
  15.  
  16. Uses
  17.   Crt,Dos,Graph,Palette,Drivers,Fonts,Mouse,Convert,MouseRs2,Box;
  18.  
  19. Var
  20.   Size,                    {size of map squares}
  21.   Color,                {current drawing color}
  22.   x,y,                    {cursor location}
  23.   LookX,LookY,
  24.   MaxRec,
  25.   i:  INTEGER;
  26.   LastMove,
  27.   cmd:  CHAR;
  28.   fp2:  FILE of AnyImage;
  29.   filenm:  STRING;
  30.   AltImage,
  31.   MyImage:  ^AnyImage;
  32.  
  33. { Table of mouse "buttons" on the screen.  Each entry contains the leftmost,
  34.   rightmost, topmost, and bottommost pixels (respectively) of the button. }
  35.  
  36. Const
  37.   mt: array[1..18,1..4] of INTEGER = (    {normal prompts}
  38.   (340,380,25,249),            {select color}
  39.   (51,211,21,181),            {draw pixel}
  40.   (400,620,68,81),            {save}
  41.   (400,620,82,95),            {read}
  42.   (400,620,96,109),            {re-read}
  43.   (400,620,110,123),            {palette functions}
  44.   (400,620,124,137),            {clear}
  45.   (400,620,138,151),            {view last images read}
  46.   (400,620,152,165),            {look}
  47.   (400,620,166,179),            {fill}
  48.   (400,620,180,193),            {flip left to right}
  49.   (400,620,194,207),            {flip top to bottom}
  50.   (400,620,208,221),            {rotate}
  51.   (400,620,222,235),            {shift right}
  52.   (400,620,236,249),            {shift left}
  53.   (400,620,250,265),            {shift up}
  54.   (400,620,266,279),            {shift down}
  55.   (400,620,280,293) );            {quit}
  56.  
  57.   mtp: array[1..5,1..4] of INTEGER = (    {palette prompts}
  58.   (400,620,84,97),            {Save palette}
  59.   (400,620,98,111),            {Load palette}
  60.   (400,620,112,125),            {Change a color}
  61.   (400,620,126,139),            {Rotate a color}
  62.   (400,620,140,153) );            {Default palette}
  63.  
  64.   PalQues: array[1..5] of STRING = (    {palette questions}
  65.   'Save','Load','Change','Rotate','Default');
  66.  
  67.   PutQues: array[1..5] of STRING = (    {PutImage questions}
  68.   'Normal','XOR','OR','AND','NOT');
  69.  
  70.   ChangeQues: array[1..7] of STRING = (    {Change color questions}
  71.   'r','g','b','R','G','B','Done');
  72.  
  73. procedure MouseOn;
  74. { turn on correct mouse cursor according to its current position }
  75. begin
  76.   case MouseLocate(Mx,My,18,@mt) of
  77.     0:  MouseCursorOn(Mx,My,HAND);
  78.     2:  MouseCursorOn(Mx,My,ARROW);
  79.     else  MouseCursorOn(Mx,My,FINGER);
  80.   end;
  81. end;
  82.  
  83. procedure MouseColor;
  84. { set drawing color from mouse }
  85. begin
  86.   Color := (My - 25) div 14;
  87.   GotoXY(52,2);
  88.   TextColor(Color);
  89.   if MyPal[Color,0] = 0 then
  90.     TextColor(LightGray);
  91.   if Color < 10 then
  92.     Write('Color=',Color,' ')
  93.   else
  94.     Write('Color=',Chr(Color+55));
  95. end;
  96.  
  97. procedure Prompts;
  98. { main menu prompts }
  99. begin
  100.   TextColor(Cyan);
  101.   GotoXY(52,3); Write('Select color by number.   ');
  102.   GotoXY(52,4); Write('Hit space to draw.        ');
  103.   GotoXY(52,5); Write('Use arrows to move.       ');
  104.   GotoXY(52,6); Write('S = Save file             ');
  105.   GotoXY(52,7); Write('R = Read file             ');
  106.   GotoXY(52,8); Write('W = Re-read               ');
  107.  
  108.   GotoXY(52,9); Write('P = Palette functions     ');
  109.   GotoXY(52,10);Write('X = Clear drawing         ');
  110.   GotoXY(52,11);Write('V = View last images read ');
  111.   GotoXY(52,12);Write('L = Look at adjacent parts');
  112.   GotoXY(52,13);Write('Z = Fill                  ');
  113.   GotoXY(52,14);Write('< = Flip left to right    ');
  114.   GotoXY(52,15);Write('> = Flip top to bottom    ');
  115.   GotoXY(52,16);Write('@ = Rotate clock-wise     ');
  116.   GotoXY(52,17);Write('- = Shift Right           ');
  117.   GotoXY(52,18);Write('+ = Shift Left            ');
  118.   GotoXY(52,19);Write('^ = Shift Up              ');
  119.   GotoXY(52,20);Write('| = Shift Down           ');
  120.   GotoXY(52,21);Write('Q = Quit                  ');
  121.   TextColor(Green);
  122. end;
  123.  
  124. procedure DefaultPalette;
  125. { load default palette }
  126. begin
  127.   for i := 0 to 15 do begin
  128.     SetPalette(i,NormPal[i]);
  129.     MyPal[i,0] := NormPal[i];
  130.     MyPal[i,1] := $FF;
  131.   end;
  132.   GotoXY(50,24);
  133.   TextColor(Black);ClrEol;
  134.   TextColor(Green);
  135.   Write('Palette: DEFAULT');
  136. end;
  137.  
  138. function RGBconvert(num:  STRING): INTEGER;
  139. { convert a string rgbRGB value to a number }
  140. var
  141.   i,j:  INTEGER;
  142. begin
  143.   j := 0;                {initialize new color}
  144.   for i := 1 to 6 do begin        {check each bit in color selection}
  145.     j := j * 2;
  146.     if num[i] = '1' then j := j + 1;
  147.   end;
  148.   RGBconvert := j;
  149. end;
  150.  
  151. procedure NewPalette;
  152. { load a new palette from disk }
  153. var
  154.   filenm:  STRING;
  155.   fp2:  TEXT;
  156.   j,i:  INTEGER;
  157. begin
  158.   filenm := '';
  159.   filenm := MGetFile('*.pal','Select palette file name:');
  160.   if filenm[0] = #255 then exit;    {abort if nothing entered}
  161.   if Pos('.',filenm) = 0 then
  162.     filenm := filenm + '.pal';
  163. {I$-}
  164.   Assign(fp2,filenm);
  165.   Reset(fp2);
  166. {I$+}
  167.   if IOResult <> 0 then begin        {error in file}
  168.     GotoXY(5,22);Write('I/O ERROR');
  169.     Delay(1000);
  170.     TextColor(Black);
  171.     GotoXY(5,22);ClrEol;
  172.     TextColor(Green);
  173.   end
  174.   else begin
  175.     GotoXY(50,24);
  176.     TextColor(Black);ClrEol;
  177.     TextColor(Green);
  178.     Write('Palette: ',filenm);
  179.     for i := 0 to 15 do begin        {read in and set new palette}
  180.       ReadLn(fp2,j);
  181.       MyPal[i,0] := j;
  182.       SetPalette(i,j);
  183.       ReadLn(fp2,j);
  184.       MyPal[i,1] := j;
  185.     end;
  186.     Close(fp2);
  187.   end;
  188. end; {NewPalette procedure}
  189.  
  190. procedure SavePalette;
  191. { save a palette to disk }
  192. var
  193.   filenm:  STRING;
  194.   fp2:  TEXT;
  195.   i:  INTEGER;
  196. begin
  197.   filenm := '';
  198.   filenm := MGetFile('*.pal','Select palette file name:');
  199.   if filenm[0] = #255 then exit;    {abort if nothing entered}
  200.   if Pos('.',filenm) = 0 then
  201.     filenm := filenm + '.pal';
  202.   Assign(fp2,filenm);
  203.   Rewrite(fp2);
  204.   for i := 0 to 15 do begin        {write current palette}
  205.     WriteLn(fp2,MyPal[i,0]);
  206.     WriteLn(fp2,MyPal[i,1]);
  207.   end;
  208.   Close(fp2);
  209.   GotoXY(50,24);
  210.   TextColor(Black);ClrEol;
  211.   TextColor(Green);
  212.   Write('Palette: ',filenm);
  213. end; {NewPalette procedure}
  214.  
  215. procedure ChangeColor(ChColor,pal: INTEGER);
  216. { toggle bits within a palette color }
  217. var
  218.   Window: POINTER;
  219.   Heading,
  220.   temp: STRING;
  221.   x1,x2,
  222.   y1,y2,
  223.   i,j: INTEGER;
  224.   c: CHAR;
  225.   mtq: array[1..7,1..4] of INTEGER;        {buttons for questions}
  226. begin
  227.   temp := '';
  228.   j := MyPal[ChColor,pal];
  229.   for i := 6 downto 1 do begin        {find current color}
  230.     if j mod 2 = 1 then
  231.       temp := '1' + temp
  232.     else
  233.       temp := '0' + temp;
  234.     j := j div 2;
  235.   end;
  236.   MouseCursorOff(Mx,My);
  237.   SetTextJustify(LeftText,BottomText);
  238.   y1 := 160 - 10 * 7;                {establish window size}
  239.   y2 := 190 + 10 * 7;                {  for 7 answer window}
  240.   Heading := 'Select bit to toggle:';
  241.   x1 := 104 - 4 * Length(Heading);
  242.   x2 := 136 + 4 * Length(Heading);
  243.   GetMem(Window,ImageSize(x1,y1,x2,y2));
  244.   GetImage(x1,y1,x2,y2,Window^);
  245.   OutlineBox(x1,y1,x2,y2,LightGray,Brown);
  246.   SetColor(Magenta);
  247.   OutTextXY(x1+16,y1+20,Heading);        {print the heading}
  248.   SetColor(Blue);
  249.   for i := 1 to 7 do begin            {print the answers}
  250.     Circle(x1+17,y1+16+(i*20),7);
  251.     if temp[i] = '1' then begin
  252.       SetFillStyle(SolidFill,DarkGray);
  253.       FloodFill(x1+17,y1+16+(i*20),Blue);
  254.     end;
  255.     OutTextXY(x1+32,y1+21+(i*20),ChangeQues[i]);
  256.     mtq[i,1] := x1 + 5;                {mouse array position}
  257.     mtq[i,2] := x1 + 20;            {  for this button}
  258.     mtq[i,3] := y1 + 9 + (i * 20);
  259.     mtq[i,4] := y1 + 23 + (i * 20);
  260.   end;
  261.   MouseCursorOn(Mx,My,HAND);
  262.   repeat                    {repeat until done...}
  263.     i := 0;
  264.     repeat                    {use mouse until key hit...}
  265.       MStatus(NewButton,NewX,NewY);        {get mouse status}
  266.       if (NewX <> Mx) or (NewY <> My) then    {mouse cursor moved!}
  267.         MouseCursor(NewX,NewY,Mx,My,FINGER);
  268.       Mx := NewX; My := NewY;            {remember new location}
  269.       if NewButton <> Button then begin        {if button changed...}
  270.         if NewButton > 0 then            {if button now down...}
  271.           i := MouseLocate(Mx,My,Size,@mtq);
  272.         Button := NewButton;            {remember new button setting}
  273.       end; {if button changed}
  274.     until KeyPressed or (i > 0);
  275.     if KeyPressed then begin
  276.       c := ReadKey;
  277.       case c of
  278.         'r': begin i := 1; j := 32; end;
  279.         'g': begin i := 2; j := 16; end;
  280.         'b': begin i := 3; j := 8; end;
  281.         'R': begin i := 4; j := 4; end;
  282.         'G': begin i := 5; j := 2; end;
  283.         'B': begin i := 6; j := 1; end;
  284.         else Delay(1);
  285.       end; {case}
  286.     end {if KeyPressed}
  287.     else begin
  288.       c := #0;
  289.       case i of
  290.         1: begin i := 1; j := 32; end;
  291.         2: begin i := 2; j := 16; end;
  292.         3: begin i := 3; j := 8; end;
  293.         4: begin i := 4; j := 4; end;
  294.         5: begin i := 5; j := 2; end;
  295.         6: begin i := 6; j := 1; end;
  296.         7: c := #13;
  297.         else Delay(1);
  298.       end; {case}
  299.     end;
  300.     if c <> #13 then begin
  301.       MouseCursorOff(Mx,My);
  302.       if temp[i] = '1' then begin    {toggle digit in string}
  303.         temp[i] := '0';
  304.         SetFillStyle(SolidFill,LightGray);
  305.         FloodFill(x1+17,y1+16+(i*20),Blue);
  306.       end
  307.       else begin
  308.         temp[i] := '1';
  309.     SetFillStyle(SolidFill,DarkGray);
  310.         FloodFill(x1+17,y1+16+(i*20),Blue);
  311.       end;
  312.       MouseCursorOn(Mx,My,FINGER);
  313.       MyPal[ChColor,pal] := MyPal[ChColor,pal] Xor j;
  314.       if pal = 0 then begin
  315.         MyPal[ChColor,1] := $FF;
  316.         SetPalette(ChColor,MyPal[ChColor,0]);{do the actual change}
  317.       end;
  318.     end;
  319.   until c = #13;
  320.   MouseCursorOff(Mx,My);
  321.   PutImage(x1,y1,Window^,NormalPut);
  322.   MouseCursorOn(Mx,My,HAND);
  323.   FreeMem(Window,ImageSize(x1,y1,x2,y2));
  324. end;
  325.  
  326. procedure ChangePalette;
  327. { change a color in the palette }
  328. var
  329.   c:  CHAR;
  330.   ChColor:  INTEGER;
  331. begin
  332.   c := MouseReadKey('Select color to change (0-9,A-F)');
  333.   if (c = #27) or (c = #13) then exit;
  334.   if c = #0 then
  335.     ChColor := (My - 25) div 14
  336.   else
  337.     ChColor := Ord(UpCase(c)) - 48;
  338.   if ChColor > 9 then ChColor := ChColor - 7;
  339.   ChangeColor(ChColor,0);
  340.   GotoXY(50,24);
  341.   TextColor(Black);ClrEol;
  342.   TextColor(Green);
  343.   Write('Palette: <none>');
  344. end; {ChangePalette procedure}
  345.  
  346. procedure RotatePalette;
  347. { set up a color to rotate (palette switch) }
  348. var
  349.   c:  CHAR;
  350.   RotColor:  INTEGER;
  351. begin
  352.   c := MouseReadKey('Select color to rotate (0-9,A-F)');
  353.   if (c = #27) or (c = #13) then exit;
  354.   if c = #0 then
  355.     RotColor := (My - 25) div 14
  356.   else
  357.     RotColor := Ord(UpCase(c)) - 48;
  358.   if RotColor > 9 then RotColor := RotColor - 7;
  359.   MyPal[RotColor,1] := MyPal[RotColor,0];
  360.   ChangeColor(RotColor,1);
  361.   GotoXY(50,24);
  362.   TextColor(Black);ClrEol;
  363.   TextColor(Green);
  364.   Write('Palette: <none>');
  365. end; {RotatePalette procedure}
  366.  
  367. procedure Look;
  368. { load adjacent parts of image to look at }
  369. var
  370.   temp:  STRING;
  371.   c:  CHAR;
  372.   code:  INTEGER;
  373.   rec:  WORD;
  374.   MyImage:  ^AnyImage;
  375. begin
  376.   SetFillStyle(SolidFill,Black);
  377.   Bar(234,80,266,112);
  378.   TextColor(Red);
  379.   GotoXY(31,7);Write('1 2');
  380.   GotoXY(31,8);Write('3 4');
  381.   for i := 1 to 4 do begin
  382.     filenm := MGetFile('*.pic','File '+ItoS(i)+' or Enter for drawing:');
  383.     if filenm[0] = #255 then begin    {abort if ESC hit}
  384.       exit;
  385.     end;    
  386.     if filenm = '' then begin            {if no name entered...}
  387.       case i of                    {this is where current goes}
  388.         1: begin LookX := 234;LookY := 80;end;
  389.         2: begin LookX := 250;LookY := 80;end;
  390.         3: begin LookX := 234;LookY := 96;end;
  391.         4: begin LookX := 250;LookY := 96;end;
  392.       end; {case}
  393.       GetMem(MyImage,Size);
  394.       GetImage(21,21,36,36,MyImage^);
  395.       PutImage(LookX,LookY,MyImage^,NormalPut);
  396.       FreeMem(MyImage,Size);
  397.     end
  398.     else begin                    {if name entered...}
  399.       if Pos('.',filenm) = 0 then
  400.         filenm := filenm + '.pic';
  401. {$I-}
  402.       Assign(fp2,filenm);            {open file}
  403.       Reset(fp2);
  404. {$I+}
  405.       if IOResult <> 0 then begin
  406.         GotoXY(5,22);Write('I/O ERROR');
  407.         Delay(1000);
  408.         TextColor(Black);
  409.         GotoXY(5,22);ClrEol;
  410.         TextColor(Red);
  411.       end
  412.       else begin
  413.         TextColor(Black);
  414.         GotoXY(5,22);ClrEol;
  415.         TextColor(Red);
  416.         if FileSize(fp2) > 1 then begin
  417.           repeat
  418.             GotoXY(5,22);Write('Record number (1-',FileSize(fp2),'): ');
  419.             TextColor(Black);ClrEol;
  420.             TextColor(Red);
  421.             ReadLn(temp);
  422.             Val(temp,rec,code);
  423.           until (rec > 0) and (rec <= FileSize(fp2)) and (code = 0);
  424.           Seek(fp2,rec-1);
  425.         end;
  426.         GetMem(MyImage,Size);                {reserve memory}
  427.         Read(fp2,MyImage^);
  428.         Close(fp2);
  429.         case i of
  430.           1: PutImage(234,80,MyImage^,Normalput);
  431.           2: PutImage(250,80,MyImage^,Normalput);
  432.           3: PutImage(234,96,MyImage^,Normalput);
  433.           4: PutImage(250,96,MyImage^,Normalput);
  434.         end; {case}
  435.         FreeMem(MyImage,Size);                {free memory}
  436.       end;
  437.     end;
  438.   end;
  439.   TextColor(Black);
  440.   GotoXY(5,22);ClrEol;
  441. end; {Look procedure}
  442.  
  443. procedure PalFunc;
  444. { select palette function }
  445. var
  446.   func:  CHAR;
  447. begin
  448.   case MouseQuestion(5,'Select a palette function',@PalQues) of
  449.     1:  SavePalette;
  450.     2:  NewPalette;
  451.     3:  ChangePalette;
  452.     4:  RotatePalette;
  453.     5:  DefaultPalette;
  454.     else Delay(1);
  455.   end; {case}
  456. end;
  457.  
  458. procedure DrawCursor(color: INTEGER);
  459. { draw the cursor }
  460. begin
  461.   SetColor(color);
  462.   Rectangle(51+x*10,21+y*10,61+x*10,31+y*10);
  463. end;
  464.  
  465. procedure PutIt(x,y,color:  INTEGER);
  466. { draw a pixel at several places so we can see the drawing several times }
  467. begin
  468.   PutPixel(x+21,y+21,Color);
  469.   PutPixel(x+234,y+21,Color);
  470.   PutPixel(x+250,y+21,Color);
  471.   PutPixel(x+266,y+21,Color);
  472.   PutPixel(x+234,y+37,Color);
  473.   PutPixel(x+250,y+37,Color);
  474.   PutPixel(x+266,y+37,Color);
  475.   PutPixel(x+234,y+53,Color);
  476.   PutPixel(x+250,y+53,Color);
  477.   PutPixel(x+266,y+53,Color);
  478.   if LookX <> 0 then
  479.     PutPixel(x+LookX,y+LookY,Color);
  480. end;
  481.  
  482. procedure SaveIt;
  483. { save image to file }
  484. var
  485.   FileRec: WORD;
  486. begin
  487.   TextColor(Brown);
  488.   GetMem(MyImage,Size);                {reserve memory}
  489.   GetImage(21,21,36,36,MyImage^);        {get image}
  490.   filenm := MGetFile('*.pic','Select picture file name:');
  491.   if filenm[0] = #255 then exit;        {abort if nothing entered}
  492.   if Pos('.',filenm) = 0 then
  493.     filenm := filenm + '.pic';
  494.   TextColor(Brown);
  495. {$I-}
  496.   Assign(fp2,filenm);
  497.   Reset(fp2);
  498. {$I+}
  499.   if IOResult <> 0 then begin            {if new file...}
  500.     GotoXY(5,22);Write('New File');
  501.     Rewrite(fp2);                {create it}
  502.     Write(fp2,MyImage^);            {write image to beginning}
  503.     Close(fp2);
  504.     FileRec := 1;
  505.   end
  506.   else begin                    {if existing file...}
  507.     GotoXY(5,22);Write('Record number (1-',FileSize(fp2)+1,'): ');
  508.     ReadLn(FileRec);
  509.     Seek(fp2,FileRec-1);            {seek desired record}
  510.     Write(fp2,MyImage^);            {write image there}
  511.     Close(fp2);
  512.   end;
  513.   TextColor(Black);
  514.   GotoXY(5,22);ClrEol;
  515.   GotoXY(50,23);
  516.   TextColor(Black);ClrEol;
  517.   TextColor(Green);
  518.   Write('  Image: ',filenm,' (',FileRec,')');
  519. end;
  520.  
  521. procedure Clear;
  522. { clear drawing areas }
  523. var
  524.   i,j:  INTEGER;
  525. begin
  526.   SetFillStyle(SolidFill,Black);
  527.   Bar(21,21,36,36);
  528.   Bar(51,21,210,180);
  529.   Bar(234,21,281,68);
  530.   SetColor(DarkGray);
  531.   for i := 0 to 16 do begin            {make grid in big box}
  532.     Line(51+(i*10),21,51+(i*10),181);
  533.     Line(51,21+(i*10),211,21+(i*10));
  534.   end;
  535.   DrawCursor(Yellow);                {initialize cursor}
  536.   GotoXY(50,23);
  537.   TextColor(Black);ClrEol;
  538.   TextColor(Green);
  539.   Write('  Image: <none>');
  540. end; {Clear procedure}
  541.  
  542. procedure Center;
  543. { move cursor to 7,7 }
  544. begin
  545.   DrawCursor(DarkGray);
  546.   x := 7; y := 7;
  547.   DrawCursor(Yellow);
  548. end;
  549.  
  550. procedure Home;
  551. { move cursor to 0,0 }
  552. begin
  553.   DrawCursor(DarkGray);
  554.   x := 0; y := 0;
  555.   DrawCursor(Yellow);
  556. end;
  557.  
  558. procedure GoEnd;
  559. { move cursor to 0,15 }
  560. begin
  561.   DrawCursor(DarkGray);
  562.   x := 0; y := 15;
  563.   DrawCursor(Yellow);
  564. end;
  565.  
  566. procedure TopRight;
  567. { move cursor to 15,0 }
  568. begin
  569.   DrawCursor(DarkGray);
  570.   x := 15; y := 0;
  571.   DrawCursor(Yellow);
  572. end;
  573.  
  574. procedure BottomRight;
  575. { move cursor to 15,15 }
  576. begin
  577.   DrawCursor(DarkGray);
  578.   x := 15; y := 15;
  579.   DrawCursor(Yellow);
  580. end;
  581.  
  582. procedure FarLeft;
  583. { move cursor to 0,y }
  584. begin
  585.   DrawCursor(DarkGray);
  586.   x := 0;
  587.   DrawCursor(Yellow);
  588. end;
  589.  
  590. procedure FarRight;
  591. { move cursor to 15,y }
  592. begin
  593.   DrawCursor(DarkGray);
  594.   x := 15;
  595.   DrawCursor(Yellow);
  596. end;
  597.  
  598. procedure UpLeft;
  599. { move the cursor up and left }
  600. begin
  601.   DrawCursor(DarkGray);
  602.   if y > 0 then
  603.     y := y - 1;
  604.   if x > 0 then
  605.     x := x - 1;
  606.   DrawCursor(Yellow);
  607. end;
  608.  
  609. procedure DownLeft;
  610. { move the cursor down and left }
  611. begin
  612.   DrawCursor(DarkGray);
  613.   if y < 15 then
  614.     y := y + 1;
  615.   if x > 0 then
  616.     x := x - 1;
  617.   DrawCursor(Yellow);
  618. end;
  619.  
  620. procedure UpRight;
  621. { move the cursor up and right }
  622. begin
  623.   DrawCursor(DarkGray);
  624.   if y > 0 then
  625.     y := y - 1;
  626.   if x < 15 then
  627.     x := x + 1;
  628.   DrawCursor(Yellow);
  629. end;
  630.  
  631. procedure DownRight;
  632. { move the cursor down and right }
  633. begin
  634.   DrawCursor(DarkGray);
  635.   if y < 15 then
  636.     y := y + 1;
  637.   if x < 15 then
  638.     x := x + 1;
  639.   DrawCursor(Yellow);
  640. end;
  641.  
  642. procedure UpArrow;
  643. { move the cursor up }
  644. begin
  645.   if y > 0 then begin
  646.     DrawCursor(DarkGray);
  647.     y := y - 1;
  648.     DrawCursor(Yellow);
  649.   end;
  650. end;
  651.  
  652. procedure DownArrow;
  653. { move the cursor up }
  654. begin
  655.   if y < 15 then begin
  656.     DrawCursor(DarkGray);
  657.     y := y + 1;
  658.     DrawCursor(Yellow);
  659.   end;
  660. end;
  661.  
  662. procedure LeftArrow;
  663. { move the cursor up }
  664. begin
  665.   if x > 0 then begin
  666.     DrawCursor(DarkGray);
  667.     x := x - 1;
  668.     DrawCursor(Yellow);
  669.   end;
  670. end;
  671.  
  672. procedure RightArrow;
  673. { move the cursor up }
  674. begin
  675.   if x < 15 then begin
  676.     DrawCursor(DarkGray);
  677.     x := x + 1;
  678.     DrawCursor(Yellow);
  679.   end;
  680. end;
  681.  
  682. procedure JustDrawIt;
  683. { like DrawIt without the cursor movements }
  684. begin
  685.   PutIt(x,y,Color);
  686.   SetFillStyle(SolidFill,Color);
  687.   Bar(52+x*10,22+y*10,60+x*10,30+y*10);
  688. end;
  689.  
  690. procedure MouseDrawIt;
  691. { draw a pixel from mouse }
  692. var
  693.   DrawX,DrawY:  INTEGER;
  694. begin
  695.   DrawX := x;                {save cursor location}
  696.   DrawY := y;
  697.   x := (Mx-52) div 10;            {set cursor to mouse position}
  698.   y := (My-22) div 10;
  699.   MouseCursorOff(Mx,My);
  700.   JustDrawIt;                {draw pixel}
  701.   MouseCursorOn(Mx,My,ARROW);
  702.   x := DrawX;                {recall cursor location}
  703.   y := DrawY;
  704. end; {MouseDrawIt procedure}
  705.  
  706. procedure DrawIt;
  707. { draw a pixel at current location }
  708. begin
  709.   PutIt(x,y,Color);
  710.   SetFillStyle(SolidFill,Color);
  711.   Bar(52+x*10,22+y*10,60+x*10,30+y*10);
  712.   case LastMove of
  713.     #71:  UpLeft;
  714.     #119: Home;
  715.     #79:  DownLeft;
  716.     #117: GoEnd;
  717.     #73:  UpRight;
  718.     #132: TopRight;
  719.     #81:  DownRight;
  720.     #118: BottomRight;
  721.     #76:  Center;
  722.     #72:  UpArrow;
  723.     #80:  DownArrow;
  724.     #75:  LeftArrow;
  725.     #115: FarLeft;
  726.     #77:  RightArrow;
  727.     #116: FarRight;
  728.     else Delay(1);
  729.    end; {case}
  730. end;
  731.  
  732. procedure Flip(FlipType:  INTEGER);
  733. { flip drawing }
  734. var
  735.   Savec,
  736.   Savex,
  737.   Savey:  INTEGER;
  738.   MyImage:  ^AnyImage;
  739. begin
  740.   GetMem(MyImage,Size);
  741.   GetImage(21,21,36,36,MyImage^);        {copy image outside normal}
  742.   PutImage(21,51,MyImage^,NormalPut);        {  location}
  743.   FreeMem(MyImage,Size);
  744.   Savex := x;                    {save cursor position}
  745.   Savey := y;
  746.   Savec := color;
  747.   for x := 0 to 15 do begin            {redraw it}
  748.     for y := 0 to 15 do begin
  749.       case FlipType of
  750.         1: color := GetPixel(36-x,51+y);    {left to right}
  751.         2: color := GetPixel(21+x,66-y);    {top to bottom}
  752.         3: color := GetPixel(21+y,66-x);    {rotate}
  753.       end; {case}
  754.       JustDrawIt;
  755.     end;
  756.   end;
  757.   x := Savex;
  758.   y := Savey;
  759.   color := Savec;
  760. end;
  761.  
  762. procedure Shift(ShiftType:  INTEGER);
  763. { shift drawing one pixel }
  764. var
  765.   Savec,
  766.   Savex,
  767.   Savey:  INTEGER;
  768.   MyImage:  ^AnyImage;
  769. begin
  770.   GetMem(MyImage,Size);
  771.   GetImage(21,21,36,36,MyImage^);        {copy image outside normal}
  772.   PutImage(21,51,MyImage^,NormalPut);        {  location}
  773.   FreeMem(MyImage,Size);
  774.   Savex := x;                    {save cursor position}
  775.   Savey := y;
  776.   Savec := color;
  777.   for x := 0 to 15 do begin            {redraw it}
  778.     for y := 0 to 15 do begin
  779.       case ShiftType of
  780.         1: color := GetPixel(20+x,51+y);    {shift right}
  781.         2: color := GetPixel(22+x,51+y);    {shift left}
  782.         3: color := GetPixel(21+x,52+y);    {shift up}
  783.         4: color := GetPixel(21+x,50+y);    {shift down}
  784.       end; {case}
  785.       JustDrawIt;
  786.     end;
  787.   end;
  788.   x := Savex;
  789.   y := Savey;
  790.   color := Savec;
  791. end;
  792.  
  793. procedure Fill;
  794. { fill in an area }
  795. var
  796.   flag:  BOOLEAN;
  797.   OldColor,
  798.   savex,savey,
  799.   xbegin,xend,
  800.   fillx,filly:  INTEGER;
  801. begin
  802.   savex := x; savey := y;        {remember where cursor was}
  803.   fillx := x; filly := y;
  804.   OldColor := GetPixel(21+fillx,21+filly);
  805.   repeat
  806.     repeat                {find left edge of region}
  807.       fillx := fillx - 1;
  808.     until (fillx < 0) or (GetPixel(21+fillx,21+filly) <> OldColor);
  809.     fillx := fillx + 1;
  810.     xbegin := fillx;
  811.     repeat                {fill from left to right edge}
  812.       x := fillx; y := filly;
  813.       JustDrawIt;
  814.       fillx := fillx + 1;
  815.     until (GetPixel(21+fillx,21+filly) <> OldColor) or (fillx > 15);
  816.     filly := filly - 1;            {back up a line}
  817.     flag := FALSE;
  818.     for i := xbegin to fillx-1 do begin    {see if empty area on previous line}
  819.       if GetPixel(21+i,21+filly) = OldColor then begin
  820.         fillx := i;            {yes, remember where}
  821.         flag := TRUE;
  822.       end;
  823.     end; {for i}
  824.   until (flag = FALSE) or (filly < 0);
  825.   x := savex; y := savey;        {restore cursor}
  826. end; {Fill procedure}
  827.  
  828. procedure ViewAll;
  829. { view page 1 to see last group of images read in }
  830. begin
  831.   MouseCursorOff(Mx,My);
  832.   SetActivePage(1);                {select alternate page}
  833.   SetVisualPage(1);
  834.   MouseCursorOn(Mx,My,FINGER);
  835.   repeat
  836.   until MouseYN(300,300,'Continue?');
  837.   MouseCursorOff(Mx,My);
  838.   SetActivePage(0);                {select normal page}
  839.   SetVisualPage(0);
  840.   MouseCursorOn(Mx,My,HAND);
  841. end;
  842.  
  843. procedure ReadIt;
  844. { read image from file }
  845. var
  846.   temp:  STRING;
  847.   SaveColor:  INTEGER;
  848.   FileRec,
  849.   PutType:  WORD;
  850. begin
  851.   SaveColor := Color;
  852.   TextColor(Brown);
  853.   GetMem(MyImage,Size);                {reserve memory}
  854.   filenm := MGetFile('*.pic','Select picture file name:');
  855.   if filenm[0] = #255 then exit;        {abort if nothing entered}
  856.   if Pos('.',filenm) = 0 then
  857.     filenm := filenm + '.pic';
  858. {$I-}
  859.   Assign(fp2,filenm);                {try to open file}
  860.   Reset(fp2);
  861. {$I+}
  862.   if IOResult <> 0 then begin            {if no such file...}
  863.     GotoXY(5,22);Write('I/O ERROR');
  864.     Delay(1000);
  865.     TextColor(Black);
  866.     GotoXY(5,22);ClrEol;
  867.     TextColor(Green);
  868.   end
  869.   else begin                    {if file exists...}
  870.     if FileSize(fp2) > 1 then begin
  871.       SetColor(Yellow);
  872.       MaxRec := FileSize(fp2);            {get # records in file}
  873.       MouseCursorOff(Mx,My);
  874.       SetActivePage(1);                {select alternate page}
  875.       SetFillStyle(SolidFill,Black);
  876.       Bar(0,0,639,349);                {clear it}
  877.       GetMem(AltImage,Size);            {get memory for images}
  878.       Reset(fp2);                {open file to beginning}
  879.       for i := 0 to MaxRec-1 do begin        {now draw each image in file}
  880.         Read(fp2,AltImage^);
  881.         PutImage(32+(i mod 18)*32,28+(i div 18)*40,AltImage^,NormalPut);
  882.         OutTextXY(32+(i mod 18)*32,54+(i div 18)*40,ItoS(i+1));
  883.       end;
  884.       OutlineBox(570,320,629,339,Red,Yellow);
  885.       OutTextXY(581,334,'ABORT');
  886.       SetVisualPage(1);
  887.       MoveTo(40,310);
  888.       SetColor(Yellow);
  889.       OutText('Record number (1-'+ItoS(MaxRec)+'): ');
  890.       MouseCursorOn(Mx,My,FINGER);
  891.       FileRec := 0;
  892.       repeat                    {use mouse until key hit...}
  893.         MStatus(NewButton,NewX,NewY);        {get mouse status}
  894.           if (NewX <> Mx) or (NewY <> My) then    {mouse cursor moved!}
  895.             MouseCursor(NewX,NewY,Mx,My,FINGER);
  896.         Mx := NewX; My := NewY;            {remember new location}
  897.         if NewButton <> Button then begin    {if button changed...}
  898.           if NewButton > 0 then            {if button now down...}
  899.             i := ((Mx-32) div 32) + 18 * ((My-28) div 40) + 1;
  900.               if i <= MaxRec then FileRec := i;
  901.         if (Mx>570) and (My>320) then begin    {if abort...}
  902.           MouseCursorOff(Mx,My);
  903.           SetActivePage(0);
  904.           SetVisualPage(0);
  905.           MouseCursorOn(Mx,My,FINGER);
  906.           exit;                {just exit}
  907.         end;
  908.       Button := NewButton;            {remember new button setting}
  909.         end; {if button changed}
  910.       until KeyPressed or (FileRec > 0);
  911.       MouseCursorOff(Mx,My);
  912.       if KeyPressed then begin
  913.         Input(temp);
  914.         Val(temp,FileRec,i);
  915.       end; {if KeyPressed}
  916.       SetActivePage(0);
  917.       SetVisualPage(0);
  918.       MouseCursorOn(Mx,My,FINGER);
  919.     end
  920.     else FileRec := 1;
  921.     PutType := MouseQuestion(5,'PutImage type:',@PutQues) - 1;
  922.     TextColor(Brown);
  923.     Seek(fp2,FileRec-1);
  924.     Read(fp2,MyImage^);
  925.     Close(fp2);
  926.     PutImage(21,21,MyImage^,PutType);        {put image in small box}
  927.     MouseCursorOff(Mx,My);
  928.     DrawCursor(DarkGray);            {erase cursor}
  929.     for x := 0 to 15 do begin            {now put it in big box}
  930.       for y := 0 to 15 do begin
  931.         Color := GetPixel(21+x,21+y);
  932.         JustDrawIt;
  933.       end;
  934.     end;
  935.     MouseOn;
  936.     x := 0; y := 0;
  937.     Color := SaveColor;                {restore drawing color}
  938.     DrawCursor(Yellow);
  939.     GotoXY(50,23);
  940.     TextColor(Black);ClrEol;
  941.     TextColor(Green);
  942.     Write('  Image: ',filenm,'(',FileRec,')');
  943.   end;
  944. end;
  945.  
  946. procedure ReRead;
  947. { reread an image from the last file opened }
  948. var
  949.   tempstr:  STRING;
  950.   temp:  POINTER;
  951.   SaveColor,
  952.   FileRec:  INTEGER;
  953. begin
  954.   SaveColor := color;
  955.   MouseCursorOff(Mx,My);
  956.   SetActivePage(1);                {select alternate page}
  957.   SetVisualPage(1);
  958.  
  959.   SetColor(Yellow);
  960.   MoveTo(40,310);            {prompt for desired image}
  961.   OutText('Record number (1-'+ItoS(MaxRec)+'): ');
  962.   SetFillStyle(SolidFill,Black);
  963.   Bar(GetX,GetY,GetX+32,GetY-8);
  964.   MouseCursorOn(Mx,My,FINGER);
  965.   FileRec := 0;
  966.   MStatus(NewButton,NewX,NewY);            {get mouse status}
  967.   Button := NewButton;
  968.   repeat                    {use mouse until key hit...}
  969.     MStatus(NewButton,NewX,NewY);        {get mouse status}
  970.       if (NewX <> Mx) or (NewY <> My) then    {mouse cursor moved!}
  971.         MouseCursor(NewX,NewY,Mx,My,FINGER);
  972.     Mx := NewX; My := NewY;            {remember new location}
  973.     if NewButton <> Button then begin        {if button changed...}
  974.       if NewButton > 0 then begin        {if button now down...}
  975.         i := ((Mx-32) div 32) + 18 * ((My-28) div 40) + 1;
  976.         if i <= MaxRec then FileRec := i;
  977.         if (Mx>570) and (My>320) then begin    {if abort...}
  978.           MouseCursorOff(Mx,My);
  979.           SetActivePage(0);
  980.           SetVisualPage(0);
  981.           MouseCursorOn(Mx,My,FINGER);
  982.           exit;                    {just exit}
  983.         end; {if abort}
  984.       end; {if button changed}
  985.       Button := NewButton;            {remember new button setting}
  986.     end; {if button changed}
  987.   until KeyPressed or (FileRec > 0);
  988.   MouseCursorOff(Mx,My);
  989.   if KeyPressed then begin            {key was pressed, get image}
  990.     Input(tempstr);                {number from keyboard}
  991.     Val(tempstr,FileRec,i);
  992.   end; {if KeyPressed}
  993.  
  994.   FileRec := FileRec - 1;
  995.   GetMem(temp,ImageSize(0,0,15,15));        {get the desired image}
  996.   GetImage(32+(FileRec mod 18)*32,28+(FileRec div 18)*40,
  997.            47+(FileRec mod 18)*32,43+(FileRec div 18)*40,temp^);
  998.   SetActivePage(0);
  999.   SetVisualPage(0);
  1000.  
  1001.   PutImage(21,21,temp^,NormalPut);        {put image in small box}
  1002.   DrawCursor(DarkGray);                {erase cursor}
  1003.   for x := 0 to 15 do begin            {now put it in big box}
  1004.     for y := 0 to 15 do begin
  1005.       Color := GetPixel(21+x,21+y);
  1006.       JustDrawIt;
  1007.     end;
  1008.   end;
  1009.   x := 0; y := 0;
  1010.   Color := SaveColor;                {restore drawing color}
  1011.   DrawCursor(Yellow);
  1012.   GotoXY(50,23);
  1013.   TextColor(Black);ClrEol;
  1014.   TextColor(Green);
  1015.   Write('  Image: ',filenm,'(',FileRec+1,')');
  1016.   FreeMem(temp,ImageSize(0,0,15,15));
  1017.  
  1018.   MouseCursorOn(Mx,My,FINGER);
  1019. end; {ReRead procedure}
  1020.  
  1021. begin {Main routine}
  1022.   if RegisterBGIdriver(@EGAVGADriverProc) < 0 then
  1023.     Abort('EGA/VGA');
  1024.   Initialize;                    {initialize graphics}
  1025.   PalFlag := 1;
  1026.   GetIntVec($1C,Int1CSave);            {save interrupt vector}
  1027.   SetIntVec($1C,New1CInt);            {install timer interrupt}
  1028.  
  1029.   LookX := 0; LookY := 0;            {no look image now}
  1030.   DefaultPalette;                {set up normal palette}
  1031.   Size := ImageSize(0,0,15,15);            {size of images}
  1032.   x := 0; y := 0;                {initialize cursor}
  1033.   SetColor(LightGray);
  1034.   Rectangle(19,19,38,38);            {outline drawing areas}
  1035.   Rectangle(50,20,212,182);
  1036.   Rectangle(310,20,390,255);            {outline color chart}
  1037.   Rectangle(339,24,381,250);
  1038.   for i := 0 to 15 do begin
  1039.     SetFillStyle(SolidFill,i);
  1040.     Bar(340,25+(i*14),380,39+(i*14));
  1041.     GotoXY(41,3+i);
  1042.     if i < 10 then
  1043.       Write(i:1)
  1044.     else
  1045.       Write(Chr(i+55));
  1046.   end;
  1047.   Clear;
  1048.   Prompts;
  1049.   Color := 0;
  1050.   if MReset = -1 then begin            {see if mouse installed}
  1051.     MLimit(0,639-MW,0,349-MH);            {set mouse limits}
  1052.     MPut(0,0);                    {reset mouse coordinates}
  1053.   end;
  1054.   Mx := 0; My := 0;                {reset mouse cursor}
  1055.   Button := 0;
  1056.   GetMem(MCurs,ImageSize(0,0,MW,MH));
  1057.   MouseCursorOn(0,0,HAND);
  1058.   repeat                    {repeat until quit}
  1059.     GotoXY(52,2);
  1060.     TextColor(Color);
  1061.     if MyPal[Color,0] = 0 then
  1062.       TextColor(LightGray);
  1063.     if Color < 10 then
  1064.       Write('Color=',Color,' ')
  1065.     else
  1066.       Write('Color=',Chr(Color+55));
  1067.     repeat                    {use mouse until key hit...}
  1068.       MStatus(NewButton,NewX,NewY);        {get mouse status}
  1069.       if (NewX <> Mx) or (NewY <> My) then    {mouse cursor moved!}
  1070.         case MouseLocate(NewX,NewY,18,@mt) of
  1071.           0:  MouseCursor(NewX,NewY,Mx,My,HAND);
  1072.           2:  MouseCursor(NewX,NewY,Mx,My,ARROW);
  1073.           else  MouseCursor(NewX,NewY,Mx,My,FINGER);
  1074.         end;
  1075.       Mx := NewX; My := NewY;            {remember new location}
  1076.       if NewButton <> Button then begin        {if button changed...}
  1077.         if NewButton > 0 then begin        {if button now down...}
  1078.           case MouseLocate(Mx,My,18,@mt) of    {do a command}
  1079.             1: MouseColor;            {set a color}
  1080.             2: MouseDrawIt;            {draw a pixel}
  1081.             3: SaveIt;
  1082.             4: ReadIt;
  1083.         5: ReRead;
  1084.         6: PalFunc;
  1085.         7: if MouseYN(200,200,'Confirm clear?') then Clear;
  1086.         8: ViewAll;
  1087.         9: Look;
  1088.         10: Fill;
  1089.         11: begin MouseCursor(Mx,My,Mx,My,1);Flip(1);MouseCursor(Mx,My,Mx,My,2);end;
  1090.         12: begin MouseCursor(Mx,My,Mx,My,1);Flip(2);MouseCursor(Mx,My,Mx,My,2);end;
  1091.         13: begin MouseCursor(Mx,My,Mx,My,1);Flip(3);MouseCursor(Mx,My,Mx,My,2);end;
  1092.         14: Shift(1);
  1093.         15: Shift(2);
  1094.         16: Shift(3);
  1095.         17: Shift(4);
  1096.         18: if MouseYN(200,200,'Confirm quit?') then Halt;
  1097.           else Delay(1);
  1098.           end; {case}
  1099.         end; {if button now down}
  1100.         Button := NewButton;            {remember new button setting}
  1101.       end; {if button changed}
  1102.     until KeyPressed;
  1103.     cmd := ReadKey;                {read a key}
  1104.     if cmd = #0 then begin
  1105.       cmd := ReadKey;                {2nd half of arrow key}
  1106.       LastMove := cmd;                {remember last move direction}
  1107.       case cmd of
  1108.         #71:  UpLeft;
  1109.         #119: Home;
  1110.         #79:  DownLeft;
  1111.         #117: GoEnd;
  1112.         #73:  UpRight;
  1113.         #132: TopRight;
  1114.         #81:  DownRight;
  1115.         #118: BottomRight;
  1116.         #76:  Center;
  1117.         #72:  UpArrow;
  1118.         #80:  DownArrow;
  1119.         #75:  LeftArrow;
  1120.         #115: FarLeft;
  1121.         #77:  RightArrow;
  1122.         #116: FarRight;
  1123.         else Begin Sound(440);Delay(250);NoSound;End;
  1124.        end; {case}
  1125.       cmd := #0;
  1126.     end
  1127.     else begin
  1128.       case UpCase(cmd) of
  1129.       '0': Color := 0;
  1130.       '1': Color := 1;
  1131.       '2': Color := 2;
  1132.       '3': Color := 3;
  1133.       '4': Color := 4;
  1134.       '5': Color := 5;
  1135.       '6': Color := 6;
  1136.       '7': Color := 7;
  1137.       '8': Color := 8;
  1138.       '9': Color := 9;
  1139.       'A': Color := 10;
  1140.       'B': Color := 11;
  1141.       'C': Color := 12;
  1142.       'D': Color := 13;
  1143.       'E': Color := 14;
  1144.       'F': Color := 15;
  1145.       'P': PalFunc;
  1146.       'L': Look;
  1147.       'S': SaveIt;
  1148.       'R': ReadIt;
  1149.       'V': ViewAll;
  1150.       'W': ReRead;
  1151.       'Q': if MouseYN(200,200,'Confirm quit <Y/N>?') then Halt;
  1152.       'X': if MouseYN(200,200,'Confirm clear?') then Clear;
  1153.       'Z': Fill;
  1154.       '-': Shift(1);                {shift right}
  1155.       '+': Shift(2);                {shift left}
  1156.       '^': Shift(3);                {shift up}
  1157.       '|': Shift(4);                {shift down}
  1158.       '<': Flip(1);
  1159.       '>': Flip(2);
  1160.       '@': Flip(3);
  1161.       ' ': DrawIt;
  1162.       else Begin Sound(440);Delay(250);NoSound;End;
  1163.       end; {case}
  1164.     end;
  1165.   until UpCase(Cmd) = 'Q';
  1166. end.
  1167.