home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / MAGAZINE / MISC / AI_MAY89.ZIP / AIIMGS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-08-24  |  16.2 KB  |  558 lines
  1. {$R-}    {Range checking off}
  2. {$B+}    {Boolean complete evaluation on}
  3. {$S+}    {Stack checking on}
  4. {$I+}    {I/O checking on}
  5.  
  6. Unit aiIMGS;
  7.  
  8. Interface
  9.  
  10. Uses
  11.      DOS,      CRT,      GLOBUNIT, aiDIGIt, JWINUNIT, BORDUNIT;
  12.  
  13. procedure SaveFile(FileName : string);
  14. procedure SubtractFile(FileName : string);
  15. procedure StoreShading;
  16. procedure ShadingCorrect;
  17. procedure pixelfinder;
  18.  
  19. {===========================================================================}
  20.  
  21. Implementation
  22.  
  23. procedure DrawCursor(X,Y : integer);
  24. { ++++++++++++++++++++++++++++++++++++++++++++++++ }
  25.  
  26.   var i,ValueA : integer;
  27.   begin
  28. {
  29.     ValueA := OldGrayValue(X,Y);
  30.     GotoXY(24,12);
  31.     writeln('X = ',X:3,'    Y = ',Y:3,'    Value = ',ValueA:3);
  32. }
  33.     if ((X < 10) or (X > 502) or (Y < 10) or (Y > 502)) then
  34.     else
  35.       begin
  36.         for i := (Y - 10) to (Y + 10) do
  37.           begin
  38.             if (i <> Y) then
  39.               begin
  40.                 ValueA := OldGrayValue(X,i) + $80;
  41.                 NewGrayValue(X,i,ValueA);
  42.               end;
  43.           end;
  44.         for i := (X - 10) to (X + 10) do
  45.           begin
  46.             if (i <> X) then
  47.               begin
  48.                 ValueA := OldGrayValue(i,Y) + $80;
  49.                 NewGrayValue(i,Y,ValueA);
  50.               end;
  51.           end;
  52.       end;
  53.     end;
  54.  
  55.  
  56. procedure UndrawCursor(X,Y : integer);
  57. { ++++++++++++++++++++++++++++++++++++++++++++++++ }
  58.  
  59.   var i,ValueA : integer;
  60.   begin
  61.     if ((X < 10) or (X > 502) or (Y < 10) or (Y > 502)) then
  62.     else
  63.       begin
  64.         for i := (Y - 10) to (Y + 10) do
  65.           begin
  66.             if (i <> Y) then
  67.               begin
  68.                 ValueA := OldGrayValue(X,i) - $80;
  69.                 NewGrayValue(X,i,ValueA);
  70.               end;
  71.           end;
  72.         for i := (X - 10) to (X + 10) do
  73.           begin
  74.             if (i <> X) then
  75.               begin
  76.                 ValueA := OldGrayValue(i,Y) - $80;
  77.                 NewGrayValue(i,Y,ValueA);
  78.               end;
  79.           end;
  80.       end;
  81.   end;
  82.  
  83.  
  84.  
  85. procedure PixelFinder;
  86. { ++++++NEW 10/6/87++++++++++++++++++++++++++++++++++++++++++++++++++ }
  87.  
  88.     var
  89.       XFirst,YFirst,XLast,YLast,XOld,YOld,XTemp,YTemp,ButCount,Choice : integer;
  90.       First : boolean;
  91.       ValueA : byte;
  92.       TempN,NumPix : integer;
  93.  
  94.   begin
  95. {    BlankDrawing; }
  96.     {clrscr;}
  97.  
  98. {    Reset_Interrupt_9;}
  99.     {***************************************************************}
  100.     zoomeffect := true;
  101.     blinkeffect := false;
  102.     zoomdelay := 20;
  103.     shadoweffect := none;
  104.     borderstyle := double;
  105.     scanpage;
  106.     createwindow(8,20,8,40,white,black,white,black);
  107.     {***************************************************************}
  108.     GotoXY(34,8);
  109.     writeln('PIXEL FINDER');
  110.     GotoXY(27,14);
  111.     writeln('Press Button #1 to CONTINUE');
  112.     Delay(500);
  113.     ButDig := 0;
  114.     ErrDig := 0;
  115.     repeat
  116.       DigitLocate(XDig,YDig,ButDig,ErrDig);
  117.     until (ErrDig = 0);
  118.     XOld := XDig;
  119.     YOld := YDig;
  120.     DrawCursor(XOld,YOld);
  121.  
  122.     repeat
  123.       repeat
  124.         DigitLocate(XDig,YDig,ButDig,ErrDig);
  125.       until (ErrDig = 0);
  126.       UnDrawCursor(XOld,YOld);
  127.       DrawCursor(Xdig,Ydig);
  128.         ValueA := OldGrayValue(XDig,YDig);
  129.         GotoXY(24,11);
  130.         writeln('X = ',XDig:3,'    Y = ',YDig:3,'    Value = ',ValueA:3);
  131.       XOld := XDig;
  132.       YOld := YDig;
  133.     until (ButDig = 1);
  134.     Repeat
  135.       DigitLocate(Xdig,Ydig,ButDig,Errdig);
  136.     Until (ButDig = 0);
  137.     UnDrawCursor(XOld,YOld);
  138.     zoomdelay := 0;
  139.     destroywindow(8,20,8,40,white,black);
  140.  end;
  141.  
  142.  
  143.  
  144. procedure RetrieveFile(PathName : string);
  145. { ++++++++++++++++++++++++++++++++++++++++++++++++ }
  146.   var PictureFile      : file;
  147.       Block,X,Y,YY     : integer;
  148.       Offset           : word;
  149.       ValueBlock       : ValueBlockType;
  150.       OldTemp,NewTemp  : integer;
  151.       FileName         : string;
  152.  
  153.   begin
  154.      FileName := PathName;
  155.      if (FileExists(FileName)) then
  156.       begin
  157.         AcquireSingle;
  158.         assign(PictureFile,FileName);
  159.         reset(PictureFile);
  160. {$IFDEF PCPLUS}
  161.         OldTemp := Port[Control] and $1F;    { mask bits 7,6,5 }
  162.         for Block := 0 to 3 do
  163.           begin
  164.             case Block of
  165.               0 : NewTemp := OldTemp;
  166.               1 : NewTemp := OldTemp + $20;
  167.               2 : NewTemp := OldTemp + $40;
  168.               3 : NewTemp := OldTemp + $60;
  169.             end;
  170.             Port[Control] := NewTemp;
  171.             for Y := 0 to 127 do
  172.               begin
  173.                 YY := 512 * Y;
  174.                 BlockRead(PictureFile,ValueBlock,4);
  175.                 for X := 0 to 511 do
  176.                   begin
  177.                     Offset := YY + X;
  178.                     Mem[MemBase : Offset] := ValueBlock[X];
  179.                   end;
  180.                end;
  181.            end;
  182. {$ENDIF}
  183. {$IFDEF PCVISION}
  184.         for Block := 0 to 3 do
  185.           begin
  186.             Port[FBB0] := Block;
  187.             for Y := 0 to 255 do
  188.               begin
  189.                 YY := 256 * Y;
  190.                 BlockRead(PictureFile,ValueBlock,2);
  191.                 for X := 0 to 255 do
  192.                   begin
  193.                     Offset := YY + X;
  194.                     Mem[MemBase : Offset] := ValueBlock[X];
  195.                   end;
  196.                end;
  197.            end;
  198. {$ENDIF}
  199.         close(PictureFile);
  200.       end;
  201.   end;
  202.  
  203.  
  204. procedure SaveFile(FileName : string);
  205. { ++++++++++++++++++++++++++++++++++++++++++++++++ }
  206.   var PictureFile      : file;
  207.       X,Y,YY,Block     : integer;
  208.       Offset           : word;
  209.       ValueBlock       : ValueBlockType;
  210.       OldTemp,NewTemp  : integer;
  211.       ch,ch2 : char;
  212.       Good             : boolean;
  213.  
  214.   begin
  215.     Ch := 'Y';
  216.     if (UpCase(ch) = 'Y') then
  217.       begin
  218.         assign(PictureFile,FileName);
  219.         rewrite(PictureFile);
  220. {$IFDEF PCVISION}
  221.         for Block := 0 to 3 do
  222.           begin
  223.             Port[FBB0] := Block;
  224.             for Y := 0 to 255 do
  225.               begin
  226.                 YY := 256 * Y;
  227.                 for X := 0 to 255 do
  228.                   begin
  229.                     Offset := YY + X;
  230.                     ValueBlock[X] := Mem[MemBase : Offset];
  231.                   end;
  232.                   BlockWrite(PictureFile,ValueBlock,2);
  233.                end;
  234.            end;
  235. {$ENDIF}
  236. {$IFDEF PCPLUS}
  237.         OldTemp := Port[Control] and $1F;
  238.         for Block := 0 to 3 do
  239.           begin
  240.             case Block of
  241.               0 : NewTemp := OldTemp;
  242.               1 : NewTemp := OldTemp + $20;
  243.               2 : NewTemp := OldTemp + $40;
  244.               3 : NewTemp := OldTemp + $60;
  245.             end;
  246.             Port[Control] := NewTemp;
  247.             for Y := 0 to 127 do
  248.               begin
  249.                 YY := 512 * Y;
  250.                 for X := 0 to 511 do
  251.                   begin
  252.                     Offset := YY + X;
  253.                     ValueBlock[X] := Mem[MemBase : Offset];
  254.                   end;
  255.                   BlockWrite(PictureFile,ValueBlock,4);
  256.                end;
  257.            end;
  258. {$ENDIF}
  259.         close(PictureFile);
  260.       end;
  261.   end;
  262.  
  263. procedure SubtractFile(FileName : string);
  264. { ++++  MOD 11/10/87 to force displayed byte to even  +++++++++++++++++++++++ }
  265. {====== MOD 12/22/87 to permit display of odd byte ========================== }
  266.   var PictureFile      : file;
  267.       X,Y,YY,Block     : integer;
  268.       Offset           : word;
  269.       ValueBlock       : ValueBlockType;
  270.       ValueHi,ValueLo  : integer;
  271.       DisplayedByte,
  272.       StoredByte:        integer;
  273.       OldTemp,NewTemp  : integer;
  274.       Ch               : char;
  275.  
  276.   function max(a,b : byte) : byte;
  277.     begin
  278.       if a >= b then max := a
  279.         else max := b;
  280.     end;
  281.  
  282.   begin
  283.     if (FileExists(FileName)) then
  284.       begin
  285.         ValueLo := 255;
  286.         ValueHi := 0;
  287.         AcquireSingle;
  288.         assign(PictureFile,FileName);
  289.         reset(PictureFile);
  290. {$IFDEF PCVISION}
  291.         for Block := 0 to 3 do
  292.           begin
  293.             Port[FBB0] := Block;
  294.             for Y := 0 to 255 do
  295.               begin
  296.                 BlockRead(PictureFile,ValueBlock,2);
  297.                 YY := 256 * Y;
  298.                 for X := 0 to 255 do
  299. {$ENDIF}
  300. {$IFDEF PCPLUS}
  301.         OldTemp := Port[Control] and $1F;
  302.         for Block := 0 to 3 do
  303.           begin
  304.             case Block of
  305.               0 : NewTemp := OldTemp;
  306.               1 : NewTemp := OldTemp + $20;
  307.               2 : NewTemp := OldTemp + $40;
  308.               3 : NewTemp := OldTemp + $60;
  309.             end;
  310.             Port[Control] := NewTemp;
  311.             for Y := 0 to 127 do
  312.               begin
  313.                 BlockRead(PictureFile,ValueBlock,4);
  314.                 YY := 512 * Y;
  315.                 for X := 0 to 511 do
  316. {$ENDIF}
  317.                   begin
  318.                     Offset := YY + X;
  319.                     DisplayedByte := Mem[MemBase : Offset];
  320.                     StoredByte := ValueBlock[X];
  321.                     DisplayedByte := DisplayedByte + (256 - StoredByte);
  322.                     if (DisplayedByte > 255) then
  323.                       if ((DisplayedByte and 1) = 1) then
  324.                         DisplayedByte := 255
  325.                       else DisplayedByte := 254
  326.                     else if (DisplayedByte < 0) then
  327.                       if ((DisplayedByte and 1) = 1) then
  328.                         DisplayedByte := 1
  329.                        else DisplayedByte := 0;
  330.                     if DisplayedByte > ValueHi then
  331.                       ValueHi := DisplayedByte;
  332.                     if DisplayedByte < ValueLo then
  333.                       ValueLo := DisplayedByte;
  334.                     Mem[MemBase : Offset] := DisplayedByte;
  335.                   end;
  336.                end;
  337.            end;
  338.         close(PictureFile);
  339.         Beep;
  340.         StretchLow := ValueLo;
  341.         StretchHigh := ValueHi;
  342.         StretchLUT;
  343.         while KeyPressed do ch := ReadKey;
  344.         MakeWindow2;
  345.           GotoXY(20,12);
  346.           write('Do you wish to save this image? (Y/N) : ');
  347.           Ch := UpCase(ReadKey);
  348.         UnMakeWindow2;
  349.         if (Ch = 'Y') then SaveFile('myfile');
  350.       end
  351.     else
  352.       begin
  353.         Beep;
  354.         while KeyPressed do Ch := ReadKey;
  355.         MakeWindow1;
  356.         GotoXY(28,12);
  357.         write('  IMAGE FILE NOT FOUND');
  358.         GotoXY(28,13);
  359.         write('Press Any Key to Continue');
  360.         repeat until KeyPressed;
  361.         UnMakeWindow1;
  362.       end;
  363.   end;
  364.  
  365. (*
  366. procedure StoreShading;
  367. { ++++++++++++++++++++++++++++++++++++++++++++++++ }
  368.   var Ch : char;
  369.   begin
  370.  
  371.     MakeWindow2;
  372.     GotoXY(10,12);
  373.     write('Storing a Shading Correction will Destroy the Displayed Image');
  374.     GotoXY(20,14);
  375.     write('ENTER Y TO PROCEED - N TO QUIT  :');
  376.     Ch := ReadKey;
  377.     if (UpCase(Ch) = 'Y') then
  378.       begin
  379.         AcquireContinuous;
  380.  
  381.         MakeWindow1;
  382.         GotoXY(26,12);
  383.         write('PLEASE SET UP A BLANK IMAGE');
  384.         GotoXY(23,14);
  385.         write('ENTER Y WHEN BLANK IMAGE IS SET UP  :');
  386.         Ch := ReadKey;
  387.         UnMakeWindow1;
  388.         if (UpCase(Ch) = 'Y') then
  389.           begin
  390.  
  391.             MakeWindow1;
  392.             AcquireSingle;
  393.             GotoXY(29,12);
  394.             write('This will take a moment');
  395.             SaveFile('SHADING.COR');
  396.             AcquireContinuous;
  397.             UnMakeWindow1;
  398.           end;
  399.       end;
  400.     UnMakeWindow2;
  401.   end;
  402.  
  403.  
  404. procedure ShadingCorrect;
  405. {========================}
  406. var Ch : char;
  407. begin
  408.  
  409.   MakeWindow1;
  410.   GotoXY(29,12);
  411.   write('This will take a moment');
  412.   while KeyPressed do Ch := ReadKey;
  413.   SubtractFile('SHADING.COR');
  414.   UnMakeWindow1;
  415. end;
  416. *)
  417. procedure StoreShading;
  418. { ++++++++++++++++++++++++++++++++++++++++++++++++ }
  419.   var Ch : char;
  420.   begin
  421.     MakeWindow2;
  422.     GotoXY(10,12);
  423.     write('Storing a Shading Correction will Destroy the Displayed Image');
  424.     GotoXY(20,14);
  425.     write('ENTER Y TO PROCEED - N TO QUIT  :');
  426.     Ch := ReadKey;
  427.     if (UpCase(Ch) = 'Y') then
  428.       begin
  429.         AcquireContinuous;
  430.         MakeWindow1;
  431.         GotoXY(26,12);
  432.         write('PLEASE SET UP A BLANK IMAGE');
  433.         GotoXY(23,14);
  434.         write('ENTER Y WHEN BLANK IMAGE IS SET UP  :');
  435.         Ch := ReadKey;
  436.         UnMakeWindow1;
  437.         if (UpCase(Ch) = 'Y') then
  438.           begin
  439. {$IFDEF PCPLUS}
  440.             Port[PanFG] := 64;
  441.             ClearDisplay;
  442.             AcquireContinuous;
  443.             Delay(500);
  444.             AcquireSingle;
  445.             Port[PanFG] := 0;
  446.             AcquireContinuous;
  447. {$ENDIF}
  448. {$IFDEF PCVISION}
  449.             MakeWindow1;
  450.             AcquireSingle;
  451.             GotoXY(29,12);
  452.             write('This will take a moment');
  453.             SaveFile('SHADING.COR');
  454.             AcquireContinuous;
  455.             UnMakeWindow1;
  456. {$ENDIF}
  457.           end;
  458.       end;
  459.     UnMakeWindow2;
  460.   end;
  461.  
  462.  
  463. procedure ShadingCorrect;
  464. {========================}
  465. var Ch : char;
  466. begin
  467.   MakeWindow1;
  468.   GotoXY(29,12);
  469.   write('This will take a moment');
  470. {$IFDEF PCPLUS}
  471. inline($B9/$04/$00/      { MOV    CX,0004     ; load counter with 4 }
  472. {#1}
  473.        $33/$C0/          { XOR    AX,AX       ; zero out ax }
  474.        $BA/$00/$03/      { MOV    DX,0300     ; load control register address }
  475.        $EC/              { IN    AL,DX       ; read in from register }
  476.        $24/$1F/          { AND    AL,1F       ; mask 3 MSBs }
  477.        $50/              { PUSH    AX          ; save it }
  478. (*
  479.        $B8/$04/$00/      { MOV    AX,4 }
  480.        $2B/$C1/          { SUB    AX,CX }
  481. *)
  482.        $89/$C8/$90/      { MOV AX,CX }      { do correction from bottom up }
  483.        $48/$90/          { DEC AX  }
  484.  
  485.        $51/              { PUSH CX }
  486.        $B1/$05/          { MOV  CL,05}
  487.        $D3/$E0/          { SHL  AX,CL}
  488.  
  489.        $8B/$D8/          { MOV    BX,AX       ; copy result to bx }
  490.        $59/              { POP  CX}
  491.        $58/              { POP    AX          ; recall value }
  492.        $03/$C3/          { ADD    AX,BX       ; and add it to shifted counter }
  493.        $89/$C7/          { MOV    DI,AX       ; save result in di register }
  494.  
  495.        $51/              { PUSH CX}
  496.        $E8/$06/$00/      { CALL    #2          ; and jump to #2}
  497.  
  498.        $59/              { POP    CX          ; restore the counter }
  499.        $E2/$DE/          { LOOP    #1          ; and do it again }
  500.  
  501.        $EB/$43/          { JMP DONE}
  502.        $90/              { NOP}
  503.  
  504. {#2}
  505.        $B9/$FE/$FF/      { MOV    CX,FFFE     ; load counter with 64k }
  506. {#6}
  507.        $89/$F8/          { MOV    AX,DI       ; recall register value }
  508.        $05/$80/$00/      { ADD    AX,0080     ; add $80 to it }
  509.        $EE/              { OUT    DX,AL       ; set the block }
  510.        $8B/$D9/          { MOV    BX,CX       ; copy counter to bx for offset }
  511.  
  512.        $B8/$00/$A0/      { MOV    AX,A000     ; copy video segment to ax }
  513.        $8E/$C0/          { MOV    ES,AX       ; and then to es }
  514.  
  515.        $26/$8A/$07/      { MOV    AL,ES:[BX]  ; read video memory MEM_B }
  516.        $32/$E4/          { XOR AH,AH }
  517.  
  518.        $50/              { PUSH    AX          ; save value }
  519.        $89/$F8/          { MOV    AX,DI       ; recall register value }
  520.        $EE/              { OUT    DX,AL       ; set the block }
  521.        $26/$8A/$07/      { MOV    AL,ES:[BX]  ; read video memory MEM_A }
  522.        $32/$E4/          { XOR AH,AH }
  523.  
  524.        $5B/              { POP    BX          ; recall MEM_B }
  525.        $29/$D8/          { SUB    AX,BX       ; and subtract result from MEM_A }
  526.        $05/$00/$01/      { ADD    AX,0100     ; now add 256 }
  527.        $3D/$00/$00/      { CMP    AX,0000     ; is it less than 0? }
  528.        $7C/$08/          { JL    #3          ; then branch to #3 }
  529.        $3D/$FF/$00/      { CMP    AX,00FF     ; is it greater than 255? }
  530.        $7F/$09/          { JG    #4          ; then branch to #4 }
  531.        $EB/$0A/          { JMP    #5          ; ok, then branch to #5 }
  532.        $90/              { NOP }
  533. {#3}
  534.        $B8/$00/$00/      { MOV    AX,0000     ; set it to 0 }
  535.        $EB/$04/          { JMP    #5 }
  536.        $90/              { NOP }
  537. {#4}
  538.        $B8/$FE/$00/      { MOV    AX,00FE     ; set it to 254 }
  539. {#5}
  540.        $8B/$D9/          { MOV    BX,CX       ; load offset into bx }
  541.        $26/$88/$07/      { MOV    ES:[BX],AL  ; write out to video location }
  542.  
  543.        $E2/$C2/          { LOOP #6          ; and return }
  544.        $C3/              {RET}
  545.        $90);
  546. {$ENDIF}
  547. {$IFDEF PCVISION}
  548.   while KeyPressed do Ch := ReadKey;
  549.   SubtractFile('SHADING.COR');
  550. {$ENDIF}
  551.   UnMakeWindow1;
  552. end;
  553.  
  554.  
  555.  
  556.  
  557. End.
  558.