← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to components/opengl/example/imguimain.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
components/opengl/example/imguimain.pas
 
1
unit imguimain;
 
2
 
 
3
{$mode objfpc}{$H+}
 
4
 
 
5
interface
 
6
 
 
7
uses
 
8
  Classes, Forms, Controls, Graphics, ExtCtrls, OpenGLContext,
 
9
  GL, LCLType, fpImage, SysUtils;
 
10
 
 
11
type
 
12
  TGLColor = record
 
13
    alpha: GLushort;
 
14
    blue: GLushort;
 
15
    green: GLushort;
 
16
    red: GLushort;
 
17
  end;
 
18
 
 
19
  { TForm1 }
 
20
 
 
21
  TForm1 = class(TForm)
 
22
    OpenGLControl1: TOpenGLControl;
 
23
    Timer1: TTimer;
 
24
    procedure FormCreate(Sender: TObject);
 
25
    procedure FormKeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
 
26
    procedure FormKeyPress(Sender: TObject; var Key: char);
 
27
    procedure OpenGLControl1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer);
 
28
    procedure OpenGLControl1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: integer);
 
29
    procedure OpenGLControl1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer);
 
30
    procedure OpenGLControl1Paint(Sender: TObject);
 
31
    procedure Timer1Timer(Sender: TObject);
 
32
  private
 
33
    { private declarations }
 
34
  public
 
35
    { public declarations }
 
36
  end;
 
37
 
 
38
  { UIStateType }
 
39
 
 
40
  UIStateType = object
 
41
    activeitem: integer;
 
42
    hotitem: integer;
 
43
    kbditem: integer;
 
44
    keychar: integer;
 
45
    keyentered: integer;
 
46
    keymod: TShiftState;
 
47
    lastwidget: integer;
 
48
    mousedown: integer;
 
49
    mousex: integer;
 
50
    mousey: integer;
 
51
 
 
52
    procedure Init;
 
53
    procedure SetMousePos(X, Y: integer);
 
54
  end;
 
55
 
 
56
var
 
57
  Form1: TForm1;
 
58
  uistate: UIStateType;
 
59
 
 
60
implementation
 
61
 
 
62
uses
 
63
  uglyfont;
 
64
 
 
65
var
 
66
  bgcolor: integer;
 
67
  sometext: string;
 
68
  genid: integer;
 
69
 
 
70
{ UIStateType }
 
71
 
 
72
procedure UIStateType.Init;
 
73
begin
 
74
  mousex := 0;
 
75
  mousey := 0;
 
76
  mousedown := 0;
 
77
 
 
78
  hotitem := 0;
 
79
  activeitem := 0;
 
80
 
 
81
  kbditem := 0;
 
82
  keyentered := 0;
 
83
  keymod := [];
 
84
 
 
85
  lastwidget := 0;
 
86
end;
 
87
 
 
88
procedure UIStateType.SetMousePos(X, Y: integer);
 
89
begin
 
90
  mousex := X;
 
91
  mousey := Y;
 
92
end;
 
93
 
 
94
{$R *.lfm}
 
95
 
 
96
function GLColor(color: GLuint): TGLColor;
 
97
begin
 
98
  Result.red := (color shr 16) and $0000ff;
 
99
  Result.green := (color shr 8) and $0000ff;
 
100
  Result.blue := (color shr 0) and $0000ff;
 
101
  //Result.alpha := (color shr 0) and $000000ff;
 
102
  Result.alpha := $ff;
 
103
end;
 
104
 
 
105
//Draw the string. Characters are fixed width, so this is also
 
106
//deadly simple.
 
107
procedure drawstring(str: string; x, y: double);
 
108
begin
 
109
  glTextOut(x, y + 14, 0, 14, 14, 1, 0, str);
 
110
end;
 
111
 
 
112
//Simplified interface to OpenGL's fillrect call
 
113
procedure drawrect(x, y, w, h: integer; AColor: TGLColor);
 
114
begin
 
115
  glColor3ub(AColor.red, AColor.green, AColor.blue);
 
