home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / KABLOO.ZIP / COLOUR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-06-19  |  5.8 KB  |  231 lines
  1. UNIT colour;
  2.  
  3. INTERFACE
  4.  
  5. TYPE
  6.     color=RECORD        { A palette 'cell' }
  7.         r,g,b: byte
  8.     END;
  9.     palette=ARRAY[0..255] OF color;   { a complete, 256-color palette }
  10.  
  11. CONST
  12.     background=0; { index of palette corresponding to background }
  13.     black:      color=(r: 0;  g: 0;  b: 0 ); { list of standard colors }
  14.     grey10:     color=(r: 6;  g: 6;  b: 6 );
  15.     grey20:     color=(r: 13; g: 13; b: 13); { grayscale -- percentages }
  16.     grey30:     color=(r: 19; g: 19; b: 19);
  17.     grey40:     color=(r: 25; g: 25; b: 25);
  18.     grey50:     color=(r: 32; g: 32; b: 32);
  19.     grey60:     color=(r: 38; g: 38; b: 38);
  20.     grey70:     color=(r: 45; g: 45; b: 45);
  21.     grey80:     color=(r: 51; g: 51; b: 51);
  22.     grey90:     color=(r: 57; g: 57; b: 57);
  23.     white:      color=(r: 63; g: 63; b: 63); { maximum intensity }
  24.     red:        color=(r: 63; g: 0;  b: 0 ); { primary colors }
  25.     green:      color=(r: 0;  g: 63; b: 0 );
  26.     blue:       color=(r: 0;  g: 0;  b: 63);
  27.     yellow:     color=(r: 63; g: 63; b: 0 ); { secondary colors }
  28.     cyan:       color=(r: 0;  g: 63; b: 63);
  29.     purple:     color=(r: 63; g: 0;  b: 63);
  30.     orange:     color=(r: 63; g: 32; b: 0 ); { tertiary colors }
  31.     chartreuse: color=(r: 32; g: 63; b: 0 ); { quite uncommon... }
  32.     jade:       color=(r: 0;  g: 63; b: 32);
  33.     robin:      color=(r: 0;  g: 32; b: 63);
  34.     periwinkle: color=(r: 32; g: 0;  b: 63);
  35.     magenta:    color=(r: 63; g: 0;  b: 32); { not typical, but accurate }
  36.  
  37.     color16map: ARRAY[0..15] OF byte =
  38.     (0,1,2,3,4,5,20,7,56,57,58,59,60,61,62,63);
  39.  
  40.     { AssignColor -- sets color INDEX to C }
  41. PROCEDURE AssignColor(index: byte; c: color);
  42.     { SetColors -- mass version of AssignColor...
  43.      Sets n colors, starting at index I and location C in palette P }
  44. PROCEDURE Assign16Color(index: byte; c: color);
  45. PROCEDURE SetColors(p: palette; i,c: byte; n: word);
  46.     { Loads a FractINT-style .MAP file into a palette
  47.      fn is the filename, p is the palette to place it in }
  48. PROCEDURE Set16Colors(p: palette; i,c: byte; n: word);
  49. PROCEDURE LoadColors(fn: STRING; VAR p: palette);
  50.     { Saves a FractINT-style .MAP file from a palette
  51.      fn is the filename, p is the palette to place it in }
  52. PROCEDURE SaveColors(fn: STRING; p: palette);
  53.     { Sets an element by red, green, and blue components...
  54.      c=color to set, r,g,b are % components 0-100 }
  55. PROCEDURE SetRGB(VAR c: color; r,g,b: byte);
  56.     { Sets color by Hue, Saturation, Intensity scale,
  57.      c=color to set, h=hue 0-360, s=saturation 0-100 (100=pure, 0=grey)
  58.      i=intensity 0-100 (0=black, 100=max) }
  59. PROCEDURE SetHSI(VAR c: color; h: word; s,i: byte);
  60.     { Returns the red, green, and blue components,
  61.      c=color to get, r,g,b=red, green, and blue returns }
  62. PROCEDURE GetRGB(c: color; VAR r,g,b: byte);
  63.     { Averages two colors, weighted with percentages.
  64.      p=resulting color
  65.      c1,c2=colors to mix
  66.      p1,p2=percentages of each color. }
  67. PROCEDURE Mix(VAR p,c1: color; p1: byte; c2: color; p2: byte);
  68.     { Rather an odd procedure...
  69.      p=resulting color
  70.      c=color to alter
  71.      t=color to tint c with
  72.      pt=percentage of tint }
  73. PROCEDURE Tint(VAR p: color; c,t: color);
  74.     { Gets the intensity of a color }
  75. FUNCTION Intensity(c: color): byte;
  76.     { Sets the contrast of a color c by pt relative to grey }
  77. PROCEDURE Contrast(VAR p: color; c: color; pt: byte);
  78.     { Uses mix to average over a selection of colors in a palette }
  79. PROCEDURE Range(VAR p: palette; i1,i2: byte);
  80.     { Sets overscan border color to c }
  81. PROCEDURE SetBorder(c: byte);
  82.  
  83. IMPLEMENTATION
  84.  
  85. USES DOS;
  86.  
  87. VAR
  88.     r: Registers;
  89.  
  90. PROCEDURE AssignColor;
  91. BEGIN
  92.     r.ax:=$1010;
  93.     r.bh:=0;
  94.     r.bl:=index;
  95.     r.dh:=c.r;
  96.     r.ch:=c.g;
  97.     r.cl:=c.b;
  98.     intr($10,r)
  99. END;
  100.  
  101. PROCEDURE Assign16Color;
  102. BEGIN
  103.     r.ax:=$1010;
  104.     r.bh:=0;
  105.     r.bl:=color16map[index];
  106.     r.dh:=c.r;
  107.     r.ch:=c.g;
  108.     r.cl:=c.b;
  109.     intr($10,r)
  110. END;
  111.  
  112. PROCEDURE SetColors;
  113. BEGIN
  114.     r.ax:=$1012;
  115.     r.bh:=0;
  116.     r.bl:=c;
  117.     r.cx:=n;
  118.     r.es:=Seg(p);
  119.     r.dx:=Ofs(p[0])+i*3;
  120.     intr($10,r)
  121. END;
  122.  
  123. PROCEDURE Set16Colors;
  124. VAR t: Palette;
  125.      j: integer;
  126. BEGIN
  127.     FOR j:=1 TO n DO
  128.         t[color16map[j+c-1]]:=p[j+i-1];
  129.     SetColors(t,color16map[i],color16map[c],color16map[c+n-1]-color16map[c]+1)
  130. END;
  131.  
  132. {$I-}
  133. PROCEDURE LoadColors;
  134. VAR f: Text;
  135.      i,r,g,b: byte;
  136. BEGIN
  137.     Assign(f,fn);
  138.     Reset(f);
  139.     FOR i:=0 TO 255 DO
  140.     BEGIN
  141.         readln(f,r,g,b);
  142.         p[i].r:=r div 4;
  143.         p[i].g:=g div 4;
  144.         p[i].b:=b div 4
  145.     END;
  146.     Close(f)
  147. END;
  148.  
  149. PROCEDURE SaveColors(fn: STRING; p: palette);
  150. VAR f: Text;
  151.      i: byte;
  152. BEGIN
  153.     Assign(f,fn);
  154.     Rewrite(f);
  155.     FOR i:=0 TO 255 DO
  156.         writeln(f,p[i].r*4,p[i].g*4,p[i].b*4);
  157.     Close(f)
  158. END;
  159. {$I+}
  160.  
  161. PROCEDURE SetRGB;
  162. BEGIN
  163.     c.r:=r*63 div 100;  { rather simple, really -- just convert % into }
  164.     c.g:=g*63 div 100;  { BIOS mapping 0-63 }
  165.     c.b:=b*63 div 100
  166. END;
  167.  
  168. PROCEDURE GetRGB;
  169. BEGIN
  170.     r:=c.r*100 div 63;
  171.     g:=c.g*100 div 63;
  172.     b:=c.b*100 div 63
  173. END;
  174.  
  175. PROCEDURE SetHSI;
  176. { Completely self-explanatory, in my opinion }
  177. VAR r,g,b,t: real;
  178. BEGIN
  179.     t:=Pi*H/180;
  180.     r:=1+s/100*sin(t-2*pi/3);
  181.     g:=1+s/100*sin(t);
  182.     b:=1+s/100*sin(t+2*pi/3);
  183.     t:=63.999*i/200;
  184.     c.r:=trunc(r*t);
  185.     c.g:=trunc(g*t);
  186.     c.b:=trunc(b*t)
  187. END;
  188.  
  189. PROCEDURE Mix;
  190. BEGIN
  191.     p.r:=(c1.r*p1+c2.r*p2) div 100; { just do a weighted average }
  192.     p.g:=(c1.g*p1+c2.g*p2) div 100;
  193.     p.b:=(c1.b*p1+c2.b*p2) div 100
  194. END;
  195.  
  196. PROCEDURE Tint;
  197. BEGIN
  198.     p.r:=c.r*t.r div 63;   { brings out components, really }
  199.     p.g:=c.g*t.g div 63;
  200.     p.b:=c.b*t.b div 63
  201. END;
  202.  
  203. FUNCTION Intensity;
  204. BEGIN
  205.     Intensity:=(c.r+c.g+c.b)*100 div 191 { really dumb function }
  206. END;
  207.  
  208. PROCEDURE Contrast;
  209. VAR i: byte;
  210. BEGIN
  211.     i:=Intensity(c)*63 div 100;
  212.     p.r:=c.r+(i-c.r)*pt div 100;  { just moves away/closer to grey }
  213.     p.g:=c.g+(i-c.g)*pt div 100;
  214.     p.b:=c.b+(i-c.b)*pt div 100
  215. END;
  216.  
  217. PROCEDURE Range;
  218. VAR i: byte;
  219. BEGIN
  220.     FOR i:=i1 TO i2 DO { simple averaging loop }
  221.         Mix(p[i],p[i1],(i2-i)*100 div (i2-i1),p[i2],(i-i1)*100 div (i2-i1))
  222. END;
  223.  
  224. PROCEDURE SetBorder;
  225. BEGIN
  226.     r.ax:=$1001;
  227.     r.bh:=c;
  228.     intr($10,r);
  229. END;
  230.  
  231. END.