main.pas

jssm的原代码

unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Clipbrd;

type
  PAdrn = ^TAdrn;
  TAdrn = packed record
    ID,
    Addr,
    BlockLength,
    dx,
    dy,
    Width,
    Height: LongInt;
    de,
    ds,
    Flag: Char;
    Unknow: array[1..45] of Char;
    Code: LongInt;
  end;
  PCGAdrn = ^TCGAdrn;
  TCGAdrn = packed record
    ID,
    Addr,
    BlockLength,
    dx,
    dy,
    Width,
    Height: LongInt;
    de,
    ds,
    Flag: Char;
    Unknow: array[1..5] of Char;  
    Code: LongInt;
  end;
  PRealHead = ^TRealHead;
  TRealHead = packed record
    Flag: array[1..2] of Char;
    Unknow: Short;
    Width,
    Height,
    BlockLength: LongInt;
  end;

  TMainForm = class(TForm)
    Panel1: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    AppInfo: TLabel;
    PicInfo: TLabel;
    TheImage: TImage;
    StaInfo: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    FReal, FAdrn: TFileStream;
    FPal: TMemoryStream;
    FLoadOK: Boolean;
    FGameID: Integer;

    FCurPic, FPicCnt: Integer;
    FJumpTo: String;
    procedure LoadGameStream;
    procedure FreeGameStream;
    function DecompressStream(AStream: TMemoryStream): TMemoryStream;
    function MakeBitmapStream(AWidth, AHeight: Integer; AStream: TMemoryStream): TMemoryStream;
  public
    procedure LoadASprit;
  end;

const
  CstState: array [0..5] of String = ('Ready.', 'View Pre Pic.', 'View Next Pic.', 'Save Cur Pic.', 'Copy to Clipboard.', 'Jump to ');
  CstInfo = 'Current View: %s'#13'(Adrn Size: %.0n Real Size: %.0n)';
  CstFail = 'Load Fail. Check install directory or get new version.';
  CstPic = 'Total: %d'#13'ID: %d'#13'Adrn: 0x%x'#13'Block: 0x%x'#13'w,h: %d,%d'#13'dx,dy: %d,%d';

var
  MainForm: TMainForm;

implementation

{$R *.dfm}
{$R pal.res}

function TMainForm.DecompressStream(AStream: TMemoryStream): TMemoryStream;
var
  I, S, Offset: LongInt;
  BS1, BS2, BS3, BS4, H, L: Byte;

  procedure DecStatic(Len: LongInt);
  var
    P: Pointer;
  begin
    P := AllocMem(Len);
    AStream.Read(P^, Len);
    Result.Write(P^, Len);
    FreeMem(P);
  end;
  procedure DecRepeat(Rep: LongInt);
  var
    K: LongInt;
  begin
    for K := 1 to Rep do Result.WriteBuffer(BS2, 1);
  end;
begin
  Offset := 0;
  Result := TMemoryStream.Create;
  try
    AStream.Position := 0;
    S := AStream.Size;
    I := 0;
    while I < S do
    begin
      AStream.ReadBuffer(BS1, 1);
      { if BS1 = $28 then Break; }
      H := BS1 shr 4;
      L := BS1 and $0F;
      case H of
        $0: begin
              Offset := L;
              DecStatic(Offset);
            end;
        $1: begin
              AStream.ReadBuffer(BS2, 1);
              Offset := L shl 8 + BS2; // L * $100 + BS2;
              DecStatic(Offset);
              Offset := Offset + 1;
            end;
        $2: begin
              AStream.ReadBuffer(BS2, 1);
              AStream.ReadBuffer(BS3, 1);
              Offset := L shl 16 + BS2 shl 8 + BS3; // L * $10000 + BS2 * $100 + BS3;
              DecStatic(Offset);
              Offset := Offset + 2;
            end;
        $8: begin
              AStream.ReadBuffer(BS2, 1);
              DecRepeat(L);
              Offset := 1;
            end;
        $9: begin
              AStream.ReadBuffer(BS2, 1);
              AStream.ReadBuffer(BS3, 1);
              DecRepeat(L shl 8 + BS3); //(L * $100 + BS3);
              Offset := 2;
            end;
        $A: begin
              AStream.ReadBuffer(BS2, 1);
              AStream.ReadBuffer(BS3, 1);
              AStream.ReadBuffer(BS4, 1);
              DecRepeat(L shl 16 + BS3 shl 8 + BS4); //(L * $10000 + BS3 * $100 + BS4);
              Offset := 3;
            end;
        $C: begin
              BS2 := $FF;
              DecRepeat(L);
              Offset := 0;
            end;
        $D: begin
              BS2 := $FF;
              AStream.ReadBuffer(BS3, 1);
              DecRepeat(L shl 8 + BS3); //(L * $100 + BS3);
              Offset := 1;
            end;
        $E: begin
              BS2 := $FF;
              AStream.ReadBuffer(BS3, 1);
              AStream.ReadBuffer(BS4, 1);
              DecRepeat(L shl 16 + BS3 shl 8 + BS4); //L * $10000 + BS3 * $100 + BS4);
              Offset := 2;
            end;
      else
        Break;
        { 52 44 01 84 28 00 00 00 ... 时结束，否则 28 00 00 00 将导致好多 00 }
      end;
      I := I + 1 + Offset;
    end;
  finally
  end;
