screentools.pas

类似文明的游戏源代码。

{$INCLUDE switches}

unit ScreenTools;

interface

uses
  StringTables,

  Windows,Messages,SysUtils,Classes,Graphics,Controls,Forms;

type
TTexture=record
  HGr,xGr,yGr,Width,Height: integer;
  clBevelLight,clBevelShade,clTextLight,clTextShade,clLitText,clMark: TColor
  end;

function Play(Item: string; Index: integer =-1): boolean;
function turntoyear(Turn: integer): integer;
function YearToTurn(year: integer): integer;
function TurnToString(Turn: integer): string;
procedure BtnFrame(ca:TCanvas;p:TRect;const T: TTexture);
procedure EditFrame(ca:TCanvas;p:TRect;const T: TTexture);
function LoadGraphicSet(Name: string): integer;
procedure Dump(dst:TBitmap; HGr,xDst,yDst,Width,Height,xGr,yGr:integer);
procedure Sprite(dst:TBitmap; HGr,xDst,yDst,Width,Height,xGr,yGr:integer);
procedure DLine(ca: TCanvas; x0,x1,y: integer; cl0,cl1: TColor);
procedure Frame(ca: TCanvas;x0,y0,x1,y1:integer;cl0,cl1:TColor);
procedure RFrame(ca: TCanvas;x0,y0,x1,y1:integer;cl0,cl1:TColor);
procedure FrameImage(ca: TCanvas; src:TBitmap; x,y,width,height,xSrc,ySrc: integer; IsControl: boolean = false);
procedure InitTexture(var T: TTexture; GrName: string; pix: integer);
procedure InitCityMark(const T: TTexture);
procedure Fill(ca: TCanvas;Left,Top,Width,Height,xOffset,yOffset: integer;const T: TTexture);
procedure Corner(ca: TCanvas; x,y,Kind:integer; const T: TTexture);
procedure LoweredTextOut(ca: TCanvas; CL: TColor; const T: TTexture;
  x,y:integer; s:string);
procedure RisedTextOut(ca: TCanvas; x,y:integer; s:string);
procedure LightGradient(ca: TCanvas; x,y,width,Color:integer);
procedure DarkGradient(ca: TCanvas; x,y,width,Kind:integer);
procedure NumberBar(dst:TBitmap; x,y:integer; Cap:string; val: integer;
  const T: TTexture);
procedure CountBar(dst:TBitmap; x,y:integer; Kind:integer; Cap:string;
  val: integer; const T: TTexture);
procedure PaintProgressBar(ca: TCanvas; Kind,x,y,pos,Growth,max: integer;
  const T: TTexture);
procedure InitButtons(const F: TForm);

const
nGrExtmax=64;

