Subversion Repositories spacemission

{$IfDef StandardDX}

  {$IfDef DX9}

  Direct3D, DirectInput,

  {$EndIf}

  DirectDraw, DirectSound;

{$Else}

  DirectX;

{$EndIf}

  {$IFDEF _DMO_}

  {  TDirectXDriverEx  }

  TDirectXDriverEx = class(TCollectionItem)

  private

    FGUID: PGUID;

    FGUID2: TGUID;

    FDescription: string;

    FDriverName: string;

    FMonitor: HMonitor;

    FMonitorInfo: TMonitorInfo;

    procedure SetGUID(Value: PGUID);

    function ConvertHMonitor(iMonitor: HMonitor): TMonitorInfo;

    function GetMonitorInfo: TMonitorInfo;

    function GetFlags: DWORD;

    function GetTempSpace: TRect;

    function GetWorkSpace: TRect;

  public

    property GUID: PGUID read FGUID write SetGUID;

    property Monitor: HMonitor read FMonitor write FMonitor;

    property MonitorInfo: TMonitorInfo read GetMonitorInfo;

  published

    property Description: string read FDescription write FDescription;

    property DriverName: string read FDriverName write FDriverName;

    property WorkSpace: TRect read GetWorkSpace;

    property TempSpace: TRect read GetTempSpace;

    property Flags: DWORD read GetFlags;

  end;

  {  TDirectXDriversEx  }

  TDirectXDriversEx = class(TCollection)

  private

    function GetDriver(Index: Integer): TDirectXDriverEx;

  public

    constructor Create;

    property Drivers[Index: Integer]: TDirectXDriverEx read GetDriver; default;

  end;

  {$ENDIF}

{Addapted from RXLib.PicClip}

  { TPicClip }

  TCellRange = 1..MaxInt;

  TDXPictureClip = class(TComponent)

  private

    FPicture: TPicture;

    FRows: TCellRange;

    FCols: TCellRange;

    FBitmap: TBitmap;

    FMasked: Boolean;

    FMaskColor: TColor;

    FOnChange: TNotifyEvent;

    procedure CheckIndex(Index: Integer);

    function GetCell(Col, Row: Cardinal): TBitmap;

    function GetGraphicCell(Index: Integer): TBitmap;

    function GetDefaultMaskColor: TColor;

    function GetIsEmpty: Boolean;

    function GetCount: Integer;

    function GetHeight: Integer;

    function GetWidth: Integer;

    function IsMaskStored: Boolean;

    procedure PictureChanged(Sender: TObject);

    procedure SetHeight(Value: Integer);

    procedure SetPicture(Value: TPicture);

    procedure SetWidth(Value: Integer);

    procedure SetMaskColor(Value: TColor);

  protected

    procedure AssignTo(Dest: TPersistent); override;

    procedure Changed; dynamic;

  public

    constructor Create(AOwner: TComponent); override;

    destructor Destroy; override;

    procedure Assign(Source: TPersistent); override;

    function GetIndex(Col, Row: Cardinal): Integer;

    procedure Draw(Canvas: TCanvas; X, Y, Index: Integer);

    procedure DrawCenter(Canvas: TCanvas; Rect: TRect; Index: Integer);

    property Cells[Col, Row: Cardinal]: TBitmap read GetCell;

    property GraphicCell[Index: Integer]: TBitmap read GetGraphicCell;

    property IsEmpty: Boolean read GetIsEmpty;

    property Count: Integer read GetCount;

  published

    property Cols: TCellRange read FCols write FCols default 1;

    property Height: Integer read GetHeight write SetHeight stored False;

    property Masked: Boolean read FMasked write FMasked default True;

    property Rows: TCellRange read FRows write FRows default 1;

    property Picture: TPicture read FPicture write SetPicture;

    property MaskColor: TColor read FMaskColor write SetMaskColor stored IsMaskStored;

    property Width: Integer read GetWidth write SetWidth stored False;

    property OnChange: TNotifyEvent read FOnChange write FOnChange;

  end;

function WideRect(ALeft, ATop, AWidth, AHeight: Integer): TRect; {$IFDEF VER9UP}inline;{$ENDIF}