116
  glRectf(x, y, x + w, y + h);
 
117
end;
 
118
 
 
119
//Check whether current mouse position is within a rectangle
 
120
function regionhit(x, y, w, h: integer): integer;
 
121
begin
 
122
  if (uistate.mousex < x) or
 
123
    (uistate.mousey < y) or
 
124
    (uistate.mousex >= x + w) or
 
125
    (uistate.mousey >= y + h) then
 
126
    Result := 0
 
127
  else
 
128
    Result := 1;
 
129
end;
 
130
 
 
131
//Simple button IMGUI widget
 
132
function button(id: integer; x: integer; y: integer): integer;
 
133
begin
 
134
  //Check whether the button should be hot
 
135
  if regionhit(x, y, 64, 48) = 1 then
 
136
  begin
 
137
    uistate.hotitem := id;
 
138
    if (uistate.activeitem = 0) and (uistate.mousedown = 1) then
 
139
      uistate.activeitem := id;
 
140
  end;
 
141
 
 
142
  //If no widget has keyboard focus, take it
 
143
  if uistate.kbditem = 0 then
 
144
    uistate.kbditem := id;
 
145
 
 
146
  //If we have keyboard focus, show it
 
147
  if uistate.kbditem = id then
 
148
    drawrect(x - 6, y - 6, 84, 68, GLColor($ff0000));
 
149
 
 
150
  drawrect(x + 8, y + 8, 64, 48, GLColor($000000));
 
151
 
 
152
  //Render button
 
153
  if uistate.hotitem = id then
 
154
  begin
 
155
    if uistate.activeitem = id then
 
156
      //Button is both 'hot' and 'active'
 
157
      drawrect(x + 2, y + 2, 64, 48, GLColor($ffffff))
 
158
    else
 
159
      //Button is merely 'hot'
 
160
      drawrect(x, y, 64, 48, GLColor($ffffff));
 
161
  end
 
162
  else
 
163
    //button is not hot, but it may be active
 
164
    drawrect(x, y, 64, 48, GLColor($aaaaaa));
 
165
 
 
166
  //If we have keyboard focus, we'll need to process the keys
 
167
  if uistate.kbditem = id then
 
168
  begin
 
169
    case uistate.keyentered of
 
170
      VK_TAB:
 
171
      begin
 
172
        //If tab is pressed, lose keyboard focus.
 
173
        //Next widget will grab the focus.
 
174
        uistate.kbditem := 0;
 
175
 
 
176
        //If shift was also pressed, we want to move focus
 
177
        //to the previous widget instead.
 
178
        if ssShift in uistate.keymod then
 
179
          uistate.kbditem := uistate.lastwidget;
 
180
 
 
181
        //Also clear the key so that next widget
 
182
        //won't process it
 
183
        uistate.keyentered := 0;
 
184
      end;
 
185
      VK_RETURN:
 
186
      begin
 
187
        //Had keyboard focus, received return,
 
188
        //so we'll act as if we were clicked.
 
189
        Result := 1;
 
190
        exit;
 
191
      end;
 
192
    end;
 
193
  end;
 
194
  uistate.lastwidget := id;
 
195
 
 
196
  //If button is hot and active, but mouse button is not
 
197
  //down, the user must have clicked the button.
 
198
  if (uistate.mousedown = 0) and
 
199
    (uistate.hotitem = id) and
 
200
    (uistate.activeitem = id) then
 
201
    Result := 1
 
202
  else
 
203
    //Otherwise, no clicky.
 
204
    Result := 0;
 
205
end;
 
206
 
 
207
//Simple scroll bar IMGUI widget
 
208
function slider(id: integer; x: integer; y: integer; max: integer; var Value: integer): integer;
 
209
var
 
210
  ypos: integer;
 
211
  mousepos: integer;
 
212
  v: integer;
 
213
begin
 
214
  //Calculate mouse cursor's relative y offset
 
215
  ypos := ((256 - 16) * Value) div max;
 
216
 
 
217
  //Check for hotness
 
