home *** CD-ROM | disk | FTP | other *** search
/ Home Edutainment Collection 4: Games & Extensions / Aztech-HomeEdutainmentCollection-Vol4-3DGamesExtensions.iso / wc / gfxmaker.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-05-24  |  25.3 KB  |  944 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.0 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.0 - Written by Vincenzo Alcamo':60);
  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.   begin
  374.     gotoxy(1,1);
  375.     textattr:=lightred;
  376.     writeln('  This program creates a patch wad file containing all the graphic resources');
  377.     writeln('  (textures/floors) of a set of games: DOOM, DOOM II, HERETIC.');
  378.     writeln;
  379.     writeln('  You can choose to merge graphics from DOOM, DOOM II or HERETIC: registered');
  380.     writeln('  version of the selected games are required, original files are not changed.');
  381.     writeln;
  382.     writeln('  This wad will enable a game (DOOM/DOOM II/HERETIC) to use levels designed');
  383.     writeln('  for another game and converted by DM2CONV with the /GFX symbol.');
  384.     writeln('  Each game must have its own wad. ');
  385.     writeln;
  386.     textattr:=lightgreen;
  387.     write('  Choose the target game:');
  388.     textattr:=green;
  389.     writeln(' (ESC quits, ENTER choose, any other key to toggle)');
  390.     repeat
  391.       textattr:=white;
  392.       case Op_Mode of
  393.         HERETIC:
  394.           begin
  395.             write('  HERETIC');
  396.             textattr:=lightgray;
  397.             write(' - include graphics from DOOM');
  398.           end;
  399.         DOOM2:
  400.           begin
  401.             write('  DOOM II');
  402.             textattr:=lightgray;
  403.             write(' - include graphics from DOOM and/or HERETIC');
  404.           end;
  405.         DOOM:
  406.           begin
  407.             write('  DOOM');
  408.             textattr:=lightgray;
  409.             write(' - include graphics from DOOM II and/or HERETIC');
  410.           end;
  411.       end;
  412.       clreol;
  413.       gotoxy(1,wherey);
  414.       case ReadKey of
  415.         #27: MyHalt(ERR_USER_ESCAPE);
  416.         #13: break;
  417.         #0: ReadKey;
  418.       end;
  419.       inc(Op_Mode);
  420.       if Op_Mode=DEST then Op_Mode:=DOOM;
  421.     until false;
  422.     writeln;
  423.     writeln;
  424.     y:=wherey;
  425.     gotoxy(1,y);
  426.     textattr:=LightGreen;
  427.     writeln('  Please insert the full path for the following sources:');
  428.     inc(y);
  429.     blank:=Op_Mode=DOOM2;
  430.     if blank then Why:=LEAVE+'HERETIC''s wads'
  431.     else Why:=REQUIRED;
  432.     Path[DOOM]:=GameDir('')+GNAMES[DOOM];
  433.     AskDir(y,GNAMES[DOOM],Path[DOOM],blank);
  434.     inc(y);
  435.     if Op_Mode<>HERETIC then begin
  436.       blank:=Op_Mode=DOOM;
  437.       if blank then Why:=LEAVE+'HERETIC''s wads'
  438.       else Why:=REQUIRED;
  439.       Path[DOOM2]:=GameDir(Path[1])+GNAMES[DOOM2];
  440.       AskDir(y,GNAMES[DOOM2],Path[DOOM2],blank);
  441.       inc(y);
  442.       Path[HERETIC]:=GameDir(Path[DOOM2])+GNAMES[HERETIC];
  443.     end
  444.     else Path[HERETIC]:=GameDir(Path[DOOM])+GNAMES[HERETIC];
  445.     blank:=(Op_Mode<>HERETIC) and (Path[DOOM]<>'') and (Path[DOOM2]<>'');
  446.     if not blank then Why:=REQUIRED
  447.     else if Op_Mode=DOOM then Why:=LEAVE+'DOOM II''s wads'
  448.     else Why:=LEAVE+'DOOM''s wads';
  449.     AskDir(y,GNAMES[HERETIC],Path[HERETIC],blank);
  450.     inc(y);
  451.     gotoxy(1,y);
  452.     textattr:=LightGreen;
  453.     clreol;
  454.     inc(y);
  455.     gotoxy(3,y);
  456.     writeln('Please insert the full path for the destination:');
  457.     inc(y);
  458.     DName:='GFX'+GID[Op_Mode]+'_';
  459.     for i:=DOOM to HERETIC do if (i<>Op_Mode) and (Path[i]<>'') then
  460.       DName:=DName+GID[i];
  461.     Path[DEST]:=Path[Op_Mode];
  462.     case Op_Mode of
  463.       DOOM:
  464.         if path[DOOM2]='' then Why:='1,414'
  465.         else if path[HERETIC]='' then Why:='2,676'
  466.         else Why:='3,630';
  467.       DOOM2:
  468.         if path[DOOM]='' then Why:='1,744'
  469.         else if path[HERETIC]='' then Why:='545'
  470.         else Why:='2,103';
  471.       HERETIC:
  472.         Why:='3,304';
  473.     end;
  474.     Why:='You will need about '+Why+' Kbytes free in this directory.';
  475.     AskDir(y,DName,Path[DEST],False);
  476.   end;
  477.  
  478. procedure StartCheckmark;
  479.   begin
  480.     textattr:=lightgray;
  481.     write('[ ] ');
  482.     InCheck:=wherey;
  483.   end;
  484.  
  485. procedure EndCheckmark;
  486.   begin
  487.     CheckAbort;
  488.     gotoxy(2,incheck);
  489.     InCheck:=textattr;
  490.     textattr:=white;
  491.     writeln('√');
  492.     textattr:=InCheck;
  493.     InCheck:=0;
  494.   end;
  495.  
  496. procedure FSeek(start:longint;index:integer);
  497.   begin
  498.     Why:=Path[index];
  499.     if start>0 then begin
  500.       seek(Wadfile[index],start);
  501.       if ioresult<>0 then MyHalt(ERR_READ);
  502.       CheckAbort;
  503.     end;
  504.   end;
  505.  
  506. procedure BlockW(var p;size:longint);
  507.   var i,s:word;
  508.       t:pointer;
  509.   begin
  510.     Why:=Path[DEST];
  511.     t:=Addr(p);
  512.     while size>0 do begin
  513.       s:=65535-Ofs(t^);
  514.       if s>size then s:=size;
  515.       BlockWrite(Wadfile[DEST],t^,s,i);
  516.       if (ioresult<>0) or (s<>i) then MyHalt(ERR_WRITE);
  517.       dec(size,s);
  518.       t:=AddPointer(t,s);
  519.       CheckAbort;
  520.     end;
  521.   end;
  522.  
  523. procedure BlockR(start:longint;index:integer;var p;size:longint);
  524.   var i,s:word;
  525.       t:pointer;
  526.   begin
  527.     FSeek(start,index);
  528.     t:=Addr(p);
  529.     while size>0 do begin
  530.       s:=65535-Ofs(t^);
  531.       if s>size then s:=size;
  532.       BlockRead(Wadfile[index],t^,s,i);
  533.       if (ioresult<>0) or (s<>i) then MyHalt(ERR_READ);
  534.       dec(size,s);
  535.       t:=AddPointer(t,s);
  536.       CheckAbort;
  537.     end;
  538.   end;
  539.  
  540. function FPos:longint;
  541.   begin
  542.     Why:=Path[DEST];
  543.     FPos:=FilePos(Wadfile[DEST]);
  544.     if ioresult<>0 then MyHalt(ERR_WRITE);
  545.   end;
  546.  
  547. procedure OpenWAD(index:integer;name:string);
  548.   var h:WAD_HEADER;
  549.       i:word;
  550.   begin
  551.     Why:=Path[index]+'\'+name+'.WAD';
  552.     Path[index]:=Why;
  553.     StartCheckmark;
  554.     writeln('Opening ',Why);
  555.     assign(Wadfile[index],Why);
  556.     FileMode:=0;
  557.     reset(Wadfile[index],1);
  558.     if ioresult<>0 then MyHalt(ERR_OPEN);
  559.     BlockR(0,index,h,sizeof(WAD_HEADER));
  560.     if h.Sig<>IWAD_SIG then MyHalt(ERR_NOWAD);
  561.     Number[index]:=h.Num;
  562.     Dirlist[index]:=DOSAlloc(h.Num*sizeof(WAD_ENTRY));
  563.     if Dirlist[index]=nil then MyHalt(ERR_NOMEM);
  564.     BlockR(h.start,index,Dirlist[index]^,h.Num*sizeof(WAD_ENTRY));
  565.     EndCheckmark;
  566.   end;
  567.  
  568. function SearchEntry(index:integer;name:CHAR8):integer;
  569.   var i:integer;
  570.   begin
  571.     i:=Number[index];
  572.     while (i>0) and (Dirlist[index]^[i].Name<>name) do dec(i);
  573.     SearchEntry:=i;
  574.   end;
  575.  
  576. procedure ReadPalette(index:integer;var cmap:COLOR_MAP);
  577.   var i:integer;
  578.       l:longint;
  579.   begin
  580.     Why:=Path[index];
  581.     i:=SearchEntry(index,PLAYPAL);
  582.     if i=0 then MyHalt(ERR_NOPALETTE);
  583.     BlockR(Dirlist[index]^[i].Start,index,cmap,sizeof(COLOR_MAP));
  584.   end;
  585.  
  586. function LSqr(x:word):longint; assembler;
  587.   asm
  588.     mov ax, x
  589.     test ah, 80h
  590.     jz  @@POSITIVE
  591.     neg ax
  592. @@POSITIVE:
  593.     mul al
  594.     xor dx, dx
  595.   end;
  596.  
  597. procedure MakeRemapTable;
  598.   var c1,c2:COLOR_MAP;
  599.       i,j,k:integer;
  600.       r,g,b:word;
  601.       l,min:longint;
  602.   begin
  603.     StartCheckmark;
  604.     writeln('Reading palette information for colour remapping');
  605.     if Op_Mode=HERETIC then ReadPalette(DOOM,c1)
  606.     else ReadPalette(HERETIC,c1);
  607.     ReadPalette(Op_Mode,c2);
  608.     for i:=0 to 255 do begin
  609.       min:=MAXLONGINT;
  610.       r:=c1[i].Red;
  611.       g:=c1[i].Green;
  612.       b:=c1[i].Blue;
  613.       for j:=0 to 255 do begin
  614.         l:=LSqr(r-c2[j].Red)+LSqr(g-c2[j].Green)+LSqr(b-c2[j].Blue);
  615.         if l<min then begin
  616.           min:=l;
  617.           k:=j;
  618.           if min=0 then break;
  619.         end;
  620.       end;
  621.       CRemap[i]:=k;
  622.       CheckAbort;
  623.     end;
  624.     EndCheckmark;
  625.   end;
  626.  
  627. procedure MergeTexture(optn,otxn,otxs:integer);
  628. {optn=old patch number,otxn=old texture number,otxs=old texture size}
  629.   var i,j,k: integer;
  630.       offs : longint;
  631.       t    : P_TXINFO;
  632.       q    : pointer;
  633.       p    : P_PTINFO;
  634.   begin
  635.     {PATCH NAMES MERGING}
  636.     k:=optn;
  637.     for i:=optn+1 to NumPt do begin
  638.       j:=optn;
  639.       while (j>0) and (PtArray[j]<>PtArray[i]) do dec(j);
  640.       if j=0 then begin
  641.         inc(k);
  642.         PtArray[k]:=PtArray[i];
  643.         j:=k;
  644.       end;
  645.       PConv[i-optn-1]:=j-1;
  646.     end;
  647.     NumPt:=k;
  648.     {TEXTURE POINTER SORT}
  649.     j:=NumTx;
  650.     while j>1 do begin
  651.       k:=0;
  652.       for i:=1 to j-1 do if TextPtr[i]>TextPtr[i+1] then begin
  653.         k:=i;
  654.         offs:=TextPtr[i];
  655.         TextPtr[i]:=TextPtr[i+1];
  656.         TextPtr[i+1]:=offs;
  657.       end;
  658.       j:=k;
  659.     end;
  660.     {TEXTURE INFO MERGING}
  661.     TxSize:=otxs;
  662.     k:=otxn;
  663.     for i:=otxn+1 to NumTx do begin
  664.       t:=addr(Texture^[TextPtr[i]]);
  665.       j:=otxn;
  666.       while (j>0) and (P_TXINFO(addr(Texture^[TextPtr[j]]))^.Name<>t^.Name) do dec(j);
  667.       if j=0 then begin
  668.         inc(k);
  669.         TextPtr[k]:=TxSize;
  670.         q:=addr(Texture^[TxSize]);
  671.         Move(t^,q^,sizeof(TXINFO));
  672.         inc(TxSize,sizeof(TXINFO));
  673.         p:=AddPointer(t,sizeof(TXINFO));
  674.         for j:=1 to t^.num do begin
  675.           q:=addr(Texture^[TxSize]);
  676.           p^.Index:=PConv[p^.Index]; {convert PNAMES entries}
  677.           Move(p^,q^,sizeof(PTINFO));
  678.           p:=AddPointer(p,sizeof(PTINFO));
  679.           inc(TxSize,sizeof(PTINFO));
  680.         end;
  681.       end;
  682.     end;
  683.     NumTx:=k;
  684.   end;
  685.  
  686. procedure ReadTx(index:integer;txname:CHAR8);
  687.   var i,j:integer;
  688.       l,m:longint;
  689.   begin
  690.     i:=SearchEntry(index,txname);
  691.     if i=0 then MyHalt(ERR_NOTEX);
  692.     BlockR(Dirlist[index]^[i].Start,index,l,4);
  693.     BlockR(0,index,TextPtr[NumTx+1],l*4);
  694.     m:=TxSize-(l+1)*4;
  695.     for j:=NumTx+1 to NumTx+l do inc(TextPtr[j],m);
  696.     m:=Dirlist[index]^[i].Size-(l+1)*4;
  697.     BlockR(0,index,Texture^[TxSize],m);
  698.     inc(TxSize,m);
  699.     inc(NumTx,l);
  700.   end;
  701.  
  702. procedure ReadPNames(index:integer);
  703.   var i:integer;
  704.       l:longint;
  705.       optn,otxn,otxs:integer;
  706.   begin
  707.     otxs:=TxSize;
  708.     otxn:=NumTx;
  709.     optn:=NumPt;
  710.     StartCheckmark;
  711.     Why:=Path[index];
  712.     write('Reading ');
  713.     if index<>Op_Mode then write('and merging ');
  714.     writeln('textures from ',Path[index]);
  715.     i:=SearchEntry(index,PNAMES);
  716.     if i=0 then myhalt(ERR_NOTEX);
  717.     BlockR(Dirlist[index]^[i].Start,index,l,4);
  718.     BlockR(0,index,PtArray[NumPt+1],l*8);
  719.     inc(NumPt,l);
  720.     ReadTx(index,TEXTURE1);
  721.     if index<>DOOM2 then ReadTx(index,TEXTURE2);
  722.     if i<>Op_Mode then MergeTexture(optn,otxn,otxs);
  723.     EndCheckmark;
  724.   end;
  725.  
  726. procedure Remap(p:P_LARGEBUFF);
  727.   var cols:integer;
  728.       i,j :integer;
  729.       offs:longint;
  730.       t   :P_LARGEBUFF;
  731.   begin
  732.     if RemapPt then begin
  733.       cols:=P_WORD(p)^;
  734.       while cols>0 do begin
  735.         dec(cols);
  736.         offs:=P_LONG(AddPointer(p,cols*4+8))^;
  737.         t:=AddPointer(p,offs);
  738.         i:=0;
  739.         while t^[i]<255 do begin
  740.           j:=t^[i+1]+2;
  741.           inc(i,2);
  742.           while j>0 do begin
  743.             t^[i]:=CRemap[t^[i]];
  744.             inc(i);
  745.             dec(j);
  746.           end;
  747.         end;
  748.       end;
  749.     end
  750.     else for i:=0 to 4095 do p^[i]:=CRemap[p^[i]];
  751.   end;
  752.  
  753. const
  754.   BufferSize : longint = 0;
  755.   BufferPos  : longint = 0;
  756. procedure FlushBuffer;
  757.   begin
  758.     if BufferPos>0 then BlockW(Buffer^,BufferPos);
  759.     BufferPos:=0;
  760.   end;
  761. procedure ReadResource(var d:WAD_ENTRY);
  762.   var offs,len:Longint;
  763.       filenum:integer;
  764.   begin
  765.     filenum:=d.FNum;
  766.     d.FNum:=0;
  767.     offs:=d.Start;
  768.     len:=d.Size;
  769.     d.Start:=FPos+BufferPos;
  770.     if len>0 then begin
  771.       if BufferSize-BufferPos<len then FlushBuffer;
  772.       BlockR(offs,filenum,AddPointer(Buffer,BufferPos)^,len);
  773.       if ((Op_Mode=HERETIC) and (filenum<>HERETIC)) or
  774.          ((Op_Mode<>HERETIC) and (filenum=HERETIC)) then
  775.          Remap(AddPointer(Buffer,BufferPos));
  776.       inc(BufferPos,len);
  777.     end;
  778.   end;
  779.  
  780. procedure WriteWad;
  781.   var h   : WAD_HEADER;
  782.       i,j : integer;
  783.       l   : longint;
  784.       a,b : integer;
  785.       num : integer;
  786.       onum: integer;
  787.   procedure AddEntry(na:CHAR8;st,si:longint);
  788.     begin
  789.       inc(num);
  790.       with Dirlist[DEST]^[num] do begin
  791.         Name:=na;
  792.         Size:=si;
  793.         Start:=st;
  794.       end;
  795.     end;
  796.   procedure CopyResources(index,initial,final:integer);
  797.     var i,j:integer;
  798.         d:CHAR8;
  799.     begin
  800.       for i:=initial to final do with Dirlist[index]^[i] do begin
  801.         d:=Name;
  802.         if Size>0 then begin
  803.           j:=a;
  804.           while (j<=b) and (Dirlist[Op_Mode]^[j].Name<>d) do inc(j);
  805.           if j>b then begin
  806.             j:=onum;
  807.             while (j<=num) and (Dirlist[4]^[j].Name<>d) do inc(j);
  808.             if j>num then begin
  809.               inc(num);
  810.               Dirlist[DEST]^[num]:=Dirlist[index]^[i];
  811.               Dirlist[DEST]^[num].FNum:=index;
  812.             end;
  813.           end;
  814.         end;
  815.       end;
  816.     end;
  817.   procedure SaveResources;
  818.     var m : longint;
  819.         i : integer;
  820.         mx: longint;
  821.     begin
  822.       l:=0;
  823.       mx:=0;
  824.       for i:=onum to num do begin
  825.         m:=Dirlist[DEST]^[i].Size and $FFFFFF;
  826.         if m>mx then mx:=m;
  827.         inc(l,m+1);
  828.       end;
  829.       if mx>DOSAlloc_Size then MyHalt(ERR_NOMEM);
  830.       m:=0;
  831.       for i:=onum to num do begin
  832.         with Dirlist[DEST]^[i] do begin
  833.           inc(m,(Size and $FFFFFF)+1);
  834.           gotoxy(5,wherey);
  835.           write(Name,m*100 div l:6,'%');
  836.         end;
  837.         ReadResource(Dirlist[DEST]^[i]);
  838.       end;
  839.       gotoxy(1,wherey);
  840.       clreol;
  841.       EndCheckmark;
  842.     end;
  843.   begin
  844.     Why:=Path[4]+'\'+DName+'.WAD';
  845.     Path[DEST]:=Why;
  846.     StartCheckmark;
  847.     writeln('Creating ',Why);
  848.     assign(Wadfile[DEST],Why);
  849.     FileMode:=2;
  850.     rewrite(Wadfile[DEST],1);
  851.     if ioresult<>0 then MyHalt(ERR_WRITE);
  852.     h.Sig:=PWAD_SIG;
  853.     BlockW(h,sizeof(h));
  854.  
  855.     num:=0;
  856.     AddEntry(PNAMES,FPos,4+NumPt*8);
  857.     l:=NumPt;
  858.     BlockW(l,4);
  859.     BlockW(PtArray,NumPt*8);
  860.  
  861.     j:=NumTx*4+4;
  862.     for i:=1 to NumTx do inc(TextPtr[i],j);
  863.     AddEntry(TEXTURE1,FPos,4+NumTx*4+TxSize);
  864.     l:=NumTx;
  865.     BlockW(l,4);
  866.     BlockW(TextPtr,NumTx*4);
  867.     BlockW(Texture^,TxSize);
  868.  
  869.     if Op_Mode<>DOOM2 then begin {DUMMY TEXTURE2}
  870.       AddEntry(TEXTURE2,FPos,sizeof(DUMMY_TEXTURE));
  871.       BlockW(DUMMY_TEXTURE,sizeof(DUMMY_TEXTURE));
  872.     end;
  873.     EndCheckmark;
  874.  
  875.     onum:=num+1;
  876.     StartCheckmark;
  877.     if path[HERETIC]<>'' then writeln('Converting and adding patches')
  878.     else writeln('Adding patches');
  879.     a:=SearchEntry(Op_Mode,P_START)+1;
  880.     b:=SearchEntry(Op_Mode,P_END)-1;
  881.     AddEntry(P_START,0,0);
  882.     AddEntry(P1_START,0,0);
  883.     for i:=DOOM to HERETIC do if (i<>Op_Mode) and (path[i]<>'') then
  884.       CopyResources(i,SearchEntry(i,P_START),SearchEntry(i,P_END));
  885.     AddEntry(P1_END,0,0);
  886.     AddEntry(P_END,0,0);
  887.     SaveResources;
  888.  
  889.     if (Op_Mode<>DOOM2) or (Path[HERETIC]<>'') then begin
  890.       onum:=num+1;
  891.       RemapPt:=False;
  892.       StartCheckmark;
  893.       writeln('Converting and adding floors');
  894.       a:=1;
  895.       b:=0;
  896.       AddEntry(F_START,0,0);
  897.       AddEntry(F1_START,0,0);
  898.       CopyResources(Op_Mode,SearchEntry(Op_Mode,F_START),SearchEntry(Op_Mode,F_END));
  899.       for i:=DOOM to HERETIC do if (i<>Op_Mode) and (Path[i]<>'') then
  900.         CopyResources(i,SearchEntry(i,F_START),SearchEntry(i,F_END));
  901.       AddEntry(F1_END,0,0);
  902.       AddEntry(F_END,0,0);
  903.       SaveResources;
  904.     end;
  905.     FlushBuffer;
  906.  
  907.     StartCheckmark;
  908.     writeln('Writing directory structure');
  909.     h.Start:=FPos;
  910.     h.Num:=num;
  911.     BlockW(Dirlist[DEST]^,num*sizeof(WAD_ENTRY));
  912.     EndSize:=FPos;
  913.     seek(Wadfile[DEST],0);
  914.     if ioresult<>0 then MyHalt(ERR_WRITE);
  915.     BlockW(h,sizeof(h));
  916.     EndCheckmark;
  917.   end;
  918.  
  919. procedure Process;
  920.   var i:integer;
  921.   begin
  922.     textattr:=lightgray;
  923.     clrscr;
  924.     for i:=DOOM to HERETIC do
  925.       if Path[i]<>'' then OpenWAD(i,GNAMES[i]);
  926.     if Path[HERETIC]<>'' then MakeRemapTable;
  927.     Texture:=DOSAlloc(0);
  928.     if DOSAlloc_Size<MAXMEMBLOCK then MyHalt(ERR_NOMEM);
  929.     Texture:=DOSAlloc(DOSAlloc_Size);
  930.     if Texture=nil then MyHalt(ERR_NOMEM);
  931.     Buffer:=Texture;
  932.     BufferSize:=DOSAlloc_size;
  933.     ReadPNames(Op_Mode);
  934.     for i:=DOOM to HERETIC do if (i<>Op_Mode) and (Path[i]<>'') then ReadPNames(i);
  935.     WriteWad;
  936.   end;
  937.  
  938. begin
  939.   Initialize;
  940.   AskParam;
  941.   Process;
  942.   MyHalt(ERR_NONE);
  943. end.
  944.