{$A+,B-,D+,E+,F-,G+,I-,L+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
{$M 8192,0,0}
{ GFXMAKER v3.1 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.1 by Vincenzo Alcamo (alcamo@arci01.bo.cnr.it) VERSION 950722':76);
    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;
  procedure writeline(i:integer);
    begin
      if Op_Mode=i then TextBackground(CYAN)
      else TextBackground(BLACK);
      gotoxy(3,wherey+i-1);
      TextColor(WHITE);
      case i of
        HERETIC:
          begin
            write(' HERETIC');
            TextColor(BLUE);
            write(' - include graphics from [ULTIMATE] DOOM');
          end;
        DOOM2:
          begin
            write(' DOOM II');
            TextColor(BLUE);
            write(' - include graphics from [ULTIMATE] DOOM and/or HERETIC');
          end;
        DOOM:
          begin
            write(' DOOM/ULTIMATE DOOM');
            TextColor(BLUE);
            write(' - include graphics from DOOM II and/or HERETIC');
          end;
      end;
      while wherex<>78 do write(#32);
      gotoxy(1,wherey-i+1);
    end;
  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: [ULTIMATE] 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 target game:');
    textattr:=green;
    writeln(' (ESC quits, ENTER choose, ARROWS change selection)');
    textattr:=0;
    write('  ');
    for i:=DOOM to HERETIC do writeline(i);
    repeat
      case ReadKey of
        #27: begin
               gotoxy(1,wherey+3);
               MyHalt(ERR_USER_ESCAPE);
             end;
        #13: break;
        #0: begin
              i:=ord(ReadKey);
              if (i=72) or (i=80) then begin
                y:=Op_Mode;
                if i=72 then
                  if Op_Mode>DOOM then dec(Op_Mode) else Op_Mode:=HERETIC
                else if Op_Mode<HERETIC then inc(Op_Mode) else Op_Mode:=DOOM;
                writeline(y);
                writeline(Op_Mode);
              end;
            end
      end;
    until false;
    y:=wherey+1;
    gotoxy(1,wherey-Op_Mode+1);
    writeline(Op_Mode);
    gotoxy(1,y);
    textattr:=LightGreen;
    clreol;
    writeln;
    clreol;
    writeln('  Please insert the full path for the following sources:');
    y:=wherey;
    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.