{ Transformations routines}

const

  L_Curve = 0;//The left curve

  R_Curve = 1;//The right curve

  C_Add = 0;//Increase (BTC)

  C_Dec = 1;//Decrease (ETC)

Type

  TDblPoint = packed record

    X, Y: Double;

  end;

  TSngPoint = packed record //SinglePoint

    X, Y: Single;

  end;

  //Transformation matrix

  T2DRowCol = Array[1..3] of Array[1..3] of Double;

  T2DVector = Array[1..3] of Double;

  //Distance between 2 points

  function Get2PointRange(a,b: TDblPoint):Double;

  //From vector angular calculation

  function Get256(dX,dY: Double):Double;

  //The angular calculation of the A from B

  function GetARadFromB(A,B: TDblPoint):Double;

  //It calculates the TDblPoint

  function DblPoint(a,b:Double):TDblPoint;

  //It converts the TDboPoint to the TPoint

  function TruncDblPoint(DblPos: TDblPoint): TPoint;

  function GetPointFromRangeAndAngle(SP: TDblPoint; Range,Angle: Double): TDblPoint;

  function Ini2DRowCol: T2DRowCol;

  function Trans2DRowCol(x,y:double):T2DRowCol;

  function Scale2DRowCol(x,y:double):T2DRowCol;

  function Rotate2DRowCol(Theta:double):T2DRowCol;

  function RotateIntoX2DRowCol(x,y: double):T2DRowCol;

  function Multiply2DRowCol(A,B:T2DRowCol):T2DRowCol;

  function ScaleAt2DRowCol(x,y,Sx,Sy:double):T2DRowCol;

  function ReflectAcross2DRowCol(x,y,dx,dy:Double): T2DRowCol;

  function Apply2DVector(V:T2DVector; M:T2DRowCol): T2DVector;

  function RotateAround2DRowCol(x,y,Theta:Double): T2DRowCol;

  //Collision decision

  function PointInCircle(PPos,CPos: TPoint; R: integer): Boolean;

  function CircleInCircle(C1Pos,C2Pos: TPoint; R1,R2:Integer): Boolean;

  function SegmentInCircle(SPos,EPos,CPos: TPoint; R: Integer): Boolean;

  //If A is closer than B from starting point S, the True is  returned.

  function CheckNearAThanB(S,A,B: TDblPoint): Boolean;

  //The Angle of 256 period is returned

  function Angle256(Angle: Single): Single;

{ Support functions }

{  Simple helper  }

procedure Log(const Co: string; const FName: string{$IFDEF VER4UP} = 'c:\logerr.txt'{$ENDIF});

{  TDXPictureClip  }

constructor TDXPictureClip.Create(AOwner: TComponent);

begin

  inherited Create(AOwner);

  FPicture := TPicture.Create;

  FPicture.OnChange := PictureChanged;

  FBitmap := TBitmap.Create;

  FRows := 1;

  FCols := 1;

  FMaskColor := GetDefaultMaskColor;

  FMasked := True;

end;

destructor TDXPictureClip.Destroy;

begin

  FOnChange := nil;

  FPicture.OnChange := nil;

  FBitmap.Free;

  FPicture.Free;

  inherited Destroy;

end;

procedure TDXPictureClip.Assign(Source: TPersistent);

begin

  if Source is TDXPictureClip then begin

    with TDXPictureClip(Source) do begin

      Self.FRows := Rows;

      Self.FCols := Cols;

      Self.FMasked := Masked;

      Self.FMaskColor := MaskColor;

      Self.FPicture.Assign(FPicture);

    end;

  end

  else if (Source is TPicture) or (Source is TGraphic) then

    FPicture.Assign(Source)

  else inherited Assign(Source);

end;

type

  THack = class(TImageList);

procedure TDXPictureClip.AssignTo(Dest: TPersistent);

var

  I: Integer;

  SaveChange: TNotifyEvent;