end;


function TMainForm.MakeBitmapStream(AWidth, AHeight: Integer; AStream: TMemoryStream): TMemoryStream;
var
  BMF: TBitmapFileHeader;
  BH: TBitmapInfoHeader;
begin
  Result := TMemoryStream.Create;
  try
    FillChar(BMF, SizeOf(BMF), 0);
    BMF.bfType := $4D42;
    BMF.bfSize := SizeOf(BMF) + SizeOf(BH) + FPal.Size + AStream.Size;
    BMF.bfOffBits := SizeOf(BMF) + SizeOf(BH) + FPal.Size;
    FillChar(BH, SizeOf(BH), 0);
    BH.biSize := SizeOf(BH);
    BH.biWidth := AWidth;
    BH.biHeight := AHeight;
    BH.biPlanes := 1;
    BH.biBitCount := 8;
    BH.biXPelsPerMeter := $EC4;
    BH.biYPelsPerMeter := $EC4;

    Result.WriteBuffer(BMF, SizeOf(BMF));
    Result.WriteBuffer(BH, SizeOf(BH));
    Result.CopyFrom(FPal, 0);
    Result.CopyFrom(AStream, 0);

    { 内存泄漏!! }
    FreeAndNil(AStream);
  finally
  end;
end;


{ TMainForm }
procedure TMainForm.LoadGameStream;
const
  CstGames: array [1..2] of String = ('StoneAge', 'CrossGate');
  GamePath: array [1..2] of String = ('data\', 'bin\');
  GameFile: array [0..1, 1..2] of String = (('adrn_*.bin', 'GraphicInfo_*.bin'), ('real_*.bin', 'Graphic_*.bin'));

  function FindGameFile(APath, AFile: String): String;
  var
    Rec: TSearchRec;
  begin
    Result := '';
    if FindFirst(APath + AFile, faAnyFile, Rec) = 0 then
    begin
      Result := APath + Rec.Name;
      FindClose(Rec);
    end;
  end;

var
  T, F1, F2: String;
  I: Integer;
  HResInfo: THandle;
  MemHandle: THandle;
  ResPtr: PByte;
  ResSize: Longint;
begin
  FLoadOK := False;
  FGameID := 0;

  T := ExtractFilePath(ParamStr(0));
  for I := 1 to 2 do
  begin
    F1 := FindGameFile(T + GamePath[I], GameFile[0][I]);
    F2 := FindGameFile(T + GamePath[I], GameFile[1][I]);
    if FileExists(F1) and FileExists(F2) then
    begin
      FGameID := I;
      Break;
    end;
  end;
  if FGameID = 0 then
  begin
    Application.MessageBox('没有找到石器或者魔力的游戏文件。'#13#13 +
      '请把BPV安装到石器或者魔力的游戏目录(和游戏执行文件放在一起)， '#13#13 +
      '如果这样还不能正确读取图片，可能需要升级BPV的版本了。',
      'BPV', MB_OK + MB_ICONWARNING);
    Exit;
  end;

  FAdrn := TFileStream.Create(F1, fmOpenRead + fmShareDenyNone);
  FReal := TFileStream.Create(F2, fmOpenRead + fmShareDenyNone);

  { load pal from resource}
  HResInfo := FindResource(HInstance, 'PAL01', RT_RCDATA);
  ResSize := SizeOfResource(HInstance, HResInfo);
  MemHandle := LoadResource(HInstance, HResInfo);
  ResPtr := LockResource(MemHandle);
  FPal := TMemoryStream.Create;
  FPal.SetSize(ResSize);
  FPal.Write(ResPtr^, ResSize);
  FreeResource(MemHandle);

  FLoadOK := True;
  if FGameID = 1 then FPicCnt := FAdrn.Size div SizeOf(TAdrn)
  else FPicCnt := FAdrn.Size div SizeOf(TCGAdrn);

  AppInfo.Caption := Format(CstInfo, [CstGames[FGameID], FAdrn.Size * 1.0, FReal.Size * 1.0]);
end;

procedure TMainForm.FreeGameStream;
begin
  if not FLoadOK then Exit;
  FreeAndNil(FAdrn);
  FreeAndNil(FReal);
  FreeAndNil(FPal);
end;


procedure TMainForm.LoadASprit;
var
  AStream, BmpStream: TMemoryStream;
  AAdrn: TAdrn;
  ACGAdrn: TCGAdrn;
  ARealHead: TRealHead;
  L: LongInt;
begin
  if not FLoadOK then Exit;
  if FCurPic < 0 then FCurPic := FPicCnt - 1;
  if FCurPic >= FPicCnt then FCurPic := 0;

  Screen.Cursor := crHourGlass;
  AStream := TMemoryStream.Create;
  try
    if FGameID = 1 then
    begin
      { 读图片信息 }
      FAdrn.Seek(FCurPic * SizeOf(TAdrn), soFromBeginning);
      FAdrn.ReadBuffer(AAdrn, SizeOf(TAdrn));
      { 读图片头 }
      FReal.Seek(AAdrn.Addr, soFromBeginning);
      { Info }
      PicInfo.Caption := Format(CstPic, [FPicCnt, FCurPic,
        AAdrn.Addr, AAdrn.BlockLength,
        AAdrn.Width, AAdrn.Height, AAdrn.dx, AAdrn.dy]);
    end
    else
    begin
      { 读图片信息 }
      FAdrn.Seek(FCurPic * SizeOf(TCGAdrn), soFromBeginning);
      FAdrn.ReadBuffer(ACGAdrn, SizeOf(TCGAdrn));
      { 读图片头 }
      FReal.Seek(ACGAdrn.Addr, soFromBeginning);
      { Info }
      PicInfo.Caption := Format(CstPic, [FPicCnt, FCurPic,
        ACGAdrn.Addr, ACGAdrn.BlockLength,
        ACGAdrn.Width, ACGAdrn.Height, ACGAdrn.dx, ACGAdrn.dy]);
    end;
    { 读图片头 }
    FReal.ReadBuffer(ARealHead, SizeOf(TRealHead));
    L := ARealHead.BlockLength;
    if FReal.Position + L > FReal.Size then L := FReal.Size - FReal.Position;
    AStream.CopyFrom(FReal, L);
    { 画图 }
    BmpStream := MakeBitmapStream(ARealHead.Width, ARealHead.Height, DecompressStream(AStream));
    BmpStream.Position := 0;
    TheImage.Picture.Bitmap.LoadFromStream(BmpStream);
    if not PicInfo.Visible then PicInfo.Visible := True;

    { 内存泄漏!! }
    FreeAndNil(AStream);
    FreeAndNil(BmpStream);
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  FCurPic := 0;
  FPicCnt := 0;
  FJumpTo := '';
  LoadGameStream;
  LoadASprit;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  FreeGameStream;
end;

procedure TMainForm.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  tmp: String;
  procedure ShowState(ID: Integer);
  begin
    if StaInfo.Font.Color = clWhite then StaInfo.Font.Color := clLime;
    StaInfo.Caption := '> ' + CstState[ID];
  end;
begin
  case Key of
    VK_PRIOR:  { PageUp }
    begin
      Dec(FCurPic);
      ShowState(1);
      LoadASprit;
    end;
    VK_NEXT:   { PageDown }
    begin
      Inc(FCurPic);
      ShowState(2);
      LoadASprit;
    end;
    83:  { S }
    begin
      ShowState(3);
      tmp := ExtractFilePath(ParamStr(0)) + 'bpv';
      if not DirectoryExists(tmp) then ForceDirectories(tmp);
      TheImage.Picture.SaveToFile(tmp + '\' + IntToStr(FCurPic) + '.bmp');
    end;
    67:  { C }
    begin
      ShowState(4);
      Clipboard.Assign(TheImage.Picture.Bitmap);
    end;
    48..57, 96..105: { '0'..'9', NumPad }
    begin
      ShowState(5);
      StaInfo.Font.Color := clWhite;
      if (Key >= 96) and (Key <= 105) then tmp := Chr(Key - 48)
      else tmp := Chr(Key);
      FJumpTo := FJumpTo + tmp;
      StaInfo.Caption := StaInfo.Caption + FJumpTo;
    end;
    VK_ESCAPE:
    begin
      ShowState(5);
      FJumpTo := '';
    end;
    VK_RETURN:
    begin
      ShowState(5);
      FCurPic := StrToIntDef(FJumpTo, 0);
      if FCurPic < 0 then FCurPic := FPicCnt - 1;
      if FCurPic >= FPicCnt then FCurPic := 0;
      FJumpTo := '';
      StaInfo.Caption := StaInfo.Caption + IntToStr(FCurPic) + '.';
      LoadASprit;
    end;
  end;
end;

end.