{$A+,B-,D+,E+,F-,G+,I-,L+,N-,O-,P-,Q-,R+,S+,T-,V-,X+}
{$M 16384,0,655360}
Uses Crt,Dos;

const
  USER_ESC = 1;
  NO_MEM   = 2;
  ERR_OPEN = 3;
  ERR_READ = 4;
  ERR_WRITE= 5;
  ERR_NOWAD= 6;
  ERR_NOTEX= 7;
  ERR_USER = 99;

  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_WAD = 'DOOM.WAD';
  DOOM2_WAD = 'DOOM2.WAD';
  PNAME = 'PNAMES'#0#0;
  TEXTURE1 = 'TEXTURE1';
  TEXTURE2 = 'TEXTURE2';
  OK = '[Ok]';

type
  header= record
    Sig   : Longint;
    Num   : Longint;
    Start : Longint;
  end;
  p_entry=^entry;
  char8 = array[1..8] of Char;
  entry = record
    Start : Longint;
    Size  : Longint;
    Name  : char8;
  end;
  p_txinfo = ^txinfo;
  txinfo = record
    Name : char8;
    dummy: array[1..6] of word;
    Num  : integer;
  end;
  p_ptinfo = ^ptinfo;
  ptinfo = record
    dummy: longint;
    index: word;
    dumm2: longint;
  end;
  entry_array = array[1..4000] of entry;
  p_entry_array = ^entry_array;

  varray = array[0..65534] of byte;
  p_varray = ^varray;

const
  BUFFSIZE1 = sizeof(entry_array);
  BUFFSIZE = BUFFSIZE1*2;

var
  path   : array[1..3] of string;
  number : array[1..3] of integer;
  dirlist: array[1..3] of p_entry_array;
  wadfile: array[1..3] of file;
  pnames : array[1..1024] of char8;
  numpn  : integer;
  pconv  : array[0..512] of integer;
  textptr: array[1..1024] of longint;
  texture: array[0..49151] of byte;
  numtx  : integer;
  txsize : word;
  why    : string;
  incheck: boolean;

  BufferPos : longint;

function PtrAdd(p:pointer;n:word):pointer; assembler;
  asm
    les ax, p
    mov dx, es
    add ax, n
  end;

procedure checkabort;
  begin
    if keypressed then case readkey of
      #0: readkey;
      #27: halt(USER_ESC);
    end;
  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;
        #32..#96 :
          if length(a)<n then
            begin
              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;

function isdir(name:string):boolean;
  var trovato:boolean;
      s:searchrec;
  begin
    trovato:=false;
    findfirst(name,directory,s);
    if (doserror=0) and (ioresult=0) then
      if (s.attr and directory)=directory then trovato:=true;
    isdir:=trovato
  end;

procedure askpath;
  var
    y:integer;
    b:Boolean;
  procedure ask(a:string;var s:String);
    begin
      gotoxy(1,y);
      textattr:=lightcyan;
      write(a);
      b:=False;
      repeat
        if b then begin
          gotoxy(14,y+1);
          textattr:=White;
          write('The path specified does not exist!');
        end;
        input(13,y,s,60);
        b:=True;
        if s='' then halt(USER_ESC);
      until isdir(s);
    end;
  begin
    gotoxy(1,1);
    textattr:=lightmagenta;
    writeln('This program creates a patch wad file named DM2CONV.WAD  containing');
    writeln('all the textures present in DOOM, but missing from DOOM II.');
    writeln;
    writeln('Both registered versions of DOOM and DOOM II are required.');
    writeln;
    writeln('This wad will enable DOOM II to use any level designed for DOOM and');
    writeln('converted by DM2CONV with no /TEXTURE argument.');
    writeln;
    writeln;
    y:=wherey;
    path[1]:='C:\GAMES\DOOM';
    path[2]:='C:\GAMES\DOOM2';
    gotoxy(1,y);
    textattr:=LightGreen;
    Writeln('Please insert the full path for the following sources:');
    inc(y);
    ask('DOOM.WAD',path[1]);
    inc(y);
    ask('DOOM2.WAD',path[2]);
    inc(y);
    gotoxy(1,y);
    textattr:=LightGreen;
    clreol;
    inc(y);
    gotoxy(1,y);
    Writeln('Please insert the full path for the destination:');
    inc(y);
    path[3]:=path[2];
    ask('DM2CONV.WAD',path[3]);
  end;

