examples/TextureFromFunction/TextureFromFunction.lpr

   1 program SimpleLoadFromFile;
   2
   3 {$mode objfpc}{$H+}
   4
   5 uses
   6   {$IFDEF UNIX}{$IFDEF UseCThreads}
   7   cthreads,
   8   {$ENDIF}{$ENDIF}
   9   Classes, Windows, SysUtils, dglOpenGL, glBitmap, Helper;
  10
  11 var
  12   oglWindow: TOpenGLWindow;
  13   running: Boolean = true;
  14   data: TglBitmapData;
  15   tex: TglBitmap2D;
  16
  17 function WindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
  18 begin
  19   case Msg of
  20     WM_DESTROY: begin
  21       running := false;
  22     end;
  23   end;
  24   result := DefWindowProc(hWnd, Msg, wParam, lParam);
  25 end;
  26
  27 procedure RenderLoop;
  28 begin
  29   tex.Bind();
  30   glColor4f(1, 1, 1, 1);
  31   glBegin(GL_QUADS);
  32     glTexCoord2f(0, 0); glVertex2f(100, 100);
  33     glTexCoord2f(1, 0); glVertex2f(700, 100);
  34     glTexCoord2f(1, 1); glVertex2f(700, 500);
  35     glTexCoord2f(0, 1); glVertex2f(100, 500);
  36   glEnd;
  37   tex.Unbind();
  38 end;
  39
  40 { function to generate texture data }
  41 procedure GenerateTextureFunc1(var FuncRec: TglBitmapFunctionRec);
  42 var
  43   g1, g2, g3, g4: Single;
  44 begin
  45   g1 := (sin(FuncRec.Position.X / 25) + 1) / 2;  // generator function 1: large sinus on x position (0.0 to 1.0)
  46   g2 := (sin(FuncRec.Position.Y / 25) + 1) / 2;  // generator function 2: large sinus on y position (0.0 to 1.0)
  47   g3 := FuncRec.Position.X / FuncRec.Size.X;     // generator function 3: linear fade on x position (0.0 to 1.0)
  48   g4 := FuncRec.Position.Y / FuncRec.Size.Y;     // generator function 4: linear fade on y position (0.0 to 1.0)
  49
  50   FuncRec.Dest.Data.r := Trunc(g1 * FuncRec.Dest.Range.r);
  51   FuncRec.Dest.Data.g := Trunc(g2 * FuncRec.Dest.Range.g);
  52   FuncRec.Dest.Data.b := Trunc(g3 * FuncRec.Dest.Range.b);
  53   FuncRec.Dest.Data.a := Trunc(g4 * FuncRec.Dest.Range.a);
  54 end;
  55
  56 { function to generate texture data }
  57 procedure GenerateTextureFunc2(var FuncRec: TglBitmapFunctionRec);
  58 var
  59   x, y: Single;
  60 begin
  61   x := FuncRec.Position.X / FuncRec.Size.X;
  62   y := FuncRec.Position.Y / FuncRec.Size.Y;
  63   if (x < 0.05) or (x > 0.95) or (y < 0.05) or (y > 0.95) then
  64   begin
  65     FuncRec.Dest.Data := FuncRec.Dest.Range;
  66   end else if (y < 0.333) then begin
  67     FuncRec.Dest.Data := glBitmapRec4ui(0, 0, 0, 0);
  68   end else if (y < 0.666) then begin
  69     FuncRec.Dest.Data := glBitmapRec4ui(FuncRec.Dest.Range.r, 0, 0, 0);
  70   end else begin
  71     FuncRec.Dest.Data := glBitmapRec4ui(FuncRec.Dest.Range.r, FuncRec.Dest.Range.g, 0, 0);
  72   end;
  73 end;
  74
  75 begin
  76   oglWindow := CreateOpenGLWindow('TextureFromFunction', 800, 600, @WindowProc);
  77   try
  78     tex  := TglBitmap2D.Create;       // create texture object
  79     data := TglBitmapData.Create;     // create texture data object
  80     try
  81       data.LoadFromFunc(              // generate texture data using either GenerateTextureFunc1 or GenerateTextureFunc2
  82         glBitmapSize(512, 512),
  83         tfRGBA8ub4,
  84         @GenerateTextureFunc1
  85         //@GenerateTextureFunc2
  86       );
  87       tex.UploadData(data);           // upload data to video card
  88     finally
  89       FreeAndNil(data);               // after upload is done, the data object could be freed to save memory
  90     end;
  91
  92     while running and ProgressMesages do begin
  93       RenderLoop;
  94       SwapBuffers(oglWindow.DC);
  95     end;
  96   finally
  97     FreeAndNil(tex);
  98     DestroyOpenGLWindow(oglWindow);
  99   end;
 100 end.
 101