type
TGrExtDescr=record {don't use dynamic strings here!}
  Name:string[31];
  Data,Mask:TBitmap;
  pixUsed: array[Byte] of Byte;
  end;
TGrExtDescrSize=record {for size calculation only - must be the same as
  TGrExtDescr, but without pixUsed}
  Name:string[31];
  Data,Mask:TBitmap;
  end;

TFontType=(ftNormal, ftSmall, ftTiny, ftCaption, ftButton);

var
HomeDir: string;
Phrases, Sounds: TStringTable;
nGrExt: integer;
GrExt:array[0..nGrExtmax-1] of ^TGrExtDescr;
TrueColor, {1 = convert images to 24 bit -> multiplies memory usage but often much faster}
HGrSystem, HGrSystem2: integer;
StartTex: TTexture;
GenerateNames: boolean;

UniFont: array[TFontType] of TFont;

implementation

uses
  DePNG, MMSystem, ButtonBase, ButtonA, ButtonB,

  Registry;


function Play(Item: string; Index: integer =-1): boolean;
var
WAVFileName: string;
begin
if Item='' then begin result:=true; exit; end;
WAVFileName:=Sounds.Lookup(Item, Index);
result:=(WAVFileName<>'') and (WAVFileName<>'*');
if result then
  SndPlaySound(pchar(HomeDir+'Sounds\'+WAVFileName+'.wav'),SND_ASYNC)
end;

function turntoyear(Turn: integer): integer;
var
i: integer;
begin
result:=-4000;
for i:=1 to Turn do
  if result<-1000 then inc(result,50)       // 0..60
  else if result<0 then inc(result,25)      // 60..100
  else if result<1500 then inc(result,20)   // 100..175
  else if result<1750 then inc(result,10)   // 175..200
  else if result<1850 then inc(result,2)    // 200..250
  else inc(result);
end;

function YearToTurn(year: integer): integer;
var
year1: integer;
begin
year1:=-4000;
result:=0;
while year1<year do
  begin
  inc(result);
  if year1<-1000 then inc(year1,50)
  else if year1<0 then inc(year1,25)
  else if year1<1500 then inc(year1,20)
  else if year1<1750 then inc(year1,10)
  else if year1<1850 then inc(year1,2)
  else inc(year1);
  end
end;

function TurnToString(Turn: integer): string;
var
year: integer;
begin
if GenerateNames then
  begin
  year:=turntoyear(Turn);
  if year<0 then result:=Format(Phrases.Lookup('BC'),[-year])
  else result:=Format(Phrases.Lookup('AD'),[year]);
  end
else result:=IntToStr(Turn)
end;

procedure BtnFrame(ca:TCanvas;p:TRect;const T: TTexture);
begin
RFrame(ca,p.Left-1,p.Top-1,p.Right,p.Bottom,T.clBevelShade,T.clBevelLight)
end;

procedure EditFrame(ca:TCanvas;p:TRect;const T: TTexture);
begin
Frame(ca,p.Left-1,p.Top-1,p.Right,p.Bottom,$000000,$000000);
Frame(ca,p.Left-2,p.Top-2,p.Right+1,p.Bottom+1,$000000,$000000);
Frame(ca,p.Left-3,p.Top-3,p.Right+2,p.Bottom+1,$000000,$000000);
RFrame(ca,p.Left-4,p.Top-4,p.Right+3,p.Bottom+2,T.clBevelShade,T.clBevelLight)
end;

function LoadGraphicSet(Name: string): integer;
type
TLine=array[0..649,0..2] of Byte;
var
i,x,y,xmax,OriginalColor: integer;
FileName: string;
Source,Mask1: TBitmap;
DataLine, MaskLine: ^TLine;
begin
i:=0;
while (i<nGrExt) and (GrExt[i].Name<>Name) do inc(i);
result:=i;
if i=nGrExt then
  begin
  FileName:=HomeDir+'Graphics\'+Name;
  Source:=TBitmap.Create;
  if not LoadBitmapFromPNG(Source,FileName+'.png') then
    try
      Source.LoadFromFile(FileName+'.bmp')
    except
      end;

  GetMem(GrExt[nGrExt],SizeOf(TGrExtDescrSize)+Source.Height div 49 *10);
  GrExt[nGrExt].Name:=Name;
  if TrueColor=1 then
    begin
    xmax:=Source.Width-1; // allows 4-byte access even for last pixel
    if xmax>650 then xmax:=650;

    GrExt[nGrExt].Data:=Source;
    GrExt[nGrExt].Data.PixelFormat:=pf24bit;
    GrExt[nGrExt].Mask:=TBitmap.Create;
    GrExt[nGrExt].Mask.PixelFormat:=pf24bit;
    GrExt[nGrExt].Mask.Width:=Source.Width;
    GrExt[nGrExt].Mask.Height:=Source.Height;

    for y:=0 to Source.Height-1 do
      begin
      DataLine:=GrExt[nGrExt].Data.ScanLine[y];
      MaskLine:=GrExt[nGrExt].Mask.ScanLine[y];
      for x:=0 to xmax-1 do
        begin
        OriginalColor:=Cardinal((@DataLine[x])^) and $FFFFFF;
        if (OriginalColor=$FF00FF) or (OriginalColor=$7F007F) then
          begin // transparent
          Cardinal((@MaskLine[x])^):=$FFFFFF;
          Cardinal((@DataLine[x])^):=Cardinal((@DataLine[x])^) and $FF000000
          end
        else Cardinal((@MaskLine[x])^):=$000000; // non-transparent
        end
      end;
    end
  else
    begin
    GrExt[nGrExt].Mask:=TBitmap.Create;
    GrExt[nGrExt].Mask.Width:=Source.Width;
    GrExt[nGrExt].Mask.Height:=Source.Height;
    Mask1:=TBitmap.Create;
    Mask1.Assign(Source);
    Mask1.Mask($7F007F); {mask dark purple}
    BitBlt(GrExt[nGrExt].Mask.Canvas.Handle,0,0,Source.Width,Source.Height,
      Mask1.Canvas.Handle,0,0,SRCCOPY);
    Mask1.Assign(Source);
    Mask1.Mask($FF00FF); {mask light purple}
    BitBlt(GrExt[nGrExt].Mask.Canvas.Handle,0,0,Source.Width,Source.Height,
      Mask1.Canvas.Handle,0,0,SRCPAINT);
    Mask1.Free;

    GrExt[nGrExt].Data:=TBitmap.Create;
    GrExt[nGrExt].Data.Assign(GrExt[nGrExt].Mask);
    BitBlt(GrExt[nGrExt].Data.Canvas.Handle,0,0,Source.Width,Source.Height,
      Source.Canvas.Handle,0,0,SRCERASE);
    Source.Free;
    end;

  FillChar(GrExt[nGrExt].pixUsed,GrExt[nGrExt].Data.Height div 49 *10,0);
  inc(nGrExt)
  end
end;

procedure Dump(dst:TBitmap; HGr,xDst,yDst,Width,Height,xGr,yGr: integer);
begin
BitBlt(dst.Canvas.Handle,xDst,yDst,Width,Height,
  GrExt[HGr].Data.Canvas.Handle,xGr,yGr,SRCCOPY);
end;

procedure Sprite(dst:TBitmap; HGr,xDst,yDst,Width,Height,xGr,yGr: integer);
begin
BitBlt(dst.Canvas.Handle,xDst,yDst,Width,Height,
  GrExt[HGr].Mask.Canvas.Handle,xGr,yGr,SRCAND);
BitBlt(dst.Canvas.Handle,xDst,yDst,Width,Height,
  GrExt[HGr].Data.Canvas.Handle,xGr,yGr,SRCPAINT);
end;

procedure DLine(ca: TCanvas; x0,x1,y: integer; cl0,cl1: TColor);
begin
with ca do
  begin
  Pen.Color:=cl0; MoveTo(x0,y); LineTo(x1,y);
  Pen.Color:=cl1; MoveTo(x0+1,y+1); LineTo(x1+1,y+1);
  Pixels[x0,y+1]:=cl0; Pixels[x1,y]:=cl1;
  end
end;

procedure Frame(ca: TCanvas;x0,y0,x1,y1:integer;cl0,cl1:TColor);
begin
with ca do
  begin
  MoveTo(x0,y1);
  Pen.Color:=cl0;LineTo(x0,y0);LineTo(x1,y0);
  Pen.Color:=cl1;LineTo(x1,y1);LineTo(x0,y1);
  end
end;

procedure RFrame(ca: TCanvas;x0,y0,x1,y1:integer;cl0,cl1:TColor);
begin
with ca do
  begin
  Pen.Color:=cl0;
  MoveTo(x0,y0+1);LineTo(x0,y1);
  MoveTo(x0+1,y0);LineTo(x1,y0);
  Pen.Color:=cl1;
  MoveTo(x1,y0+1);LineTo(x1,y1);
  MoveTo(x0+1,y1);LineTo(x1,y1);
  end
end;

procedure FrameImage(ca: TCanvas; src:TBitmap; x,y,width,height,xSrc,ySrc: integer;
  IsControl: boolean = false);
begin
if IsControl then
  begin
  Frame(ca,x-1,y-1,x+width,y+height,$000000,$808080);
  RFrame(ca,x-2,y-2,x+width+1,y+height+1,$808080,$000000);
  end
else Frame(ca,x-1,y-1,x+width,y+height,$000000,$000000);
BitBlt(ca.Handle,x,y,width,height,src.Canvas.Handle,xSrc,ySrc,SRCCOPY);
end;

procedure InitTexture(var T: TTexture; GrName: string; pix: integer);
begin
with T do
  begin
  HGr:=LoadGraphicSet(GrName);
  xGr:=1+pix mod 10 *65;
  yGr:=1+pix div 10 *49;
  Width:=1;
  while (Width<64) and (GrExt[HGr].Mask.Canvas.Pixels[xGr+Width,yGr]=0) do
    inc(Width);
  Height:=1;
  while (Height<88) and (GrExt[HGr].Mask.Canvas.Pixels[xGr,yGr+Height]=0) do
    inc(Height);
  clBevelLight:=GrExt[HGr].Data.Canvas.Pixels[xGr,yGr+95];
  clBevelShade:=GrExt[HGr].Data.Canvas.Pixels[xGr+3,yGr+95];
  clTextLight:=GrExt[HGr].Data.Canvas.Pixels[xGr+6,yGr+95];
  clTextShade:=GrExt[HGr].Data.Canvas.Pixels[xGr+9,yGr+95];
  clLitText:=GrExt[HGr].Data.Canvas.Pixels[xGr,yGr+92];
  clMark:=GrExt[HGr].Data.Canvas.Pixels[xGr+3,yGr+92];
  end
end;

procedure InitCityMark(const T: TTexture);
var
x,y,intensity: integer;
begin
for x:=0 to 9 do for y:=0 to 9 do
  if GrExt[HGrSystem].Mask.Canvas.Pixels[66+x,47+y]=0 then
    begin