var OldExitProc:Pointer;

procedure SExitProc; far;
  const xxx=':'#13#10;
  var i:integer;
  begin
    ExitProc:=OldExitProc;
    if incheck then begin
      textattr:=LightRed;
      gotoxy(2,wherey-1);
      writeln('x');
    end;
    textattr:=white;
    clreol;
    writeln;
    if Exitcode=0 then begin
      writeln('DM2CONV.WAD succesfully created.');
      textattr:=lightgray;
      writeln;
      writeln('Now, to play any DOOM level simply include DM2CONV.WAD');
      writeln('in the list of patches after -FILE.');
      writeln;
      writeln('example: DOOM2 -FILE DM2CONV.WAD anywad.WAD');
      writeln;
      textattr:=yellow;
      writeln('Remember to convert the wads with DM2CONV without /TEXTURE');
      textattr:=lightgray;
    end
    else begin
      write('Operation aborted');
      case exitcode of
        USER_ESC: writeln(' by user request!');
        NO_MEM: writeln(': not enough memory!');
        ERR_OPEN: writeln(xxx,'Cannot open ',why);
        ERR_READ: writeln(xxx,'Cannot read ',why);
        ERR_WRITE: writeln(xxx,'Cannot write ',why);
        ERR_NOTEX: writeln(xxx,'Missing texture info in ',why);
        else writeln(xxx,why);
      end;
    end;
    i:=wherey;
    window(1,1,80,25);
    textattr:=lightgray;
    gotoxy(1,25);
    clreol;
    gotoxy(1,i+2);
  end;

function HeapCheck(size:Word):Integer; far;
  begin
    HeapCheck:=1;
  end;

procedure initialize;
  var i:integer;
  begin
    OldExitProc:=ExitProc;
    ExitProc:=@SExitProc;
    HeapError:=@HeapCheck;
    for i:=1 to 3 do begin
      new(dirlist[i]);
      if dirlist[i]=nil then halt(NO_MEM);
    end;
    textmode(CO80);
    textattr:=blue*16+white;
    gotoxy(1,1);
    clreol;
    write('Welcome to DM2CONV.WAD''s maker':55);
    textattr:=lightgray*16+black;
    gotoxy(1,25);
    clreol;
    write(' Press ESC to abort the creation process.');
    window(1,3,80,24);
  end;

procedure checkmark;
  var i:byte;
  begin
    i:=textattr;
    textattr:=white;
    gotoxy(2,wherey-1);
    writeln('û');
    textattr:=i;
    incheck:=false;
  end;

procedure putcheckmark;
  begin
    textattr:=lightgray;
    write('[ ] ');
    incheck:=true;
  end;

procedure blockw(var p;size:word);
  var i:word;
  begin
    why:=path[3];
    blockwrite(wadfile[3],p,size,i);
    if (ioresult<>0) or (size<>i) then halt(ERR_WRITE);
    checkabort;
  end;

procedure blockr(var start:longint;index:integer;var p;size:word);
  var i:word;
  begin
    why:=path[index];
    if start>0 then begin
      seek(wadfile[index],start);
      start:=0;
      if ioresult<>0 then halt(ERR_READ);
      checkabort;
    end;
    blockread(wadfile[index],p,size,i);
    if (ioresult<>0) or (size<>i) then halt(ERR_READ);
    checkabort;
  end;

