home *** CD-ROM | disk | FTP | other *** search
/ The Party 1994: Try This At Home / disk_image.bin / source / gallery / subdirs.exe / TEXTURE / GPIX2BIN.PAS < prev    next >
Pascal/Delphi Source File  |  1993-07-21  |  3KB  |  139 lines
  1. {$N+,G+}
  2. uses dos;
  3.  
  4. {$IFOPT N+} type real = single; {$ENDIF}
  5.  
  6. const TexRes = 128;
  7.  
  8. Type
  9.    PIX = array[0..199,0..319] of byte;
  10.    BIN = array[0..TexRes-1,0..TexRes-1] of byte;
  11.    hue = (red, green, blue);
  12.    rgb = array[hue] of byte;
  13.  
  14.    Palette = array[0..255] of rgb;
  15.  
  16.  
  17. { Fits palette taking into account human eye sensitivity: }
  18.  
  19. const                           { 1, 4.59, 0.061 }
  20.    hueFac : array[hue] of real = (1, 1, 1);
  21.  
  22. procedure SetRGBblock  ( first : byte; number : word; var RGB ); assembler;
  23. asm
  24.   push ds
  25.   lds si, RGB       { ds:si -> palette }
  26.   mov ax, number
  27.   mov cx, ax        { cx = count }
  28.   shl cx, 1
  29.   add cx, ax        { cx = count*3  (total RGB bytes) }
  30.   mov al, first
  31.   mov dx, $3c8
  32.   out dx, al
  33.   inc dx
  34.   rep outsb
  35.   pop ds
  36. end;
  37.  
  38.  
  39. var I, O : File;
  40.     N : string;
  41.  
  42.     SrcPal, DestPal : Palette;
  43.  
  44.     Xlate : array[0..255] of byte;
  45.  
  46.     c : byte;
  47.     B : BIN;
  48.     P : ^PIX;
  49.  
  50.     k,j : integer;
  51.  
  52.     ImWidth, ImHeight : integer;
  53.  
  54. procedure fitpalette;
  55. var bestcol : byte;
  56.     besterr, err : real;
  57.     i,j : byte;
  58.     h : hue;
  59.     r : rgb;
  60. begin
  61.   for j := 0 to 255 do begin
  62.     r := SrcPal[j];
  63.     bestcol := 0;
  64.     besterr := sqr(64)*3+1;
  65.     for i := 0 to 255 do if ((i mod 16)<>0) or (i=0) then begin
  66.       err := 0;
  67.       for h := red to blue do
  68.         err := err + sqr( integer(r[h])-DestPal[i,h] )*hueFac[h];
  69.       if err < besterr then begin
  70.         besterr := err;
  71.         bestcol := i
  72.       end;
  73.     end;
  74.     Xlate[j] := bestcol;
  75.     SetRGBblock( j, 1, DestPal[bestcol] );
  76.   end;
  77. end;
  78.  
  79. procedure value( var w : integer; s : string );
  80. var v,i : integer;
  81. begin
  82.   val(s, v, i);
  83.   if i=0 then w := v;
  84. end;
  85.  
  86. begin
  87.   writeln('PIX2BIN converter (for BINOBJ.EXE)  //  A.R-M. 7/93.');
  88.   writeln;
  89.  
  90.   GetMem( P, SizeOf(PIX) );
  91.  
  92.   if ParamCount<1 then begin
  93.     write ('.PIX file name: '); readln( N );
  94.     writeln;
  95.   end else N := ParamStr(1);
  96.  
  97.   ImWidth := 320;
  98.   ImHeight := 200;
  99.   if ParamCount>=2 then Value(ImWidth, ParamStr(2));
  100.   if ParamCount>=3 then Value(ImHeight, ParamStr(3));
  101.  
  102.   assign(I,N+'.PAL'); reset(I,1);
  103.   blockread( I, SrcPal, SizeOf(SrcPal) );
  104.   close(I);
  105.  
  106.   assign(I,'PIX2BIN.PAL'); reset(I,1);
  107.   blockread( I, DestPal, SizeOf(DestPal) );
  108.   close(I);
  109.  
  110.   assign(I, N+'.PIX'); reset(I,1);
  111.   blockread( I, P^, SizeOf(P^) );
  112.   close(I);
  113.  
  114.   asm
  115.     mov ax,$13
  116.     int $10
  117.   end;
  118.   Move( P^, ptr($a000,0000)^, 320*200 );
  119.   SetRGBblock( 0,255,SrcPal );
  120.  
  121.   FitPalette;
  122.  
  123.   for j := 0 to TexRes-1 do begin
  124.    for k := 0 to TexRes-1 do begin
  125.      c := P^[ round(k/(TexRes-1)*(ImHeight-1)), round(j/(TexRes-1)*(ImWidth-1)) ];
  126.      B[j,k] := Xlate[c];
  127.    end;
  128.   end;
  129.  
  130.   assign( O, N+'.BIN'); rewrite(O,1);
  131.   blockwrite( O, B, SizeOf(B) );
  132.   close(O);
  133.  
  134.   FreeMem( P, SizeOf(P^) );
  135.  
  136. end.
  137.  
  138.  
  139.