begin

  if (Dest is TPicture) then Dest.Assign(FPicture)

  else if (Dest is TImageList) and not IsEmpty then begin

    with TImageList(Dest) do begin

      SaveChange := OnChange;

      try

        OnChange := nil;

        Clear;

        Width := Self.Width;

        Height := Self.Height;

        for I := 0 to Self.Count - 1 do begin

          if Self.Masked and (MaskColor <> clNone) then

            TImageList(Dest).AddMasked(GraphicCell[I], MaskColor)

          else TImageList(Dest).Add(GraphicCell[I], nil);

        end;

        Masked := Self.Masked;

      finally

        OnChange := SaveChange;

      end;

      THack(Dest).Change;

    end;

  end

  else inherited AssignTo(Dest);

end;

procedure TDXPictureClip.Changed;

begin

  if Assigned(FOnChange) then FOnChange(Self);

end;

function TDXPictureClip.GetIsEmpty: Boolean;

begin

  Result := not Assigned(Picture) or Picture.Graphic.Empty;

end;

function TDXPictureClip.GetCount: Integer;

begin

  if IsEmpty then Result := 0

  else Result := Cols * Rows;

end;

const

{ TBitmap.GetTransparentColor from GRAPHICS.PAS uses this value }

  PaletteMask = $02000000;

