home *** CD-ROM | disk | FTP | other *** search
/ The Party 1994: Try This At Home / disk_image.bin / source / gallery / subdirs.exe / COLOR / PAL2.PAS < prev    next >
Pascal/Delphi Source File  |  1994-06-15  |  4KB  |  191 lines
  1. uses dos;
  2.  
  3. type
  4.    HLSREGISTER = record
  5.       HUE, LIGHTNESS, SATURATION : real
  6.    end;
  7.  
  8.    RGBregister = record
  9.       red, green, blue : byte
  10.    end;
  11.  
  12.  
  13.  
  14. function MAXIMUM (A, B, C : REAL): real;
  15.  
  16.    begin
  17.       if A > B then
  18.          if A > C then
  19.             MAXIMUM := A
  20.          else
  21.             MAXIMUM := C
  22.       else
  23.          if B > C then
  24.             MAXIMUM := B
  25.          else
  26.             MAXIMUM := C
  27.    end;
  28.  
  29.  
  30. function MINIMUM (A, B, C : REAL): real;
  31.  
  32.    begin
  33.       if A < B then
  34.          if A < C then
  35.             MINIMUM := A
  36.          else
  37.             MINIMUM := C
  38.       else
  39.          if B < C then
  40.             MINIMUM := B
  41.          else
  42.             MINIMUM := C
  43.    end;
  44.  
  45.  
  46.  
  47.  
  48. const ProHead : array[0..7] of byte = (8,3,0,0,$23,$b1,0,0);
  49.  
  50. const SpecialColor : array[0..15] of RGBregister =
  51.       ((red:   0;  green:   0; blue:   0),
  52.        (red:   0;  green:   0; blue:   0),
  53.        (red:   0;  green:   0; blue:   0),
  54.        (red:   0;  green:   0; blue:   0),
  55.        (red:   0;  green:   0; blue:   0),
  56.        (red:   0;  green:   0; blue:   0),
  57.        (red:   0;  green:   0; blue:   0),
  58.        (red:   0;  green:   0; blue:   0),
  59.        (red:   0;  green:   0; blue:   0),
  60.        (red:   0;  green:   0; blue:   0),
  61.        (red:   0;  green:   0; blue:   0),
  62.        (red:   0;  green:   0; blue:   0),
  63.        (red:   0;  green:   0; blue:   0),
  64.        (red:   0;  green:   0; blue:   0),
  65.        (red:   0;  green:   0; blue:   0),
  66.        (red:   0;  green:   0; blue:   0) );
  67.  
  68. var
  69.     N : String;
  70.     I : Text;
  71.     F1: File;
  72.     F2: Text;
  73.     Palette : array[0..15,0..15] of RGBRegister;
  74.  
  75.     k,j : integer;
  76.  
  77.     RGBr : RGBregister;
  78.     HLSr : HLSregister;
  79.  
  80.     s,r,g,b : real;
  81.  
  82.     AAPro : Boolean;
  83.     Max64 : Boolean;
  84.  
  85. procedure ParseParms;
  86. var i : integer;
  87.     s : string;
  88. begin
  89.   if ParamCount=0 then exit;
  90.   for i := 1 to ParamCount do begin
  91.      s := ParamStr(i);
  92.      if (s = '/p') or ((N<>'') and (s='p')) then
  93.         AAPro := True
  94.      else
  95.      if (s = '/v') or ((N<>'') and (s='v')) then
  96.         Max64 := True
  97.      else
  98.      if N='' then N := s;
  99.   end;
  100. end;
  101.  
  102.  
  103. begin
  104.   writeln('PALETTE creator  //  A.R-M. 7/93.');
  105.  
  106.   N := '';
  107.   Max64 := False;
  108.   AAPro := False;
  109.   ParseParms;
  110.  
  111.   if not AAPro then
  112.     writeln('Use /p to create Animator Pro 1.0 version .COL files.');
  113.   if not Max64 then
  114.     writeln('Use /v to create 0..3f palette (default 0..ff).');
  115.  
  116.   writeln;
  117.  
  118.   if N='' then begin
  119.     write ('Input file name: '); readln( N );
  120.     writeln;
  121.   end;{ else N := ParamStr(1);}
  122.  
  123.   assign(I, N); reset(I);
  124.  
  125.   writeln('Reading "',N,'"...'); writeln;
  126.  
  127.   for k := 0 to 15 do begin
  128.     readln(I, r,g,b);
  129.     writeln('  color ',k:2,', r=',r:7:4,'  g=',g:7:4,'  b=',b:7:4 );
  130.  
  131.     s := MAXIMUM(r,g,b); if s=0 then s := 1;
  132.  
  133.     with RGBr do begin
  134.        red := round(r/s*63);
  135.        green := round(g/s*63);
  136.        blue := round(b/s*63);
  137.     end;
  138.  
  139.     Palette[k,0] := SpecialColor[k];
  140.     for j := 1 to 15 do with Palette[k,j] do begin
  141.       s := {sqr}((j-1)/14);
  142.       red := round(RGBr.red*s);
  143.       green := round(RGBr.green*s);
  144.       blue := round(RGBr.blue*s);
  145.     end;
  146.  
  147.   end;
  148.  
  149.   close(I);
  150.  
  151.  
  152.   assign(F2,'PALETTE.INC'); rewrite(F2);
  153.  
  154.   writeln(F2,'; Palette created from "',N,'"');
  155.   writeln(F2,'; Use RADIX 10');
  156.   writeln(F2);
  157.  
  158.   for k := 0 to 255 do begin
  159.     with Palette[k div 16, k mod 16] do
  160.       write(F2,'    DB   ',red:3,',',green:3,',',blue:3);
  161.     if (k mod 16)=0 then writeln(F2,'   ; color ',k div 16) else writeln(F2);
  162.   end;
  163.  
  164.   close(F2);
  165.  
  166.   if not Max64 then
  167.   begin
  168.   asm
  169.     mov cx,3*256
  170.     mov si, offset Palette
  171. @1:
  172.     mov al,[si]
  173.     shl al,1
  174.     shl al,1
  175.     mov [si],al
  176.     inc si
  177.     loop @1
  178.   end;
  179.   end;
  180.  
  181.   assign(F1,'PALETTE.COL'); rewrite(F1,1);
  182.     if AAPro then blockwrite(F1, ProHead, SizeOf(ProHead) );
  183.     blockwrite(F1, Palette, SizeOf(Palette) );
  184.   close(F1);
  185.  
  186.   writeln;
  187.   writeln('PALETTE.COL and PALETTE.INC files successfully created.');
  188.  
  189. end.
  190.  
  191.