218
  if regionhit(x + 8, y + 8, 16, 255) = 1 then
 
219
  begin
 
220
    uistate.hotitem := id;
 
221
    if (uistate.activeitem = 0) and (uistate.mousedown = 1) then
 
222
      uistate.activeitem := id;
 
223
  end;
 
224
 
 
225
  //If no widget has keyboard focus, take it
 
226
  if uistate.kbditem = 0 then
 
227
    uistate.kbditem := id;
 
228
 
 
229
  //If we have keyboard focus, show it
 
230
  if uistate.kbditem = id then
 
231
    drawrect(x - 4, y - 4, 40, 280, GLColor($ff0000));
 
232
 
 
233
  drawrect(x, y, 32, 256 + 16, GLColor($777777));
 
234
 
 
235
  //Render the scrollbar
 
236
  if (uistate.activeitem = id) or (uistate.hotitem = id) then
 
237
    drawrect(x + 8, y + 8 + ypos, 16, 16, GLColor($ffffff))
 
238
  else
 
239
    drawrect(x + 8, y + 8 + ypos, 16, 16, GLColor($aaaaaa));
 
240
 
 
241
  //If we have keyboard focus, we'll need to process the keys
 
242
  if uistate.kbditem = id then
 
243
  begin
 
244
    case uistate.keyentered of
 
245
      VK_TAB:
 
246
      begin
 
247
        //If tab is pressed, lose keyboard focus.
 
248
        //Next widget will grab the focus.
 
249
        uistate.kbditem := 0;
 
250
 
 
251
        //If shift was also pressed, we want to move focus
 
252
        //to the previous widget instead.
 
253
        if ssShift in uistate.keymod then
 
254
          uistate.kbditem := uistate.lastwidget;
 
255
 
 
256
        //Also clear the key so that next widget
 
257
        //won't process it
 
258
        uistate.keyentered := 0;
 
259
      end;
 
260
      VK_UP:
 
261
      begin
 
262
        //Slide slider up (if not at zero)
 
263
        if Value > 0 then
 
264
        begin
 
265
          Dec(Value);
 
266
 
 
267
          Result := 1;
 
268
          exit;
 
269
        end;
 
270
      end;
 
271
      VK_DOWN:
 
272
      begin
 
273
        //Slide slider down (if not at max)
 
274
        if Value < max then
 
275
        begin
 
276
          Inc(Value);
 
277
 
 
278
          Result := 1;
 
279
          exit;
 
280
        end;
 
281
      end;
 
282
    end;
 
283
  end;
 
284
  uistate.lastwidget := id;
 
285
 
 
286
  //Update widget value
 
287
  if uistate.activeitem = id then
 
288
  begin
 
289
    mousepos := uistate.mousey - (y + 8);
 
290
 
 
291
    if mousepos < 0 then
 
292
      mousepos := 0;
 
293
 
 
294
    if mousepos > 255 then
 
295
      mousepos := 255;
 
296
 
 
297
    v := (mousepos * max) div 255;
 
298
 
 
299
    if v <> Value then
 
300
    begin
 
301
      Value := v;
 
302
 
 
303
      Result := 1;
 
304
      exit;
 
305
    end;
 
306
  end;
 
307
 
 
308
  Result := 0;
 
309
end;
 
310
 
 
311
function GetTickCount: DWord;
 
312
begin
 
313
  Result := DWord(Trunc(Now * 24 * 60 * 60 * 1000));
 
314
end;
 
315
 
 
316
function textfield(id: integer; x: integer; y: integer; var buffer: string): integer;
 
317
var
 
318
  len: integer;
 
319
  changed: integer;
 
320
begin
 
321
  len := Length(buffer);
 
322
  changed := 0;
 
323
 
 
324
  //Check for hotness
 
325
  if regionhit(x - 4, y - 4, 30 * 14 + 8, 24 + 8) = 1 then
 
326
  begin
 
327
    uistate.hotitem := id;
 
328
 
 
329
    if (uistate.activeitem = 0) and (uistate.mousedown = 1) then
 
330
      uistate.activeitem := id;
 