procedure TDXPictureClip.Draw(Canvas: TCanvas; X, Y, Index: Integer);

  function PaletteColor(Color: TColor): Longint;

  begin

    Result := ColorToRGB(Color) or PaletteMask;

  end;

  procedure StretchBltTransparent(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;

    SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; Palette: HPalette;

    TransparentColor: TColorRef);

  var

    Color: TColorRef;

    bmAndBack, bmAndObject, bmAndMem, bmSave: HBitmap;

    bmBackOld, bmObjectOld, bmMemOld, bmSaveOld: HBitmap;

    MemDC, BackDC, ObjectDC, SaveDC: HDC;

    palDst, palMem, palSave, palObj: HPalette;

  begin

    { Create some DCs to hold temporary data }

    BackDC := CreateCompatibleDC(DstDC);

    ObjectDC := CreateCompatibleDC(DstDC);

    MemDC := CreateCompatibleDC(DstDC);

    SaveDC := CreateCompatibleDC(DstDC);

    { Create a bitmap for each DC }

    bmAndObject := CreateBitmap(SrcW, SrcH, 1, 1, nil);

    bmAndBack := CreateBitmap(SrcW, SrcH, 1, 1, nil);

    bmAndMem := CreateCompatibleBitmap(DstDC, DstW, DstH);

    bmSave := CreateCompatibleBitmap(DstDC, SrcW, SrcH);

    { Each DC must select a bitmap object to store pixel data }

    bmBackOld := SelectObject(BackDC, bmAndBack);

    bmObjectOld := SelectObject(ObjectDC, bmAndObject);

    bmMemOld := SelectObject(MemDC, bmAndMem);

    bmSaveOld := SelectObject(SaveDC, bmSave);

    { Select palette }

    palDst := 0; palMem := 0; palSave := 0; palObj := 0;

    if Palette <> 0 then begin

      palDst := SelectPalette(DstDC, Palette, True);

      RealizePalette(DstDC);

      palSave := SelectPalette(SaveDC, Palette, False);

      RealizePalette(SaveDC);

      palObj := SelectPalette(ObjectDC, Palette, False);

      RealizePalette(ObjectDC);

      palMem := SelectPalette(MemDC, Palette, True);

      RealizePalette(MemDC);

    end;

    { Set proper mapping mode }

    SetMapMode(SrcDC, GetMapMode(DstDC));

    SetMapMode(SaveDC, GetMapMode(DstDC));

    { Save the bitmap sent here }

    BitBlt(SaveDC, 0, 0, SrcW, SrcH, SrcDC, SrcX, SrcY, SRCCOPY);

    { Set the background color of the source DC to the color,         }

    { contained in the parts of the bitmap that should be transparent }

    Color := SetBkColor(SaveDC, PaletteColor(TransparentColor));

    { Create the object mask for the bitmap by performing a BitBlt()  }

    { from the source bitmap to a monochrome bitmap                   }

    BitBlt(ObjectDC, 0, 0, SrcW, SrcH, SaveDC, 0, 0, SRCCOPY);

    { Set the background color of the source DC back to the original  }

    SetBkColor(SaveDC, Color);

    { Create the inverse of the object mask }

    BitBlt(BackDC, 0, 0, SrcW, SrcH, ObjectDC, 0, 0, NOTSRCCOPY);

    { Copy the background of the main DC to the destination }

    BitBlt(MemDC, 0, 0, DstW, DstH, DstDC, DstX, DstY, SRCCOPY);

    { Mask out the places where the bitmap will be placed }

    StretchBlt(MemDC, 0, 0, DstW, DstH, ObjectDC, 0, 0, SrcW, SrcH, SRCAND);

    { Mask out the transparent colored pixels on the bitmap }

    BitBlt(SaveDC, 0, 0, SrcW, SrcH, BackDC, 0, 0, SRCAND);

    { XOR the bitmap with the background on the destination DC }

    StretchBlt(MemDC, 0, 0, DstW, DstH, SaveDC, 0, 0, SrcW, SrcH, SRCPAINT);

    { Copy the destination to the screen }

    BitBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0,

      SRCCOPY);

    { Restore palette }

    if Palette <> 0 then begin

      SelectPalette(MemDC, palMem, False);

      SelectPalette(ObjectDC, palObj, False);

      SelectPalette(SaveDC, palSave, False);

      SelectPalette(DstDC, palDst, True);

    end;

    { Delete the memory bitmaps }

    DeleteObject(SelectObject(BackDC, bmBackOld));

    DeleteObject(SelectObject(ObjectDC, bmObjectOld));

    DeleteObject(SelectObject(MemDC, bmMemOld));

    DeleteObject(SelectObject(SaveDC, bmSaveOld));

    { Delete the memory DCs }

    DeleteDC(MemDC);

    DeleteDC(BackDC);

    DeleteDC(ObjectDC);

    DeleteDC(SaveDC);

  end;

  procedure StretchBitmapTransparent(Dest: TCanvas; Bitmap: TBitmap;

    TransparentColor: TColor; DstX, DstY, DstW, DstH, SrcX, SrcY,

    SrcW, SrcH: Integer);

  var

    CanvasChanging: TNotifyEvent;

  begin

    if DstW <= 0 then DstW := Bitmap.Width;

    if DstH <= 0 then DstH := Bitmap.Height;

    if (SrcW <= 0) or (SrcH <= 0) then begin

      SrcX := 0; SrcY := 0;

      SrcW := Bitmap.Width;

      SrcH := Bitmap.Height;

    end;

    if not Bitmap.Monochrome then

      SetStretchBltMode(Dest.Handle, STRETCH_DELETESCANS);

    CanvasChanging := Bitmap.Canvas.OnChanging;

    Bitmap.Canvas.Lock;

    try

      Bitmap.Canvas.OnChanging := nil;

      if TransparentColor = clNone then begin

        StretchBlt(Dest.Handle, DstX, DstY, DstW, DstH, Bitmap.Canvas.Handle,

          SrcX, SrcY, SrcW, SrcH, Dest.CopyMode);

      end

      else begin

        if TransparentColor = clDefault then

          TransparentColor := Bitmap.Canvas.Pixels[0, Bitmap.Height - 1];

        if Bitmap.Monochrome then TransparentColor := clWhite

        else TransparentColor := ColorToRGB(TransparentColor);

        StretchBltTransparent(Dest.Handle, DstX, DstY, DstW, DstH,

          Bitmap.Canvas.Handle, SrcX, SrcY, SrcW, SrcH, Bitmap.Palette,

          TransparentColor);

      end;

    finally

      Bitmap.Canvas.OnChanging := CanvasChanging;

      Bitmap.Canvas.Unlock;

    end;

  end;

  procedure DrawBitmapTransparent(Dest: TCanvas; DstX, DstY: Integer;

    Bitmap: TBitmap; TransparentColor: TColor);

  begin

    StretchBitmapTransparent(Dest, Bitmap, TransparentColor, DstX, DstY,

      Bitmap.Width, Bitmap.Height, 0, 0, Bitmap.Width, Bitmap.Height);

  end;

var

  Image: TGraphic;

