LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
  Routines to interact with the screen/desktop.
6
}
7
unit GLScreen;
8

9
// screen    - This units contains routines to interact with the screen/desktop.
10
// Version     - 0.0.8
11
// Last Change - 30. September 1998
12
// for more information see help file
13

14
interface
15

16
{$I GLScene.inc}
17

18
uses
19
{$IFDEF MSWINDOWS} Windows, {$ENDIF}
20
{$IFDEF GLS_X11_SUPPORT} x, xlib, xf86vmode, {$ENDIF}
21
 LCLVersion,
22
  Classes, GLVectorGeometry, GLCrossPlatform;
23

24
const
25
  MaxVideoModes = 200;
26

27

28
type
29

30
  TResolution = 0 .. MaxVideoModes;
31

32
  // window attributes
33
  TWindowAttribute = (woDesktop, woStayOnTop, woTransparent);
34
  TWindowAttributes = set of TWindowAttribute;
35

36
  // window-to-screen fitting
37
  TWindowFitting = (wfDefault, wfFitWindowToScreen, wfFitScreenToWindow);
38

39
  // TGLDisplayOptions
40
  //
41
  TGLDisplayOptions = class(TPersistent)
42
  private
43
    FFullScreen: Boolean;
44
    FScreenResolution: TResolution;
45
    FWindowAttributes: TWindowAttributes;
46
    FWindowFitting: TWindowFitting;
47
  public
48
    procedure Assign(Source: TPersistent); override;
49
  published
50
    property FullScreen: Boolean read FFullScreen write FFullScreen
51
      default False;
52
    property ScreenResolution: TResolution read FScreenResolution
53
      write FScreenResolution default 0;
54
    property WindowAttributes: TWindowAttributes read FWindowAttributes
55
      write FWindowAttributes default [];
56
    property WindowFitting: TWindowFitting read FWindowFitting
57
      write FWindowFitting default wfDefault;
58
  end;
59

60
  TVideoMode = packed record
61
    Width: Word;
62
    Height: Word;
63
    ColorDepth: Byte;
64
    MaxFrequency: Byte;
65
    Description: String;
66
  end;
67

68
  PVideoMode = ^TVideoMode;
69

70
function GetIndexFromResolution(XRes, YRes, BPP: Integer): TResolution;
71

72
procedure ReadVideoModes;
73

74
// : Changes to the video mode given by 'Index'
75
function SetFullscreenMode(modeIndex: TResolution;
76
  displayFrequency: Integer = 0): Boolean;
77

78
{$IFDEF MSWINDOWS}
79
procedure ReadScreenImage(Dest: HDC; DestLeft, DestTop: Integer;
80
  SrcRect: TRectangle);
81
{$ENDIF}
82
procedure RestoreDefaultMode;
83

84
procedure GLShowCursor(AShow: Boolean);
85
procedure GLSetCursorPos(AScreenX, AScreenY: Integer);
86
procedure GLGetCursorPos(var point: TGLPoint);
87
function GLGetScreenWidth: Integer;
88
function GLGetScreenHeight: Integer;
89

90
var
91
  vNumberVideoModes: Integer = 0;
92
  vCurrentVideoMode: Integer = 0;
93
{$IFDEF MSWINDOWS}
94
  vVideoModes: array of TVideoMode;
95
{$ENDIF} // Unix
96
{$IFDEF GLS_X11_SUPPORT}
97
  vDisplay: PDisplay;
98
  vScreenModeChanged: Boolean;
99
  vVideoModes: array of PXF86VidModeModeInfo;
100
  vDesktop: TXF86VidModeModeInfo;
101
{$ENDIF}
102

103
  // ------------------------------------------------------------------------------
104
  // ------------------------------------------------------------------------------
105
  // ------------------------------------------------------------------------------
106
implementation
107

108
// ------------------------------------------------------------------------------
109
// ------------------------------------------------------------------------------
110
// ------------------------------------------------------------------------------
111

112
uses
113
  Forms,
114
  SysUtils;
115

116
type
117
  TLowResMode = packed record
118
    Width: Word;
119
    Height: Word;
120
    ColorDepth: Byte;
121
  end;
122

123
const
124
  NumberLowResModes = 15;
