screentools.pas

类似文明的游戏源代码。

    intensity:=GrExt[HGrSystem].Data.Canvas.Pixels[66+x,47+y] and $FF;
    GrExt[HGrSystem].Data.Canvas.Pixels[77+x,47+y]:=
      T.clMark and $FF *intensity div $FF
      +T.clMark shr 8 and $FF *intensity div $FF shl 8
      +T.clMark shr 16 and $FF *intensity div $FF shl 16
    end;
bitblt(GrExt[HGrSystem].Mask.Canvas.Handle,77,47,10,10,
  GrExt[HGrSystem].Mask.Canvas.Handle,66,47,SRCCOPY);
end;

procedure Fill(ca: TCanvas;Left,Top,Width,Height,xOffset,yOffset: integer;
  const T: TTexture);
var
x,y,x0cut,y0cut,x1cut,y1cut: integer;
begin
for y:=(Top+yOffset) div T.Height to (Top+yOffset+Height-1) div T.Height do
  begin
  y0cut:=Top+yOffset-y*T.Height;
  if y0cut<0 then y0cut:=0;
  y1cut:=(y+1)*T.Height-(Top+yOffset+Height);
  if y1cut<0 then y1cut:=0;
  for x:=(Left+xOffset) div T.Width to (Left+xOffset+Width-1) div T.Width do
    begin
    x0cut:=Left+xOffset-x*T.Width;
    if x0cut<0 then x0cut:=0;
    x1cut:=(x+1)*T.Width-(Left+xOffset+Width);
    if x1cut<0 then x1cut:=0;
    BitBlt(ca.Handle,x*T.Width+x0cut-xOffset,y*T.Height+y0cut-yOffset,
      T.Width-x0cut-x1cut,T.Height-y0cut-y1cut,
      GrExt[T.HGr].Data.Canvas.Handle,T.xGr+x0cut,T.yGr+y0cut,SRCCOPY);
    end
  end;
end;

procedure Corner(ca: TCanvas; x,y,Kind:integer; const T: TTexture);
begin
BitBlt(ca.Handle,x,y,8,8,GrExt[T.HGr].Mask.Canvas.Handle,
  T.xGr+29+Kind*9,T.yGr+89,SRCAND);
BitBlt(ca.Handle,x,y,8,8,GrExt[T.HGr].Data.Canvas.Handle,
  T.xGr+29+Kind*9,T.yGr+89,SRCPAINT);
end;

procedure LoweredTextOut(ca: TCanvas; CL: TColor; const T: TTexture;
  x,y:integer; s:string);
begin
with ca do
  begin
  Font.Color:=T.clTextLight;
  Textout(x+1,y+1,s);
  if CL<0 then Font.Color:=T.clTextShade
  else Font.Color:=CL;
  Textout(x,y,s);
  end
end;

procedure RisedTextOut(ca: TCanvas; x,y:integer; s:string);
begin
with ca do
  begin
  Font.Color:=$000000;
  Textout(x+1,y+1,s);
  Font.Color:=$FFFFFF;
  Textout(x,y,s);
  end
end;

procedure Gradient(ca: TCanvas; x,y,width,Color:integer; Brightness: array of integer);
var
i,r,g,b: integer;
begin
with ca do
  begin
  for i:=0 to 15 do
    begin // gradient
    r:=Color and $FF+Brightness[i];
    if r<0 then r:=0
    else if r>=256 then r:=255;
    g:=Color shr 8 and $FF+Brightness[i];
    if g<0 then g:=0
    else if g>=256 then g:=255;
    b:=Color shr 16 and $FF+Brightness[i];
    if b<0 then b:=0
    else if b>=256 then b:=255;
    pen.color:=r+g shl 8+b shl 16;
    MoveTo(x,y+i);
    LineTo(x+width,y+i);
    end;
  pen.color:=$000000;
  MoveTo(x+1,y+16);
  LineTo(x+width,y+16);
  LineTo(x+width,y);
  end
end;

procedure LightGradient(ca: TCanvas; x,y,width,Color:integer);
const
Brightness: array[0..15] of integer=
(16,12,8,4,0,-4,-8,-12,-16,-20,-24,-28,-32,-36,-40,-44);
begin
Gradient(ca,x,y,width,Color,Brightness)
end;