procedure openread(index:integer;name:string);
  var h:header;
      i:word;
  begin
    why:=path[index]+'\'+name;
    path[index]:=why;
    putcheckmark;
    writeln('Opening ',why);
    assign(wadfile[index],why);
    reset(wadfile[index],1);
    if ioresult<>0 then halt(ERR_OPEN);
    blockread(wadfile[index],h,sizeof(h),i);
    if (ioresult<>0) or (i<>sizeof(h)) then halt(ERR_READ);
    if h.Sig<>IWAD_SIG then halt(ERR_NOWAD);
    checkabort;
    seek(wadfile[index],h.start);
    number[index]:=h.num;
    if ioresult<>0 then halt(ERR_OPEN);
    Blockread(wadfile[index],dirlist[index]^,h.num*sizeof(entry),i);
    if (ioresult<>0) or (i<>h.num*sizeof(entry)) then halt(ERR_READ);
    checkabort;
    checkmark;
  end;

procedure flushBuffer;
  var j:word;
  begin
    if BufferPos>0 then begin
      if bufferpos>BUFFSIZE1 then j:=BUFFSIZE1
      else j:=bufferpos;
      blockw(DirList[1]^,j);
      dec(bufferpos,j);
      if bufferpos>0 then blockw(DirList[2]^,bufferpos);
      BufferPos:=0;
    end;
  end;

procedure ReadBuffer(var d:entry);
  var offs,len,size:Longint;
      i:integer;
      j:word;
  begin
    offs:=d.Start;
    len:=d.Size;
    d.Start:=FilePos(wadfile[3])+BufferPos;
    if len>0 then begin
      while len>0 do begin
        if bufferpos>=BUFFSIZE1 then begin
          size:=BUFFSIZE-BufferPos;
          if size>len then size:=len;
          blockr(offs,1,p_varray(dirlist[2])^[bufferpos-BUFFSIZE1],size);
        end
        else begin
          size:=BUFFSIZE1-BufferPos;
          if size>len then size:=len;
          blockr(offs,1,p_varray(dirlist[1])^[bufferpos],size);
        end;
        dec(len,size);
        inc(BufferPos,size);
        if BufferPos=BUFFSIZE then FlushBuffer;
      end;
    end;
  end;

procedure findpatch(index:integer;var a,b:integer);
  var i:integer;
  begin
    for i:=1 to number[index] do with dirlist[index]^[i] do
      if Name='P_START'#0 then a:=i
      else if Name='P_END'#0#0#0 then b:=i;
  end;

procedure writewad;
  var h      : header;
      l,m    : longint;
      num    : integer;
      ip1,fp1: integer;
      ip2,fp2: integer;
      i,j,k  : integer;
      d      : char8;
  begin
    why:=path[3]+'\DM2CONV.WAD';
    path[3]:=why;
    putcheckmark;
    writeln('Creating ',why);
    assign(wadfile[3],why);
    rewrite(wadfile[3],1);
    if ioresult<>0 then halt(ERR_WRITE);
    h.sig:=PWAD_SIG;
    blockw(h,sizeof(h));
    num:=1;
    with dirlist[3]^[num] do begin
      Name:=PNAME;
      Start:=FilePos(wadfile[3]);
      l:=numpn;
      blockw(l,4);
      blockw(pnames,numpn*8);
      Size:=FilePos(wadfile[3])-Start;
    end;
    inc(num);
    with dirlist[3]^[num] do begin
      Name:=TEXTURE1;
      Start:=FilePos(wadfile[3]);
      l:=numtx;
      blockw(l,4);
      blockw(textptr,numtx*4);
      blockw(texture,txsize);
      Size:=FilePos(wadfile[3])-Start;
    end;
    checkmark;

    putcheckmark;
    writeln('Adding DOOM patches');
    findpatch(1,ip1,fp1);
    findpatch(2,ip2,fp2);
    for i:=ip1 to fp1 do with dirlist[1]^[i] do begin
      if Size>0 then begin
        d:=Name;
        j:=ip2+1;
        if (d[1]<>'S') or (d[2]<>'K') or (d[3]<>'Y') then
          while (j<fp2) and (dirlist[2]^[j].Name<>d) do inc(j);
      end
      else j:=fp2;
      if j>=fp2 then begin
        inc(num);
        dirlist[3]^[num]:=dirlist[1]^[i];
      end;
    end;
    BufferPos:=0;
    l:=0;
    for i:=3 to num do inc(l,dirlist[3]^[i].Size+1);
    m:=0;
    for i:=3 to num do begin
      with dirlist[3]^[i] do begin
        inc(m,Size+1);
        gotoxy(5,wherey);
        write(Name,m*100 div l:6,'%');
      end;
      ReadBuffer(dirlist[3]^[i]);
    end;
    FlushBuffer;
    gotoxy(1,wherey);
    clreol;
    why:=path[3];
    h.Start:=FilePos(wadfile[3]);
    h.Num:=num;
    blockw(dirlist[3]^,num*sizeof(entry));
    seek(wadfile[3],0);
    if ioresult<>0 then halt(ERR_WRITE);
    blockw(h,sizeof(h));
    checkmark;
  end;

