home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Home Edutainment Collection 4: Games & Extensions
/
Aztech-HomeEdutainmentCollection-Vol4-3DGamesExtensions.iso
/
wc
/
gfxmaker.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-05-24
|
26KB
|
944 lines
{$A+,B-,D+,E+,F-,G+,I-,L+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
{$M 8192,0,0}
{ GFXMAKER v3.0 by Vincenzo Alcamo }
{ This program is Public Domain }
Uses Crt;
const
IWAD_SIG = Ord('I')+(Ord('W')+(Ord('A')+Ord('D') shl 8) shl 8) shl 8;
PWAD_SIG = Ord('P')+(Ord('W')+(Ord('A')+Ord('D') shl 8) shl 8) shl 8;
DOOM = 1;
DOOM2 = 2;
HERETIC = 3;
DEST = 4;
GNAMES : array[DOOM..HERETIC] of string[8]=('DOOM','DOOM2','HERETIC');
GID : array[DOOM..HERETIC] of string[2]=('D','D2','H');
PNAMES = 'PNAMES'#0#0;
TEXTURE1 = 'TEXTURE1';
TEXTURE2 = 'TEXTURE2';
PLAYPAL = 'PLAYPAL'#0;
P_START = 'P_START'#0;
P_END = 'P_END'#0#0#0;
P1_START= 'P1_START';
P1_END = 'P1_END'#0#0;
F_START = 'F_START'#0;
F_END = 'F_END'#0#0#0;
F1_START= 'F1_START';
F1_END = 'F1_END'#0#0;
DUMMY_TEXTURE : array[1..20] of word = (1,0,12,0,95,0,0,0,0,0,64,64,0,0,1,0,0,0,0,0);
MAXMEMBLOCK = 65535;
type
WAD_HEADER = record {header of a wadfile}
Sig : longint; {signature}
Num : longint; {numbers of resources}
Start : longint; {offset of dirlist}
end;
CHAR8 = array[1..8] of Char;
WAD_ENTRY = record {each single entry in the dirlist}
Start : Longint; {offset of resource}
case integer of
1: (Size : longint; {length in bytes}
Name : CHAR8; {resource's name});
2: (dummy : array[1..3] of byte;
fnum : byte; {file number});
end;
A_WADENTRY = array[1..MAXMEMBLOCK div sizeof(WAD_ENTRY)] of WAD_ENTRY;
P_A_WADENTRY = ^A_WADENTRY;
P_TXINFO = ^TXINFO;
TXINFO = record {texture info}
Name : CHAR8; {name of the texture}
dummy: array[1..6] of word;
Num : integer; {number of patches}
end;
P_PTINFO = ^PTINFO;
PTINFO = record {patch info}
dummy: longint;
Index: word; {index of patch name inside PNAMES}
dumm2: longint;
end;
COLOR_REMAP = array[0..255] of byte;
RGB_TRIPLET = record
Red : byte;
Green : byte;
Blue : byte;
end;
COLOR_MAP = array[0..255] of RGB_TRIPLET;
LARGEBUFF = array[0..MAXMEMBLOCK-1] of byte;
P_LARGEBUFF = ^LARGEBUFF;
P_WORD = ^integer;
P_LONG = ^longint;
ERRORS = (ERR_NONE,ERR_USER_ESCAPE,ERR_NOMEM,ERR_OPEN,ERR_READ,ERR_WRITE,
ERR_NOWAD,ERR_NOPALETTE,ERR_NOTEX);
const
Op_Mode : integer = DOOM2; {operation mode: specify dest game}
InCheck : integer = 0; {row where a checkmark is located, or 0}
NumPt : integer = 0; {number of patches in PtArray}
NumTx : integer = 0; {number of textures}
TxSize : word = 0; {size of texture}
RemapPt : boolean = True; {remap Patch or Floor}
var
Path : array[DOOM..DEST] of string; {wad paths}
Number : array[DOOM..DEST] of integer; {number of resources}
Dirlist: array[DOOM..DEST] of P_A_WADENTRY; {pointers to dirlist}
Wadfile: array[DOOM..DEST] of file; {file handle}
EndSize: longint; {size of dest file}
Why : string; {general description string}
DName : string[12]; {name of destination wad}
CRemap : COLOR_REMAP;
PtArray: array[1..1024] of CHAR8; {array of patch names}
PConv : array[0..512] of integer;
TextPtr: array[1..1024] of longint; {texture pointer inside texture}
Texture: P_LARGEBUFF; {texture data}
Buffer : P_LARGEBUFF; {data buffer: collides with Texture}
procedure MyHalt(err:ERRORS);
var i,j:integer;
begin
if InCheck>0 then begin
textattr:=LightRed;
gotoxy(2,InCheck);
writeln('x');
end;
textattr:=white;
clreol;
writeln;
if err=ERR_NONE then begin
writeln(DName,' succesfully created (',EndSize,' bytes).');
textattr:=lightgray;
writeln;
write('Now, to play any ');
j:=0;
for i:=DOOM to HERETIC do if (i<>Op_Mode) and (Path[i]<>'') then begin
if j=0 then j:=i
else write('/');
write(GNAMES[i]);
end;
writeln(' level simply include ',dname,' after -FILE.');
writeln('example: ',GNAMES[Op_Mode],' -FILE ',dname,' anywad.WAD');
writeln;
textattr:=yellow;
writeln('Remember to convert the wads with DM2CONV using the /GFX parameter');
textattr:=lightgray;
write('example: DM2CONV anywad /GFX @:');
writeln(GID[j],'TO',GID[Op_Mode]);
textattr:=lightgray;
end
else begin
write('Operation aborted');
case err of
ERR_USER_ESCAPE: writeln(' by user request!');
ERR_NOMEM : writeln(': not enough memory!');
ERR_OPEN : writeln(':'#13#10'Cannot open ',Why);
ERR_READ : writeln(':'#13#10'Cannot read ',Why);
ERR_WRITE : writeln(':'#13#10'Cannot write ',Why);
ERR_NOWAD : writeln(':'#13#10'Not a valid wad ',Why);
ERR_NOPALETTE : writeln(':'#13#10'Missing palette in ',Why);
ERR_NOTEX : writeln(':'#13#10'Missing texture info in ',Why);
end;
end;
i:=wherey;
window(1,1,80,25);
textattr:=lightgray;
gotoxy(1,25);
clreol;
gotoxy(1,i+2);
Halt;
end;
var DOSAlloc_Size:longint;
{Allocate a DOS memory block, return nil if not enough memory}
{If size is 0, DOSAlloc_Size contains the largest block free }
function DOSAlloc(size:longint):pointer; assembler;
asm
les bx, size
mov ax, es
mov word ptr DOSAlloc_Size, bx
mov word ptr DOSAlloc_Size+2, ax
add bx, 15
adc ax, 0
mov cx, 4
@@LOOP1:
shr ax, 1
rcr bx, 1
loop @@LOOP1
cmp bx, 0
jne @@NOZERO
dec bx
@@NOZERO:
mov ah, 48h
int 21h
jnc @@OK
xor ax, ax
mov cx, 4
@@LOOP2:
shl bx, 1
rcl ax, 1
loop @@LOOP2
mov word ptr DOSAlloc_Size, bx
mov word ptr DOSAlloc_Size+2, ax
xor ax, ax
@@OK:
xor dx, dx
xchg ax, dx
end;
procedure DOSFree(p:pointer); assembler;
asm
les bx, p
mov ah, 49h
int 21h
end;
function AddPointer(p:pointer;l:longint):pointer; assembler;
asm
les dx, l
mov ax, es
les bx, p
add bx, dx
adc ax, 0
mov cx, 4
@@LOOP:
shr ax, 1
rcr bx, 1
rcr dx, 1
loop @@LOOP
shr dx, 12
mov ax, es
add ax, bx
xchg ax, dx
end;
procedure CheckAbort;
begin
if KeyPressed then case ReadKey of
#0: Readkey;
#27: MyHalt(ERR_USER_ESCAPE);
end;
end;
function IsDir(s:string):boolean;
var curdir:string;
begin
GetDir(0,curdir);
ChDir(s);
IsDir:=ioresult=0;
ChDir(curdir);
if ioresult<>0 then ;
end;
procedure Initialize;
var i:integer;
begin
textmode(CO80);
textattr:=blue*16+white;
gotoxy(1,1);
clreol;
write('GFXMAKER v3.0 - Written by Vincenzo Alcamo':60);
gotoxy(1,25);
textattr:=lightgray*16+black;
clreol;
textattr:=lightgray*16+black;
write(' Press ');
textattr:=lightgray*16+red;
write('ESC');
textattr:=lightgray*16+black;
write(' at any time to abort program and return to DOS.');
window(1,3,80,24);
for i:=DOOM to DEST do Path[i]:='';
Dirlist[DEST]:=DOSAlloc(2000*sizeof(WAD_ENTRY));
if Dirlist[DEST]=nil then MyHalt(ERR_NOMEM);
end;
procedure Input(x,y:integer;var a:string;n:integer);
var
i,p : integer;
c : char;
done : boolean;
procedure del;
begin
dec(p);
delete(a,p,1);
gotoxy(x+p,y);
write(copy(a,p,n),#32);
gotoxy(x+p,y)
end;
begin
textattr:=red*16+yellow;
gotoxy(x,y);
write(#32:n+2);
gotoxy(x+1,y);
write(a);
p:=length(a)+1;
gotoxy(x+p,y);
done:=FALSE;
repeat
c:=UpCase(ReadKey);
case c of
#0 :
begin
c:=ReadKey;
case c of
#75 : if p>1 then dec(p);
#77 : if p<=length(a) then inc(p);
#71 : p:=1;
#79 : p:=length(a)+1;
#83 :
if p<=length(a) then
begin
inc(p);
del
end
end;
gotoxy(x+p,y)
end;
#33..#96 :
if length(a)<n then
begin
if c='/' then c:='\';
insert(c,a,p);
gotoxy(x+p,y);
write(copy(a,p,n));
inc(p);
gotoxy(x+p,y)
end;
#8 : if p>1 then del;
#27 :
begin
p:=1;
gotoxy(x+p,y);
write(#32:length(a));
a:='';
gotoxy(x+p,y);
done:=true;
end;
#13 : done:=true
end
until done;
gotoxy(x,y);
writeln(#32,a,#32:n-length(a)+1)
end;
procedure AskDir(y:integer;a:string;var s:String;blank:boolean);
var flag : boolean;
begin
gotoxy(1,y);
textattr:=lightcyan;
write(' ',a,'.WAD');
flag:=False;
repeat
gotoxy(17,y+1);
textattr:=White;
if flag then begin
write('The path specified does not exist!');
clreol;
while not KeyPressed do ;
gotoxy(17,y+1);
end;
write(Why);
clreol;
input(16,y,s,60);
flag:=True;
if (s='') and not blank then MyHalt(ERR_USER_ESCAPE);
until (s='') or isdir(s);
if s='' then begin
gotoxy(16,y);
textattr:=white;
write(' *** NOT INCLUDED ***');
clreol;
end;
gotoxy(17,y+1);
textattr:=White;
clreol;
end;
function GameDir(prev:string):string;
var i:integer;
begin
if prev='' then prev:='C:\GAMES\';
i:=length(prev);
while (i>0) and (prev[i]<>':') and (prev[i]<>'\') do dec(i);
prev[0]:=chr(i);
GameDir:=prev;
end;
procedure AskParam;
const REQUIRED = 'This parameter is required!';
LEAVE = 'Leave this field blank if you convert only ';
var i,y:integer;
blank:boolean;
begin
gotoxy(1,1);
textattr:=lightred;
writeln(' This program creates a patch wad file containing all the graphic resources');
writeln(' (textures/floors) of a set of games: DOOM, DOOM II, HERETIC.');
writeln;
writeln(' You can choose to merge graphics from DOOM, DOOM II or HERETIC: registered');
writeln(' version of the selected games are required, original files are not changed.');
writeln;
writeln(' This wad will enable a game (DOOM/DOOM II/HERETIC) to use levels designed');
writeln(' for another game and converted by DM2CONV with the /GFX symbol.');
writeln(' Each game must have its own wad. ');
writeln;
textattr:=lightgreen;
write(' Choose the target game:');
textattr:=green;
writeln(' (ESC quits, ENTER choose, any other key to toggle)');
repeat
textattr:=white;
case Op_Mode of
HERETIC:
begin
write(' HERETIC');
textattr:=lightgray;
write(' - include graphics from DOOM');
end;
DOOM2:
begin
write(' DOOM II');
textattr:=lightgray;
write(' - include graphics from DOOM and/or HERETIC');
end;
DOOM:
begin
write(' DOOM');
textattr:=lightgray;
write(' - include graphics from DOOM II and/or HERETIC');
end;
end;
clreol;
gotoxy(1,wherey);
case ReadKey of
#27: MyHalt(ERR_USER_ESCAPE);
#13: break;
#0: ReadKey;
end;
inc(Op_Mode);
if Op_Mode=DEST then Op_Mode:=DOOM;
until false;
writeln;
writeln;
y:=wherey;
gotoxy(1,y);
textattr:=LightGreen;
writeln(' Please insert the full path for the following sources:');
inc(y);
blank:=Op_Mode=DOOM2;
if blank then Why:=LEAVE+'HERETIC''s wads'
else Why:=REQUIRED;
Path[DOOM]:=GameDir('')+GNAMES[DOOM];
AskDir(y,GNAMES[DOOM],Path[DOOM],blank);
inc(y);
if Op_Mode<>HERETIC then begin
blank:=Op_Mode=DOOM;
if blank then Why:=LEAVE+'HERETIC''s wads'
else Why:=REQUIRED;
Path[DOOM2]:=GameDir(Path[1])+GNAMES[DOOM2];
AskDir(y,GNAMES[DOOM2],Path[DOOM2],blank);
inc(y);
Path[HERETIC]:=GameDir(Path[DOOM2])+GNAMES[HERETIC];
end
else Path[HERETIC]:=GameDir(Path[DOOM])+GNAMES[HERETIC];
blank:=(Op_Mode<>HERETIC) and (Path[DOOM]<>'') and (Path[DOOM2]<>'');
if not blank then Why:=REQUIRED
else if Op_Mode=DOOM then Why:=LEAVE+'DOOM II''s wads'
else Why:=LEAVE+'DOOM''s wads';
AskDir(y,GNAMES[HERETIC],Path[HERETIC],blank);
inc(y);
gotoxy(1,y);
textattr:=LightGreen;
clreol;
inc(y);
gotoxy(3,y);
writeln('Please insert the full path for the destination:');
inc(y);
DName:='GFX'+GID[Op_Mode]+'_';
for i:=DOOM to HERETIC do if (i<>Op_Mode) and (Path[i]<>'') then
DName:=DName+GID[i];
Path[DEST]:=Path[Op_Mode];
case Op_Mode of
DOOM:
if path[DOOM2]='' then Why:='1,414'
else if path[HERETIC]='' then Why:='2,676'
else Why:='3,630';
DOOM2:
if path[DOOM]='' then Why:='1,744'
else if path[HERETIC]='' then Why:='545'
else Why:='2,103';
HERETIC:
Why:='3,304';
end;
Why:='You will need about '+Why+' Kbytes free in this directory.';
AskDir(y,DName,Path[DEST],False);
end;
procedure StartCheckmark;
begin
textattr:=lightgray;
write('[ ] ');
InCheck:=wherey;
end;
procedure EndCheckmark;
begin
CheckAbort;
gotoxy(2,incheck);
InCheck:=textattr;
textattr:=white;
writeln('√');
textattr:=InCheck;
InCheck:=0;
end;
procedure FSeek(start:longint;index:integer);
begin
Why:=Path[index];
if start>0 then begin
seek(Wadfile[index],start);
if ioresult<>0 then MyHalt(ERR_READ);
CheckAbort;
end;
end;
procedure BlockW(var p;size:longint);
var i,s:word;
t:pointer;
begin
Why:=Path[DEST];
t:=Addr(p);
while size>0 do begin
s:=65535-Ofs(t^);
if s>size then s:=size;
BlockWrite(Wadfile[DEST],t^,s,i);
if (ioresult<>0) or (s<>i) then MyHalt(ERR_WRITE);
dec(size,s);
t:=AddPointer(t,s);
CheckAbort;
end;
end;
procedure BlockR(start:longint;index:integer;var p;size:longint);
var i,s:word;
t:pointer;
begin
FSeek(start,index);
t:=Addr(p);
while size>0 do begin
s:=65535-Ofs(t^);
if s>size then s:=size;
BlockRead(Wadfile[index],t^,s,i);
if (ioresult<>0) or (s<>i) then MyHalt(ERR_READ);
dec(size,s);
t:=AddPointer(t,s);
CheckAbort;
end;
end;
function FPos:longint;
begin
Why:=Path[DEST];
FPos:=FilePos(Wadfile[DEST]);
if ioresult<>0 then MyHalt(ERR_WRITE);
end;
procedure OpenWAD(index:integer;name:string);
var h:WAD_HEADER;
i:word;
begin
Why:=Path[index]+'\'+name+'.WAD';
Path[index]:=Why;
StartCheckmark;
writeln('Opening ',Why);
assign(Wadfile[index],Why);
FileMode:=0;
reset(Wadfile[index],1);
if ioresult<>0 then MyHalt(ERR_OPEN);
BlockR(0,index,h,sizeof(WAD_HEADER));
if h.Sig<>IWAD_SIG then MyHalt(ERR_NOWAD);
Number[index]:=h.Num;
Dirlist[index]:=DOSAlloc(h.Num*sizeof(WAD_ENTRY));
if Dirlist[index]=nil then MyHalt(ERR_NOMEM);
BlockR(h.start,index,Dirlist[index]^,h.Num*sizeof(WAD_ENTRY));
EndCheckmark;
end;
function SearchEntry(index:integer;name:CHAR8):integer;
var i:integer;
begin
i:=Number[index];
while (i>0) and (Dirlist[index]^[i].Name<>name) do dec(i);
SearchEntry:=i;
end;
procedure ReadPalette(index:integer;var cmap:COLOR_MAP);
var i:integer;
l:longint;
begin
Why:=Path[index];
i:=SearchEntry(index,PLAYPAL);
if i=0 then MyHalt(ERR_NOPALETTE);
BlockR(Dirlist[index]^[i].Start,index,cmap,sizeof(COLOR_MAP));
end;
function LSqr(x:word):longint; assembler;
asm
mov ax, x
test ah, 80h
jz @@POSITIVE
neg ax
@@POSITIVE:
mul al
xor dx, dx
end;
procedure MakeRemapTable;
var c1,c2:COLOR_MAP;
i,j,k:integer;
r,g,b:word;
l,min:longint;
begin
StartCheckmark;
writeln('Reading palette information for colour remapping');
if Op_Mode=HERETIC then ReadPalette(DOOM,c1)
else ReadPalette(HERETIC,c1);
ReadPalette(Op_Mode,c2);
for i:=0 to 255 do begin
min:=MAXLONGINT;
r:=c1[i].Red;
g:=c1[i].Green;
b:=c1[i].Blue;
for j:=0 to 255 do begin
l:=LSqr(r-c2[j].Red)+LSqr(g-c2[j].Green)+LSqr(b-c2[j].Blue);
if l<min then begin
min:=l;
k:=j;
if min=0 then break;
end;
end;
CRemap[i]:=k;
CheckAbort;
end;
EndCheckmark;
end;
procedure MergeTexture(optn,otxn,otxs:integer);
{optn=old patch number,otxn=old texture number,otxs=old texture size}
var i,j,k: integer;
offs : longint;
t : P_TXINFO;
q : pointer;
p : P_PTINFO;
begin
{PATCH NAMES MERGING}
k:=optn;
for i:=optn+1 to NumPt do begin
j:=optn;
while (j>0) and (PtArray[j]<>PtArray[i]) do dec(j);
if j=0 then begin
inc(k);
PtArray[k]:=PtArray[i];
j:=k;
end;
PConv[i-optn-1]:=j-1;
end;
NumPt:=k;
{TEXTURE POINTER SORT}
j:=NumTx;
while j>1 do begin
k:=0;
for i:=1 to j-1 do if TextPtr[i]>TextPtr[i+1] then begin
k:=i;
offs:=TextPtr[i];
TextPtr[i]:=TextPtr[i+1];
TextPtr[i+1]:=offs;
end;
j:=k;
end;
{TEXTURE INFO MERGING}
TxSize:=otxs;
k:=otxn;
for i:=otxn+1 to NumTx do begin
t:=addr(Texture^[TextPtr[i]]);
j:=otxn;
while (j>0) and (P_TXINFO(addr(Texture^[TextPtr[j]]))^.Name<>t^.Name) do dec(j);
if j=0 then begin
inc(k);
TextPtr[k]:=TxSize;
q:=addr(Texture^[TxSize]);
Move(t^,q^,sizeof(TXINFO));
inc(TxSize,sizeof(TXINFO));
p:=AddPointer(t,sizeof(TXINFO));
for j:=1 to t^.num do begin
q:=addr(Texture^[TxSize]);
p^.Index:=PConv[p^.Index]; {convert PNAMES entries}
Move(p^,q^,sizeof(PTINFO));
p:=AddPointer(p,sizeof(PTINFO));
inc(TxSize,sizeof(PTINFO));
end;
end;
end;
NumTx:=k;
end;
procedure ReadTx(index:integer;txname:CHAR8);
var i,j:integer;
l,m:longint;
begin
i:=SearchEntry(index,txname);
if i=0 then MyHalt(ERR_NOTEX);
BlockR(Dirlist[index]^[i].Start,index,l,4);
BlockR(0,index,TextPtr[NumTx+1],l*4);
m:=TxSize-(l+1)*4;
for j:=NumTx+1 to NumTx+l do inc(TextPtr[j],m);
m:=Dirlist[index]^[i].Size-(l+1)*4;
BlockR(0,index,Texture^[TxSize],m);
inc(TxSize,m);
inc(NumTx,l);
end;
procedure ReadPNames(index:integer);
var i:integer;
l:longint;
optn,otxn,otxs:integer;
begin
otxs:=TxSize;
otxn:=NumTx;
optn:=NumPt;
StartCheckmark;
Why:=Path[index];
write('Reading ');
if index<>Op_Mode then write('and merging ');
writeln('textures from ',Path[index]);
i:=SearchEntry(index,PNAMES);
if i=0 then myhalt(ERR_NOTEX);
BlockR(Dirlist[index]^[i].Start,index,l,4);
BlockR(0,index,PtArray[NumPt+1],l*8);
inc(NumPt,l);
ReadTx(index,TEXTURE1);
if index<>DOOM2 then ReadTx(index,TEXTURE2);
if i<>Op_Mode then MergeTexture(optn,otxn,otxs);
EndCheckmark;
end;
procedure Remap(p:P_LARGEBUFF);
var cols:integer;
i,j :integer;
offs:longint;
t :P_LARGEBUFF;
begin
if RemapPt then begin
cols:=P_WORD(p)^;
while cols>0 do begin
dec(cols);
offs:=P_LONG(AddPointer(p,cols*4+8))^;
t:=AddPointer(p,offs);
i:=0;
while t^[i]<255 do begin
j:=t^[i+1]+2;
inc(i,2);
while j>0 do begin
t^[i]:=CRemap[t^[i]];
inc(i);
dec(j);
end;
end;
end;
end
else for i:=0 to 4095 do p^[i]:=CRemap[p^[i]];
end;
const
BufferSize : longint = 0;
BufferPos : longint = 0;
procedure FlushBuffer;
begin
if BufferPos>0 then BlockW(Buffer^,BufferPos);
BufferPos:=0;
end;
procedure ReadResource(var d:WAD_ENTRY);
var offs,len:Longint;
filenum:integer;
begin
filenum:=d.FNum;
d.FNum:=0;
offs:=d.Start;
len:=d.Size;
d.Start:=FPos+BufferPos;
if len>0 then begin
if BufferSize-BufferPos<len then FlushBuffer;
BlockR(offs,filenum,AddPointer(Buffer,BufferPos)^,len);
if ((Op_Mode=HERETIC) and (filenum<>HERETIC)) or
((Op_Mode<>HERETIC) and (filenum=HERETIC)) then
Remap(AddPointer(Buffer,BufferPos));
inc(BufferPos,len);
end;
end;
procedure WriteWad;
var h : WAD_HEADER;
i,j : integer;
l : longint;
a,b : integer;
num : integer;
onum: integer;
procedure AddEntry(na:CHAR8;st,si:longint);
begin
inc(num);
with Dirlist[DEST]^[num] do begin
Name:=na;
Size:=si;
Start:=st;
end;
end;
procedure CopyResources(index,initial,final:integer);
var i,j:integer;
d:CHAR8;
begin
for i:=initial to final do with Dirlist[index]^[i] do begin
d:=Name;
if Size>0 then begin
j:=a;
while (j<=b) and (Dirlist[Op_Mode]^[j].Name<>d) do inc(j);
if j>b then begin
j:=onum;
while (j<=num) and (Dirlist[4]^[j].Name<>d) do inc(j);
if j>num then begin
inc(num);
Dirlist[DEST]^[num]:=Dirlist[index]^[i];
Dirlist[DEST]^[num].FNum:=index;
end;
end;
end;
end;
end;
procedure SaveResources;
var m : longint;
i : integer;
mx: longint;
begin
l:=0;
mx:=0;
for i:=onum to num do begin
m:=Dirlist[DEST]^[i].Size and $FFFFFF;
if m>mx then mx:=m;
inc(l,m+1);
end;
if mx>DOSAlloc_Size then MyHalt(ERR_NOMEM);
m:=0;
for i:=onum to num do begin
with Dirlist[DEST]^[i] do begin
inc(m,(Size and $FFFFFF)+1);
gotoxy(5,wherey);
write(Name,m*100 div l:6,'%');
end;
ReadResource(Dirlist[DEST]^[i]);
end;
gotoxy(1,wherey);
clreol;
EndCheckmark;
end;
begin
Why:=Path[4]+'\'+DName+'.WAD';
Path[DEST]:=Why;
StartCheckmark;
writeln('Creating ',Why);
assign(Wadfile[DEST],Why);
FileMode:=2;
rewrite(Wadfile[DEST],1);
if ioresult<>0 then MyHalt(ERR_WRITE);
h.Sig:=PWAD_SIG;
BlockW(h,sizeof(h));
num:=0;
AddEntry(PNAMES,FPos,4+NumPt*8);
l:=NumPt;
BlockW(l,4);
BlockW(PtArray,NumPt*8);
j:=NumTx*4+4;
for i:=1 to NumTx do inc(TextPtr[i],j);
AddEntry(TEXTURE1,FPos,4+NumTx*4+TxSize);
l:=NumTx;
BlockW(l,4);
BlockW(TextPtr,NumTx*4);
BlockW(Texture^,TxSize);
if Op_Mode<>DOOM2 then begin {DUMMY TEXTURE2}
AddEntry(TEXTURE2,FPos,sizeof(DUMMY_TEXTURE));
BlockW(DUMMY_TEXTURE,sizeof(DUMMY_TEXTURE));
end;
EndCheckmark;
onum:=num+1;
StartCheckmark;
if path[HERETIC]<>'' then writeln('Converting and adding patches')
else writeln('Adding patches');
a:=SearchEntry(Op_Mode,P_START)+1;
b:=SearchEntry(Op_Mode,P_END)-1;
AddEntry(P_START,0,0);
AddEntry(P1_START,0,0);
for i:=DOOM to HERETIC do if (i<>Op_Mode) and (path[i]<>'') then
CopyResources(i,SearchEntry(i,P_START),SearchEntry(i,P_END));
AddEntry(P1_END,0,0);
AddEntry(P_END,0,0);
SaveResources;
if (Op_Mode<>DOOM2) or (Path[HERETIC]<>'') then begin
onum:=num+1;
RemapPt:=False;
StartCheckmark;
writeln('Converting and adding floors');
a:=1;
b:=0;
AddEntry(F_START,0,0);
AddEntry(F1_START,0,0);
CopyResources(Op_Mode,SearchEntry(Op_Mode,F_START),SearchEntry(Op_Mode,F_END));
for i:=DOOM to HERETIC do if (i<>Op_Mode) and (Path[i]<>'') then
CopyResources(i,SearchEntry(i,F_START),SearchEntry(i,F_END));
AddEntry(F1_END,0,0);
AddEntry(F_END,0,0);
SaveResources;
end;
FlushBuffer;
StartCheckmark;
writeln('Writing directory structure');
h.Start:=FPos;
h.Num:=num;
BlockW(Dirlist[DEST]^,num*sizeof(WAD_ENTRY));
EndSize:=FPos;
seek(Wadfile[DEST],0);
if ioresult<>0 then MyHalt(ERR_WRITE);
BlockW(h,sizeof(h));
EndCheckmark;
end;
procedure Process;
var i:integer;
begin
textattr:=lightgray;
clrscr;
for i:=DOOM to HERETIC do
if Path[i]<>'' then OpenWAD(i,GNAMES[i]);
if Path[HERETIC]<>'' then MakeRemapTable;
Texture:=DOSAlloc(0);
if DOSAlloc_Size<MAXMEMBLOCK then MyHalt(ERR_NOMEM);
Texture:=DOSAlloc(DOSAlloc_Size);
if Texture=nil then MyHalt(ERR_NOMEM);
Buffer:=Texture;
BufferSize:=DOSAlloc_size;
ReadPNames(Op_Mode);
for i:=DOOM to HERETIC do if (i<>Op_Mode) and (Path[i]<>'') then ReadPNames(i);
WriteWad;
end;
begin
Initialize;
AskParam;
Process;
MyHalt(ERR_NONE);
end.