125
{$IFDEF MSWINDOWS}
126
  LowResModes: array [0 .. NumberLowResModes - 1] of TLowResMode = ((Width: 320;
127
    Height: 200; ColorDepth: 8), (Width: 320; Height: 200; ColorDepth: 15),
128
    (Width: 320; Height: 200; ColorDepth: 16), (Width: 320; Height: 200;
129
    ColorDepth: 24), (Width: 320; Height: 200; ColorDepth: 32), (Width: 400;
130
    Height: 300; ColorDepth: 8), (Width: 400; Height: 300; ColorDepth: 15),
131
    (Width: 400; Height: 300; ColorDepth: 16), (Width: 400; Height: 300;
132
    ColorDepth: 24), (Width: 400; Height: 300; ColorDepth: 32), (Width: 512;
133
    Height: 384; ColorDepth: 8), (Width: 512; Height: 384; ColorDepth: 15),
134
    (Width: 512; Height: 384; ColorDepth: 16), (Width: 512; Height: 384;
135
    ColorDepth: 24), (Width: 512; Height: 384; ColorDepth: 32));
136
{$ENDIF}
137

138
   
139
  //
140
procedure TGLDisplayOptions.Assign(Source: TPersistent);
141
begin
142
  if Source is TGLDisplayOptions then
143
  begin
144
    FFullScreen := TGLDisplayOptions(Source).FFullScreen;
145
    FScreenResolution := TGLDisplayOptions(Source).FScreenResolution;
146
    FWindowAttributes := TGLDisplayOptions(Source).FWindowAttributes;
147
    FWindowFitting := TGLDisplayOptions(Source).FWindowFitting;
148
  end
149
  else
150
    inherited Assign(Source);
151
end;
152

153
// GetIndexFromResolution
154
//
155
function GetIndexFromResolution(XRes, YRes, BPP: Integer): TResolution;
156

157
// Determines the index of a screen resolution nearest to the
158
// given values. The returned screen resolution is always greater
159
// or equal than XRes and YRes or, in case the resolution isn't
160
// supported, the value 0, which indicates the default mode.
161

162
var
163
  I: Integer;
164
  XDiff, YDiff: Integer;
165
{$IFDEF MSWINDOWS}
166
  CDiff: Integer;
167
{$ENDIF}
168
begin
169
  ReadVideoModes;
170
  // prepare result in case we don't find a valid mode
171
  Result := 0;
172
  // set differences to maximum
173
  XDiff := 9999;
174
  YDiff := 9999;
175
{$IFDEF MSWINDOWS}
176
  CDiff := 99;
177
{$ENDIF}
178
  for I := 1 to vNumberVideoModes - 1 do
179
{$IFDEF MSWINDOWS}
180
    with vVideoModes[I] do
181
    begin
182
      if (Width >= XRes) and ((Width - XRes) <= XDiff) and (Height >= YRes) and
183
        ((Height - YRes) <= YDiff) and (ColorDepth >= BPP) and
184
        ((ColorDepth - BPP) <= CDiff) then
185
      begin
186
        XDiff := Width - XRes;
187
        YDiff := Height - YRes;
188
        CDiff := ColorDepth - BPP;
189
        Result := I;
190
      end;
191
    end;
192
{$ENDIF}
193
{$IFDEF GLS_X11_SUPPORT}
194
  with vVideoModes[I]^ do
195
  begin
196
    if (hDisplay >= XRes) and ((hDisplay - XRes) <= XDiff) and
197
      (vDisplay >= YRes) and ((vDisplay - YRes) <= YDiff) then
198
    begin
199
      XDiff := hDisplay - XRes;
200
      YDiff := vDisplay - YRes;
201
      Result := I;
202
    end;
203
  end;
204
{$ENDIF}
205
{$IFDEF Darwin}
206
  begin
207
{$MESSAGE Warn 'Needs to be implemented'}
208
  end;
209
{$ENDIF}
210
end;
211

212

213
// TryToAddToList
214
//
215
{$IFDEF MSWINDOWS}
216

217
procedure TryToAddToList(deviceMode: TDevMode);
218
// Adds a video mode to the list if it's not a duplicate and can actually be set.
219
var
220
  I: Integer;
221
  vm: PVideoMode;
222
begin
223
  // See if this is a duplicate mode (can happen because of refresh
224
  // rates, or because we explicitly try all the low-res modes)
225
  for I := 1 to vNumberVideoModes - 1 do
226
    with deviceMode do
227
    begin
228
      vm := @vVideoModes[I];
229
      if ((dmBitsPerPel = vm^.ColorDepth) and (dmPelsWidth = vm^.Width) and
230
        (dmPelsHeight = vm^.Height)) then
231
      begin
232
        // it's a duplicate mode, higher frequency?
233
        if dmDisplayFrequency > vm^.MaxFrequency then
234
          vm^.MaxFrequency := dmDisplayFrequency;
