home *** CD-ROM | disk | FTP | other *** search
/ Demon Gate Mega Collection / DemonGateMegaCollection.bin / utils / dm2conv / gfxmaker.pas < prev    next >
Pascal/Delphi Source File  |  1995-07-22  |  27KB  |  967 lines
  1. {$A+,B-,D+,E+,F-,G+,I-,L+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
  2. {$M 8192,0,0}
  3. { GFXMAKER v3.1 by Vincenzo Alcamo }
  4. { This program is Public Domain    }
  5. Uses Crt;
  6.  
  7. const
  8.   IWAD_SIG = Ord('I')+(Ord('W')+(Ord('A')+Ord('D') shl 8) shl 8) shl 8;
  9.   PWAD_SIG = Ord('P')+(Ord('W')+(Ord('A')+Ord('D') shl 8) shl 8) shl 8;
  10.   DOOM    = 1;
  11.   DOOM2   = 2;
  12.   HERETIC = 3;
  13.   DEST    = 4;
  14.   GNAMES : array[DOOM..HERETIC] of string[8]=('DOOM','DOOM2','HERETIC');
  15.   GID : array[DOOM..HERETIC] of string[2]=('D','D2','H');
  16.   PNAMES = 'PNAMES'#0#0;
  17.   TEXTURE1 = 'TEXTURE1';
  18.   TEXTURE2 = 'TEXTURE2';
  19.   PLAYPAL = 'PLAYPAL'#0;
  20.   P_START = 'P_START'#0;
  21.   P_END   = 'P_END'#0#0#0;
  22.   P1_START= 'P1_START';
  23.   P1_END  = 'P1_END'#0#0;
  24.   F_START = 'F_START'#0;
  25.   F_END   = 'F_END'#0#0#0;
  26.   F1_START= 'F1_START';
  27.   F1_END  = 'F1_END'#0#0;
  28.  
  29.   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);
  30.   MAXMEMBLOCK = 65535;
  31.  
  32. type
  33.   WAD_HEADER = record {header of a wadfile}
  34.     Sig   : longint;  {signature}
  35.     Num   : longint;  {numbers of resources}
  36.     Start : longint;  {offset of dirlist}
  37.   end;
  38.   CHAR8 = array[1..8] of Char;
  39.   WAD_ENTRY = record  {each single entry in the dirlist}
  40.     Start : Longint;  {offset of resource}
  41.     case integer of
  42.       1: (Size  : longint;  {length in bytes}
  43.           Name  : CHAR8;    {resource's name});
  44.       2: (dummy : array[1..3] of byte;
  45.           fnum  : byte;     {file number});
  46.   end;
  47.   A_WADENTRY = array[1..MAXMEMBLOCK div sizeof(WAD_ENTRY)] of WAD_ENTRY;
  48.   P_A_WADENTRY = ^A_WADENTRY;
  49.   P_TXINFO = ^TXINFO;
  50.   TXINFO = record   {texture info}
  51.     Name : CHAR8;   {name of the texture}
  52.     dummy: array[1..6] of word;
  53.     Num  : integer; {number of patches}
  54.   end;
  55.   P_PTINFO = ^PTINFO;
  56.   PTINFO = record   {patch info}
  57.     dummy: longint;
  58.     Index: word;    {index of patch name inside PNAMES}
  59.     dumm2: longint;
  60.   end;
  61.   COLOR_REMAP = array[0..255] of byte;
  62.   RGB_TRIPLET = record
  63.     Red   : byte;
  64.     Green : byte;
  65.     Blue  : byte;
  66.   end;
  67.   COLOR_MAP = array[0..255] of RGB_TRIPLET;
  68.   LARGEBUFF = array[0..MAXMEMBLOCK-1] of byte;
  69.   P_LARGEBUFF = ^LARGEBUFF;
  70.   P_WORD = ^integer;
  71.   P_LONG = ^longint;
  72.   ERRORS = (ERR_NONE,ERR_USER_ESCAPE,ERR_NOMEM,ERR_OPEN,ERR_READ,ERR_WRITE,
  73.             ERR_NOWAD,ERR_NOPALETTE,ERR_NOTEX);
  74.  
  75. const
  76.   Op_Mode : integer = DOOM2;  {operation mode: specify dest game}
  77.   InCheck : integer = 0;      {row where a checkmark is located, or 0}
  78.   NumPt   : integer = 0;      {number of patches in PtArray}
  79.   NumTx   : integer = 0;      {number of textures}
  80.   TxSize  : word = 0;         {size of texture}
  81.   RemapPt : boolean = True;   {remap Patch or Floor}
  82.  
  83. var
  84.   Path   : array[DOOM..DEST] of string;         {wad paths}
  85.   Number : array[DOOM..DEST] of integer;        {number of resources}
  86.   Dirlist: array[DOOM..DEST] of P_A_WADENTRY;   {pointers to dirlist}
  87.   Wadfile: array[DOOM..DEST] of file;           {file handle}
  88.   EndSize: longint;                             {size of dest file}
  89.   Why    : string;                              {general description string}
  90.   DName  : string[12];                          {name of destination wad}
  91.   CRemap : COLOR_REMAP;
  92.   PtArray: array[1..1024] of CHAR8;     {array of patch names}
  93.   PConv  : array[0..512] of integer;
  94.   TextPtr: array[1..1024] of longint;   {texture pointer inside texture}
  95.   Texture: P_LARGEBUFF;                 {texture data}
  96.   Buffer : P_LARGEBUFF;                 {data buffer: collides with Texture}
  97.  
  98. procedure MyHalt(err:ERRORS);
  99.   var i,j:integer;
  100.   begin
  101.     if InCheck>0 then begin
  102.       textattr:=LightRed;
  103.       gotoxy(2,InCheck);
  104.       writeln('x');
  105.     end;
  106.     textattr:=white;
  107.     clreol;
  108.     writeln;
  109.     if err=ERR_NONE then begin
  110.       writeln(DName,' succesfully created (',EndSize,' bytes).');
  111.       textattr:=lightgray;
  112.       writeln;
  113.       write('Now, to play any ');
  114.       j:=0;
  115.       for i:=DOOM to HERETIC do if (i<>Op_Mode) and (Path[i]<>'') then begin
  116.         if j=0 then j:=i
  117.         else write('/');
  118.         write(GNAMES[i]);
  119.       end;
  120.       writeln(' level simply include ',dname,' after -FILE.');
  121.       writeln('example: ',GNAMES[Op_Mode],' -FILE ',dname,' anywad.WAD');
  122.       writeln;
  123.       textattr:=yellow;
  124.       writeln('Remember to convert the wads with DM2CONV using the /GFX parameter');
  125.       textattr:=lightgray;
  126.       write('example: DM2CONV anywad /GFX @:');
  127.       writeln(GID[j],'TO',GID[Op_Mode]);
  128.       textattr:=lightgray;
  129.     end
  130.     else begin
  131.       write('Operation aborted');
  132.       case err of
  133.         ERR_USER_ESCAPE: writeln(' by user request!');
  134.         ERR_NOMEM      : writeln(': not enough memory!');
  135.         ERR_OPEN       : writeln(':'#13#10'Cannot open ',Why);
  136.         ERR_READ       : writeln(':'#13#10'Cannot read ',Why);
  137.         ERR_WRITE      : writeln(':'#13#10'Cannot write ',Why);
  138.         ERR_NOWAD      : writeln(':'#13#10'Not a valid wad ',Why);
  139.         ERR_NOPALETTE  : writeln(':'#13#10'Missing palette in ',Why);
  140.         ERR_NOTEX      : writeln(':'#13#10'Missing texture info in ',Why);
  141.       end;
  142.     end;
  143.     i:=wherey;
  144.     window(1,1,80,25);
  145.     textattr:=lightgray;
  146.     gotoxy(1,25);
  147.     clreol;
  148.     gotoxy(1,i+2);
  149.     Halt;
  150.   end;
  151.  
  152. var DOSAlloc_Size:longint;
  153. {Allocate a DOS memory block, return nil if not enough memory}
  154. {If size is 0, DOSAlloc_Size contains the largest block free }
  155. function DOSAlloc(size:longint):pointer; assembler;
  156.   asm
  157.     les bx, size
  158.     mov ax, es
  159.     mov word ptr DOSAlloc_Size, bx
  160.     mov word ptr DOSAlloc_Size+2, ax
  161.     add bx, 15
  162.     adc ax, 0
  163.     mov cx, 4
  164. @@LOOP1:
  165.     shr ax, 1
  166.     rcr bx, 1
  167.     loop @@LOOP1
  168.     cmp bx, 0
  169.     jne @@NOZERO
  170.     dec bx
  171. @@NOZERO:
  172.     mov ah, 48h
  173.     int 21h
  174.     jnc @@OK
  175.     xor ax, ax
  176.     mov cx, 4
  177. @@LOOP2:
  178.     shl bx, 1
  179.     rcl ax, 1
  180.     loop @@LOOP2
  181.     mov word ptr DOSAlloc_Size, bx
  182.     mov word ptr DOSAlloc_Size+2, ax
  183.     xor ax, ax
  184. @@OK:
  185.     xor dx, dx
  186.     xchg ax, dx
  187.   end;
  188.  
  189. procedure DOSFree(p:pointer); assembler;
  190.   asm
  191.     les bx, p
  192.     mov ah, 49h
  193.     int 21h
  194.   end;
  195.  
  196. function AddPointer(p:pointer;l:longint):pointer; assembler;
  197.   asm
  198.     les dx, l
  199.     mov ax, es
  200.     les bx, p
  201.     add bx, dx
  202.     adc ax, 0
  203.     mov cx, 4
  204. @@LOOP:
  205.     shr ax, 1
  206.     rcr bx, 1
  207.     rcr dx, 1
  208.     loop @@LOOP
  209.     shr dx, 12
  210.     mov ax, es
  211.     add ax, bx
  212.     xchg ax, dx
  213.   end;
  214.  
  215. procedure CheckAbort;
  216.   begin
  217.     if KeyPressed then case ReadKey of
  218.       #0: Readkey;
  219.       #27: MyHalt(ERR_USER_ESCAPE);
  220.     end;
  221.   end;
  222.  
  223. function IsDir(s:string):boolean;
  224.   var curdir:string;
  225.   begin
  226.     GetDir(0,curdir);
  227.     ChDir(s);
  228.     IsDir:=ioresult=0;
  229.     ChDir(curdir);
  230.     if ioresult<>0 then ;
  231.   end;
  232.  
  233. procedure Initialize;
  234.   var i:integer;
  235.   begin
  236.     textmode(CO80);
  237.     textattr:=blue*16+white;
  238.     gotoxy(1,1);
  239.     clreol;
  240.     write('GFXMAKER v3.1 by Vincenzo Alcamo (alcamo@arci01.bo.cnr.it) VERSION 950722':76);
  241.     gotoxy(1,25);
  242.     textattr:=lightgray*16+black;
  243.     clreol;
  244.     textattr:=lightgray*16+black;
  245.     write(' Press ');
  246.     textattr:=lightgray*16+red;
  247.     write('ESC');
  248.     textattr:=lightgray*16+black;
  249.     write(' at any time to abort program and return to DOS.');
  250.     window(1,3,80,24);
  251.     for i:=DOOM to DEST do Path[i]:='';
  252.     Dirlist[DEST]:=DOSAlloc(2000*sizeof(WAD_ENTRY));
  253.     if Dirlist[DEST]=nil then MyHalt(ERR_NOMEM);
  254.   end;
  255.  
  256. procedure Input(x,y:integer;var a:string;n:integer);
  257.   var
  258.     i,p  : integer;
  259.     c    : char;
  260.     done : boolean;
  261.   procedure del;
  262.     begin
  263.       dec(p);
  264.       delete(a,p,1);
  265.       gotoxy(x+p,y);
  266.       write(copy(a,p,n),#32);
  267.       gotoxy(x+p,y)
  268.     end;
  269.   begin
  270.     textattr:=red*16+yellow;
  271.     gotoxy(x,y);
  272.     write(#32:n+2);
  273.     gotoxy(x+1,y);
  274.     write(a);
  275.     p:=length(a)+1;
  276.     gotoxy(x+p,y);
  277.     done:=FALSE;
  278.     repeat
  279.       c:=UpCase(ReadKey);
  280.       case c of
  281.         #0 :
  282.           begin
  283.             c:=ReadKey;
  284.             case c of
  285.               #75 : if p>1 then dec(p);
  286.               #77 : if p<=length(a) then inc(p);
  287.               #71 : p:=1;
  288.               #79 : p:=length(a)+1;
  289.               #83 :
  290.                 if p<=length(a) then
  291.                   begin
  292.                     inc(p);
  293.                     del
  294.                   end
  295.               end;
  296.             gotoxy(x+p,y)
  297.           end;
  298.         #33..#96 :
  299.           if length(a)<n then
  300.             begin
  301.               if c='/' then c:='\';
  302.               insert(c,a,p);
  303.               gotoxy(x+p,y);
  304.               write(copy(a,p,n));
  305.               inc(p);
  306.               gotoxy(x+p,y)
  307.             end;
  308.         #8 : if p>1 then del;
  309.         #27 :
  310.           begin
  311.             p:=1;
  312.             gotoxy(x+p,y);
  313.             write(#32:length(a));
  314.             a:='';
  315.             gotoxy(x+p,y);
  316.             done:=true;
  317.           end;
  318.         #13 : done:=true
  319.         end
  320.     until done;
  321.     gotoxy(x,y);
  322.     writeln(#32,a,#32:n-length(a)+1)
  323.   end;
  324.  
  325. procedure AskDir(y:integer;a:string;var s:String;blank:boolean);
  326.   var flag : boolean;
  327.   begin
  328.     gotoxy(1,y);
  329.     textattr:=lightcyan;
  330.     write('  ',a,'.WAD');
  331.     flag:=False;
  332.     repeat
  333.       gotoxy(17,y+1);
  334.       textattr:=White;
  335.       if flag then begin
  336.         write('The path specified does not exist!');
  337.         clreol;
  338.         while not KeyPressed do ;
  339.         gotoxy(17,y+1);
  340.       end;
  341.       write(Why);
  342.       clreol;
  343.       input(16,y,s,60);
  344.       flag:=True;
  345.       if (s='') and not blank then MyHalt(ERR_USER_ESCAPE);
  346.     until (s='') or isdir(s);
  347.     if s='' then begin
  348.       gotoxy(16,y);
  349.       textattr:=white;
  350.       write(' *** NOT INCLUDED ***');
  351.       clreol;
  352.     end;
  353.     gotoxy(17,y+1);
  354.     textattr:=White;
  355.     clreol;
  356.   end;
  357.  
  358. function GameDir(prev:string):string;
  359.   var i:integer;
  360.   begin
  361.     if prev='' then prev:='C:\GAMES\';
  362.     i:=length(prev);
  363.     while (i>0) and (prev[i]<>':') and (prev[i]<>'\') do dec(i);
  364.     prev[0]:=chr(i);
  365.     GameDir:=prev;
  366.   end;
  367.  
  368. procedure AskParam;
  369.   const REQUIRED = 'This parameter is required!';
  370.         LEAVE = 'Leave this field blank if you convert only ';
  371.   var i,y:integer;
  372.       blank:boolean;
  373.   procedure writeline(i:integer);
  374.     begin
  375.       if Op_Mode=i then TextBackground(CYAN)
  376.       else TextBackground(BLACK);
  377.       gotoxy(3,wherey+i-1);
  378.       TextColor(WHITE);
  379.       case i of
  380.         HERETIC:
  381.           begin
  382.             write(' HERETIC');
  383.             TextColor(BLUE);
  384.             write(' - include graphics from [ULTIMATE] DOOM');
  385.           end;
  386.         DOOM2:
  387.           begin
  388.             write(' DOOM II');
  389.             TextColor(BLUE);
  390.             write(' - include graphics from [ULTIMATE] DOOM and/or HERETIC');
  391.           end;
  392.         DOOM:
  393.           begin
  394.             write(' DOOM/ULTIMATE DOOM');
  395.             TextColor(BLUE);
  396.             write(' - include graphics from DOOM II and/or HERETIC');
  397.           end;
  398.       end;
  399.       while wherex<>78 do write(#32);
  400.       gotoxy(1,wherey-i+1);
  401.     end;
  402.   begin
  403.     gotoxy(1,1);
  404.     textattr:=lightred;
  405.     writeln('  This program creates a patch wad file containing all the graphic resources');
  406.     writeln('  (textures/floors) of a set of games: [ULTIMATE] DOOM, DOOM II, HERETIC.');
  407.     writeln;
  408.     writeln('  You can choose to merge graphics from DOOM, DOOM II or HERETIC: registered');
  409.     writeln('  version of the selected games are required, original files are not changed.');
  410.     writeln;
  411.     writeln('  This wad will enable a game (DOOM/DOOM II/HERETIC) to use levels designed');
  412.     writeln('  for another game and converted by DM2CONV with the /GFX symbol.');
  413.     writeln('  Each game must have its own wad. ');
  414.     writeln;
  415.     textattr:=lightgreen;
  416.     write('  Choose target game:');
  417.     textattr:=green;
  418.     writeln(' (ESC quits, ENTER choose, ARROWS change selection)');
  419.     textattr:=0;
  420.     write('  ');
  421.     for i:=DOOM to HERETIC do writeline(i);
  422.     repeat
  423.       case ReadKey of
  424.         #27: begin
  425.                gotoxy(1,wherey+3);
  426.                MyHalt(ERR_USER_ESCAPE);
  427.              end;
  428.         #13: break;
  429.         #0: begin
  430.               i:=ord(ReadKey);
  431.               if (i=72) or (i=80) then begin
  432.                 y:=Op_Mode;
  433.                 if i=72 then
  434.                   if Op_Mode>DOOM then dec(Op_Mode) else Op_Mode:=HERETIC
  435.                 else if Op_Mode<HERETIC then inc(Op_Mode) else Op_Mode:=DOOM;
  436.                 writeline(y);
  437.                 writeline(Op_Mode);
  438.               end;
  439.             end
  440.       end;
  441.     until false;
  442.     y:=wherey+1;
  443.     gotoxy(1,wherey-Op_Mode+1);
  444.     writeline(Op_Mode);
  445.     gotoxy(1,y);
  446.     textattr:=LightGreen;
  447.     clreol;
  448.     writeln;
  449.     clreol;
  450.     writeln('  Please insert the full path for the following sources:');
  451.     y:=wherey;
  452.     blank:=Op_Mode=DOOM2;
  453.     if blank then Why:=LEAVE+'HERETIC''s wads'
  454.     else Why:=REQUIRED;
  455.     Path[DOOM]:=GameDir('')+GNAMES[DOOM];
  456.     AskDir(y,GNAMES[DOOM],Path[DOOM],blank);
  457.     inc(y);
  458.     if Op_Mode<>HERETIC then begin
  459.       blank:=Op_Mode=DOOM;
  460.       if blank then Why:=LEAVE+'HERETIC''s wads'
  461.       else Why:=REQUIRED;
  462.       Path[DOOM2]:=GameDir(Path[1])+GNAMES[DOOM2];
  463.       AskDir(y,GNAMES[DOOM2],Path[DOOM2],blank);
  464.       inc(y);
  465.       Path[HERETIC]:=GameDir(Path[DOOM2])+GNAMES[HERETIC];
  466.     end
  467.     else Path[HERETIC]:=GameDir(Path[DOOM])+GNAMES[HERETIC];
  468.     blank:=(Op_Mode<>HERETIC) and (Path[DOOM]<>'') and (Path[DOOM2]<>'');
  469.     if not blank then Why:=REQUIRED
  470.     else if Op_Mode=DOOM then Why:=LEAVE+'DOOM II''s wads'
  471.     else Why:=LEAVE+'DOOM''s wads';
  472.     AskDir(y,GNAMES[HERETIC],Path[HERETIC],blank);
  473.     inc(y);
  474.     gotoxy(1,y);
  475.     textattr:=LightGreen;
  476.     clreol;
  477.     inc(y);
  478.     gotoxy(3,y);
  479.     writeln('Please insert the full path for the destination:');
  480.     inc(y);
  481.     DName:='GFX'+GID[Op_Mode]+'_';
  482.     for i:=DOOM to HERETIC do if (i<>Op_Mode) and (Path[i]<>'') then
  483.       DName:=DName+GID[i];
  484.     Path[DEST]:=Path[Op_Mode];
  485.     case Op_Mode of
  486.       DOOM:
  487.         if path[DOOM2]='' then Why:='1,414'
  488.         else if path[HERETIC]='' then Why:='2,676'
  489.         else Why:='3,630';
  490.       DOOM2:
  491.         if path[DOOM]='' then Why:='1,744'
  492.         else if path[HERETIC]='' then Why:='545'
  493.         else Why:='2,103';
  494.       HERETIC:
  495.         Why:='3,304';
  496.     end;
  497.     Why:='You will need about '+Why+' Kbytes free in this directory.';
  498.     AskDir(y,DName,Path[DEST],False);
  499.   end;
  500.  
  501. procedure StartCheckmark;
  502.   begin
  503.     textattr:=lightgray;
  504.     write('[ ] ');
  505.     InCheck:=wherey;
  506.   end;
  507.  
  508. procedure EndCheckmark;
  509.   begin
  510.     CheckAbort;
  511.     gotoxy(2,incheck);
  512.     InCheck:=textattr;
  513.     textattr:=white;
  514.     writeln('√');
  515.     textattr:=InCheck;
  516.     InCheck:=0;
  517.   end;
  518.  
  519. procedure FSeek(start:longint;index:integer);
  520.   begin
  521.     Why:=Path[index];
  522.     if start>0 then begin
  523.       seek(Wadfile[index],start);
  524.       if ioresult<>0 then MyHalt(ERR_READ);
  525.       CheckAbort;
  526.     end;
  527.   end;
  528.  
  529. procedure BlockW(var p;size:longint);
  530.   var i,s:word;
  531.       t:pointer;
  532.   begin
  533.     Why:=Path[DEST];
  534.     t:=Addr(p);
  535.     while size>0 do begin
  536.       s:=65535-Ofs(t^);
  537.       if s>size then s:=size;
  538.       BlockWrite(Wadfile[DEST],t^,s,i);
  539.       if (ioresult<>0) or (s<>i) then MyHalt(ERR_WRITE);
  540.       dec(size,s);
  541.       t:=AddPointer(t,s);
  542.       CheckAbort;
  543.     end;
  544.   end;
  545.  
  546. procedure BlockR(start:longint;index:integer;var p;size:longint);
  547.   var i,s:word;
  548.       t:pointer;
  549.   begin
  550.     FSeek(start,index);
  551.     t:=Addr(p);
  552.     while size>0 do begin
  553.       s:=65535-Ofs(t^);
  554.       if s>size then s:=size;
  555.       BlockRead(Wadfile[index],t^,s,i);
  556.       if (ioresult<>0) or (s<>i) then MyHalt(ERR_READ);
  557.       dec(size,s);
  558.       t:=AddPointer(t,s);
  559.       CheckAbort;
  560.     end;
  561.   end;
  562.  
  563. function FPos:longint;
  564.   begin
  565.     Why:=Path[DEST];
  566.     FPos:=FilePos(Wadfile[DEST]);
  567.     if ioresult<>0 then MyHalt(ERR_WRITE);
  568.   end;
  569.  
  570. procedure OpenWAD(index:integer;name:string);
  571.   var h:WAD_HEADER;
  572.       i:word;
  573.   begin
  574.     Why:=Path[index]+'\'+name+'.WAD';
  575.     Path[index]:=Why;
  576.     StartCheckmark;
  577.     writeln('Opening ',Why);
  578.     assign(Wadfile[index],Why);
  579.     FileMode:=0;
  580.     reset(Wadfile[index],1);
  581.     if ioresult<>0 then MyHalt(ERR_OPEN);
  582.     BlockR(0,index,h,sizeof(WAD_HEADER));
  583.     if h.Sig<>IWAD_SIG then MyHalt(ERR_NOWAD);
  584.     Number[index]:=h.Num;
  585.     Dirlist[index]:=DOSAlloc(h.Num*sizeof(WAD_ENTRY));
  586.     if Dirlist[index]=nil then MyHalt(ERR_NOMEM);
  587.     BlockR(h.start,index,Dirlist[index]^,h.Num*sizeof(WAD_ENTRY));
  588.     EndCheckmark;
  589.   end;
  590.  
  591. function SearchEntry(index:integer;name:CHAR8):integer;
  592.   var i:integer;
  593.   begin
  594.     i:=Number[index];
  595.     while (i>0) and (Dirlist[index]^[i].Name<>name) do dec(i);
  596.     SearchEntry:=i;
  597.   end;
  598.  
  599. procedure ReadPalette(index:integer;var cmap:COLOR_MAP);
  600.   var i:integer;
  601.       l:longint;
  602.   begin
  603.     Why:=Path[index];
  604.     i:=SearchEntry(index,PLAYPAL);
  605.     if i=0 then MyHalt(ERR_NOPALETTE);
  606.     BlockR(Dirlist[index]^[i].Start,index,cmap,sizeof(COLOR_MAP));
  607.   end;
  608.  
  609. function LSqr(x:word):longint; assembler;
  610.   asm
  611.     mov ax, x
  612.     test ah, 80h
  613.     jz  @@POSITIVE
  614.     neg ax
  615. @@POSITIVE:
  616.     mul al
  617.     xor dx, dx
  618.   end;
  619.  
  620. procedure MakeRemapTable;
  621.   var c1,c2:COLOR_MAP;
  622.       i,j,k:integer;
  623.       r,g,b:word;
  624.       l,min:longint;
  625.   begin
  626.     StartCheckmark;
  627.     writeln('Reading palette information for colour remapping');
  628.     if Op_Mode=HERETIC then ReadPalette(DOOM,c1)
  629.     else ReadPalette(HERETIC,c1);
  630.     ReadPalette(Op_Mode,c2);
  631.     for i:=0 to 255 do begin
  632.       min:=MAXLONGINT;
  633.       r:=c1[i].Red;
  634.       g:=c1[i].Green;
  635.       b:=c1[i].Blue;
  636.       for j:=0 to 255 do begin
  637.         l:=LSqr(r-c2[j].Red)+LSqr(g-c2[j].Green)+LSqr(b-c2[j].Blue);
  638.         if l<min then begin
  639.           min:=l;
  640.           k:=j;
  641.           if min=0 then break;
  642.         end;
  643.       end;
  644.       CRemap[i]:=k;
  645.       CheckAbort;
  646.     end;
  647.     EndCheckmark;
  648.   end;
  649.  
  650. procedure MergeTexture(optn,otxn,otxs:integer);
  651. {optn=old patch number,otxn=old texture number,otxs=old texture size}
  652.   var i,j,k: integer;
  653.       offs : longint;
  654.       t    : P_TXINFO;
  655.       q    : pointer;
  656.       p    : P_PTINFO;
  657.   begin
  658.     {PATCH NAMES MERGING}
  659.     k:=optn;
  660.     for i:=optn+1 to NumPt do begin
  661.       j:=optn;
  662.       while (j>0) and (PtArray[j]<>PtArray[i]) do dec(j);
  663.       if j=0 then begin
  664.         inc(k);
  665.         PtArray[k]:=PtArray[i];
  666.         j:=k;
  667.       end;
  668.       PConv[i-optn-1]:=j-1;
  669.     end;
  670.     NumPt:=k;
  671.     {TEXTURE POINTER SORT}
  672.     j:=NumTx;
  673.     while j>1 do begin
  674.       k:=0;
  675.       for i:=1 to j-1 do if TextPtr[i]>TextPtr[i+1] then begin
  676.         k:=i;
  677.         offs:=TextPtr[i];
  678.         TextPtr[i]:=TextPtr[i+1];
  679.         TextPtr[i+1]:=offs;
  680.       end;
  681.       j:=k;
  682.     end;
  683.     {TEXTURE INFO MERGING}
  684.     TxSize:=otxs;
  685.     k:=otxn;
  686.     for i:=otxn+1 to NumTx do begin
  687.       t:=addr(Texture^[TextPtr[i]]);
  688.       j:=otxn;
  689.       while (j>0) and (P_TXINFO(addr(Texture^[TextPtr[j]]))^.Name<>t^.Name) do dec(j);
  690.       if j=0 then begin
  691.         inc(k);
  692.         TextPtr[k]:=TxSize;
  693.         q:=addr(Texture^[TxSize]);
  694.         Move(t^,q^,sizeof(TXINFO));
  695.         inc(TxSize,sizeof(TXINFO));
  696.         p:=AddPointer(t,sizeof(TXINFO));
  697.         for j:=1 to t^.num do begin
  698.           q:=addr(Texture^[TxSize]);
  699.           p^.Index:=PConv[p^.Index]; {convert PNAMES entries}
  700.           Move(p^,q^,sizeof(PTINFO));
  701.           p:=AddPointer(p,sizeof(PTINFO));
  702.           inc(TxSize,sizeof(PTINFO));
  703.         end;
  704.       end;
  705.     end;
  706.     NumTx:=k;
  707.   end;
  708.  
  709. procedure ReadTx(index:integer;txname:CHAR8);
  710.   var i,j:integer;
  711.       l,m:longint;
  712.   begin
  713.     i:=SearchEntry(index,txname);
  714.     if i=0 then MyHalt(ERR_NOTEX);
  715.     BlockR(Dirlist[index]^[i].Start,index,l,4);
  716.     BlockR(0,index,TextPtr[NumTx+1],l*4);
  717.     m:=TxSize-(l+1)*4;
  718.     for j:=NumTx+1 to NumTx+l do inc(TextPtr[j],m);
  719.     m:=Dirlist[index]^[i].Size-(l+1)*4;
  720.     BlockR(0,index,Texture^[TxSize],m);
  721.     inc(TxSize,m);
  722.     inc(NumTx,l);
  723.   end;
  724.  
  725. procedure ReadPNames(index:integer);
  726.   var i:integer;
  727.       l:longint;
  728.       optn,otxn,otxs:integer;
  729.   begin
  730.     otxs:=TxSize;
  731.     otxn:=NumTx;
  732.     optn:=NumPt;
  733.     StartCheckmark;
  734.     Why:=Path[index];
  735.     write('Reading ');
  736.     if index<>Op_Mode then write('and merging ');
  737.     writeln('textures from ',Path[index]);
  738.     i:=SearchEntry(index,PNAMES);
  739.     if i=0 then myhalt(ERR_NOTEX);
  740.     BlockR(Dirlist[index]^[i].Start,index,l,4);
  741.     BlockR(0,index,PtArray[NumPt+1],l*8);
  742.     inc(NumPt,l);
  743.     ReadTx(index,TEXTURE1);
  744.     if index<>DOOM2 then ReadTx(index,TEXTURE2);
  745.     if i<>Op_Mode then MergeTexture(optn,otxn,otxs);
  746.     EndCheckmark;
  747.   end;
  748.  
  749. procedure Remap(p:P_LARGEBUFF);
  750.   var cols:integer;
  751.       i,j :integer;
  752.       offs:longint;
  753.       t   :P_LARGEBUFF;
  754.   begin
  755.     if RemapPt then begin
  756.       cols:=P_WORD(p)^;
  757.       while cols>0 do begin
  758.         dec(cols);
  759.         offs:=P_LONG(AddPointer(p,cols*4+8))^;
  760.         t:=AddPointer(p,offs);
  761.         i:=0;
  762.         while t^[i]<255 do begin
  763.           j:=t^[i+1]+2;
  764.           inc(i,2);
  765.           while j>0 do begin
  766.             t^[i]:=CRemap[t^[i]];
  767.             inc(i);
  768.             dec(j);
  769.           end;
  770.         end;
  771.       end;
  772.     end
  773.     else for i:=0 to 4095 do p^[i]:=CRemap[p^[i]];
  774.   end;
  775.  
  776. const
  777.   BufferSize : longint = 0;
  778.   BufferPos  : longint = 0;
  779. procedure FlushBuffer;
  780.   begin
  781.     if BufferPos>0 then BlockW(Buffer^,BufferPos);
  782.     BufferPos:=0;
  783.   end;
  784. procedure ReadResource(var d:WAD_ENTRY);
  785.   var offs,len:Longint;
  786.       filenum:integer;
  787.   begin
  788.     filenum:=d.FNum;
  789.     d.FNum:=0;
  790.     offs:=d.Start;
  791.     len:=d.Size;
  792.     d.Start:=FPos+BufferPos;
  793.     if len>0 then begin
  794.       if BufferSize-BufferPos<len then FlushBuffer;
  795.       BlockR(offs,filenum,AddPointer(Buffer,BufferPos)^,len);
  796.       if ((Op_Mode=HERETIC) and (filenum<>HERETIC)) or
  797.          ((Op_Mode<>HERETIC) and (filenum=HERETIC)) then
  798.          Remap(AddPointer(Buffer,BufferPos));
  799.       inc(BufferPos,len);
  800.     end;
  801.   end;
  802.  
  803. procedure WriteWad;
  804.   var h   : WAD_HEADER;
  805.       i,j : integer;
  806.       l   : longint;
  807.       a,b : integer;
  808.       num : integer;
  809.       onum: integer;
  810.   procedure AddEntry(na:CHAR8;st,si:longint);
  811.     begin
  812.       inc(num);
  813.       with Dirlist[DEST]^[num] do begin
  814.         Name:=na;
  815.         Size:=si;
  816.         Start:=st;
  817.       end;
  818.     end;
  819.   procedure CopyResources(index,initial,final:integer);
  820.     var i,j:integer;
  821.         d:CHAR8;
  822.     begin
  823.       for i:=initial to final do with Dirlist[index]^[i] do begin
  824.         d:=Name;
  825.         if Size>0 then begin
  826.           j:=a;
  827.           while (j<=b) and (Dirlist[Op_Mode]^[j].Name<>d) do inc(j);
  828.           if j>b then begin
  829.             j:=onum;
  830.             while (j<=num) and (Dirlist[4]^[j].Name<>d) do inc(j);
  831.             if j>num then begin
  832.               inc(num);
  833.               Dirlist[DEST]^[num]:=Dirlist[index]^[i];
  834.               Dirlist[DEST]^[num].FNum:=index;
  835.             end;
  836.           end;
  837.         end;
  838.       end;
  839.     end;
  840.   procedure SaveResources;
  841.     var m : longint;
  842.         i : integer;
  843.         mx: longint;
  844.     begin
  845.       l:=0;
  846.       mx:=0;
  847.       for i:=onum to num do begin
  848.         m:=Dirlist[DEST]^[i].Size and $FFFFFF;
  849.         if m>mx then mx:=m;
  850.         inc(l,m+1);
  851.       end;
  852.       if mx>DOSAlloc_Size then MyHalt(ERR_NOMEM);
  853.       m:=0;
  854.       for i:=onum to num do begin
  855.         with Dirlist[DEST]^[i] do begin
  856.           inc(m,(Size and $FFFFFF)+1);
  857.           gotoxy(5,wherey);
  858.           write(Name,m*100 div l:6,'%');
  859.         end;
  860.         ReadResource(Dirlist[DEST]^[i]);
  861.       end;
  862.       gotoxy(1,wherey);
  863.       clreol;
  864.       EndCheckmark;
  865.     end;
  866.   begin
  867.     Why:=Path[4]+'\'+DName+'.WAD';
  868.     Path[DEST]:=Why;
  869.     StartCheckmark;
  870.     writeln('Creating ',Why);
  871.     assign(Wadfile[DEST],Why);
  872.     FileMode:=2;
  873.     rewrite(Wadfile[DEST],1);
  874.     if ioresult<>0 then MyHalt(ERR_WRITE);
  875.     h.Sig:=PWAD_SIG;
  876.     BlockW(h,sizeof(h));
  877.  
  878.     num:=0;
  879.     AddEntry(PNAMES,FPos,4+NumPt*8);
  880.     l:=NumPt;
  881.     BlockW(l,4);
  882.     BlockW(PtArray,NumPt*8);
  883.  
  884.     j:=NumTx*4+4;
  885.     for i:=1 to NumTx do inc(TextPtr[i],j);
  886.     AddEntry(TEXTURE1,FPos,4+NumTx*4+TxSize);
  887.     l:=NumTx;
  888.     BlockW(l,4);
  889.     BlockW(TextPtr,NumTx*4);
  890.     BlockW(Texture^,TxSize);
  891.  
  892.     if Op_Mode<>DOOM2 then begin {DUMMY TEXTURE2}
  893.       AddEntry(TEXTURE2,FPos,sizeof(DUMMY_TEXTURE));
  894.       BlockW(DUMMY_TEXTURE,sizeof(DUMMY_TEXTURE));
  895.     end;
  896.     EndCheckmark;
  897.  
  898.     onum:=num+1;
  899.     StartCheckmark;
  900.     if path[HERETIC]<>'' then writeln('Converting and adding patches')
  901.     else writeln('Adding patches');
  902.     a:=SearchEntry(Op_Mode,P_START)+1;
  903.     b:=SearchEntry(Op_Mode,P_END)-1;
  904.     AddEntry(P_START,0,0);
  905.     AddEntry(P1_START,0,0);
  906.     for i:=DOOM to HERETIC do if (i<>Op_Mode) and (path[i]<>'') then
  907.       CopyResources(i,SearchEntry(i,P_START),SearchEntry(i,P_END));
  908.     AddEntry(P1_END,0,0);
  909.     AddEntry(P_END,0,0);
  910.     SaveResources;
  911.  
  912.     if (Op_Mode<>DOOM2) or (Path[HERETIC]<>'') then begin
  913.       onum:=num+1;
  914.       RemapPt:=False;
  915.       StartCheckmark;
  916.       writeln('Converting and adding floors');
  917.       a:=1;
  918.       b:=0;
  919.       AddEntry(F_START,0,0);
  920.       AddEntry(F1_START,0,0);
  921.       CopyResources(Op_Mode,SearchEntry(Op_Mode,F_START),SearchEntry(Op_Mode,F_END));
  922.       for i:=DOOM to HERETIC do if (i<>Op_Mode) and (Path[i]<>'') then
  923.         CopyResources(i,SearchEntry(i,F_START),SearchEntry(i,F_END));
  924.       AddEntry(F1_END,0,0);
  925.       AddEntry(F_END,0,0);
  926.       SaveResources;
  927.     end;
  928.     FlushBuffer;
  929.  
  930.     StartCheckmark;
  931.     writeln('Writing directory structure');
  932.     h.Start:=FPos;
  933.     h.Num:=num;
  934.     BlockW(Dirlist[DEST]^,num*sizeof(WAD_ENTRY));
  935.     EndSize:=FPos;
  936.     seek(Wadfile[DEST],0);
  937.     if ioresult<>0 then MyHalt(ERR_WRITE);
  938.     BlockW(h,sizeof(h));
  939.     EndCheckmark;
  940.   end;
  941.  
  942. procedure Process;
  943.   var i:integer;
  944.   begin
  945.     textattr:=lightgray;
  946.     clrscr;
  947.     for i:=DOOM to HERETIC do
  948.       if Path[i]<>'' then OpenWAD(i,GNAMES[i]);
  949.     if Path[HERETIC]<>'' then MakeRemapTable;
  950.     Texture:=DOSAlloc(0);
  951.     if DOSAlloc_Size<MAXMEMBLOCK then MyHalt(ERR_NOMEM);
  952.     Texture:=DOSAlloc(DOSAlloc_Size);
  953.     if Texture=nil then MyHalt(ERR_NOMEM);
  954.     Buffer:=Texture;
  955.     BufferSize:=DOSAlloc_size;
  956.     ReadPNames(Op_Mode);
  957.     for i:=DOOM to HERETIC do if (i<>Op_Mode) and (Path[i]<>'') then ReadPNames(i);
  958.     WriteWad;
  959.   end;
  960.  
  961. begin
  962.   Initialize;
  963.   AskParam;
  964.   Process;
  965.   MyHalt(ERR_NONE);
  966. end.
  967.