procedure DarkGradient(ca: TCanvas; x,y,width,Kind:integer);
const
Brightness: array[0..15] of integer=
(16,12,8,4,0,-4,-8,-12-24,-16+16,-20,-24,-28,-32,-36,-40,-44);
begin
Gradient(ca,x,y,width,
  GrExt[HGrSystem].Data.Canvas.Pixels[187,137+Kind],Brightness)
end;

procedure NumberBar(dst:TBitmap; x,y:integer;
  Cap:string; val: integer; const T: TTexture);
var
s:string;
begin
if val>0 then
  begin
  DLine(dst.Canvas,x-2,x+170,y+16,T.clBevelShade,T.clBevelLight);
  LoweredTextOut(dst.Canvas,-1,T,x-2,y,Cap);
  s:=IntToStr(val);
  RisedTextout(dst.canvas,x+170-dst.Canvas.TextWidth(s),y,s);
  end
end;

procedure CountBar(dst:TBitmap; x,y:integer; Kind:integer;
  Cap:string; val: integer; const T: TTexture);
var
i,sd,ld,cl: integer;
s:string;
begin
//val:=random(40); //!!!
if val=0 then exit;
assert(Kind>=0);
with dst.Canvas do
  begin
  DLine(dst.Canvas,x-2,x+170+32,y+16,T.clBevelShade,T.clBevelLight);

  s:=IntToStr(val);
  if val<0 then cl:=$0000FF
  else cl:=-1;
  LoweredTextOut(dst.Canvas,cl,T,x-2,y,Cap);
  LoweredTextout(dst.canvas,cl,T,x+170+32-TextWidth(s),y,s);

  val:=abs(val);
  if val mod 10=0 then sd:=14*(val div 10-1)
  else sd:=10*(val mod 10-1)+14*(val div 10);
  if sd=0 then sd:=1;
  if sd<60 then ld:=sd else ld:=60;
  for i:=0 to val div 10-1 do
    begin
    BitBlt(Handle,x-6+77+i*(14*ld div sd)+33,y+2+1,14,14,
      GrExt[HGrSystem].Mask.Canvas.Handle,67+Kind mod 8 *15,70+Kind div 8 *15,SRCAND);
    Sprite(dst,HGrSystem,x-6+77+32+i*(14*ld div sd),y+2,14,14,67+Kind mod 8 *15,
      70+Kind div 8 *15);
    end;
  for i:=0 to val mod 10-1 do
    begin
    BitBlt(dst.Canvas.Handle,x-6+77+(val div 10)*(14*ld div sd)
      +i*(10*ld div sd)+33,y+6+1,10,10,GrExt[HGrSystem].Mask.Canvas.Handle,
      66+Kind mod 11 *11,115+Kind div 11 *11,SRCAND);
    Sprite(dst,HGrSystem,x-6+77+32+(val div 10)*(14*ld div sd)
      +i*(10*ld div sd),y+6,10,10,66+Kind mod 11 *11,115+Kind div 11 *11)
    end;
  end
end; //CountBar

procedure PaintProgressBar(ca: TCanvas; Kind,x,y,pos,Growth,max: integer;
  const T: TTexture);
var
i: integer;
begin
if pos>max then pos:=max;
if Growth<0 then
  begin
  pos:=pos+Growth;
  if pos<0 then begin Growth:=Growth-pos; pos:=0 end
  end
else if pos+Growth>max then Growth:=max-pos;
Frame(ca,x-1,y-1,x+max,y+7,$000000,$000000);
RFrame(ca,x-2,y-2,x+max+1,y+8,T.clBevelShade,T.clBevelLight);
with ca do
  begin
  for i:=0 to pos div 8-1 do
    BitBlt(Handle,x+i*8,y,8,7,GrExt[HGrSystem].Data.Canvas.Handle,104,
      9+8*Kind,SRCCOPY);
  BitBlt(Handle,x+8*(pos div 8),y,
    pos-8*(pos div 8),7,GrExt[HGrSystem].Data.Canvas.Handle,104,9+8*Kind,SRCCOPY);
  if Growth>0 then
    begin
    for i:=0 to Growth div 8-1 do
      BitBlt(Handle,x+pos+i*8,y,8,7,GrExt[HGrSystem].Data.Canvas.Handle,112,
        9+8*Kind,SRCCOPY);
    BitBlt(Handle,x+pos+8*(Growth div 8),y,
      Growth-8*(Growth div 8),7,GrExt[HGrSystem].Data.Canvas.Handle,112,
      9+8*Kind,SRCCOPY);
    end
  else if Growth<0 then
    begin
    for i:=0 to -Growth div 8-1 do
      BitBlt(Handle,x+pos+i*8,y,8,7,GrExt[HGrSystem].Data.Canvas.Handle,104,1,
        SRCCOPY);
    BitBlt(Handle,x+pos+8*(-Growth div 8),y,
      -Growth-8*(-Growth div 8),7,GrExt[HGrSystem].Data.Canvas.Handle,104,1,
      SRCCOPY);
    end;
  Brush.Color:=$000000;
  FillRect(Rect(x+pos+abs(Growth),y,x+max,y+7));
  Brush.Style:=bsClear;
  end