begin

  if Index < 0 then Image := Picture.Graphic

  else Image := GraphicCell[Index];

  if (Image <> nil) and not Image.Empty then begin

    if FMasked and (FMaskColor <> clNone) and

      (Picture.Graphic is TBitmap) then

      DrawBitmapTransparent(Canvas, X, Y, TBitmap(Image), FMaskColor)

    else Canvas.Draw(X, Y, Image);

  end;

end;

procedure TDXPictureClip.DrawCenter(Canvas: TCanvas; Rect: TRect; Index: Integer);

var

  X, Y: Integer;

begin

  X := (Rect.Left + Rect.Right - Width) div 2;

  Y := (Rect.Bottom + Rect.Top - Height) div 2;

  Draw(Canvas, X, Y, Index);

end;

procedure TDXPictureClip.CheckIndex(Index: Integer);

begin

  if (Index >= Cols * Rows) or (Index < 0) then

    raise EListError.CreateFmt('%s (%d)', ['Load list error', Index]);

end;

function TDXPictureClip.GetIndex(Col, Row: Cardinal): Integer;

begin

  Result := Col + (Row * Cols);

  if (Result >= Cols * Rows) or IsEmpty then Result := -1;

end;

function TDXPictureClip.GetCell(Col, Row: Cardinal): TBitmap;

begin

  Result := GetGraphicCell(GetIndex(Col, Row));

end;

function TDXPictureClip.GetGraphicCell(Index: Integer): TBitmap;

  procedure AssignBitmapCell(Source: TGraphic; Dest: TBitmap; Cols, Rows,

    Index: Integer);

  var

    CellWidth, CellHeight: Integer;

  begin

    if (Source <> nil) and (Dest <> nil) then begin

      if Cols <= 0 then Cols := 1;

      if Rows <= 0 then Rows := 1;

      if Index < 0 then Index := 0;

      CellWidth := Source.Width div Cols;

      CellHeight := Source.Height div Rows;

      with Dest do begin

        Width := CellWidth; Height := CellHeight;

      end;

      if Source is TBitmap then begin

        Dest.Canvas.CopyRect(Bounds(0, 0, CellWidth, CellHeight),

          TBitmap(Source).Canvas, Bounds((Index mod Cols) * CellWidth,

          (Index div Cols) * CellHeight, CellWidth, CellHeight));

        Dest.TransparentColor := TBitmap(Source).TransparentColor;

      end

      else begin

        Dest.Canvas.Brush.Color := clSilver;

        Dest.Canvas.FillRect(Bounds(0, 0, CellWidth, CellHeight));

        Dest.Canvas.Draw(-(Index mod Cols) * CellWidth,

          -(Index div Cols) * CellHeight, Source);

      end;

      Dest.Transparent := Source.Transparent;

    end;

  end;

begin

  CheckIndex(Index);

  AssignBitmapCell(Picture.Graphic, FBitmap, Cols, Rows, Index);

  if Picture.Graphic is TBitmap then

    if FBitmap.PixelFormat <> pfDevice then

      FBitmap.PixelFormat := TBitmap(Picture.Graphic).PixelFormat;

  FBitmap.TransparentColor := FMaskColor or PaletteMask;

  FBitmap.Transparent := (FMaskColor <> clNone) and Masked;

  Result := FBitmap;

end;

function TDXPictureClip.GetDefaultMaskColor: TColor;

begin

  Result := clOlive;

  if (Picture.Graphic <> nil) and (Picture.Graphic is TBitmap) then

    Result := TBitmap(Picture.Graphic).TransparentColor and

      not PaletteMask;

end;

function TDXPictureClip.GetHeight: Integer;

begin

  Result := Picture.Height div FRows;

end;

function TDXPictureClip.GetWidth: Integer;

begin

  Result := Picture.Width div FCols;

end;

function TDXPictureClip.IsMaskStored: Boolean;

begin

  Result := MaskColor <> GetDefaultMaskColor;

end;

procedure TDXPictureClip.SetMaskColor(Value: TColor);

begin

  if Value <> FMaskColor then begin

    FMaskColor := Value;

    Changed;

  end;

end;

procedure TDXPictureClip.PictureChanged(Sender: TObject);

begin

  FMaskColor := GetDefaultMaskColor;

  if not (csReading in ComponentState) then Changed;

