home *** CD-ROM | disk | FTP | other *** search
/ Maximum CD 1999 February / maximum-cd-1999-02.iso / Benchmarks / White Paper / unit1.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-11-20  |  7.7 KB  |  248 lines
  1. unit Unit1;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls, Unit2, Unit3;
  8.  
  9. type
  10.   TGIFmainwin = class(TForm)
  11.     GroupBox1: TGroupBox;
  12.     MactoPCButton: TRadioButton;
  13.     PCtoMacButton: TRadioButton;
  14.     CustomButton: TRadioButton;
  15.     GammaSlider: TScrollBar;
  16.     Label1: TLabel;
  17.     GammaLabel: TLabel;
  18.     ConvertButton: TButton;
  19.     Label2: TLabel;
  20.     HelpButton: TButton;
  21.     OpenDialog1: TOpenDialog;
  22.     SaveDialog1: TSaveDialog;
  23.     procedure GammaSliderChange(Sender: TObject);
  24.     procedure CustomButtonClick(Sender: TObject);
  25.     procedure MactoPCButtonClick(Sender: TObject);
  26.     procedure PCtoMacButtonClick(Sender: TObject);
  27.     procedure HelpButtonClick(Sender: TObject);
  28.     procedure ConvertButtonClick(Sender: TObject);
  29.   private
  30.     { Private declarations }
  31.   public
  32.     { Public declarations }
  33.   end;
  34.  
  35. var
  36.   GIFmainwin: TGIFmainwin;
  37.   c: char;
  38.   errnum: integer;
  39.   infile,outfile: file;
  40.   infilename,outfilename: string[80];
  41.   infilesize: longint;  {Size of input file in bytes}
  42.   totalread: longint;   {Total # of bytes read from input file}
  43.   gammain,gammaout: real;
  44.   file_incomplete: boolean;
  45.  
  46. implementation
  47.  
  48. {$R *.DFM}
  49.  
  50. procedure TGIFmainwin.GammaSliderChange(Sender: TObject);
  51. var
  52.   gammastr: string[8];
  53. begin
  54.   gammaout := GammaSlider.position / 10;
  55.   str(gammaout:4:1, gammastr);
  56.   GammaLabel.caption := 'New gamma value = ' + gammastr;
  57. end;
  58.  
  59. procedure TGIFmainwin.CustomButtonClick(Sender: TObject);
  60. var
  61.   gammastr: string[8];
  62. begin
  63.   GammaSlider.position := round(gammaout * 10);
  64.   str(gammaout:4:1, gammastr);
  65.   GammaLabel.caption := 'New gamma value = ' + gammastr;
  66.   Label1.visible := true;
  67.   GammaSlider.visible := true;
  68. end;
  69.  
  70. procedure TGIFmainwin.MactoPCButtonClick(Sender: TObject);
  71. begin
  72.   Label1.visible := false;
  73.   GammaSlider.visible := false;
  74.   gammain := 1.0;
  75.   gammaout := 1.8;
  76.   GammaLabel.caption := 'New gamma value = 1.8';
  77. end;
  78.  
  79. procedure TGIFmainwin.PCtoMacButtonClick(Sender: TObject);
  80. begin
  81.   Label1.visible := false;
  82.   GammaSlider.visible := false;
  83.   gammain := 1.8;
  84.   gammaout := 1.0;
  85.   GammaLabel.caption := 'New gamma value = 1.0';
  86. end;
  87.  
  88. procedure TGIFmainwin.HelpButtonClick(Sender: TObject);
  89. begin
  90.   Unit2.AboutBox.ShowModal;
  91. end;
  92.  
  93. procedure ErrorHandler;
  94. var
  95.   errormessage: string[80];
  96.   errnumstring: string[10];
  97. begin
  98.   case errnum of
  99.     2: errormessage := 'File not found: ' + infilename + '.';
  100.     3: errormessage := 'Path not found: ' + infilename + '.';
  101.     4: errormessage := 'Too many open files.';
  102.     12: errormessage := 'Invalid file access code.';
  103.     15: errormessage := 'Invalid drive number.';
  104.     100: errormessage := 'Disk read error.';
  105.     101: errormessage := 'Disk write error.';
  106.     102: errormessage := 'File not assigned.';
  107.     103: errormessage := 'File not open.';
  108.     104: errormessage := 'File not open for input: ' + infilename + '.';
  109.     105: errormessage := 'File not open for output: ' + outfilename + '.';
  110.     150: errormessage := 'Disk is write-protected.';
  111.     152: errormessage := 'Drive not ready.';
  112.     156: errormessage := 'Disk seek error.';
  113.     162: errormessage := 'Hardware failure.';
  114.   else
  115.     begin
  116.       str(errnum,errnumstring);
  117.       errormessage := 'Unknown error #' + errnumstring + '.';
  118.     end
  119.   end;
  120.   errormessage := errormessage + ' Program halted.';
  121.   MessageDlg(errormessage, mtError, [mbOK], 0);
  122.   halt;
  123. end; {of procedure ErrorHandler}
  124.  
  125. procedure ConvertGIF;
  126. var
  127.   pal: array[1..768] of char;            {Holds GIF color table}
  128.   originalheader: array[1..13] of char;  {Holds GIF file header}
  129.   buffer: array[1..2048] of char;        {I/O file buffer}
  130.   numread, numwritten: integer;          {# of bytes read, written}
  131.   byte,count,numin,temp: integer;
  132.   gamma,pallum,devisor: real;
  133.   errormessage: string[80];
  134. begin
  135.   file_incomplete:=false;    {Initialize error flag to no error}
  136.   totalread := 0;
  137.   blockread(infile,originalheader,13,numread);  {Read GIF file header}
  138.   errnum:=IOresult;
  139.   if errnum<>0 then ErrorHandler;
  140.   totalread := totalread + numread;
  141.   GaugeWin.Gauge1.Progress := totalread;
  142.   temp:=ord(originalheader[11]);   {Get 11th element of header}
  143.   temp:=temp and 7;         {Begin calculating length of GIF color table...}
  144.   numin:=2;
  145.   count:=0;
  146.   while count < temp do
  147.   begin
  148.     numin:=numin*2;
  149.     inc(count);
  150.   end;
  151.   blockwrite(outfile,originalheader,13,numwritten); {Save GIF file header}
  152.   errnum:=IOresult;
  153.   if errnum<>0 then ErrorHandler;
  154.   byte:=numin*3;            {Finish calculating length of GIF color table}
  155.   blockread(infile,pal,byte,numread);  {Read GIF color table into buffer}
  156.   errnum:=IOresult;
  157.   if errnum<>0 then ErrorHandler;
  158.   totalread := totalread + numread;
  159.   GaugeWin.Gauge1.Progress := totalread;
  160.   gamma:=gammain/gammaout;             {Calculate new gamma}
  161.   devisor:=255;
  162.   devisor:=(exp(ln(devisor)*gamma))/255;    { (255^gamma)/255) }
  163.   for count:=1 to byte do           {Begin converting GIF color table}
  164.   begin
  165.     if (ord(pal[count]) <> 0) and (ord(pal[count]) <> 255) then
  166.     begin
  167.       pallum:=ord(pal[count]);
  168.       pallum:=(exp(ln(pallum)*gamma))/devisor;   { (pallum^gamma)/devisor) }
  169.       pallum:=int(pallum);             {Convert real to integer}
  170.       pal[count]:=chr(round(pallum));  {Round down}
  171.     end;
  172.   end;
  173.   blockwrite(outfile,pal,byte,numwritten);     {Write new GIF color table}
  174.   errnum:=IOresult;
  175.   if errnum<>0 then ErrorHandler;
  176.   repeat
  177.     blockread(infile,buffer,sizeof(buffer),numread);  {Read a bunch of bytes}
  178.     errnum:=IOresult;
  179.     if errnum<>0 then ErrorHandler;
  180.     totalread := totalread + numread;
  181.     GaugeWin.Gauge1.Progress := totalread;
  182.     blockwrite(outfile,buffer,numread,numwritten);    {Save a bunch of bytes}
  183.     errnum:=IOresult;
  184.     if errnum<>0 then ErrorHandler;
  185.   until (numread = 0) or (numwritten <> numread);  {Continue until EOF}
  186.   if numwritten <> numread then file_incomplete:=true; {I/O discrepancy?}
  187.   system.close(infile);
  188.   errnum:=IOresult;
  189.   if errnum<>0 then ErrorHandler;
  190.   system.close(outfile);
  191.   errnum:=IOresult;
  192.   if errnum<>0 then ErrorHandler;
  193.   {Turn on system error checking here with $I+}
  194.   {$I+}
  195. if file_incomplete = false then
  196.   begin
  197.     GaugeWin.GaugeLabel.caption := 'New file: ' + outfilename;
  198.     GaugeWin.Cursor := crDefault;
  199.   end
  200. else
  201.   begin
  202.     errormessage := outfilename + ' is incomplete. I/O error or disk full.';
  203.     MessageDlg(errormessage, mtError, [mbOK], 0);
  204.   end;
  205. end; {of procedure ConvertGIF}
  206.  
  207. procedure TGIFmainwin.ConvertButtonClick(Sender: TObject);
  208. var
  209.   warnMsg: String;
  210. begin
  211.   infilename := '';
  212.   outfilename := '';
  213.   warnMsg := chr(10) + chr(13) + '   already exists. Replace it?';
  214.   if OpenDialog1.Execute then
  215.     infilename := OpenDialog1.filename
  216.   else exit;
  217.   if SaveDialog1.Execute then
  218.     outfilename := SaveDialog1.filename
  219.   else exit;
  220.   if FileExists(outfilename) then
  221.     if MessageDlg(outfilename + warnMsg, mtWarning, [mbYes, mbNo], 0) = mrNo then exit;
  222.   assignfile(infile,infilename);
  223.   assignfile(outfile,outfilename);
  224.   {Turn off system error-checking here with $I-}
  225.   {$I-}
  226.   reset(infile,1);
  227.   errnum:=IOresult;
  228.   if errnum<>0 then ErrorHandler;
  229.   rewrite(outfile,1);
  230.   errnum:=IOresult;
  231.   if errnum<>0 then ErrorHandler;
  232.   infilesize := FileSize(infile);
  233.   GaugeWin.GaugeLabel.caption := 'Converting ' + infilename + '...';
  234.   GaugeWin.Gauge1.MinValue :=1;
  235.   GaugeWin.Gauge1.MaxValue := infilesize;
  236.   Unit3.GaugeWin.Show;
  237.   ConvertGIF;    {Convert the GIF file}
  238. end; {of procedure ConvertButtonClick}
  239.  
  240. initialization
  241.  
  242. begin {main}
  243.   gammain := 1.0;
  244.   gammaout := 1.8;
  245.   file_incomplete := false;
  246. end;
  247. end.
  248.