* fixed some small bugs in format settings
[glBitmap.git] / 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