end;

procedure TDXPictureClip.SetHeight(Value: Integer);

begin

  if (Value > 0) and (Picture.Height div Value > 0) then

    Rows := Picture.Height div Value;

end;

procedure TDXPictureClip.SetWidth(Value: Integer);

begin

  if (Value > 0) and (Picture.Width div Value > 0) then

    Cols := Picture.Width div Value;

end;

procedure TDXPictureClip.SetPicture(Value: TPicture);

begin

  FPicture.Assign(Value);

end;

{ Transformations routines }

{ Authorisation: Mr. Takanori Kawasaki}

//Distance between 2 points is calculated

function Get2PointRange(a,b: TDblPoint):Double;

var

  x,y: Double;

begin

  x := a.X - b.X;

  y := a.Y - b.Y;

  Result := Sqrt(x*x+y*y);

end;

//Direction angle in the coordinate A which was seen from  coordinate B is calculated

function GetARadFromB(A,B: TDblPoint):Double;

var

  dX,dY: Double;

begin

  dX := A.X - B.X;

  dY := A.Y - B.Y;

  Result := Get256(dX,dY);

end;

//Direction angle is returned with 0 - 255.

function Get256(dX,dY:Double):Double;

begin

  Result := 0;

  if dX > 0 then

  begin//0-63

    if dY > 0 then Result := ArcTan(dY / dX)          // 0 < Res < 90

    else//0

    if dY = 0 then Result := 0                        // 0

    else//192-255

    if dY < 0 then Result := 2*Pi + ArcTan(dY / dX)   // 270 < Res < 360

  end else

  if dX = 0 then

  begin//64

    if dY > 0 then Result := 1 / 2 * Pi               // 90

    else//0

    if dY = 0 then Result := 0                        // 0

    else//192

    if dY < 0 then Result := 3 / 2 * Pi               // 270

  end else

  if dX < 0 then

  begin//64-127

    if dY > 0 then Result := Pi + ArcTan(dY / dX)     // 90 < Res < 180

    else//128

    if dY = 0 then Result := Pi                       // 180

    else//128-191

    if dY < 0 then Result := Pi + ArcTan(dY / dX)     // 180 < Res < 270

  end;

  Result := 256 * Result / (2*Pi);

end;

//From the coordinate SP the Range it calculates the point  which leaves with the angular Angle

function GetPointFromRangeAndAngle(SP: TDblPoint; Range,Angle: Double): TDblPoint;

begin

  Result.X := SP.X + Range * Cos(Angle);

  Result.Y := SP.Y + Range * Sin(Angle);

end;

//* As for coordinate transformation coordinate for mathematics is used

//Identity matrix for the 2d is returned.

function Ini2DRowCol: T2DRowCol;

var

  i,ii:integer;

begin

  for i := 1 to 3 do

    for ii := 1 to 3 do

      if i = ii then Result[i,ii] := 1 else Result[i,ii] := 0;

end;

//Transformation matrix of the portable quantity

//where the one  for 2d is appointed is returned.

function Trans2DRowCol(x,y:double):T2DRowCol;

begin

  Result := Ini2DRowCol;

  Result[3,1] := x;

  Result[3,2] := y;

end;

//Conversion coordinate of the expansion and contraction

//quantity where the one for 2d is appointed is returned.

function Scale2DRowCol(x,y:double):T2DRowCol;

begin

  Result := Ini2DRowCol;

  Result[1,1] := x;

  Result[2,2] := y;

end;

//Coordinate transformation of the rotary quantity

//where the  one for 2d is appointed is returned.

function Rotate2DRowCol(Theta:double):T2DRowCol;

begin

  Result := Ini2DRowCol;

  Result[1,1] := Cos256(Trunc(Theta));

  Result[1,2] := Sin256(Trunc(Theta));

  Result[2,1] := -1 * Result[1,2];

  Result[2,2] := Result[1,1];

end;

//You apply two conversion coordinates and adjust.

function Multiply2DRowCol(A,B:T2DRowCol):T2DRowCol;

begin

  Result[1,1] := A[1,1] * B[1,1] + A[1,2] * B[2,1];