home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / MAGAZINE / MISC / PCTV1N2.ZIP / VGAMIXER.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-06-07  |  7.6 KB  |  297 lines
  1. PROGRAM VgaColorMixer;
  2. { Michael A. Covington 1990 }
  3.  
  4. USES Crt,Dos;
  5.  
  6. CONST  Quality: ARRAY[1..5] OF String[12] =
  7.         ('Redness','Greenness','Blueness','Saturation','Intensity');
  8.  
  9. CONST
  10.   C: INTEGER = 1;   { Color being edited   }
  11.   Q: INTEGER = 1;   { Quality being edited  }
  12.  
  13.   R: ARRAY[1..3] OF REAL = (63.05,  0,  0);   { Red component }
  14.   G: ARRAY[1..3] OF REAL = ( 0, 63.05,  0);   { Green component }
  15.   B: ARRAY[1..3] OF REAL = ( 0,  0, 63.05);   { Blue component }
  16.  
  17.  
  18. PROCEDURE SetRgbPalette(ColorNum,Red,Green,Blue:INTEGER);
  19.   { Like the SetRgbPalette procedure provided
  20.     in GRAPH.TPU, but does not require .BGI files.
  21.     Copy and use in your own programs. }
  22. VAR
  23.    R: Registers;
  24. BEGIN
  25.    R.ax := $1010;
  26.    R.bx := ColorNum;
  27.    R.dh := Red;
  28.    R.ch := Green;
  29.    R.cl := Blue;
  30.    Intr($10,R)
  31. END;
  32.  
  33. PROCEDURE HideCursor;
  34.   { For VGA and most others. Undone by textmode(co80). }
  35. VAR
  36.    R: Registers;
  37. BEGIN
  38.    R.cx := $2000;  { Start cursor on scan line $20, end on $00 }
  39.    R.ah := 1;      { i.e., end it before it starts }
  40.    Intr($10,R)
  41. END;
  42.  
  43.  
  44. PROCEDURE Block(Left,Upper,Right,Lower,Color: INTEGER);
  45. VAR
  46.   Row, Col: INTEGER;
  47. BEGIN
  48.   TextColor(Color);
  49.   FOR Row := Upper TO Lower DO
  50.     FOR Col := Left TO Right DO
  51.       BEGIN
  52.         GoToXY(Col,Row); write(#219)
  53.       END;
  54.   TextColor(White);
  55. END;
  56.  
  57. PROCEDURE Box(Left,Upper,Right,Lower,Color: INTEGER);
  58. BEGIN
  59.   Block(Left,Upper,Left,Lower,Color);
  60.   Block(Right,Upper,Right,Lower,Color);
  61.   Block(Left,Upper,Right,Upper,Color);
  62.   Block(Left,Lower,Right,Lower,Color)
  63. END;
  64.  
  65. PROCEDURE WriteCentered(Msg:String;Row,Color:INTEGER);
  66. BEGIN
  67.   GoToXY(40-(length(Msg) div 2),Row);
  68.   write(Msg)
  69. END;
  70.  
  71. PROCEDURE WriteInverse(Msg:String);
  72. BEGIN
  73.   TextBackground(White);
  74.   TextColor(Black);
  75.   write(Msg);
  76.   TextColor(White);
  77.   TextBackground(Black)
  78. END;
  79.  
  80. PROCEDURE UpdateColors;
  81.   { Updates just those parts of the screen that change }
  82.   { when the user alters a color quality }
  83. VAR
  84.   j, red, green, blue: INTEGER;
  85.  
  86. BEGIN
  87.  
  88.   SetRgbPalette(4,round(R[C]),round(G[C]),round(B[C]));
  89.     { Color 4 will always be the color currently being edited }
  90.  
  91.   FOR j:=1 TO 3 DO
  92.     BEGIN
  93.       SetRgbPalette(j,round(R[j]),round(G[j]),round(B[j]));
  94.  
  95.       { Label the colors }
  96.  
  97.       TextColor(White);
  98.       GoToXY(20*j-3,9);
  99.       IF j=C THEN
  100.         WriteInverse('Color '+chr(ord('0')+j))
  101.       ELSE
  102.         write('Color '+chr(ord('0')+j));
  103.  
  104.       GoToXY(20*j-7,7);
  105.       IF j=C THEN
  106.         TextColor(White)
  107.       ELSE
  108.         TextColor(LightGray);
  109.       Write(  'R=',round(R[j]):2,
  110.             '  G=',round(G[j]):2,
  111.             '  B=',round(B[j]):2);
  112.  
  113.     END;
  114.  
  115.   { Update the menu of qualities }
  116.  
  117.   TextBackground(Black); TextColor(White);
  118.   GoToXY(11,19);
  119.   FOR j:=1 TO 5 DO
  120.     BEGIN
  121.       IF j=Q THEN
  122.         WriteInverse(Quality[j])
  123.       ELSE
  124.         Write(Quality[j]);
  125.       Write('    ')
  126.     END
  127.  
  128.  
  129. END;
  130.  
  131.  
  132. PROCEDURE UpdateScreen;
  133. VAR
  134.   j,k: INTEGER;
  135. BEGIN
  136.   TextMode(Co80); { Clears screen and resets colors }
  137.   HideCursor;
  138.   UpdateColors;
  139.  
  140.   Box(1,1,80,21,DarkGray);
  141.   WriteCentered('V G A   C o l o r   M i x e r',3,White);
  142.   WriteCentered('TAB chooses color to edit',22,White);
  143.   WriteCentered(
  144.         #$1B + ' ' + #$1A + ' choose a quality to alter',
  145.                 23,White);
  146.   WriteCentered(
  147.         #$18 + ' increases and ' + #$19 + ' decreases that quality',
  148.                 24,White);
  149.   WriteCentered('Alt-X ends program',25,White);
  150.  
  151.   { Color swatches }
  152.  
  153.   Block(11,5,29,6,1);
  154.   Block(31,5,49,6,2);
  155.   Block(51,5,69,6,3);
  156.  
  157.   { Large patch of the color currently being edited }
  158.   Block(11,11,69,15,4);
  159.  
  160.   { Text samples }
  161.  
  162.   GoToXY(10,17);
  163.   FOR j:=1 to 3 DO
  164.       FOR k:=1 TO 3 DO
  165.         IF j<>k THEN
  166.           BEGIN
  167.             TextBackground(Black); Write(' ');
  168.             TextBackground(j);
  169.             TextColor(k);
  170.             Write('  ',k,' on ',j,' ')
  171.           END;
  172.   TextBackground(Black);
  173.  
  174. END;
  175.  
  176.  
  177. FUNCTION Min(X,Y,Z:REAL):REAL;
  178. BEGIN
  179.   IF X<Y THEN
  180.     { Minimum is not Y }
  181.     IF X<Z THEN Min:=X ELSE Min:=Z
  182.   ELSE
  183.     { Minimum is not X }
  184.     IF Y<Z THEN Min:=Y ELSE Min:=Z
  185. END;
  186.  
  187. FUNCTION Max(X,Y,Z:REAL):REAL;
  188. BEGIN
  189.   IF X>Y THEN
  190.     { Maximum is not Y }
  191.     IF X>Z THEN Max:=X ELSE Max:=Z
  192.   ELSE
  193.     { Maximum is not X }
  194.     IF Y>Z THEN Max:=Y ELSE Max:=Z
  195. END;
  196.  
  197.  
  198. { Main }
  199.  
  200. VAR
  201.   Keys: string;
  202.   Top, Factor: real;
  203.  
  204. BEGIN
  205.  UpdateScreen;
  206.  Keys := '';
  207.  WHILE TRUE DO
  208.  BEGIN
  209.   IF Keys = '' then Keys := ReadKey;
  210.   CASE Keys[1] OF
  211.     #09 : { Tab }
  212.              BEGIN
  213.                C := C MOD 3 + 1;
  214.                UpdateColors
  215.              END;
  216.     #27 : { First byte of any non-ASCII key }
  217.              { do nothing };
  218.     #72 : { Up arrow }
  219.              BEGIN
  220.                CASE Q OF
  221.                  1: IF R[C]<62.5 THEN R[C] := R[C]+1;
  222.                  2: IF G[C]<62.5 THEN G[C] := G[C]+1;
  223.                  3: IF B[C]<62.5 THEN B[C] := B[C]+1;
  224.                  4: { Up saturation }
  225.                     BEGIN
  226.                       Top  := Max(R[C],G[C],B[C]);
  227.                       IF Min(R[C],G[C],B[C]) > 0.5 THEN
  228.                         BEGIN
  229.                           Factor := (Top-Min(R[C],G[C],B[C]));
  230.                           IF Factor > 0 THEN
  231.                             BEGIN
  232.                               Factor := 1/Factor;
  233.                               R[C] := R[C] + Factor*(R[C] - Top);
  234.                               G[C] := G[C] + Factor*(G[C] - Top);
  235.                               B[C] := B[C] + Factor*(B[C] - Top)
  236.                             END
  237.                         END
  238.                     END;
  239.                  5: { Up intensity  }
  240.                     IF Max(R[C],G[C],B[C])<62.5 THEN
  241.                       BEGIN
  242.                         R[C] := R[C]*1.01;
  243.                         G[C] := G[C]*1.01;
  244.                         B[C] := B[C]*1.01
  245.                       END
  246.                END;
  247.                UpdateColors
  248.              END;
  249.     #73 : { PgUp = five Up Arrows }
  250.              Keys := Keys[1]+#72+#72+#72+#72+#72+copy(Keys,2,255);
  251.     #80 : { Down arrow }
  252.              BEGIN
  253.                CASE Q OF
  254.                  1: IF R[C]>=0.5 THEN R[C] := R[C]-1;
  255.                  2: IF G[C]>=0.5 THEN G[C] := G[C]-1;
  256.                  3: IF B[C]>=0.5 THEN B[C] := B[C]-1;
  257.                  4: { Down saturation }
  258.                     BEGIN
  259.                       Top  := Max(R[C],G[C],B[C]);
  260.                       IF (Top-Min(R[C],G[C],B[C])) > 0.5 THEN
  261.                         BEGIN
  262.                           Factor := 1/Abs(Top-Min(R[C],G[C],B[C]));
  263.                           R[C] := R[C] - Factor*(R[C] - Top);
  264.                           G[C] := G[C] - Factor*(G[C] - Top);
  265.                           B[C] := B[C] - Factor*(B[C] - Top)
  266.                         END
  267.                     END;
  268.                  5: { Down intensity  }
  269.                     BEGIN
  270.                       R[C]:=R[C]*0.99;
  271.                       G[C]:=G[C]*0.99;
  272.                       B[C]:=B[C]*0.99
  273.                     END
  274.                END;
  275.                UpdateColors
  276.              END;
  277.     #81 : { PgDn = five Down Arrows }
  278.              Keys := Keys[1]+#80+#80+#80+#80+#80+copy(Keys,2,255);
  279.     #75 : { Left arrow }
  280.              BEGIN
  281.                IF Q > 1 THEN Dec(Q);
  282.                UpdateColors
  283.              END;
  284.     #77 : { Right arrow }
  285.              BEGIN
  286.                IF Q < 5 THEN Inc(Q);
  287.                UpdateColors
  288.              END;
  289.     #45 : { Alt-X }
  290.              BEGIN
  291.                TextMode(Co80); { Reset colors }
  292.                Halt
  293.              END
  294.   END {Case};
  295.  Delete(Keys,1,1); { Eat the keystroke that was just acted on }
  296.  END
  297. END.