235
        Exit;
236
      end;
237
    end;
238

239
  // do a mode set test (doesn't actually do the mode set, but reports whether it would have succeeded).
240
  if ChangeDisplaySettings(deviceMode, CDS_TEST or CDS_FULLSCREEN) <> DISP_CHANGE_SUCCESSFUL
241
  then
242
    Exit;
243

244
  // it's a new, valid mode, so add this to the list
245
  vm := @vVideoModes[vNumberVideoModes];
246
  with deviceMode do
247
  begin
248
    vm^.ColorDepth := dmBitsPerPel;
249
    vm^.Width := dmPelsWidth;
250
    vm^.Height := dmPelsHeight;
251
    vm^.MaxFrequency := dmDisplayFrequency;
252
    vm^.Description := Format('%d x %d, %d bpp', [dmPelsWidth, dmPelsHeight,
253
      dmBitsPerPel]);
254
  end;
255
  Inc(vNumberVideoModes);
256
{$ENDIF}
257
{$IFDEF GLS_X11_SUPPORT}
258

259
  procedure TryToAddToList(); // Without input parameters.
260
  begin
261
    XF86VidModeGetAllModeLines(vDisplay, vCurrentVideoMode, @vNumberVideoModes,
262
      @vVideoModes[0]);
263
{$ENDIF}
264
{$IFDEF Darwin}
265

266
    procedure TryToAddToList(); // Without input parameters.
267
    begin
268
{$MESSAGE Warn 'Needs to be implemented'}
269
{$ENDIF}
270
    end;
271

272
    // ReadVideoModes
273
    //
274
    procedure ReadVideoModes;
275
{$IFDEF MSWINDOWS}
276
    var
277
      I, ModeNumber: Integer;
278
      done: Boolean;
279
      deviceMode: TDevMode;
280
      DeskDC: HDC;
281
    begin
282
      if vNumberVideoModes > 0 then
283
        Exit;
284

285
      SetLength(vVideoModes, MaxVideoModes);
286
      vNumberVideoModes := 1;
287

288
      // prepare 'default' entry
289
      DeskDC := GetDC(0);
290
      with vVideoModes[0] do
291
        try
292
          ColorDepth := GetDeviceCaps(DeskDC, BITSPIXEL) *
293
            GetDeviceCaps(DeskDC, PLANES);
294
          Width := Screen.Width;
295
          Height := Screen.Height;
296
          Description := 'default';
297
        finally
298
          ReleaseDC(0, DeskDC);
299
        end;
300

301
      // enumerate all available video modes
302
      ModeNumber := 0;
303
      repeat
304
        done := not EnumDisplaySettings(nil, ModeNumber, deviceMode);
305
        TryToAddToList(deviceMode);
306
        Inc(ModeNumber);
307
      until (done or (vNumberVideoModes >= MaxVideoModes));
308

309
      // low-res modes don't always enumerate, ask about them explicitly
310
      with deviceMode do
311
      begin
312
        dmBitsPerPel := 8;
313
        dmPelsWidth := 42;
314
        dmPelsHeight := 37;
315
        dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
316
        // make sure the driver doesn't just answer yes to all tests
317
        if ChangeDisplaySettings(deviceMode, CDS_TEST or CDS_FULLSCREEN) <> DISP_CHANGE_SUCCESSFUL
318
        then
319
        begin
320
          I := 0;
321
          while (I < NumberLowResModes - 1) and
322
            (vNumberVideoModes < MaxVideoModes) do
323
          begin
324
            dmSize := Sizeof(deviceMode);
325
            with LowResModes[I] do
326
            begin
327
              dmBitsPerPel := ColorDepth;
328
              dmPelsWidth := Width;
329
              dmPelsHeight := Height;
330
            end;
331
            dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
332
            TryToAddToList(deviceMode);
333
            Inc(I);
334
          end;
335
        end;
336
      end;
337
{$ENDIF}
338
{$IFDEF GLS_X11_SUPPORT}
339
      var
340
        I, j: Integer;
341
      begin
342
        SetLength(vVideoModes, MaxVideoModes);
343
        // if error usr/bin/ld: cannot find -lXxf86vm
344
        // then sudo apt-get install libXxf86vm-dev
345

346
        // Connect to XServer
347
        vDisplay := XOpenDisplay(nil);
348
        if not Assigned(vDisplay) Then
349
          Assert(False, 'Not conected with X Server');
350
        vCurrentVideoMode := DefaultScreen(vDisplay);
351

352
        // Check support XF86VidMode Extension