331
  end;
 
332
 
 
333
  //If no widget has keyboard focus, take it
 
334
  if uistate.kbditem = 0 then
 
335
    uistate.kbditem := id;
 
336
 
 
337
  //If we have keyboard focus, show it
 
338
  if uistate.kbditem = id then
 
339
    drawrect(x - 6, y - 6, 30 * 14 + 12, 24 + 12, GLColor($ff0000));
 
340
 
 
341
  //Render the text field
 
342
  if (uistate.activeitem = id) or (uistate.hotitem = id) then
 
343
    drawrect(x - 4, y - 4, 30 * 14 + 8, 24 + 8, GLColor($aaaaaa))
 
344
  else
 
345
    drawrect(x - 4, y - 4, 30 * 14 + 8, 24 + 8, GLColor($777777));
 
346
 
 
347
  glColor3ub($00, $00, $00);
 
348
  drawstring(buffer, x, y);
 
349
 
 
350
  //Render cursor if we have keyboard focus
 
351
  if (uistate.kbditem = id) and (((GetTickCount shr 8) and 1) = 1) then
 
352
    drawstring('_', x + len * 14, y);
 
353
 
 
354
  //If we have keyboard focus, we'll need to process the keys
 
355
  if uistate.kbditem = id then
 
356
  begin
 
357
    case uistate.keyentered of
 
358
      VK_TAB:
 
359
      begin
 
360
        //If tab is pressed, lose keyboard focus.
 
361
        //Next widget will grab the focus.
 
362
        uistate.kbditem := 0;
 
363
 
 
364
        //If shift was also pressed, we want to move focus
 
365
        //to the previous widget instead.
 
366
        if ssShift in uistate.keymod then
 
367
          uistate.kbditem := uistate.lastwidget;
 
368
 
 
369
        uistate.keyentered := 0;
 
370
      end;
 
371
      VK_BACK:
 
372
      begin
 
373
        //Also clear the key so that next widget
 
374
        //won't process it
 
375
        if len > 0 then
 
376
        begin
 
377
          Delete(buffer, len, 1);
 
378
          Dec(len);
 
379
          changed := 1;
 
380
        end;
 
381
      end;
 
382
    end;
 
383
 
 
384
    if (uistate.keychar >= 32) and (uistate.keychar < 127) and (len < 30) then
 
385
    begin
 
386
      buffer := buffer + Chr(uistate.keyentered);
 
387
      Inc(len);
 
388
      changed := 1;
 
389
    end;
 
390
  end;
 
391
 
 
392
  //If button is hot and active, but mouse button is not
 
393
  //down, the user must have clicked the widget; give it
 
394
  //keyboard focus.
 
395
  if (uistate.mousedown = 0) and (uistate.hotitem = id) and (uistate.activeitem = id) then
 
396
    uistate.kbditem := id;
 
397
 
 
398
  uistate.lastwidget := id;
 
399
 
 
400
  Result := changed;
 
401
end;
 
402
 
 
403
procedure imgui_prepare;
 
404
begin
 
405
  uistate.hotitem := 0;
 
406
  genid := 0;
 
407
end;
 
408
 
 
409
procedure imgui_finish;
 
410
begin
 
411
  if uistate.mousedown = 0 then
 
412
    uistate.activeitem := 0
 
413
  else
 
414
    if uistate.activeitem = 0 then
 
415
      uistate.activeitem := -1;
 
416
 
 
417
  //If no widget grabbed tab, clear focus
 
418
  if uistate.keyentered = VK_TAB then
 
419
    uistate.kbditem := 0;
 
420
 
 
421
  //Clear the entered key
 
422
  uistate.keyentered := 0;
 
423
  uistate.keychar := 0;
 
424
end;
 
425
 
 
426
function GEN_ID: integer;
 
427
begin
 
428
  Inc(genid);
 
429
  Result := genid;
 
430
end;
 
431
 
 
432
//Rendering function
 
433
procedure render;
 
434
var
 
435
  slidervalue: integer;
 
436
begin
 
