home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / dc / edit256.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-04-11  |  8.7 KB  |  300 lines
  1. {
  2.   Copyright 1992 by Digital Crime.
  3.  
  4.   All rights reserved.
  5.  
  6.   Permission to use, copy, modify, and distribute this software and its
  7.   documentation for any purpose and without fee is hereby granted,
  8.   provided that the above copyright notice appear in all copies and that
  9.   both that copyright notice and this permission notice appear in
  10.   supporting documentation, and that the name of the Digital Crime
  11.   not be used in advertising or publicity pertaining to distribution
  12.   of the software without specific, written  prior permission.
  13.  
  14.   DIGITAL CRIME DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS
  15.   SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
  16.   AND FITNESS, IN NO EVENT SHALL DIGITAL CRIME BE LIABLE FOR ANY SPECIAL,
  17.   INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  18.   FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
  19.   NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
  20.   WITH THE USE OR PERFORMANCE OF THIS  SOFTWARE.
  21.  
  22.   s924683@minyos.xx.rmit.OZ.AU   Chandi.
  23.   s924698@minyos.xx.rmit.OZ.AU   Ed.
  24.  
  25. }
  26.  
  27. {$R-}
  28. program Edit_256_Palette;
  29.  
  30. { This program lets you edit a 256 colour palette }
  31. { The keys to use are as follows :                }
  32. {   Use arrow keys to move around.                }
  33. {                                                 }
  34. {   Increase color  F    G    H                   }
  35. {   Decrease color   V    B    N                  }
  36. {                  Red   Grn   Blu                }
  37. {                                                 }
  38. {   Press 'p' to get into "Pan" mode              }
  39. {   Press 'p' again to mark first color           }
  40. {   Move to second color and press 'p' to mark    }
  41. {   The colors between these two markers will be  }
  42. {   "panned". If you don't understand then just   }
  43. {   try it!                                       }
  44. {   Press 'q' to quit                             }
  45. {   Press 's' to save a pallette                  }
  46. {   The program is not very user friendly but it  }
  47. {   does the job!                                 }
  48.  
  49. uses SVGA, Dos, crt;
  50.  
  51. const x1 = 30; x2 = 90;
  52.       y1 = 260; y2 = 290;
  53.       Red = 252;
  54.       Green = 253;
  55.       Blue = 254;
  56.       White = 255;
  57.  
  58. var i, j, Rx, Ry : integer;
  59.     register : registers;
  60.     Colors : RGB;
  61.     XPos, YPos, OldXPos, OldYPos : byte;
  62.     Ch : char;
  63.     PaletteName : string;
  64.  
  65. procedure ShowCol( Col : RGB );
  66.  
  67.   begin
  68.     Line( 51, 150, 51, 20, 0 );
  69.     Line( 52, 150, 52, 20, 0 );
  70.     Line( 58, 150, 58, 20, 0 );
  71.     Line( 59, 150, 59, 20, 0 );
  72.     Line( 65, 150, 65, 20, 0 );
  73.     Line( 66, 150, 66, 20, 0 );
  74.     Line( 51, 150, 51, 150-Col.Red*2, red );
  75.     Line( 52, 150, 52, 150-Col.Red*2, red );
  76.     Line( 58, 150, 58, 150-Col.Grn*2, Green );
  77.     Line( 59, 150, 59, 150-Col.Grn*2, Green );
  78.     Line( 65, 150, 65, 150-Col.Blu*2, Blue );
  79.     Line( 66, 150, 66, 150-Col.Blu*2, Blue );
  80.     RectFill( x1, y1, x2, y2, XPos+YPos );
  81.   end;
  82.  
  83. procedure ReadPal( PalNum : byte; var Col : RGB );
  84.  
  85. begin
  86.     Col.Grn := Color[PalNum].Grn;
  87.     Col.Blu := Color[PalNum].Blu;
  88.     Col.Red := Color[PalNum].Red;
  89. end;
  90.  
  91. procedure ChangeColor( PalNum: byte; Hue : RGB );
  92.  
  93.   begin
  94.     with register do
  95.       begin
  96.         AX := $1010;
  97.         BX := PalNum;
  98.         CH := Hue.Grn;
  99.         CL := Hue.Blu;
  100.         DH := Hue.Red;
  101.       end;
  102.     intr( $10, register );
  103.   end;
  104.  
  105. procedure PutCursor( X, Y, OldX, OldY : byte );
  106.  
  107.   begin
  108.     Rx := trunc(OldX/32)*50+150;
  109.     Ry := OldY*15;
  110.     Rectangle( Rx, Ry, Rx+49, Ry+14, OldX+OldY );
  111.     Rectangle( Rx+1, Ry+1, Rx+48, Ry+13, OldX+OldY );
  112.     Rx := trunc(X/32)*50+150;
  113.     Ry := Y*15;
  114.     Rectangle( Rx, Ry, Rx+49, Ry+14, Red );
  115.     Rectangle( Rx+1, Ry+1, Rx+48, Ry+13, White );
  116.     OldXPos := XPos; OldYPos := YPos;
  117.   end;
  118.  
  119. procedure GetKey;
  120.  
  121.   begin
  122.     Case Ch of
  123.         'K' : XPos := XPos - 32;
  124.         'M' : XPos := XPos + 32;
  125.         'H' : if (YPos-1) >= 0 then YPos := YPos - 1
  126.                else YPos := 31;
  127.         'P' : if (YPos+1) <= 31 then YPos := YPos + 1
  128.                 else YPos := 0;
  129.     end;
  130.   end;
  131.  
  132. procedure Swap2( var A , B : byte );
  133.  
  134.   var swapper : byte;
  135.  
  136.   begin
  137.     swapper := A;
  138.     A := B;
  139.     B := swapper;
  140.   end;
  141.  
  142. procedure Pan;
  143.  
  144.   var Markers, Count, Start, Finish, Fx, Sx, Fy, Sy : byte;
  145.       R, G, B : real;
  146.       swap : boolean;
  147.  
  148.   begin
  149.     Markers := 0;
  150.     Count := 0;
  151.     repeat
  152.       Ch := ReadKey;
  153.       if Ch = 'p' then
  154.         begin
  155.           Markers := Markers + 1;
  156.           if Markers = 1 then
  157.             begin
  158.               Start := XPos + YPos;
  159.               Sx := XPos; Sy := YPos;
  160.             end
  161.           else
  162.             begin
  163.               Finish := XPos + YPos;
  164.               Fx := XPos; Fy := YPos;
  165.             end;
  166.           Rx := trunc(XPos/32)*50+170;
  167.           Ry := YPos*15+3;
  168.           RectFill( Rx, Ry, Rx+9, Ry+8, Red );
  169.           RectFill( Rx+2, Ry+1, Rx+7, Ry+7, White );
  170.         end;
  171.       if (Ch = #0) then
  172.       begin
  173.         Ch := ReadKey;
  174.         GetKey;
  175.         PutCursor( XPos, YPos, OldXPos, OldYPos );
  176.         ReadPal( XPos+YPos, Colors );
  177.         ShowCol( Colors );
  178.       end;
  179.     until Markers = 2;
  180.     if Start <> Finish then
  181.       begin
  182.         if Start > Finish then
  183.           begin
  184.             Swap2( Start, Finish );
  185.             Swap2( Sx, Fx );
  186.             Swap2( Sy, Fy );
  187.           end;
  188.         Markers := Start;
  189.         R := (Color[Finish].Red - Color[Start].Red) / abs(Finish - Start);
  190.         G := (Color[Finish].Grn - Color[Start].Grn) / abs(Finish - Start);
  191.         B := (Color[Finish].Blu - Color[Start].Blu) / abs(Finish - Start);
  192.         repeat
  193.           Colors := Color[Markers];
  194.           if (Color[Start].Red + Count*R) <= 63 then
  195.             Colors.Red := round(Color[Start].Red + Count*R)
  196.               else Colors.Red := 63;
  197.           if (Color[Start].Grn + Count*G) <= 63 then
  198.             Colors.Grn := round(Color[Start].Grn + Count*G)
  199.               else Colors.Grn := 63;
  200.           if (Color[Start].Blu + Count*B) <= 63 then
  201.             Colors.Blu := round(Color[Start].Blu + Count*B)
  202.               else Colors.Blu := 63;
  203.           ChangeColor( Markers, Colors );
  204.           Color[Markers] := Colors;
  205.           Count := Count + 1;
  206.           Markers := Markers + 1;
  207.         until Markers = Finish;
  208.         Rx := round((Start-Sy)/32)*50+170;
  209.         Ry := (Start-Sx)*15+3;
  210.         RectFill( Rx, Ry, Rx+9, Ry+8, Start );
  211.         Rx := round((Finish-Fy)/32)*50+170;
  212.         Ry := (Finish-Fx)*15+3;
  213.         RectFill( Rx, Ry, Rx+9, Ry+8, Finish );
  214.       end;
  215.   end;
  216.  
  217. procedure SavePal;
  218.  
  219.   var Fil : File of RGB;
  220.       t : byte;
  221.  
  222.   begin
  223.     assign( fil, PaletteName );
  224.     {$I-} rewrite( fil ); {$I+}
  225.     i := IOResult;
  226.     if i = 0 then
  227.       begin
  228.         for t := 0 to 255 do
  229.           write( fil, Color[t] );
  230.         Close( fil );
  231.       end;
  232.   end;
  233.  
  234. procedure SetUp;
  235.  
  236.   var ch : char;
  237.  
  238.   begin
  239.     write( 'Start New Palette ? ');
  240.     Ch := ReadKey;
  241.     if (Ch = 'n') OR (Ch = 'N') then
  242.       begin
  243.         clrscr;
  244.         write( 'Name of Existing Palette to work with : ' );
  245.         read( PaletteName );
  246.       end
  247.     else
  248.       begin
  249.         clrscr;
  250.         write( 'Name of New Palette : ');
  251.         read( PaletteName );
  252.       end;
  253.     SetMode( SVGAMED );
  254.     if (Ch='n') OR (Ch='N') then LoadPalette( PaletteName )
  255.       else LoadPalette( 'pal256.002' );
  256.     for i := 0 to 7 do
  257.       for j := 0 to 31 do
  258.         RectFill( i*50+150, j*15, i*50+199, j*15+14, i*32+j );
  259.     OldXPos := 0; OldYPos :=20;
  260.     XPos := 0; YPos := 20;
  261.     PutCursor( XPos, YPos, 0, 0 );
  262.     ReadPal( XPos+YPos, Colors );
  263.     ShowCol( Colors );
  264.     RectFill( x1, y1, x2, y2, XPos+YPos );
  265.     Ch := 't';
  266.   end;
  267.  
  268.  
  269. begin
  270.   SetUp;
  271.   repeat
  272.     Ch := ReadKey;
  273.     if Ch in ['p','P'] then Pan;
  274.     if Ch in ['s','S'] then SavePal;
  275.     if (Ch <> #0) then
  276.     begin
  277.       Colors := Color[XPos+YPos];
  278.       Case Ch of
  279.           'f','F' :  if (Colors.Red + 1) <= 63 then Colors.Red := Colors.Red + 1;
  280.           'v','V' :  if (Colors.Red - 1) >= 0  then Colors.Red := Colors.Red - 1;
  281.           'g','G' :  if (Colors.Grn + 1) <= 63 then Colors.Grn := Colors.Grn + 1;
  282.           'b','B' :  if (Colors.Grn - 1) >= 0  then Colors.Grn := Colors.Grn - 1;
  283.           'h','H' :  if (Colors.Blu + 1) <= 63 then Colors.Blu := Colors.Blu + 1;
  284.           'n','N' :  if (Colors.Blu - 1) >= 0  then Colors.Blu := Colors.Blu - 1;
  285.       end;
  286.       ChangeColor( XPos+YPos, Colors );
  287.       ShowCol( Colors );
  288.       Color[XPos+YPos] := Colors;
  289.     end;
  290.     if (Ch = #0) then
  291.     begin
  292.       Ch := ReadKey;
  293.       GetKey;
  294.       PutCursor( XPos, YPos, OldXPos, OldYPos );
  295.       ReadPal( XPos+YPos, Colors );
  296.       ShowCol( Colors );
  297.     end;
  298.   until Ch in ['q','Q'];
  299.   ExitGraphics;
  300. end.