home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / MAGAZINE / MISC / AI_MAY89.ZIP / AIUSER.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-08-24  |  9.1 KB  |  384 lines
  1. unit AiUser;
  2.  
  3. interface
  4.  
  5. uses crt,aiglob,
  6.              initunit,bordunit,aidigit;
  7.  
  8.  
  9. Procedure MakeVideoBox(x1,y1,x2,y2:word);
  10. Procedure EraseVideoBox(x1,y1,x2,y2:word);
  11. procedure Makecross(x,y:word;size:byte);
  12. procedure Erasecross(x,y:word;size:byte);
  13. Procedure TabletDriver(var x1,y1,x2,y2:word;TwoLayer:boolean);
  14. Function GetGray(x,y:word;Size : byte):byte;
  15. Procedure EraseIt(x,y:word;Nucsize : byte);
  16. Procedure BlackToRed(x1,y1,x2,y2:word);
  17.  
  18. implementation
  19.  
  20. Var
  21.     graydatah,
  22.     graydatav : array[1..7] of byte;
  23.  
  24. Procedure MakeCross(x,y:word;size:byte);
  25. var i : word;
  26.     count : byte;
  27. begin
  28.   If size > 3 then
  29.     size := 3;
  30.   newgrayvalue(1,1,1);
  31.   count := 0;
  32.   for i := x-size to x+size do
  33.   begin
  34.     count := count+1;
  35.     graydatah[count] := oldgrayvalue(i,y);
  36.     If (graydatah[count] and 1 <> 1) then
  37.        newgrayvalue(i,y,graydatah[count] or 1)
  38.     else
  39.        newgrayvalue(i,y,20);
  40.   end;
  41.   count := 0;
  42.   for i := y-size to y+size do
  43.   begin
  44.     count := count+1;
  45.     If (i <> y) then
  46.     begin
  47.       graydatav[count] := oldgrayvalue(x,i);
  48.       If (graydatav[count] and 1 <> 1) then
  49.          newgrayvalue(x,i,graydatav[count] or 1)
  50.       else
  51.          newgrayvalue(x,i,20);
  52.     end;
  53.   end;
  54. end;
  55.  
  56. Procedure EraseCross(x,y:word;size:byte);
  57. var i : word;
  58.     count : byte;
  59. begin
  60.   If size > 3 then
  61.     size := 3;
  62.   newgrayvalue(1,1,1);
  63.   count := 0;
  64.   for i := x-size to x+size do
  65.   begin
  66.     count := count+1;
  67.     newgrayvalue(i,y,graydatah[count]);
  68.   end;
  69.   count := 0;
  70.   for i := y-size to y+size do
  71.   begin
  72.     count := count+1;
  73.     If (i <> y) then
  74.       newgrayvalue(x,i,graydatav[count]);
  75.   end;
  76. end;
  77.  
  78.  
  79. Procedure MakeVideoBox(x1,y1,x2,y2:word);
  80. Var
  81.     j,k : word;
  82.     xc,yc : word;
  83. begin
  84.     newgrayvalue(1,1,oldgrayvalue(1,1));
  85.     for j := x1 to x2 do
  86.     begin
  87.        newgrayvalue(j,y1,(oldgrayvalue(j,y1) or 1));
  88.        newgrayvalue(j,y2,(oldgrayvalue(j,y2) or 1));
  89.     end;
  90.     for k := y1 to y2 do
  91.     begin
  92.        newgrayvalue(x1,k,(oldgrayvalue(x1,k) or 1));
  93.        newgrayvalue(x2,k,(oldgrayvalue(x2,k) or 1));
  94.     end;
  95.     xc := (x1+x2) shr 1;
  96.     yc := (y1+y2) shr 1;
  97. end;
  98.  
  99. Procedure EraseVideoBox(x1,y1,x2,y2:word);
  100. Var
  101.     j,k : word;
  102.     xc,yc : word;
  103. begin
  104.     newgrayvalue(1,1,oldgrayvalue(1,1));
  105.     for j := x1 to x2 do
  106.     begin
  107.        newgrayvalue(j,y1,(oldgrayvalue(j,y1) and $FE));
  108.        newgrayvalue(j,y2,(oldgrayvalue(j,y2) and $FE));
  109.     end;
  110.     for k := y1 to y2 do
  111.     begin
  112.        newgrayvalue(x1,k,(oldgrayvalue(x1,k) and $FE));
  113.        newgrayvalue(x2,k,(oldgrayvalue(x2,k) and $FE));
  114.     end;
  115.     xc := (x1+x2) shr 1;
  116.     yc := (y1+y2) shr 1;
  117. end;
  118.  
  119.  
  120. procedure TabletDriver(var x1,y1,x2,y2:word;TwoLayer:boolean);
  121. Const
  122.     xc = 256;
  123.     yc = 240;
  124. Var
  125.     xdig,ydig,butdig,errdig : integer;
  126.     buttemp,butold : integer;
  127.     xo1,xo2,yo1,yo2 : integer;
  128.     xold,yold : integer;
  129.     width,height,
  130.     W_old,H_old : word;
  131.     Enlarge,
  132.     done        : boolean;
  133. begin
  134.   done := false;
  135.   butdig := 0;                                     {button to zero}
  136.   xold := 0;                                       {init old coords}
  137.   yold := 0;
  138.   Width := 100;                                     {Init aspects}
  139.   Height := 100;
  140.   W_old := 100;
  141.   H_old := 100;
  142.   x1 := xc-width;
  143.   x2 := xc+width;
  144.   y1 := yc-height;
  145.   y2 := yc+height;
  146.  
  147.   Enlarge := TRUE;                                 {using 1 or 2 enlarges
  148.                                                      by default}
  149.  
  150.   repeat
  151.     digitlocate(xdig,ydig,butdig,errdig);
  152.     If (butold = 3) and (butdig = 3) then           {exit?}
  153.       done := true;                                 {do this because 3 twice
  154.                                                         is the exit code}
  155.     If butdig <> 0 then                             {set button}
  156.        butold := butdig;
  157.     buttemp := butdig;
  158.  
  159.     If butdig = 3 then                              {only have 3 buts to use}
  160.     begin
  161.      repeat
  162.         digitlocate(xdig,ydig,butdig,errdig);
  163.      until butdig = 0;
  164.      delay(100);
  165.     end;
  166.     Case buttemp of                                  {what do we do?}
  167.       3: Enlarge := Not Enlarge;
  168.       1: If Enlarge and (width > 50) then
  169.             Width := Width - 20
  170.           Else if (Not Enlarge) and (width < 200) then
  171.             Width := Width + 20;
  172.       2: If Enlarge and (height > 50) then
  173.             Height := Height - 20
  174.           Else if (Not Enlarge) and (height < 200) then
  175.             Height := Height + 20;
  176.       else;
  177.      end;{end case}
  178.  
  179.                                                       {do something}
  180.     If (buttemp = 1) or (buttemp = 2) then
  181.     begin
  182.       x1 := xc - width;                          {change size or location}
  183.       x2 := xc + width;
  184.       y1 := yc - height;
  185.       y2 := yc + height;
  186.       xo1 := xold-w_old;
  187.       xo2 := xold+w_old;
  188.       yo1 := yold-h_old;
  189.       yo2 := yold+h_old;
  190.       w_old := width;
  191.       h_old := height;
  192.       erasevideobox(xo1,yo1,xo2,yo2);
  193.       If twolayer then
  194.         erasevideobox(xo1-5,yo1-5,xo2+5,yo2+5);
  195.       makevideobox(x1,y1,x2,y2);
  196.       If twolayer then
  197.         makevideobox(x1-5,y1-5,x2+5,y2+5);
  198.       xold := xc;
  199.       yold := yc;
  200.     end;
  201.   until done;
  202.   erasevideobox(x1,y1,x2,y2);
  203.   if twolayer then
  204.     erasevideobox(x1-5,y1-5,x2+5,y2+5);
  205.  
  206. end;
  207.  
  208. Function Sampleit(x1,y1,x2,y2:word):word;
  209. var j,k : word;
  210.     sum : word;
  211.     count : word;
  212. begin
  213.   sum := 0;
  214.   count := 0;
  215.   for k := y1+1 to y2-1 do
  216.     for j := x1+1 to x2-1 do
  217.       begin
  218.        count := count + 1;
  219.        sum := sum + oldgrayvalue(j,k);
  220.       end;
  221.    Sampleit := round(sum/count);
  222. end;
  223.  
  224. Procedure SampleBackFor(Var Bk1,Fr1,bk2,fr2,bk3,fr3,bk4,fr4 : byte);
  225. Var
  226.     done : boolean;
  227.     xdig,ydig,butdig,errdig : integer;
  228.     xold,yold : integer;
  229.     x1,y1,x2,y2,
  230.     xo1,yo1,xo2,yo2 : word;
  231.     j,i : word;
  232.     temp : byte;
  233.  
  234. begin
  235.   done := false;
  236.   xold := 0;
  237.   yold := 0;
  238.   newgrayvalue(1,1,1);
  239.  
  240.   Writeln('Sample four background/foreground pairs:');
  241.  
  242.   for j := 0 to 512 do                                {set up grid}
  243.   begin
  244.      newgrayvalue(j,256,(oldgrayvalue(j,256) or 1));
  245.      newgrayvalue(256,j,(oldgrayvalue(256,j) or 1));
  246.   end;
  247.  
  248.  for i := 1 to 1 do
  249.  begin
  250.  
  251.   Repeat                                               {mov box}
  252.     digitlocate(xdig,ydig,butdig,errdig);
  253.     If butdig = 1 then
  254.       done := true
  255.     else if (xold <> xdig) or (yold <> ydig) then
  256.     begin
  257.       x1 := xdig - 5;                          {change size or location}
  258.       x2 := xdig + 5;
  259.       y1 := ydig - 5;
  260.       y2 := ydig + 5;
  261.       xo1 := xold-5;
  262.       xo2 := xold+5;
  263.       yo1 := yold-5;
  264.       yo2 := yold+5;
  265.       erasevideobox(xo1,yo1,xo2,yo2);
  266.       makevideobox(x1,y1,x2,y2);
  267.       xold := xdig;
  268.       yold := ydig;
  269.     end;
  270.   until done;
  271.   erasevideobox(x1,y1,x2,y2);
  272.  
  273.   repeat
  274.     digitlocate(xdig,ydig,butdig,errdig);
  275.   until butdig = 0;
  276.  
  277.   temp := sampleit(x1,y1,x2,y2);
  278.   writeln('sample ',i,' is ',temp);
  279.   done := false;
  280.   bk1 := temp;
  281.  
  282.  end;
  283.  
  284.   for j := 0 to 512 do                           {erase grid}
  285.   begin
  286.      newgrayvalue(j,256,(oldgrayvalue(j,256) and $FE));
  287.      newgrayvalue(256,j,(oldgrayvalue(256,j) and $FE));
  288.   end;
  289.  
  290.  
  291. end;
  292.  
  293. Function GetGray(x,y:word;Size : byte):byte;
  294. Var j,k:word;
  295.     Temp : word;
  296.     gray1 : byte;
  297.     count : word;
  298. begin
  299.     Temp := 0;
  300.     For k := y-size to y+size do
  301.       for j := x-size to x+size do
  302.          Temp := Temp + oldgrayvalue(j,k);
  303.     Count := sqr((2*size) + 1);
  304.     GetGray := round(Temp/count);
  305. end;
  306.  
  307. Procedure BlackToRed(x1,y1,x2,y2:word);
  308. var j,k:word;
  309.     gray1 : byte;
  310. begin
  311.   for k := y1 to y2 do
  312.     for j := x1 to x2 do
  313.     begin
  314.       gray1 := oldgrayvalue(j,k);
  315.       If (gray1 = 20) then
  316.         newgrayvalue(j,k,1);
  317.     end;
  318. end;
  319.  
  320. Procedure EraseIt(x,y:word;Nucsize : byte);
  321. var j,k: word;
  322.     gray1 : byte;
  323.     foundfirst : boolean;
  324.     end1,end2 : word;
  325. begin
  326.   newgrayvalue(1,1,1);
  327.   FoundFirst := FALSE;
  328.   j := x;
  329.   While Not(FoundFirst) or (j = x-(2*nucsize)) do
  330.   begin
  331.     If (oldgrayvalue(j,y) and 1 <> 1) then
  332.       FoundFirst := TRUE;
  333.     j := j-1;
  334.   end;
  335.   end1 := j-5;
  336.   FoundFirst := FALSE;
  337.   j := x+1;
  338.   While Not(FoundFirst) or (j = x+(2*nucsize)) do
  339.   begin
  340.     If (oldgrayvalue(j,y) and 1 <> 1) then
  341.       FoundFirst := TRUE;
  342.     j := j+1;
  343.   end;
  344.   end2 := j+5;
  345.  
  346.   FoundFirst := FALSE;
  347.   k := y;
  348.   While Not(FoundFirst) or (k = y-(2*nucsize)) do
  349.   begin
  350.     FoundFirst := TRUE;
  351.     For j := end1 to end2 do
  352.     begin
  353.       Gray1 := oldgrayvalue(j,k);
  354.       If (gray1 and 1 = 1) then
  355.       begin
  356.         FoundFirst := FALSE;
  357.         newgrayvalue(j,k,gray1 and $FE);
  358.       end;
  359.     end;
  360.     k := k-1;
  361.   end;
  362.  
  363.   FoundFirst := FALSE;
  364.   k := y+1;
  365.   While Not(FoundFirst) or (k = y+(3*nucsize)) do
  366.   begin
  367.     FoundFirst := TRUE;
  368.     For j := end1 to end2 do
  369.     begin
  370.       Gray1 := oldgrayvalue(j,k);
  371.       If (gray1 and 1 = 1) then
  372.       begin
  373.         FoundFirst := FALSE;
  374.         newgrayvalue(j,k,gray1 and $FE);
  375.       end;
  376.     end;
  377.     k := k+1;
  378.   end;
  379.  
  380. end;
  381.  
  382.  
  383.  
  384. END.