home *** CD-ROM | disk | FTP | other *** search
/ PC Home 32 / PC_HOME_95-uncompressed-cd-image.iso / doom / dm2con / dm2mkwad.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-11-11  |  14.9 KB  |  614 lines
  1. {$A+,B-,D+,E+,F-,G+,I-,L+,N-,O-,P-,Q-,R+,S+,T-,V-,X+}
  2. {$M 16384,0,655360}
  3. Uses Crt,Dos;
  4.  
  5. const
  6.   USER_ESC = 1;
  7.   NO_MEM   = 2;
  8.   ERR_OPEN = 3;
  9.   ERR_READ = 4;
  10.   ERR_WRITE= 5;
  11.   ERR_NOWAD= 6;
  12.   ERR_NOTEX= 7;
  13.   ERR_USER = 99;
  14.  
  15.   IWAD_SIG = Ord('I')+(Ord('W')+(Ord('A')+Ord('D') shl 8) shl 8) shl 8;
  16.   PWAD_SIG = Ord('P')+(Ord('W')+(Ord('A')+Ord('D') shl 8) shl 8) shl 8;
  17.   DOOM_WAD = 'DOOM.WAD';
  18.   DOOM2_WAD = 'DOOM2.WAD';
  19.   PNAME = 'PNAMES'#0#0;
  20.   TEXTURE1 = 'TEXTURE1';
  21.   TEXTURE2 = 'TEXTURE2';
  22.   OK = '[Ok]';
  23.  
  24. type
  25.   header= record
  26.     Sig   : Longint;
  27.     Num   : Longint;
  28.     Start : Longint;
  29.   end;
  30.   p_entry=^entry;
  31.   char8 = array[1..8] of Char;
  32.   entry = record
  33.     Start : Longint;
  34.     Size  : Longint;
  35.     Name  : char8;
  36.   end;
  37.   p_txinfo = ^txinfo;
  38.   txinfo = record
  39.     Name : char8;
  40.     dummy: array[1..6] of word;
  41.     Num  : integer;
  42.   end;
  43.   p_ptinfo = ^ptinfo;
  44.   ptinfo = record
  45.     dummy: longint;
  46.     index: word;
  47.     dumm2: longint;
  48.   end;
  49.   entry_array = array[1..4000] of entry;
  50.   p_entry_array = ^entry_array;
  51.  
  52.   varray = array[0..65534] of byte;
  53.   p_varray = ^varray;
  54.  
  55. const
  56.   BUFFSIZE1 = sizeof(entry_array);
  57.   BUFFSIZE = BUFFSIZE1*2;
  58.  
  59. var
  60.   path   : array[1..3] of string;
  61.   number : array[1..3] of integer;
  62.   dirlist: array[1..3] of p_entry_array;
  63.   wadfile: array[1..3] of file;
  64.   pnames : array[1..1024] of char8;
  65.   numpn  : integer;
  66.   pconv  : array[0..512] of integer;
  67.   textptr: array[1..1024] of longint;
  68.   texture: array[0..49151] of byte;
  69.   numtx  : integer;
  70.   txsize : word;
  71.   why    : string;
  72.   incheck: boolean;
  73.  
  74.   BufferPos : longint;
  75.  
  76. function PtrAdd(p:pointer;n:word):pointer; assembler;
  77.   asm
  78.     les ax, p
  79.     mov dx, es
  80.     add ax, n
  81.   end;
  82.  
  83. procedure checkabort;
  84.   begin
  85.     if keypressed then case readkey of
  86.       #0: readkey;
  87.       #27: halt(USER_ESC);
  88.     end;
  89.   end;
  90.  
  91. procedure input(x,y:integer;var a:string;n:integer);
  92.   var
  93.    i,p : integer;
  94.    c : char;
  95.    done : boolean;
  96.  
  97.   procedure del;
  98.     begin
  99.       dec(p);
  100.       delete(a,p,1);
  101.       gotoxy(x+p,y);
  102.       write(copy(a,p,n),#32);
  103.       gotoxy(x+p,y)
  104.     end;
  105.  
  106.   begin
  107.     textattr:=red*16+yellow;
  108.     gotoxy(x,y);
  109.     write(#32:n+2);
  110.     gotoxy(x+1,y);
  111.     write(a);
  112.     p:=length(a)+1;
  113.     gotoxy(x+p,y);
  114.     done:=FALSE;
  115.     repeat
  116.       c:=upcase(readkey);
  117.       case c of
  118.         #0 :
  119.           begin
  120.             c:=readkey;
  121.             case c of
  122.               #75 : if p>1 then dec(p);
  123.               #77 : if p<=length(a) then inc(p);
  124.               #71 : p:=1;
  125.               #79 : p:=length(a)+1;
  126.               #83 :
  127.                 if p<=length(a) then
  128.                   begin
  129.                     inc(p);
  130.                     del
  131.                   end
  132.               end;
  133.             gotoxy(x+p,y)
  134.           end;
  135.         #32..#96 :
  136.           if length(a)<n then
  137.             begin
  138.               insert(c,a,p);
  139.               gotoxy(x+p,y);
  140.               write(copy(a,p,n));
  141.               inc(p);
  142.               gotoxy(x+p,y)
  143.             end;
  144.         #8 : if p>1 then del;
  145.         #27 :
  146.           begin
  147.             p:=1;
  148.             gotoxy(x+p,y);
  149.             write(#32:length(a));
  150.             a:='';
  151.             gotoxy(x+p,y);
  152.             done:=true;
  153.           end;
  154.         #13 : done:=true
  155.         end
  156.     until done;
  157.     gotoxy(x,y);
  158.     writeln(#32,a,#32:n-length(a)+1)
  159.   end;
  160.  
  161. function isdir(name:string):boolean;
  162.   var trovato:boolean;
  163.       s:searchrec;
  164.   begin
  165.     trovato:=false;
  166.     findfirst(name,directory,s);
  167.     if (doserror=0) and (ioresult=0) then
  168.       if (s.attr and directory)=directory then trovato:=true;
  169.     isdir:=trovato
  170.   end;
  171.  
  172. procedure askpath;
  173.   var
  174.     y:integer;
  175.     b:Boolean;
  176.   procedure ask(a:string;var s:String);
  177.     begin
  178.       gotoxy(1,y);
  179.       textattr:=lightcyan;
  180.       write(a);
  181.       b:=False;
  182.       repeat
  183.         if b then begin
  184.           gotoxy(14,y+1);
  185.           textattr:=White;
  186.           write('The path specified does not exist!');
  187.         end;
  188.         input(13,y,s,60);
  189.         b:=True;
  190.         if s='' then halt(USER_ESC);
  191.       until isdir(s);
  192.     end;
  193.   begin
  194.     gotoxy(1,1);
  195.     textattr:=lightmagenta;
  196.     writeln('This program creates a patch wad file named DM2CONV.WAD  containing');
  197.     writeln('all the textures present in DOOM, but missing from DOOM II.');
  198.     writeln;
  199.     writeln('Both registered versions of DOOM and DOOM II are required.');
  200.     writeln;
  201.     writeln('This wad will enable DOOM II to use any level designed for DOOM and');
  202.     writeln('converted by DM2CONV with no /TEXTURE argument.');
  203.     writeln;
  204.     writeln;
  205.     y:=wherey;
  206.     path[1]:='C:\GAMES\DOOM';
  207.     path[2]:='C:\GAMES\DOOM2';
  208.     gotoxy(1,y);
  209.     textattr:=LightGreen;
  210.     Writeln('Please insert the full path for the following sources:');
  211.     inc(y);
  212.     ask('DOOM.WAD',path[1]);
  213.     inc(y);
  214.     ask('DOOM2.WAD',path[2]);
  215.     inc(y);
  216.     gotoxy(1,y);
  217.     textattr:=LightGreen;
  218.     clreol;
  219.     inc(y);
  220.     gotoxy(1,y);
  221.     Writeln('Please insert the full path for the destination:');
  222.     inc(y);
  223.     path[3]:=path[2];
  224.     ask('DM2CONV.WAD',path[3]);
  225.   end;
  226.  
  227. var OldExitProc:Pointer;
  228.  
  229. procedure SExitProc; far;
  230.   const xxx=':'#13#10;
  231.   var i:integer;
  232.   begin
  233.     ExitProc:=OldExitProc;
  234.     if incheck then begin
  235.       textattr:=LightRed;
  236.       gotoxy(2,wherey-1);
  237.       writeln('x');
  238.     end;
  239.     textattr:=white;
  240.     clreol;
  241.     writeln;
  242.     if Exitcode=0 then begin
  243.       writeln('DM2CONV.WAD succesfully created.');
  244.       textattr:=lightgray;
  245.       writeln;
  246.       writeln('Now, to play any DOOM level simply include DM2CONV.WAD');
  247.       writeln('in the list of patches after -FILE.');
  248.       writeln;
  249.       writeln('example: DOOM2 -FILE DM2CONV.WAD anywad.WAD');
  250.       writeln;
  251.       textattr:=yellow;
  252.       writeln('Remember to convert the wads with DM2CONV without /TEXTURE');
  253.       textattr:=lightgray;
  254.     end
  255.     else begin
  256.       write('Operation aborted');
  257.       case exitcode of
  258.         USER_ESC: writeln(' by user request!');
  259.         NO_MEM: writeln(': not enough memory!');
  260.         ERR_OPEN: writeln(xxx,'Cannot open ',why);
  261.         ERR_READ: writeln(xxx,'Cannot read ',why);
  262.         ERR_WRITE: writeln(xxx,'Cannot write ',why);
  263.         ERR_NOTEX: writeln(xxx,'Missing texture info in ',why);
  264.         else writeln(xxx,why);
  265.       end;
  266.     end;
  267.     i:=wherey;
  268.     window(1,1,80,25);
  269.     textattr:=lightgray;
  270.     gotoxy(1,25);
  271.     clreol;
  272.     gotoxy(1,i+2);
  273.   end;
  274.  
  275. function HeapCheck(size:Word):Integer; far;
  276.   begin
  277.     HeapCheck:=1;
  278.   end;
  279.  
  280. procedure initialize;
  281.   var i:integer;
  282.   begin
  283.     OldExitProc:=ExitProc;
  284.     ExitProc:=@SExitProc;
  285.     HeapError:=@HeapCheck;
  286.     for i:=1 to 3 do begin
  287.       new(dirlist[i]);
  288.       if dirlist[i]=nil then halt(NO_MEM);
  289.     end;
  290.     textmode(CO80);
  291.     textattr:=blue*16+white;
  292.     gotoxy(1,1);
  293.     clreol;
  294.     write('Welcome to DM2CONV.WAD''s maker':55);
  295.     textattr:=lightgray*16+black;
  296.     gotoxy(1,25);
  297.     clreol;
  298.     write(' Press ESC to abort the creation process.');
  299.     window(1,3,80,24);
  300.   end;
  301.  
  302. procedure checkmark;
  303.   var i:byte;
  304.   begin
  305.     i:=textattr;
  306.     textattr:=white;
  307.     gotoxy(2,wherey-1);
  308.     writeln('√');
  309.     textattr:=i;
  310.     incheck:=false;
  311.   end;
  312.  
  313. procedure putcheckmark;
  314.   begin
  315.     textattr:=lightgray;
  316.     write('[ ] ');
  317.     incheck:=true;
  318.   end;
  319.  
  320. procedure blockw(var p;size:word);
  321.   var i:word;
  322.   begin
  323.     why:=path[3];
  324.     blockwrite(wadfile[3],p,size,i);
  325.     if (ioresult<>0) or (size<>i) then halt(ERR_WRITE);
  326.     checkabort;
  327.   end;
  328.  
  329. procedure blockr(var start:longint;index:integer;var p;size:word);
  330.   var i:word;
  331.   begin
  332.     why:=path[index];
  333.     if start>0 then begin
  334.       seek(wadfile[index],start);
  335.       start:=0;
  336.       if ioresult<>0 then halt(ERR_READ);
  337.       checkabort;
  338.     end;
  339.     blockread(wadfile[index],p,size,i);
  340.     if (ioresult<>0) or (size<>i) then halt(ERR_READ);
  341.     checkabort;
  342.   end;
  343.  
  344. procedure openread(index:integer;name:string);
  345.   var h:header;
  346.       i:word;
  347.   begin
  348.     why:=path[index]+'\'+name;
  349.     path[index]:=why;
  350.     putcheckmark;
  351.     writeln('Opening ',why);
  352.     assign(wadfile[index],why);
  353.     reset(wadfile[index],1);
  354.     if ioresult<>0 then halt(ERR_OPEN);
  355.     blockread(wadfile[index],h,sizeof(h),i);
  356.     if (ioresult<>0) or (i<>sizeof(h)) then halt(ERR_READ);
  357.     if h.Sig<>IWAD_SIG then halt(ERR_NOWAD);
  358.     checkabort;
  359.     seek(wadfile[index],h.start);
  360.     number[index]:=h.num;
  361.     if ioresult<>0 then halt(ERR_OPEN);
  362.     Blockread(wadfile[index],dirlist[index]^,h.num*sizeof(entry),i);
  363.     if (ioresult<>0) or (i<>h.num*sizeof(entry)) then halt(ERR_READ);
  364.     checkabort;
  365.     checkmark;
  366.   end;
  367.  
  368. procedure flushBuffer;
  369.   var j:word;
  370.   begin
  371.     if BufferPos>0 then begin
  372.       if bufferpos>BUFFSIZE1 then j:=BUFFSIZE1
  373.       else j:=bufferpos;
  374.       blockw(DirList[1]^,j);
  375.       dec(bufferpos,j);
  376.       if bufferpos>0 then blockw(DirList[2]^,bufferpos);
  377.       BufferPos:=0;
  378.     end;
  379.   end;
  380.  
  381. procedure ReadBuffer(var d:entry);
  382.   var offs,len,size:Longint;
  383.       i:integer;
  384.       j:word;
  385.   begin
  386.     offs:=d.Start;
  387.     len:=d.Size;
  388.     d.Start:=FilePos(wadfile[3])+BufferPos;
  389.     if len>0 then begin
  390.       while len>0 do begin
  391.         if bufferpos>=BUFFSIZE1 then begin
  392.           size:=BUFFSIZE-BufferPos;
  393.           if size>len then size:=len;
  394.           blockr(offs,1,p_varray(dirlist[2])^[bufferpos-BUFFSIZE1],size);
  395.         end
  396.         else begin
  397.           size:=BUFFSIZE1-BufferPos;
  398.           if size>len then size:=len;
  399.           blockr(offs,1,p_varray(dirlist[1])^[bufferpos],size);
  400.         end;
  401.         dec(len,size);
  402.         inc(BufferPos,size);
  403.         if BufferPos=BUFFSIZE then FlushBuffer;
  404.       end;
  405.     end;
  406.   end;
  407.  
  408. procedure findpatch(index:integer;var a,b:integer);
  409.   var i:integer;
  410.   begin
  411.     for i:=1 to number[index] do with dirlist[index]^[i] do
  412.       if Name='P_START'#0 then a:=i
  413.       else if Name='P_END'#0#0#0 then b:=i;
  414.   end;
  415.  
  416. procedure writewad;
  417.   var h      : header;
  418.       l,m    : longint;
  419.       num    : integer;
  420.       ip1,fp1: integer;
  421.       ip2,fp2: integer;
  422.       i,j,k  : integer;
  423.       d      : char8;
  424.   begin
  425.     why:=path[3]+'\DM2CONV.WAD';
  426.     path[3]:=why;
  427.     putcheckmark;
  428.     writeln('Creating ',why);
  429.     assign(wadfile[3],why);
  430.     rewrite(wadfile[3],1);
  431.     if ioresult<>0 then halt(ERR_WRITE);
  432.     h.sig:=PWAD_SIG;
  433.     blockw(h,sizeof(h));
  434.     num:=1;
  435.     with dirlist[3]^[num] do begin
  436.       Name:=PNAME;
  437.       Start:=FilePos(wadfile[3]);
  438.       l:=numpn;
  439.       blockw(l,4);
  440.       blockw(pnames,numpn*8);
  441.       Size:=FilePos(wadfile[3])-Start;
  442.     end;
  443.     inc(num);
  444.     with dirlist[3]^[num] do begin
  445.       Name:=TEXTURE1;
  446.       Start:=FilePos(wadfile[3]);
  447.       l:=numtx;
  448.       blockw(l,4);
  449.       blockw(textptr,numtx*4);
  450.       blockw(texture,txsize);
  451.       Size:=FilePos(wadfile[3])-Start;
  452.     end;
  453.     checkmark;
  454.  
  455.     putcheckmark;
  456.     writeln('Adding DOOM patches');
  457.     findpatch(1,ip1,fp1);
  458.     findpatch(2,ip2,fp2);
  459.     for i:=ip1 to fp1 do with dirlist[1]^[i] do begin
  460.       if Size>0 then begin
  461.         d:=Name;
  462.         j:=ip2+1;
  463.         if (d[1]<>'S') or (d[2]<>'K') or (d[3]<>'Y') then
  464.           while (j<fp2) and (dirlist[2]^[j].Name<>d) do inc(j);
  465.       end
  466.       else j:=fp2;
  467.       if j>=fp2 then begin
  468.         inc(num);
  469.         dirlist[3]^[num]:=dirlist[1]^[i];
  470.       end;
  471.     end;
  472.     BufferPos:=0;
  473.     l:=0;
  474.     for i:=3 to num do inc(l,dirlist[3]^[i].Size+1);
  475.     m:=0;
  476.     for i:=3 to num do begin
  477.       with dirlist[3]^[i] do begin
  478.         inc(m,Size+1);
  479.         gotoxy(5,wherey);
  480.         write(Name,m*100 div l:6,'%');
  481.       end;
  482.       ReadBuffer(dirlist[3]^[i]);
  483.     end;
  484.     FlushBuffer;
  485.     gotoxy(1,wherey);
  486.     clreol;
  487.     why:=path[3];
  488.     h.Start:=FilePos(wadfile[3]);
  489.     h.Num:=num;
  490.     blockw(dirlist[3]^,num*sizeof(entry));
  491.     seek(wadfile[3],0);
  492.     if ioresult<>0 then halt(ERR_WRITE);
  493.     blockw(h,sizeof(h));
  494.     checkmark;
  495.   end;
  496.  
  497. function readpnames(i:integer):integer;
  498.   var j:integer;
  499.       l:longint;
  500.   procedure readtx(txname:char8);
  501.     var k:integer;
  502.         m:longint;
  503.     begin
  504.       j:=number[i];
  505.       while (j>0) and (dirlist[i]^[j].Name<>txname) do dec(j);
  506.       if j=0 then halt(ERR_NOTEX);
  507.       blockr(dirlist[i]^[j].Start,i,l,4);
  508.       blockr(dirlist[i]^[j].Start,i,textptr[numtx+1],l*4);
  509.       m:=txsize-(l+1)*4;
  510.       for k:=numtx+1 to numtx+l do inc(textptr[k],m);
  511.       m:=dirlist[i]^[j].Size-(l+1)*4;
  512.       blockr(dirlist[i]^[j].Start,i,texture[txsize],m);
  513.       inc(txsize,m);
  514.       inc(numtx,l);
  515.     end;
  516.   begin
  517.     putcheckmark;
  518.     writeln('Reading texture from ',path[i]);
  519.     j:=number[i];
  520.     while (j>0) and (dirlist[i]^[j].Name<>PNAME) do dec(j);
  521.     if j=0 then halt(ERR_NOTEX);
  522.     blockr(dirlist[i]^[j].Start,i,l,4);
  523.     blockr(dirlist[i]^[j].Start,i,pnames[numpn+1],dirlist[i]^[j].Size-4);
  524.     readpnames:=l;
  525.     readtx(TEXTURE1);
  526.     if i=1 then readtx(TEXTURE2);
  527.     checkmark;
  528.   end;
  529.  
  530. procedure install;
  531.   var i,j,k: integer;
  532.       maxpn: integer;
  533.       otxn : integer;
  534.       otxs : integer;
  535.       offs : longint;
  536.       t    : p_txinfo;
  537.       q    : pointer;
  538.       p    : p_ptinfo;
  539.   begin
  540.     textattr:=lightgray;
  541.     clrscr;
  542.     openread(1,DOOM_WAD);
  543.     openread(2,DOOM2_WAD);
  544.     numpn:=0;
  545.     numtx:=0;
  546.     txsize:=0;
  547.     numpn:=readpnames(2);
  548.     otxs:=txsize;
  549.     otxn:=numtx;
  550.     maxpn:=readpnames(1)+numpn;
  551.     putcheckmark;
  552.     writeln('Merging texture information');
  553.     k:=numpn;
  554.     for i:=numpn+1 to maxpn do begin
  555.       j:=numpn;
  556.       while (j>0) and (pnames[j]<>pnames[i]) do dec(j);
  557.       if j=0 then begin
  558.         inc(k);
  559.         pnames[k]:=pnames[i];
  560.         j:=k;
  561.       end;
  562.       pconv[i-numpn-1]:=j-1;
  563.     end;
  564.     numpn:=k;
  565.     j:=numtx;
  566.     while j>1 do begin
  567.       k:=0;
  568.       for i:=1 to j-1 do if textptr[i]>textptr[i+1] then begin
  569.         k:=i;
  570.         offs:=textptr[i];
  571.         textptr[i]:=textptr[i+1];
  572.         textptr[i+1]:=offs;
  573.       end;
  574.       j:=k;
  575.     end;
  576.     txsize:=otxs;
  577.     k:=otxn;
  578.     for i:=otxn+1 to numtx do begin
  579.       t:=addr(texture[textptr[i]]);
  580.       j:=otxn;
  581.       while (j>0) and (p_txinfo(addr(texture[textptr[j]]))^.Name<>t^.Name) do dec(j);
  582.       if j=0 then begin
  583.         inc(k);
  584.         textptr[k]:=txsize;
  585.         q:=addr(texture[txsize]);
  586.         Move(t^,q^,sizeof(txinfo));
  587.         inc(txsize,sizeof(txinfo));
  588.         p:=PtrAdd(t,sizeof(txinfo));
  589.         for j:=1 to t^.num do begin
  590.           q:=addr(texture[txsize]);
  591.           p^.Index:=pconv[p^.Index];
  592.           Move(p^,q^,sizeof(ptinfo));
  593.           p:=PtrAdd(p,sizeof(ptinfo));
  594.           inc(txsize,sizeof(ptinfo));
  595.         end;
  596.       end;
  597.     end;
  598.     numtx:=k;
  599.     k:=k*4+4;
  600.     for i:=1 to numtx do inc(textptr[i],k);
  601.     checkmark;
  602.     writewad;
  603.     putcheckmark;
  604.     writeln('Closing files');
  605.     for i:=1 to 3 do close(wadfile[i]);
  606.     checkmark;
  607.   end;
  608.  
  609. begin
  610.   initialize;
  611.   gotoxy(1,6);
  612.   askpath;
  613.   install;
  614. end.