353
        // {$IF (FPC_VERSION = 2) and (FPC_RELEASE < 5)}
354
        // if XF86VidModeQueryExtension( vDisplay, @i, @j )=0 then
355
        // {$ELSE}
356
        if not XF86VidModeQueryExtension(vDisplay, @I, @j) then
357
          // {$IFEND}
358
          Assert(False, 'XF86VidMode Extension not support');
359

360
        // Get Current Settings
361
        if not vScreenModeChanged then
362
          if XF86VidModeGetModeLine(vDisplay, vCurrentVideoMode,
363
            @vDesktop.dotclock, PXF86VidModeModeLine(PtrUInt(@vDesktop) +
364
            Sizeof(vDesktop.dotclock))) then
365
            TryToAddToList;
366
        XCloseDisplay(vDisplay);
367
{$ENDIF}
368
{$IFDEF Darwin}
369
        begin
370
{$MESSAGE Warn 'ReadVideoModes not yet implemented for Darwin platforms'}
371
{$ENDIF}
372
        end;
373

374
        // SetFullscreenMode
375
        //
376
        function SetFullscreenMode(modeIndex: TResolution;
377
          displayFrequency: Integer = 0): Boolean;
378
{$IFDEF MSWINDOWS}
379
        var
380
          deviceMode: TDevMode;
381
        begin
382
          ReadVideoModes;
383
          FillChar(deviceMode, Sizeof(deviceMode), 0);
384
          with deviceMode do
385
          begin
386
            dmSize := Sizeof(deviceMode);
387
            dmBitsPerPel := vVideoModes[modeIndex].ColorDepth;
388
            dmPelsWidth := vVideoModes[modeIndex].Width;
389
            dmPelsHeight := vVideoModes[modeIndex].Height;
390
            dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
391
            if displayFrequency > 0 then
392
            begin
393
              dmFields := dmFields or DM_DISPLAYFREQUENCY;
394
              if displayFrequency > vVideoModes[modeIndex].MaxFrequency then
395
                displayFrequency := vVideoModes[modeIndex].MaxFrequency;
396
              dmDisplayFrequency := displayFrequency;
397
            end;
398
          end;
399
          Result := ChangeDisplaySettings(deviceMode, CDS_FULLSCREEN)
400
            = DISP_CHANGE_SUCCESSFUL;
401
          if Result then
402
            vCurrentVideoMode := modeIndex;
403
{$ENDIF}
404
{$IFDEF GLS_X11_SUPPORT}
405
          var
406
            vSettings: TXF86VidModeModeInfo;
407
            wnd: TWindow;
408
          begin
409
            ReadVideoModes;
410
            vDisplay := XOpenDisplay(nil);
411
            vSettings := vVideoModes[modeIndex]^;
412
            if (vSettings.hDisplay <> vDesktop.hDisplay) and
413
              (vSettings.vDisplay <> vDesktop.vDisplay) then
414
            begin
415

416
              // vsettings.vtotal:=vsettings.vdisplay;
417
              XF86VidModeSwitchToMode(vDisplay, vCurrentVideoMode, @vSettings);
418
              XF86VidModeSetViewPort(vDisplay, vCurrentVideoMode, 0, 0);
419
              wnd := XDefaultRootWindow(vDisplay);
420
              XGrabPointer(vDisplay, wnd, true,
421
                PointerMotionMask + ButtonReleaseMask, GrabModeAsync,
422
                GrabModeAsync, wnd, none, 0);
423
              vScreenModeChanged := true;
424
            end
425
            else
426
            begin
427
              // Restore
428
              XF86VidModeSwitchToMode(vDisplay, vCurrentVideoMode, @vDesktop);
429
              vScreenModeChanged := False;
430
            end;
431
            // Disconnect to XServer else settings not accept
432
            XCloseDisplay(vDisplay);
433
            Result := vScreenModeChanged;
434
{$ENDIF}
435
{$IFDEF Darwin}
436
            begin
437
{$MESSAGE Warn 'Needs to be implemented'}
438
{$ENDIF}
439
            end;
440

441
            // ReadScreenImage
442
            //
443
{$IFDEF MSWINDOWS}
444

445
            procedure ReadScreenImage(Dest: HDC; DestLeft, DestTop: Integer;
446
              SrcRect: TRectangle);
447
            var
448
              screenDC: HDC;
449
            begin
450
              screenDC := GetDC(0);
451
              try
452
                GDIFlush;
