program raw2hm3;

uses crt;
var f,f2:file;
    per,c,cf,cb,m,b,mx,mn:byte;
    map:array[0..15] of shortint;
    buf:array[0..7] of byte;
    pal:array[0..255] of record r,g,b:byte;end;
    n:longint;
    s,s2:string;

procedure clear_map;
var ww:byte;
begin
 for ww:=0 to 15 do
  map[ww]:=0;
end;

procedure find_color(var xx,zz:byte);
var ww,olx,oln:byte;
begin
 zz:=0;
 xx:=0;
 olx:=0;
 oln:=0;
 for ww:=0 to 15 do
  begin
   if (map[ww]>olx) then
    begin
     xx:=ww;
     olx:=map[ww];
    end;
   if ((map[ww]>oln) and (ww<>xx)) then
    begin
     zz:=ww;
     oln:=map[ww];
    end;
  end;
end;

function byte_map:byte;
var ww,aa:byte;
    qq:word;
begin
 aa:=0;
 qq:=1;
 for ww:=7 downto 0 do
  begin
   if (buf[ww]=mx) then aa:=aa+qq;
   qq:=qq*2;
  end;
 byte_map:=aa;
end;

begin
 per:=255;
 clrscr;
 s:=paramstr(1);
 s2:=copy(s,1,length(s)-3)+'hm3';
 assign(f,s);reset(f,1);
 assign(f2,s2);rewrite(f2,1);
 s:='HM3THI1';
 blockwrite(f2,s[1],7);
 blockread(f,pal[0],768);
 blockwrite(f2,pal[0],48);
 n:=0;
 repeat
  if n mod 2560=0 then
   begin
    inc(per);
    write('Processing... ',per,'%',#13);
   end;
  clear_map;
  for m:=0 to 7 do
   begin
    blockread(f,c,1);
    buf[m]:=c;
    inc(map[c]);
   end;
  find_color(mx,mn);
  b:=byte_map;
{  if mx>=4 then mn:=mx else
  if mn>=4 then mx:=mn;}
  if ((mn=0)) then mn:=7; {comment}
  c:=mx+mn*16;
  if c=119 then c:=247;{comment}
  blockwrite(f2,b,1);
  blockwrite(f2,c,1);
  n:=n+8;
 until n>=256000;
 close(f2);
 close(f)
end.

    Source: geocities.com/~franzglaser/tpsrc

               ( geocities.com/~franzglaser)