end;

procedure InitButtons(const F: TForm);
var
cix: integer;
ButtonDownSound, ButtonUpSound: string;
begin
ButtonDownSound:=Sounds.Lookup('BUTTON_DOWN');
ButtonUpSound:=Sounds.Lookup('BUTTON_UP');
for cix:=0 to F.ComponentCount-1 do
  if F.Components[cix] is TButtonBase then
    with TButtonBase(F.Components[cix]) do
      begin
      Graphic:=GrExt[HGrSystem].Data;
      if ButtonDownSound<>'*' then
        DownSound:=HomeDir+'Sounds\'+ButtonDownSound+'.wav';
      if ButtonUpSound<>'*' then
        UpSound:=HomeDir+'Sounds\'+ButtonUpSound+'.wav';
      if F.Components[cix] is TButtonA then
        TButtonA(F.Components[cix]).Font:=UniFont[ftButton];
      if F.Components[cix] is TButtonB then
        TButtonB(F.Components[cix]).Mask:=GrExt[HGrSystem].Mask;
      end;
end;

var
i,p,size: integer;
s: string;
fontscript: TextFile;
section: TFontType;
Reg: TRegistry;

initialization
HomeDir:=ExtractFilePath(ParamStr(0));

TrueColor:=-1;
Reg:=TRegistry.Create;
Reg.OpenKey('SOFTWARE\cevo\RegVer5',true);
try
  TrueColor:=Reg.ReadInteger('TrueColor');
except
  TrueColor:=1;
  Reg.WriteInteger('TrueColor',TrueColor);
  end;
Reg.closekey;
Reg.Free;

Phrases:=TStringTable.Create;
Phrases.LoadFromFile(HomeDir+'Language.txt');
Sounds:=TStringTable.Create;
Sounds.LoadFromFile(HomeDir+'Sounds\sound.txt');

for section:=Low(TFontType) to High(TFontType) do
  UniFont[section]:=TFont.Create;

section:=ftNormal;
AssignFile(fontscript,HomeDir+'Fonts.txt');
try
  Reset(fontscript);
  while not eof(fontscript) do
    begin
    ReadLn(fontscript,s);
    if s<>'' then
      if s[1]='#' then
        begin
        s:=TrimRight(s);
        if s='#SMALL' then section:=ftSmall
        else if s='#TINY' then section:=ftTiny
        else if s='#CAPTION' then section:=ftCaption
        else if s='#BUTTON' then section:=ftButton
        else section:=ftNormal;
        end
      else
        begin
        p:=pos(',',s);
        if p>0 then
          begin
          UniFont[section].Name:=Trim(copy(s,1,p-1));
          size:=0;
          for i:=p+1 to length(s) do
            case s[i] of
              '0'..'9': size:=size*10+byte(s[i])-48;
              'B','b': UniFont[section].Style:=UniFont[section].Style+[fsBold];
              'I','i': UniFont[section].Style:=UniFont[section].Style+[fsItalic];
              end;
          UniFont[section].Size:=Round(size * 72/UniFont[section].PixelsPerInch);
          end
        end
    end;
  CloseFile(fontscript);
except
  end;

nGrExt:=0;
InitTexture(StartTex,'StdTextures',1);
HGrSystem:=LoadGraphicSet('System');
HGrSystem2:=LoadGraphicSet('System2');

finalization
for i:=0 to nGrExt-1 do
  begin
  GrExt[i].Data.Free; GrExt[i].Mask.Free;
  FreeMem(GrExt[i]);
  end;
for section:=Low(TFontType) to High(TFontType) do
  UniFont[section].Free;
Phrases.Free;
Sounds.Free;
end.