function readpnames(i:integer):integer;
  var j:integer;
      l:longint;
  procedure readtx(txname:char8);
    var k:integer;
        m:longint;
    begin
      j:=number[i];
      while (j>0) and (dirlist[i]^[j].Name<>txname) do dec(j);
      if j=0 then halt(ERR_NOTEX);
      blockr(dirlist[i]^[j].Start,i,l,4);
      blockr(dirlist[i]^[j].Start,i,textptr[numtx+1],l*4);
      m:=txsize-(l+1)*4;
      for k:=numtx+1 to numtx+l do inc(textptr[k],m);
      m:=dirlist[i]^[j].Size-(l+1)*4;
      blockr(dirlist[i]^[j].Start,i,texture[txsize],m);
      inc(txsize,m);
      inc(numtx,l);
    end;
  begin
    putcheckmark;
    writeln('Reading texture from ',path[i]);
    j:=number[i];
    while (j>0) and (dirlist[i]^[j].Name<>PNAME) do dec(j);
    if j=0 then halt(ERR_NOTEX);
    blockr(dirlist[i]^[j].Start,i,l,4);
    blockr(dirlist[i]^[j].Start,i,pnames[numpn+1],dirlist[i]^[j].Size-4);
    readpnames:=l;
    readtx(TEXTURE1);
    if i=1 then readtx(TEXTURE2);
    checkmark;
  end;

procedure install;
  var i,j,k: integer;
      maxpn: integer;
      otxn : integer;
      otxs : integer;
      offs : longint;
      t    : p_txinfo;
      q    : pointer;
      p    : p_ptinfo;
  begin
    textattr:=lightgray;
    clrscr;
    openread(1,DOOM_WAD);
    openread(2,DOOM2_WAD);
    numpn:=0;
    numtx:=0;
    txsize:=0;
    numpn:=readpnames(2);
    otxs:=txsize;
    otxn:=numtx;
    maxpn:=readpnames(1)+numpn;
    putcheckmark;
    writeln('Merging texture information');
    k:=numpn;
    for i:=numpn+1 to maxpn do begin
      j:=numpn;
      while (j>0) and (pnames[j]<>pnames[i]) do dec(j);
      if j=0 then begin
        inc(k);
        pnames[k]:=pnames[i];
        j:=k;
      end;
      pconv[i-numpn-1]:=j-1;
    end;
    numpn:=k;
    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;
    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:=PtrAdd(t,sizeof(txinfo));
        for j:=1 to t^.num do begin
          q:=addr(texture[txsize]);
          p^.Index:=pconv[p^.Index];
          Move(p^,q^,sizeof(ptinfo));
          p:=PtrAdd(p,sizeof(ptinfo));
          inc(txsize,sizeof(ptinfo));
        end;
      end;
    end;
    numtx:=k;
    k:=k*4+4;
    for i:=1 to numtx do inc(textptr[i],k);
    checkmark;
    writewad;
    putcheckmark;
    writeln('Closing files');
    for i:=1 to 3 do close(wadfile[i]);
    checkmark;
  end;

begin
  initialize;
  gotoxy(1,6);
  askpath;
  install;
end.