home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Doom 2 Explosion
/
Doom2Explosion.bin
/
doom2exp
/
programs
/
dhtk100
/
wad.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-05-26
|
8KB
|
325 lines
{****************************************************************************
* The DOOM Hacker's Tool Kit *
*****************************************************************************
* Unit: WAD *
* Purpose: Loading WAD File directory and much more *
* Date: 4/28/94 *
* Author: Joshua Jackson Internet: joshjackson@delphi.com *
****************************************************************************}
{$O+,F+}
unit wad;
interface
uses WadDecl;
type PWadDirectory=^TWadDirectory;
TWadDirectory=object
WadName :array[1..9] of char;
WadFile :file;
WadID :array[1..4] of char;
DirEntries :longint;
DirStart :longint;
DirEntry :PWADDirList;
Constructor Init(WadFileName:String);
Procedure DisplayWadDir;
Function FindObject(ObjName:ObjNameStr):word;
Procedure SetWadPalette(PlayPalNum:integer);
Procedure RestorePalette;
Destructor Done;
end;
Function WadResultMsg(ErrNum:byte):string;
Const TerminateOnWadError:boolean=True;
WadResult :Integer = 0;
wrOk = 00;
wrInvalidFile = 01;
wrMaxEntries = 02;
wrNoObject = 03;
wrNoSound = 04;
wrBadImageSize = 05;
wrNoPicture = 06;
wrNoPalette = 07;
wrNoFile = 08;
ShowInit :boolean=False;
WadPaletteIsSet:Boolean=false;
implementation
uses crt,windos,dos;
var OldPalette:array[1..768] of byte;
Function TWadDirectory.FindObject(ObjName:ObjNameStr):word;
var t,x:integer;
TempName:ObjNameStr;
begin
for t:=8 downto 1 do begin
if ObjName[t] = ' ' then
ObjName[t]:= #0;
ObjName[t]:=Upcase(ObjName[t]);
end;
for t:=1 to DirEntries do begin
for x:=1 to 8 do
if ObjName[x]='?' then
TempName[x]:=DirEntry^[t].ObjName[x]
else
TempName[x]:=ObjName[x];
if DirEntry^[t].ObjName = TempName then begin
FindObject:=t;
exit;
end;
end;
FindObject:=0;
end;
{Procedure ReadSound(Dir:PWadDir;SoundName:ObjNameStr;var SBuff:PSoundBuff);
var l:word;
TempPtr:PSoundBuff;
begin
l:=FindObject(Dir,SoundName);
if l=0 then begin
if TerminateOnWadError then begin
TextMode(co80);
writeln('ReadSound: Could not locate sound ID: ',SoundName);
halt(1);
end
else begin
WadResult:=wrNoSound;
exit;
end;
end;
seek(Dir^.WadFile,Dir^.DirEntry^[l].ObjStart);
New(TempPtr);} {Allocate New Sound Descriptor}
{ BlockRead(Dir^.WadFile,Dir^.ObjBuffer^[0],Dir^.DirEntry^[l].ObjLength);
Move(Dir^.ObjBuffer^[2],TempPtr^.SampleRate,4);
GetMem(TempPtr^.Sound,TempPtr^.Samples);
Move(Dir^.ObjBuffer^[6],TempPtr^.Sound^,TempPtr^.Samples);
writeln('Sound Size: ',TempPtr^.Samples);
SBuff:=TempPtr;
WadResult:=wrOk;
end;}
Procedure TWadDirectory.SetWadPalette(PlayPalNum:integer);
var Regs:Registers;
PalEnt:word;
PBuff:array[1..768] of byte;
Procedure SaveColor(ColorNum:word);
begin
move(OldPalette[ColorNum * 3],PBuff[ColorNum * 3],3);
end;
begin
if Not WadPaletteIsSet then begin
with regs do begin
Regs.ax:=$1017;
Regs.es:=Seg(OldPalette);
Regs.dx:=ofs(OldPalette);
Regs.bx:=0;
Regs.cx:=256;
Intr($10,Regs);
end;
end;
PalEnt:=FindObject('PLAYPAL ');
if PalEnt=0 then begin
if TerminateOnWadError then begin
TextMode(CO80);
writeln('SetWadPalette: Could not locate PLAYPAL');
halt(1);
end
else begin
WadResult:=wrNoPalette;
exit;
end;
end;
Seek(WadFile,DirEntry^[PalEnt].ObjStart + (768 * PlayPalNum));
Blockread(WadFile,Pbuff,768);
for PalEnt:=1 to 768 do
Pbuff[PalEnt]:=Pbuff[PalEnt] div 4;
{ SaveColor(7);
SaveColor(1);
SaveColor(2);
SaveColor(3);
SaveColor(15);
SaveColor(8);}
with regs do begin
ax:=$1012;
bx:=0;
cx:=256;
es:=seg(PBuff);
dx:=ofs(PBuff);
Intr($10,Regs);
end;
WadResult:=wrOk;
WadPaletteIsSet:=True;
end;
Procedure TWadDirectory.RestorePalette;
var Regs:Registers;
begin
if WadPaletteIsSet then begin
with regs do begin
ax:=$1012;
bx:=0;
cx:=256;
es:=seg(OldPalette);
dx:=ofs(OldPalette);
Intr($10,Regs);
end;
end;
WadPaletteIsSet:=False;
end;
{$I-}
Constructor TWadDirectory.Init(WadFileName:String);
var DirSize:longint;
begin
if ShowInit then
writeln('W_Init: Initializing WAD file');
assign(WadFile,WadFileName);
reset(WadFile,1);
if IOResult<>0 then begin
if TerminateOnWadError then begin
TextMode(CO80);
writeln('WadDirectory_Init: Error Reading WAD FILE: ',WadFileName);
halt(1);
end
else begin
WadResult:=wrNoFile;
exit;
end;
end;
WadFileName:=WadFileName+#0;
FillChar(WadName,8,#0);
filesplit(@WadFileName,NIL,@WadName,NIL);
blockread(WadFile,WadID,12);
if (WadID<>'IWAD') and (WadID<>'PWAD') then begin
if TerminateOnWadError then begin
TextMode(CO80);
Close(WadFile);
writeln('W_Init: ',WadFileName,' is not a valid WAD file');
halt(1);
end
else begin
WadResult:=wrInvalidFile;
exit;
end;
end;
if DirEntries > MaxEntries then begin
if TerminateOnWadError then begin
TextMode(CO80);
Close(WadFile);
write(' W_Init_Alloc: Can not allocate for more than ',MaxEntries);
writeln(' Directory Entries');
halt(1);
end
else begin
WadResult:=wrMaxEntries;
exit;
end;
end;
DirSize:=DirEntries * 16;
GetMem(DirEntry, DirSize);
FillChar(DirEntry^,DirSize,#00);
if ShowInit then
writeln(' W_Init_Alloc: ',DirSize,' Allocated for directory');
seek(WadFile, DirStart);
BlockRead(WadFile, DirEntry^, DirSize);
WadResult:=wrOk;
end;
Procedure TWadDirectory.DisplayWadDir;
var x:word;
begin
writeln('Directory of WAD: ',WadName);
for x:=1 to DirEntries do begin
with DirEntry^[x] do begin
writeln(ObjName,' ',ObjStart,' ',ObjLength);
end;
end;
end;
Destructor TWadDirectory.Done;
var DirSize:word;
begin
close(WadFile);
DirSize:=DirEntries * 16;
FreeMem(DirEntry, DirSize);
end;
Function WadResultMsg(ErrNum:byte):string;
begin
case ErrNum of
wrOk:WadResultMsg:='';
wrInvalidFile:WadResultMsg:='Invalid WAD file Format';
wrMaxEntries:WadResultMsg:='Too many WAD directory Entries';
wrNoObject:WadResultMsg:='Specified WAD Object Not Found';
wrNoSound:WadResultMsg:='Specified WAD Sound Not Found';
wrBadImageSize:WadResultMsg:='Invalid WAD Image Size';
wrNoPicture:WadResultMsg:='Specified Picture ID Not Found';
wrNoPalette:WadResultMsg:='PLAYPAL Entry Not Found';
wrNoFile:WadResultMsg:='Error Accessing WAD File';
else
WadResultMsg:='Unknown WAD file Error'
end;
end;
begin
{$IFDEF DFE}
TextAttr:=7;
ClrScr;
TextAttr:=31;
write(' The DOOM Hacker''s Tool Kit ');
TextAttr:=7;
writeln('Sys_Init: Examining System');
case Test8086 of
00:begin
writeln(' CPU_Check: 8088 or 8086');
writeln(' This Program requires at least an 80386.');
halt(1);
end;
01:begin
writeln(' CPU_Check: 80286');
writeln(' This Program requires at least an 80386.');
halt(1);
end;
02:begin
writeln(' CPU_Check: 80386 or better');
end;
end;
delay(450);
writeln('SysMem_Init: Initializing Memory Allocation Deamon...');
writeln(' SysMem_Init: ',Hex_String(MaxAvail),' ');
if MaxAvail < 300000 then begin
writeln(' SysMem_Init: Insufficient System Memory!');
halt(1);
end;
delay(500);
{$ELSE}
writeln;
writeln('The DOOM Hacker''s Tool Kit v1.00');
writeln;
writeln('by: Jackson Software');
writeln('author: Joshua Jackson internet: joshjackson@delphi.com');
delay(1000);
{$ENDIF}
end.