437
  imgui_prepare;
 
438
 
 
439
  button(GEN_ID, 50, 50);
 
440
 
 
441
  button(GEN_ID, 150, 50);
 
442
 
 
443
  if button(GEN_ID, 50, 150) = 1 then
 
444
    bgcolor := Round(Random * $ffffff);
 
445
 
 
446
  if button(GEN_ID, 150, 150) = 1 then
 
447
    halt(0);
 
448
 
 
449
  textfield(GEN_ID, 50, 250, sometext);
 
450
 
 
451
  slidervalue := bgcolor and $ff;
 
452
  if slider(GEN_ID, 500, 40, 255, slidervalue) = 1 then
 
453
    bgcolor := (bgcolor and $ffff00) or slidervalue;
 
454
 
 
455
  slidervalue := ((bgcolor shr 10) and $3f);
 
456
  if slider(GEN_ID, 550, 40, 63, slidervalue) = 1 then
 
457
    bgcolor := (bgcolor and $ff00ff) or (slidervalue shl 10);
 
458
 
 
459
  slidervalue := ((bgcolor shr 20) and $f);
 
460
  if slider(GEN_ID, 600, 40, 15, slidervalue) = 1 then
 
461
    bgcolor := (bgcolor and $00ffff) or (slidervalue shl 20);
 
462
 
 
463
  imgui_finish;
 
464
end;
 
465
 
 
466
{ TForm1 }
 
467
 
 
468
procedure TForm1.OpenGLControl1Paint(Sender: TObject);
 
469
begin
 
470
  //setup 2D projection
 
471
  glMatrixMode(GL_PROJECTION);
 
472
  glLoadIdentity;
 
473
  glOrtho(0, OpenGLControl1.Width, OpenGLControl1.Height, 0, 0, 1);
 
474
  glMatrixMode(GL_MODELVIEW);
 
475
 
 
476
  //clear screen
 
477
  drawrect(0, 0, 640, 480, GLColor(bgcolor));
 
478
 
 
479
  render;
 
480
 
 
481
  glColor3ub($ff, $00, $00);
 
482
  glTextOut(10, 20, 0, 10, 10, 1, 0, Format('%f FPS', [1000 / OpenGLControl1.FrameDiffTimeInMSecs]));
 
483
 
 
484
  OpenGLControl1.SwapBuffers;
 
485
end;
 
486
 
 
487
procedure TForm1.Timer1Timer(Sender: TObject);
 
488
begin
 
489
  OpenGLControl1.Paint;
 
490
end;
 
491
 
 
492
procedure TForm1.OpenGLControl1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: integer);
 
493
begin
 
494
  uistate.SetMousePos(X, Y);
 
495
end;
 
496
 
 
497
procedure TForm1.OpenGLControl1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer);
 
498
begin
 
499
  uistate.mousedown := 1;
 
500
end;
 
501
 
 
502
procedure TForm1.FormKeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
 
503
begin
 
504
  uistate.keymod := Shift;
 
505
  uistate.keyentered := Key;
 
506
end;
 
507
 
 
508
procedure TForm1.FormKeyPress(Sender: TObject; var Key: char);
 
509
begin
 
510
  //if escape is pressed, quit the application
 
511
  if Ord(Key) = VK_ESCAPE then
 
512
    halt(0);
 
513
 
 
514
  uistate.keyentered := Ord(Key);
 
515
 
 
516
  //if key is ASCII, accept it as character input
 
517
  if (uistate.keyentered and $FF80) = 0 then
 
518
    uistate.keychar := uistate.keyentered and $7f;
 
519
end;
 
520
 
 
521
procedure TForm1.FormCreate(Sender: TObject);
 
522
begin
 
523
  bgcolor := $77;
 
524
  sometext := 'Some text';
 
525
end;
 
526
 
 
527
procedure TForm1.OpenGLControl1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer);
 
528
begin
 
529
  uistate.mousedown := 0;
 
530
end;
 
531
 
 
532
initialization
 
533
  uistate.Init;
 
534
 
 
535
end.
 
536