返回
{***************************************************************}
{*** FVision Unit Version1.0 ***}
{*** 蓝蚂蚁工作室 ***}
{***************************************************************}
{*** 缓冲式图象类单元 ***}
{***************************************************************}
{$O+,F+,X+,I-}
Unit FPhoto;
Interface
Uses
Dos,Graph,FGraph,FTool,FView,FDac,
FEvent,FMouse,FXmsDrv,FVesa,FExtDrv;
Const
MaxPicLine = 2048;
Const
{Style Code}
phAdaptSize = $0001;
phSetVideo = $0002;
phNoMalloc = $0004;
phDragAble = $0008;
phProgress = $0100;
{DacStyle Code}
phOwnerDac = $01;
phStandDac = $02;
phAdaptDac = $03;
phNoneDac = $04;
phOtherDac = $05;
{Edit Code}
phClear = $01;
phCopyPut = $02;
{PictureType Code}
ptNull = $01;
ptPcx = $02;
ptBmp = $03;
ptGif = $04;
ptTiff = $05;
ptJpg = $06;
ptFlc = $07;
ptIco = $08;
Const
ptBKColor :Byte = $0F;
ptFlColor :Byte = $07;
ptRecColor :Byte = $0A;
Type
PPhoto=^TPhoto;
TPhoto=object(TView)
Style:Word;
DacStyle:Byte;
PictureType:Byte;
XmsHandle,VideoMode:Word;
FileName:PathStr;
PhotoDac,SortDac:DacType;
DacIndex:array[0..255] of Integer;
PixelNum:array[0..255] of Longint;
Line:array[0..MaxPicLine-1] of Byte;
Width,Height,ColorBits,BitsPerPixel,StartDac,ColorDlt:Integer;
ViewRec,SaveRec,WinRec,DRec,Rect:TRect;
ModifyFlag,DrawRectFlag:Boolean;
Progress:PProgressBar;
Constructor Init;
Destructor Done;virtual;
Procedure MoveTo(X,Y:Integer);virtual;
Procedure ViewProgress(L:Real);
Function LessDac(X,Y:Integer):Boolean;
Procedure QuickSortDac(L,R:Integer);
Procedure SearchDac(L1,R1,L2,R2:Integer);
Procedure CompressDac(N1,N2,Dlt:Integer);
Procedure ConvertDac(D:DacType);
Procedure SetVideoMode(Mode:Word);
Procedure SetViewRec(var R:TRect);
Procedure SetSaveRec(var R:TRect);
Procedure MallocPictureMem(X,Y:Integer);
Procedure FreePictureMem;
Procedure NewPicture(Name:PathStr;St,Wid,Hig,Col:Integer);
Procedure LoadFromFile(Name:PathStr);virtual;
Function SaveToFile(Name:PathStr):Boolean;virtual;
Procedure CopyToClip(P:PPhoto);
Procedure CutToClip(P:PPhoto);
Procedure ClearSelect;
Procedure PasteFromClip(Mode:Byte;P:PPhoto;X,Y:Integer);
Function GetColor(X,Y:Integer):Byte;
Procedure SetVideo;
Procedure Paint;virtual;
Procedure Draw;virtual;
Procedure Draw8Bit;virtual;
Function MoveInWin(PX,PY:Real):Boolean;virtual;
Function SplitInWin(X,Y:Integer):Boolean;virtual;
Procedure DrawRect(R:TRect);
Procedure HandleEvent(var Event:TEvent);virtual;
end;
Implementation
Const
StdDacFile:PathStr='D:\XYF\GRA\STD1.PAL';
Const
DefaultDac:array[1..32*3] of Byte =
(0,0,0, 0,0,42, 0,42,0, 0,42,42,
42,0,0, 42,0,42, 42,21,0, 42,42,42,
21,21,21, 21,21,63, 21,63,21, 21,63,63,
63,21,21, 63,21,63, 63,63,21, 63,63,63,
0,0,0, 5,5,5, 8,8,8, 11,11,11,
14,14,14, 17,17,17, 20,20,20, 24,24,24,
28,28,28, 32,32,32, 36,36,36, 40,40,40,
45,45,45, 50,50,50, 56,56,56, 63,63,63
);
Constructor TPhoto.Init;
begin
Inherited Init;
GrowMode:=gfGrowHiX+gfGrowHiY;
IsValid:=XmsCanUse;
XmsHandle:=0;
Style:=0;
DacStyle:=phOwnerDac;
Width:=0;
Height:=0;
BitsPerPixel:=8;
ColorBits:=8;
DrawRectFlag:=False;
AssignRect(ViewRec,0,0,0,0);
AssignRect(SaveRec,0,0,0,0);
AssignRect(DRec,0,0,0,0);
Dac.GetDac(PhotoDac);
StartDac:=0;
ColorDlt:=0;
FileName:='';
ModifyFlag:=False;
Progress:=New(PProgressBar,Init(0,0,292,17,pbBroad+pbSaveBack));
end;
Destructor TPhoto.Done;
begin
FreePictureMem;
Dispose(Progress,Done);
Inherited Done;
end;
Procedure TPhoto.MoveTo;
begin
Inherited MoveTo(X,Y);
ViewRec.B.X:=ViewRec.A.X+Size.X;
ViewRec.B.Y:=ViewRec.A.Y+Size.Y;
AssignRect(WinRec,Origin.X,Origin.Y,Origin.X+Size.X,Origin.Y+Size.Y);
Progress^.MoveTo(X-2,Y+Size.Y+7);
end;
Procedure TPhoto.ViewProgress;
var
i:Integer;
begin
if (Style and phProgress)<>0 then Progress^.Modify(L);
for i:=0 to Width-1 do Inc(PixelNum[Line[i]]);
end;
Function TPhoto.LessDac(X, Y: Integer): Boolean;
begin
LessDac := (Integer(PhotoDac[X*3+1])*30+
Integer(PhotoDac[X*3+2])*59+
Integer(PhotoDac[X*3+3])*11)<
(Integer(PhotoDac[Y*3+1])*30+
Integer(PhotoDac[Y*3+2])*59+
Integer(PhotoDac[Y*3+3])*11);
end;
Procedure TPhoto.QuickSortDac(L, R: Integer);
var
I, J, X: Integer;
Temp: array[0..2] of Byte;
begin
I := L;
J := R;
X := (L + R) div 2;
repeat
while LessDac(I, X) do Inc(I);
while LessDac(X, J) do Dec(J);
if I <= J then
begin
System.Move(PhotoDac[I*3+1],Temp,3);
System.Move(PhotoDac[J*3+1],PhotoDac[I*3+1],3);
System.Move(Temp,PhotoDac[J*3+1],3);
Inc(I);
Dec(J);
end;
until I > J;
if L < J then QuickSortDac(L, J);
if I < R then QuickSortDac(I, R);
end;
Procedure TPhoto.SearchDac;
var
i,j,Temp,TempDlt:Integer;
begin
for i:=L1 to R1 do
begin
Temp:=0;
TempDlt:=1000;
for j:=L2 to R2 do
if Abs(Integer(SortDac[i*3+1])-Integer(PhotoDac[j*3+1]))+
Abs(Integer(SortDac[i*3+2])-Integer(PhotoDac[j*3+2]))+
Abs(Integer(SortDac[i*3+3])-Integer(PhotoDac[j*3+3]))<TempDlt then
begin
Temp:=j;
TempDlt:=Abs(Integer(SortDac[i*3+1])-Integer(PhotoDac[j*3+1]))+
Abs(Integer(SortDac[i*3+2])-Integer(PhotoDac[j*3+2]))+
Abs(Integer(SortDac[i*3+3])-Integer(PhotoDac[j*3+3]));
end;
DacIndex[i]:=Temp;
end;
end;
Procedure TPhoto.CompressDac;
var
i:Integer;
Function IsInDefault:Boolean;
var
j:Integer;
begin
IsInDefault:=False;
for j:=0 to 15 do
if Abs(Integer(PhotoDac[i*3+1])-Integer(DefaultDac[j*3+1]))+
Abs(Integer(PhotoDac[i*3+2])-Integer(DefaultDac[j*3+2]))+
Abs(Integer(PhotoDac[i*3+3])-Integer(DefaultDac[j*3+3]))<=Dlt then
IsInDefault:=True;
end;
begin
i:=N2;
while (i>N1) and (i>StartDac) do
begin
if IsInDefault then
begin
System.Move(PhotoDac[StartDac*3+1],PhotoDac[StartDac*3+4],(i-StartDac)*3);
Inc(StartDac);
end else
if Abs(Integer(PhotoDac[i*3+1])-Integer(PhotoDac[i*3-2]))+
Abs(Integer(PhotoDac[i*3+2])-Integer(PhotoDac[i*3-1]))+
Abs(Integer(PhotoDac[i*3+3])-Integer(PhotoDac[i*3]))<=Dlt then
begin
System.Move(PhotoDac[StartDac*3+1],PhotoDac[StartDac*3+4],(i-StartDac-1)*3);
Inc(StartDac);
end else
Dec(i);
end;
end;
Procedure TPhoto.ConvertDac;
var
i:Integer;
begin
StartDac:=0;
ColorDlt:=0;
for i:=0 to 255 do DacIndex[i]:=i;
if BitsPerPixel<8 then
begin
System.Move(PhotoDac,SortDac,768);
case DacStyle of
phStandDac:begin
SearchDac(0,15,32,32+15);
for i:=0 to 15 do Dec(DacIndex[i],32);
end;
else for i:=0 to 15 do DacIndex[i]:=i+32;
end;
end;
if BitsPerPixel<>8 then Exit;
System.Move(D,SortDac,768);
case DacStyle of
phOwnerDac:System.Move(SortDac,PhotoDac,768);
phStandDac:begin
LoadDacFile(StdDacFile,PhotoDac);
SearchDac(0,255,0,255);
end;
phAdaptDac:begin
System.Move(D,PhotoDac,768);
for i:=0 to 3 do
QuickSortDac(0,255);
while StartDac<16 do
begin
CompressDac(0,255,ColorDlt);
if StartDac<16 then Inc(ColorDlt);
end;
System.Move(DefaultDac,PhotoDac,16*3);
SearchDac(0,255,0,255);
end;
phOtherDac:SearchDac(0,255,0,255);
end;
end;
Procedure TPhoto.SetVideoMode;
begin
VideoMode:=Mode;
end;
Procedure TPhoto.SetViewRec;
begin
Size.x:=R.b.x-R.a.x;
Size.y:=R.b.y-R.a.y;
ViewRec:=R;
MoveTo(Origin.X,Origin.Y);
end;
Procedure TPhoto.SetSaveRec;
begin
SaveRec:=R;
if SaveRec.a.x<0 then SaveRec.a.x:=0;
if SaveRec.a.y<0 then SaveRec.a.y:=0;
if SaveRec.b.x>=Width then SaveRec.b.x:=Width-1;
if SaveRec.b.y>=Height then SaveRec.b.y:=Height-1;
end;
Procedure TPhoto.MallocPictureMem;
begin
if not IsValid then Exit;
XmsHandle:=MallocXms(Longint(X)*Longint(Y)*Longint(ColorBits) div $2000+1);
end;
Procedure TPhoto.FreePictureMem;
begin
if XmsHandle=0 then Exit;
Width:=0;
Height:=0;
FileName:='';
FreeXms(XmsHandle);
XmsHandle:=0;
Dac.GetDac(PhotoDac);
ModifyFlag:=False;
end;
Procedure TPhoto.NewPicture;
var
i:Integer;
begin
FreePictureMem;
FileName:=Name;
PictureType:=St;
Width:=Wid;
Height:=Hig;
BitsPerPixel:=Col;
MallocPictureMem(Width,Height);
FillChar(Line,MaxPicLine,ptBkColor);
for i:=0 to Hig do
MoveXms(Pointer(Longint(i)*Longint(Width)),XmsHandle,@Line,0,Width+Width mod 2);
AssignRect(ViewRec,0,0,ViewRec.b.x-ViewRec.a.x,ViewRec.b.y-ViewRec.a.y);
ModifyFlag:=True;
end;
Procedure TPhoto.LoadFromFile;
begin
end;
Function TPhoto.SaveToFile;
begin
end;
Procedure TPhoto.CopyToClip;
var
TempOffset:Longint;
i,Len:Integer;
begin
if XmsHandle=0 then Exit;
if Longint(DRec.a)=Longint(DRec.b) then Exit;
if DRec.b.x<DRec.a.x then SwapInt(DRec.a.x,DRec.b.x);
if DRec.b.y<DRec.a.y then SwapInt(DRec.a.y,DRec.b.y);
P^.FreePictureMem;
P^.MallocPictureMem(DRec.b.x-DRec.a.x+1,DRec.b.y-DRec.a.y+1);
Len:=DRec.b.x-DRec.a.x+1;
TempOffset:=Longint(Width)*Longint(DRec.a.y)+DRec.a.x;
for i:=0 to DRec.b.y-DRec.a.y do
begin
MoveXms(@Line,0,Pointer(TempOffset),XmsHandle,Len+Len mod 2);
MoveXms(Pointer(Longint(i)*Longint(Len)),P^.XmsHandle,@Line,0,Len+Len mod 2);
Inc(TempOffset,Width);
end;
P^.Width:=DRec.b.x-DRec.a.x+1;
P^.Height:=DRec.b.y-DRec.a.y+1;
P^.BitsPerPixel:=BitsPerPixel;
System.Move(PhotoDac,P^.PhotoDac,768);
end;
Procedure TPhoto.CutToClip;
begin
CopyToClip(P);
if Longint(DRec.a)=Longint(DRec.b) then Exit;
PasteFromClip(phClear,P,DRec.a.x,DRec.a.y);
end;
Procedure TPhoto.ClearSelect;
begin
if Longint(DRec.a)=Longint(DRec.b) then Exit;
PasteFromClip(phClear,nil,DRec.a.x,DRec.a.y);
end;
Procedure TPhoto.PasteFromClip;
var
TempOffset:Longint;
i,j,Len,Hig:Integer;
Temp:Byte;
begin
if (XmsHandle=0) or (P^.XmsHandle=0) then Exit;
if (X<0)or(X>Width-1)or(Y<0)or(Y>Height-1) then Exit;
System.Move(P^.PhotoDac,SortDac,768);
SearchDac(0,255,0,255);
case Mode of
phClear:begin Len:=DRec.b.x-DRec.a.x+1;Hig:=DRec.b.y-DRec.a.y; end;
phCopyPut:begin Len:=P^.Width;Hig:=P^.Height; end;
end;
if X+Len>Width then Len:=Width-X;
if Y+Hig>Height then Hig:=Height-Y;
TempOffset:=Longint(Width)*Longint(Y)+X;
for i:=0 to Hig-1 do
begin
MoveXms(@Line,0,Pointer(TempOffset),XmsHandle,Len+Len mod 2);
Temp:=Line[Len];
case Mode of
phClear:FillChar(Line,Len,ptBkColor);
phCopyPut:MoveXms(@Line,0,Pointer(Longint(i)*Longint(P^.Width)),P^.XmsHandle,Len+Len mod 2);
end;
if Odd(Len) then Line[Len]:=Temp;
for j:=0 to Len-1 do Line[j]:=DacIndex[Line[j]];
MoveXms(Pointer(TempOffset),XmsHandle,@Line,0,Len+Len mod 2);
Inc(TempOffset,Width);
end;
ModifyFlag:=True;
end;
Function TPhoto.GetColor;
var
Temp:Word;
begin
GetColor:=0;
if XmsHandle=0 then Exit;
MoveXms(@Temp,0,Pointer(Longint(Width)*Longint(Y)+X),XmsHandle,2);
GetColor:=Lo(Temp);
end;
Procedure TPhoto.SetVideo;
begin
FVesa.SetVideoMode(VideoMode);
end;
Procedure TPhoto.Paint;
begin
if (Style and phSetVideo)<>0 then
begin
HideMouse;
FVesa.SetVideoMode(VideoMode);
ShowMouse;
end;
if DacStyle<>phNoneDac then
Dac.SetNewDac(PhotoDac);
Draw;
end;
Procedure TPhoto.Draw;
begin
if XmsHandle=0 then Exit;
Rect.a:=Origin;
Rect.b:=Origin;
AssignRect(DRec,0,0,0,0);
Draw8Bit;
end;
Procedure TPhoto.Draw8Bit;
var
TempLen,TempOffset:Longint;
i,TempWidth:Integer;
OddFlag:Boolean;
begin
if MouIn(Broad) then HideMouse;
LockVesaPage;
PutPixel(Origin.x,Origin.y,7);
TempOffset:=Longint(ViewRec.a.y)*Longint(Width)+ViewRec.a.x;
TempWidth:=ViewRec.b.x-ViewRec.a.x+1;
TempLen:=TempWidth;
if ViewRec.a.x+TempWidth>Width then
TempLen:=Width-ViewRec.a.x;
if TempLen<0 then TempLen:=0;
OddFlag:=False;
if Odd(TempLen) then
begin
Inc(TempLen);
OddFlag:=True;
end;
FillChar(Line,TempWidth,ptFlColor);
for i:=0 to ViewRec.b.y-ViewRec.a.y do
if (ViewRec.a.y+i>=0)and(ViewRec.a.y+i<Height) then
begin
MoveXms(@Line,0,Pointer(TempOffset),XmsHandle,TempLen);
if OddFlag then Line[TempLen-1]:=ptFlColor;
PutLine8(Origin.x,Origin.y+i,Seg(Line),Ofs(Line),TempWidth);
Inc(TempOffset,Width);
end else
begin
FillChar(Line,TempWidth,ptFlColor);
PutLine8(Origin.x,Origin.y+i,Seg(Line),Ofs(Line),TempWidth);
Inc(TempOffset,Width);
end;
UnLockVesaPage;
PutPixel(0,0,7);
PutPixel(GetMaxx,GetMaxy,7);
ShowMouse;
end;
Function TPhoto.MoveInWin;
var
X,Y,Wid,Hig:Integer;
begin
MoveInWin:=False;
if XmsHandle=0 then Exit;
Wid:=ViewRec.b.x-ViewRec.a.x;
Hig:=ViewRec.b.y-ViewRec.a.y;
X:=Trunc((Width-Wid)*PX);
Y:=Trunc((Height-Hig)*PY);
if X<0 then X:=0;
if Y<0 then Y:=0;
if (ViewRec.a.x=X)and(ViewRec.a.y=Y) then Exit;
AssignRect(ViewRec,X,Y,X+Wid,Y+Hig);
Draw;
MoveInWin:=True;
end;
Function TPhoto.SplitInWin;
begin
SplitInWin:=False;
if (XmsHandle=0) or
((ViewRec.a.x=0)and(X<0)) or
((ViewRec.a.y=0)and(Y<0)) or
((ViewRec.b.x>=Width-1)and(X>0)) or
((ViewRec.b.y>=Height-1)and(Y>0)) then
Exit;
if (X<0)and(ViewRec.a.x+X<0) then X:=-ViewRec.a.x;
if (Y<0)and(ViewRec.a.y+Y<0) then Y:=-ViewRec.a.y;
if (X>0)and(ViewRec.b.x+X>Width-1) then X:=Width-ViewRec.b.x-1;
if (Y>0)and(ViewRec.b.y+Y>Height-1) then Y:=Height-ViewRec.b.y-1;
Inc(ViewRec.a.x,X);
Inc(ViewRec.b.x,X);
Inc(ViewRec.a.y,Y);
Inc(ViewRec.b.y,Y);
Draw;
SplitInWin:=True;
end;
Procedure TPhoto.DrawRect;
begin
HideMouse;
FGraph.DrawRect(Rect.a.x,Rect.a.y,Rect.b.x,Rect.b.y,ptRecColor,2);
ShowMouse;
end;
Procedure TPhoto.HandleEvent;
var
X,Y:Integer;
begin
if (XmsHandle=0) or ((Style and phDragAble)=0) then Exit;
case Event.What of
evMouseDown:if IsIn(Event.Where,WinRec)and(Event.Buttons=mbLeftButton) then
begin
if Longint(Rect.a)<>Longint(Rect.b) then DrawRect(Rect);
Rect.a:=Event.Where;
Rect.b:=Event.Where;
if (Rect.a.x-Origin.x+ViewRec.a.x>=Width) or
(Rect.a.y-Origin.y+ViewRec.a.y>=Height) then Exit;
DrawRect(Rect);
DrawRectFlag:=True;
end;
evMouseUp: if DrawRectFlag then
begin
DrawRectFlag:=False;
AssignRect(DRec,Rect.a.x-Origin.x+ViewRec.a.x,
Rect.a.y-Origin.y+ViewRec.a.y,
Rect.b.x-Origin.x+ViewRec.a.x,
Rect.b.y-Origin.y+ViewRec.a.y);
if Longint(DRec.a)=Longint(DRec.b) then DrawRect(Rect);
Event.What:=evCommand;
Event.Command:=cmCopyToClip;
Event.InfoPtr:=@Self;
end;
evMouseMove:if DrawRectFlag then
begin
DrawRect(Rect);
X:=Event.Where.x;
Y:=Event.Where.y;
if X<Origin.x then X:=Origin.x;
if Y<Origin.y then Y:=Origin.y;
if X>WinRec.b.x then X:=WinRec.b.x;
if Y>WinRec.b.y then Y:=WinRec.b.y;
if X-Origin.x+ViewRec.a.x>=Width then X:=Origin.x+Width-1;
if Y-Origin.y+ViewRec.a.y>=Height then Y:=Origin.y+Height-1;
Rect.b.x:=X;
Rect.b.y:=Y;
DrawRect(Rect);
end;
end;
end;
end.