453
                BitBlt(Dest, DestLeft, DestTop, SrcRect.Width, SrcRect.Height,
454
                  screenDC, SrcRect.Left, SrcRect.Top, SRCCOPY);
455
              finally
456
                ReleaseDC(0, screenDC);
457
              end;
458
            end;
459
{$ENDIF}
460

461
            // RestoreDefaultMode
462
            //
463
            procedure RestoreDefaultMode;
464
{$IFDEF MSWINDOWS}
465
            var
466
              t: PDevMode;
467
            begin
468
              t := nil;
469
              ChangeDisplaySettings(t^, CDS_FULLSCREEN);
470
{$ENDIF}
471
{$IFDEF GLS_X11_SUPPORT}
472
              begin
473
                // if vCurrentVideoMode=0 then
474
                ReadVideoModes;
475
                vDisplay := XOpenDisplay(nil);
476
                XF86VidModeSwitchToMode(vDisplay, vCurrentVideoMode, @vDesktop);
477
                vScreenModeChanged := False;
478
                XCloseDisplay(vDisplay);
479
{$ENDIF}
480
{$IFDEF Darwin}
481
                begin
482
{$MESSAGE Warn 'Needs to be implemented'}
483
{$ENDIF}
484
                end;
485

486
                procedure GLShowCursor(AShow: Boolean);
487
                begin
488
{$IFDEF MSWINDOWS}
489
                  ShowCursor(AShow);
490
{$ENDIF}
491
{$IFDEF UNIX}
492
{$MESSAGE Warn 'ShowCursor: Needs to be implemented'}
493
                  // Use Form.Cursor:=crNone
494
{$ENDIF}
495
                end;
496

497
                procedure GLSetCursorPos(AScreenX, AScreenY: Integer);
498
{$IFDEF MSWINDOWS}
499
                begin
500
                  SetCursorPos(AScreenX, AScreenY);
501
{$ENDIF}
502
{$IFDEF GLS_X11_SUPPORT}
503
                  var
504
                    dpy: PDisplay;
505
                    root: TWindow;
506
                  begin
507
                    dpy := XOpenDisplay(nil);
508
                    root := RootWindow(dpy, DefaultScreen(dpy));
509
                    XWarpPointer(dpy, none, root, 0, 0, 0, 0, AScreenX,
510
                      AScreenY);
511
                    XCloseDisplay(dpy);
512
{$ENDIF}
513
{$IFDEF Darwin}
514
                    begin
515
{$MESSAGE Warn 'Needs to be implemented'}
516
{$ENDIF}
517
                    end;
518

519
                    procedure GLGetCursorPos(var point: TGLPoint);
520
{$IFDEF MSWINDOWS}
521
                    begin
522
                      GetCursorPos(point);
523
{$ENDIF}
524
{$IFDEF GLS_X11_SUPPORT}
525
                      var
526
                        dpy: PDisplay;
527
                        root, child: TWindow;
528
                        rootX, rootY, winX, winY: Integer;
529
                        xstate: Word;
530
                        Result: Boolean;
531
                      begin
532
                        point.x := 0;
533
                        point.y := 0;
534
                        dpy := XOpenDisplay(nil);
535
                        Result := LongBool
536
                          (XQueryPointer(dpy, XDefaultRootWindow(dpy), @root,
537
                          @child, @rootX, @rootY, @winX, @winY, @xstate));
538
                        If Result then
539
                        begin
540
                          point.x := rootX;
541
                          point.y := rootY;
542
                        end;
543
                        XCloseDisplay(dpy);
544
{$ENDIF}
545
{$IFDEF Darwin}
546
                        begin
547
{$MESSAGE Warn 'Needs to be implemented'}
548
{$ENDIF}
549
                        end;
550

551
                        function GLGetScreenWidth: Integer;
552
                        begin
553
                          Result := Screen.Width;
554
                        end;
555

556
                        function GLGetScreenHeight: Integer;
557
                        begin
558
                          Result := Screen.Height;
559
                        end;
560

561
                        // ------------------------------------------------------------------
562
                        // ------------------------------------------------------------------
563
                        // ------------------------------------------------------------------
564
initialization
565

566
// ------------------------------------------------------------------
567
// ------------------------------------------------------------------
568
// ------------------------------------------------------------------
569

570
finalization
571

572
{$IFDEF MSWINDOWS}
573
if vCurrentVideoMode <> 0 then
574
{$ENDIF}
575
{$IFDEF GLS_X11_SUPPORT}
576
  if vScreenModeChanged then
577
{$ENDIF}
578
    RestoreDefaultMode; // set default video mode
579

580
end.
581