{*******************************************************}
{                                                       }
{       nrCommLib Communication Library for Delphi      }
{       Simple visual controls (VCL)                    }
{       Copyright (c) 1997-2011 Roman Novgorodov        }
{       v9.27                                           }
{       last update: 8 Aug 2008                         }
{                                                       }
{       e-mail:noro@deepsoftware.com                    }
{       DeepSoftware                                    }
{       http://www.deepsoftware.com/                    }
{                                                       }
{*******************************************************}
{$I nrcommlib.inc}
unit nrsemaphore;
interface
uses
  {$IFNDEF LINUX}
    controls,graphics,extctrls, messages,nrwin32,
    {$IFNDEF GEN3}
    imglist,
    {$ENDIF}
  {$ELSE}
     QControls,Qgraphics,QImglist,Qextctrls,
  {$ENDIF}
  Classes;

Type

  TnrStyle3D = (nrs3DNone,nrs3DSphere,nrs3DBox);

  TnrSemaphore=class(TGraphicControl)
  private
    fImageChecked: integer;
    fImageUnChecked: integer;
    FImages: TImageList;
    fChecked: boolean;
    fBlink: boolean;
    PulseTimer:TTimer;
    fPulse: boolean;
    fStretchImage: boolean;
    fStyle3D:TnrStyle3D;
    fTransparent:boolean;
    fColor3DCheck:TColor;
    fColor3DUnCheck:TColor;
    fFrame3D:boolean;
    fOnDraw3D:TNotifyEvent;
    procedure SetImageChecked(const Value: integer);
    procedure SetImages(const Value: TImageList);
    procedure SetImageUnChecked(const Value: integer);
    procedure SetChecked(const Value: boolean);
    procedure SetBlink(const Value: boolean);
    function GetBlinkInterval: integer;
    procedure SetBlinkInterval(const Value: integer);
    procedure OnPulseTimer(Sender: TObject);
    function GetPulseDuration: cardinal;
    procedure SetPulseDuration(const Value: cardinal);
    procedure SetPulse(const Value: boolean);
    procedure SetStretchImage(const Value: boolean);
    function GetBlink: boolean;
    function GetChecked: boolean;
    function GetImageChecked: integer;
    function GetImages: TImageList;
    function GetImageUnChecked: integer;
    function GetPulse: boolean;
    function GetStretchImage: boolean;
    function GetStyle3D: TnrStyle3D;
    procedure SetStyle3D(const Value: TnrStyle3D);
    function GetColorCheck: TColor;
    function GetTransparent: boolean;
    function GetUnColorCheck: TColor;
    procedure SetColorCheck(const Value: TColor);
    procedure SetColorUnCheck(const Value: TColor);
    procedure SetTransparent(const Value: boolean);
    function GetFrame3D: boolean;
    procedure SetFrame3D(const Value: boolean);
    function GetOnDraw3D: TNotifyEvent;
    procedure SetOnDraw3D(const Value: TNotifyEvent);
  protected
    fBmpCheck:TBitmap;    // real
    fBmpUnCheck:TBitmap;  // real
    fBmpPaint:TBitmap;    // pointer for paint ...
    LockCount:cardinal;
    procedure Paint; override;
    procedure ChangeBitmap(const Light:boolean);
    procedure Draw3DStyle(aBmp: Graphics.TBitmap; aColor: TColor; aStyle: TnrStyle3D);
    procedure Draw3DBall(AQuad: GLUquadricObj);
    procedure Draw3DBox(AQuad: GLUquadricObj);
    procedure Resize; {$IFNDEF GEN3} override; {$ENDIF}
    procedure Redraw2D;
    procedure Redraw3D;
    procedure RedrawBmp;

  public
    constructor Create(AOwner:TComponent);override;
    destructor Destroy;override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SaveToFile(aFileName:string);

  published

    property Align;
    property Top;
    property Left;
    property Height;
    property Width;
    property Hint;
    property ShowHint;
    property Visible;
    property StretchImage:boolean read GetStretchImage write SetStretchImage;
    property Blink:boolean read GetBlink write SetBlink;
    property BlinkInterval:integer read GetBlinkInterval write SetBlinkInterval;
    property Checked:boolean read GetChecked write SetChecked;
    property Images:TImageList read GetImages write SetImages;
    property ImageChecked:integer read GetImageChecked write SetImageChecked;
    property ImageUnChecked:integer read GetImageUnChecked write SetImageUnChecked;
    property Pulse:boolean read GetPulse write SetPulse;
    property PulseDuration:cardinal read GetPulseDuration write SetPulseDuration;
    property Style3D:TnrStyle3D read GetStyle3D write SetStyle3D;
    property Transparent:boolean read GetTransparent write SetTransparent;
    property Color3DCheck:TColor read GetColorCheck write SetColorCheck;
    property Color3DUnCheck:TColor read GetUnColorCheck write SetColorUnCheck;
    property Frame3D:boolean read GetFrame3D write SetFrame3D;
    property OnDraw3D:TNotifyEvent read GetOnDraw3D write SetOnDraw3D;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

implementation
uses
  {$IFNDEF LINUX}
    windows, sysutils;
  {$ELSE}
    types, nrlinux;
  {$ENDIF}

Type
  TnrBlink=class(TTimer)
  private
    List:TList;
    LightFlag:boolean;
  public
    constructor Create(AOwner: TComponent);override;
    destructor Destroy;override;
    procedure AddSemaphore(Sem:TnrSemaphore);
    procedure DeleteSemaphore(Sem:TnrSemaphore);
    procedure OnBlinkTimer(Sender: TObject);
  end;

var
  Blinker:TnrBlink=nil;

{ TnrBlink }

constructor TnrBlink.Create(AOwner: TComponent);
begin
  inherited Create(nil);
  List := TList.Create;
  Interval := 100;
  OnTimer := OnBlinkTimer;
  Enabled := False;
end;

destructor TnrBlink.Destroy;
begin
  List.Free;
  inherited;
end;

procedure TnrBlink.AddSemaphore(Sem: TnrSemaphore);
begin
  if List.IndexOf(Sem)<0 then List.Add(Sem);
  if List.Count>0 then Enabled:=True;
end;

procedure TnrBlink.DeleteSemaphore(Sem: TnrSemaphore);
var i:integer;
begin
  i:=List.IndexOf(Sem);
  if i>=0 then List.Delete(i);
  if List.Count=0 then Enabled:=False;
end;

procedure TnrBlink.OnBlinkTimer(Sender: TObject);
var i:integer;
begin
  LightFlag:=not LightFlag;
  for i:=0 to List.Count-1
    do if TnrSemaphore(List.Items[i]).Checked then
      TnrSemaphore(List.Items[i]).ChangeBitmap(LightFlag);
end;

{ TnrSemaphore }

constructor TnrSemaphore.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
//  ControlStyle := ControlStyle + [{csReplicatable,}csOpaque];
  {$IFNDEF LINUX}
  fBmpCheck := Graphics.TBitmap.Create;
  fBmpUnCheck := Graphics.TBitmap.Create;
  {$ELSE}
  fBmpCheck := QGraphics.TBitmap.Create;
  fBmpUnCheck := QGraphics.TBitmap.Create;
  {$ENDIF}

  PulseTimer:=TTimer.Create(Self);
  PulseTimer.Enabled:=False;
  PulseTimer.OnTimer:=OnPulseTimer;
//  if Blinker=nil then Blinker:=TnrBlink.Create(nil);
  Width:=16;Height:=16;
//  LockCount:=0;
  fColor3DCheck := clBlue;
  fColor3DUnCheck := clRed;
  fStyle3D := nrs3DSphere;
  fTransparent := True;
  Checked := True;
  RedrawBmp;
end;

destructor TnrSemaphore.Destroy;
begin
  if Blinker<>nil then Blinker.DeleteSemaphore(Self);
  PulseTimer.Free;
  fBmpCheck.Free;
  fBmpUnCheck.Free;
  inherited Destroy;
end;

procedure TnrSemaphore.Resize;
begin
  RedrawBmp;
  inherited;
end;

procedure TnrSemaphore.SaveToFile(aFileName: string);
begin
  RedrawBmp;
  if fChecked
    then fBmpCheck.SaveToFile(aFileName)
    else fBmpPaint.SaveToFile(aFileName);
end;

function TnrSemaphore.GetBlinkInterval: integer;
begin
  Result := Blinker.Interval;
end;

procedure TnrSemaphore.SetBlinkInterval(const Value: integer);
begin
  Blinker.Interval := Value;
end;

procedure TnrSemaphore.SetBlink(const Value: boolean);
begin
  if fBlink = Value then exit;
  fBlink := Value;
  if fBlink then Blinker.AddSemaphore(Self)
            else begin
              Blinker.DeleteSemaphore(Self);
              ChangeBitmap(fChecked);
            end;
end;

procedure TnrSemaphore.SetImageChecked(const Value: integer);
begin
  fImageChecked := Value;
  RedrawBmp;
end;

procedure TnrSemaphore.SetImages(const Value: TImageList);
begin
  fImages := Value;
  if fImages<>nil then fImages.FreeNotification(Self);
  RedrawBmp;
end;

procedure TnrSemaphore.SetImageUnChecked(const Value: integer);
begin
  fImageUnChecked := Value;
  RedrawBmp;
end;

procedure TnrSemaphore.SetChecked(const Value: boolean);
begin
  if fPulse then begin
    if PulseTimer.Enabled then PulseTimer.Enabled:=False;
    PulseTimer.Enabled:=Value;
  end;
  if fChecked<>Value then begin
    fChecked := Value;
    ChangeBitmap(Value);
  end;
end;

procedure TnrSemaphore.OnPulseTimer(Sender: TObject);
begin
  Checked:=False;
end;

function TnrSemaphore.GetPulseDuration: cardinal;
begin
  Result:=PulseTimer.Interval;
end;

procedure TnrSemaphore.SetPulseDuration(const Value: cardinal);
begin
  PulseTimer.Interval:=Value;
end;

procedure TnrSemaphore.SetPulse(const Value: boolean);
begin
  PulseTimer.Enabled:=Value;
  fPulse:=Value;
end;

procedure TnrSemaphore.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent=fImages) AND (Operation=opRemove)
    then fImages := nil;
end;

procedure TnrSemaphore.SetStretchImage(const Value: boolean);
begin
  if fStretchImage<>Value then begin
    fStretchImage := Value;
    RedrawBmp;
  end;
end;

function TnrSemaphore.GetBlink: boolean;
begin
  Result:=fBlink;
end;

function TnrSemaphore.GetChecked: boolean;
begin
  Result:=fChecked;
end;

function TnrSemaphore.GetImageChecked: integer;
begin
  Result:=fImageChecked;
end;

function TnrSemaphore.GetImages: TImageList;
begin
  Result:=FImages;
end;

function TnrSemaphore.GetImageUnChecked: integer;
begin
  Result:=fImageUnChecked;
end;

function TnrSemaphore.GetPulse: boolean;
begin
  Result:=fPulse;
end;

function TnrSemaphore.GetStretchImage: boolean;
begin
  Result:=fStretchImage;
end;

function TnrSemaphore.GetStyle3D: TnrStyle3D;
begin
  Result := fStyle3D;
end;

procedure TnrSemaphore.SetStyle3D(const Value: TnrStyle3D);
begin
  if Value <> fStyle3D then begin
    fStyle3D := Value;
    RedrawBmp;
  end;
end;

function TnrSemaphore.GetFrame3D: boolean;
begin
  Result := fFrame3D;
end;

procedure TnrSemaphore.SetFrame3D(const Value: boolean);
begin
  if fFrame3D <> Value then begin
    fFrame3D := Value;
    RedrawBmp;
  end;
end;

function TnrSemaphore.GetColorCheck: TColor;
begin
  Result := fColor3DCheck;
end;

procedure TnrSemaphore.SetColorCheck(const Value: TColor);
begin
  if fColor3DCheck <> Value then begin
    fColor3DCheck := Value;
    RedrawBmp;
  end;
end;

function TnrSemaphore.GetUnColorCheck: TColor;
begin
  Result :=  fColor3DUnCheck;
end;

procedure TnrSemaphore.SetColorUnCheck(const Value: TColor);
begin
  if fColor3DUnCheck <> Value then begin
    fColor3DUnCheck := Value;
    RedrawBmp;
  end;
end;

function TnrSemaphore.GetTransparent: boolean;
begin
  Result := fTransparent;
end;

procedure TnrSemaphore.SetTransparent(const Value: boolean);
begin
  if fTransparent <> Value then begin
//    if Value
//      then ControlStyle := ControlStyle - [csOpaque]
//      else ControlStyle := ControlStyle + [csOpaque];
    fTransparent := Value;
    RedrawBmp;
  end;
end;

procedure TnrSemaphore.ChangeBitmap(const Light:boolean);
begin
  if Light
    then fBmpPaint := fBmpCheck
    else fBmpPaint := fBmpUnCheck;
//  OutputDebugString('Change bmp ...');
  Invalidate;
end;

procedure TnrSemaphore.Paint;
var r:TRect;
//    ps:TPaintStruct;
//    BPP: Integer;
begin
  if fBmpPaint = nil then exit;
  Inc(LockCount);
  if( csDesigning in ComponentState)and(fBmpPaint.Empty)then
    with inherited Canvas do begin
      Pen.Style := psDot;
      Brush.Style := bsClear;
      Rectangle(0, 0, Width, Height);
    end;

  try
//    OutputDebugString('Paint ... ');
    with inherited Canvas do
    begin
//      Pen.Style := psClear;
//      Brush.Style := bsClear;
//      Rectangle(0, 0, Width, Height);
      r:=ClientRect;
      if fStyle3D = nrs3DNone then begin
        if not fStretchImage then begin
          r.Left:=(r.Right - fBmpPaint.Width) div 2;
          r.Top:=(r.Bottom - fBmpPaint.Height) div 2;
          r.Right:=r.Left+fBmpPaint.Width;
          r.Bottom:=r.Top+fBmpPaint.Height;
        end;
      end;
      StretchDraw(r, fBmpPaint);
    end;
  finally
    Dec(LockCount);
  end;
//  OutputDebugString('... Paint');
//  inherited Paint;
end;

procedure TnrSemaphore.Draw3DStyle(aBmp: Graphics.TBitmap; aColor: TColor; aStyle: TnrStyle3D);
var hcDev: HGLRC;
    hBmp:HDC;
    w,h:integer;
    pf : TPixelFormatDescriptor;
    iPixFmt : integer;
    AQuad: GLUquadricObj;
    clR,clG,clB:real;
    glfLightAmbient: real;
    gldAspect : double;
    position : Array [0..3] of Single;
begin
  w := Width;
  h := Height;

  aBmp.PixelFormat := pf24bit;
  if fTransparent then begin
    aBmp.TransparentColor := clWhite;
    aBmp.Transparent := True;
  end else
    aBmp.Transparent := False;

  aBmp.Width := 0;
  aBmp.Height := 0;
  aBmp.FreeImage;
//  aBmp.Dormant;
  aBmp.Width := w;
  aBmp.Height := h;

  // create OpenGL device context for BMP ...
  hBmp := aBmp.Canvas.Handle;
  ZeroMemory(@pf,SizeOf(pf));
  pf.nSize := SizeOf(pf);
  pf.nVersion := 1;
  pf.dwFlags := PFD_DRAW_TO_BITMAP or
                  //PFD_DRAW_TO_WINDOW or
                  PFD_SUPPORT_OPENGL or
                  PFD_TYPE_RGBA or
                  PFD_SUPPORT_GDI ;
  pf.iPixelType := PFD_TYPE_RGBA;    // RGBA color format
  pf.cColorBits := 24;               // OpenGL color depth
  pf.cDepthBits := 32;               // Specifies the depth of the depth buffer
  pf.iLayerType := PFD_MAIN_PLANE;   // Ignored

  iPixFmt := ChoosePixelFormat(hBmp,@pf);
  if not SetPixelFormat(hBmp,iPixFmt,@pf)
    then exit;

  hcDev := wglCreateContext(hBmp);
  if (hcDev = 0)
    then exit;

  wglMakeCurrent(hBmp,hcDev);
  glClear({GL_COLOR_BUFFER_BIT or} GL_DEPTH_BUFFER_BIT);
  glViewport(0, 0, w, h);

  glEnable(GL_DEPTH_TEST);
  glEnable(GL_POINT_SMOOTH);

  gldAspect := w / h;

  glMatrixMode(GL_PROJECTION);
//  glLoadIdentity;
  gluPerspective(30.0,           // Field-of-view angle
                 gldAspect,      // Aspect ratio of viewing volume
                 1.0,            // Distance to near clipping plane
                 100.0);         // Distance to far clipping plane

//  glEnable(GL_CULL_FACE);

  position[0]:=-7.0;
  position[1]:=7.0;
  position[2]:=0.7;
  position[3]:=0.5;
  glLightfv(GL_LIGHT0, GL_POSITION, @position); // задаем новую позицию
  glLightModelfv(GL_LIGHT_MODEL_AMBIENT, @glfLightAmbient);
  glEnable(GL_LIGHTING);
  glEnable(GL_LIGHT0);
  glEnable(GL_COLOR_MATERIAL);

  // Set Material properties to follow glColor values
  glColorMaterial(GL_FRONT, GL_AMBIENT_AND_DIFFUSE);

  // Define the modelview transformation.
  glMatrixMode(GL_MODELVIEW);
  glLoadIdentity;
  glTranslatef(0.0, 0.0, -32.0);
//  glRotatef(0.0, 1.0, 0.0, 0.0);

  AQuad := gluNewQuadric;

  aColor := aColor and $FFFFFF;
  clB := (aColor shr 16)/255;
  clG := ((aColor and $FF00) shr 8)/255;
  clR := (aColor and $FF)/255;
  glColor3d(clR,clG,clB);


  if Assigned(fOnDraw3D)
    then fOnDraw3D(Self)
    else
      case aStyle of
        nrs3DSphere: Draw3DBall(AQuad);
        nrs3DBox:    Draw3DBox(AQuad);
      end;

  gluDeleteQuadric(AQuad);
  wglMakeCurrent(hBmp,0);
  wglDeleteContext(hcDev);
end;

procedure TnrSemaphore.Redraw2D;
begin
  if fImages <> nil then begin
    if ImageChecked >= 0 then Images.GetBitmap(ImageChecked,fBmpCheck);
    fBmpCheck.TransparentMode:=tmAuto;
    fBmpCheck.Transparent := fTransparent;
//    fBmpCheck.TransparentColor := clWhite;
    if ImageUnChecked >= 0 then Images.GetBitmap(ImageUnChecked,fBmpUnCheck);
    fBmpUnCheck.Transparent := fTransparent;
    fBmpUnCheck.TransparentMode:=tmAuto;
//    fBmpUnCheck.TransparentColor := clWhite;
  end;
end;

procedure TnrSemaphore.Redraw3D;
begin
  Draw3DStyle(fBmpCheck,fColor3DCheck,fStyle3D);
  Draw3DStyle(fBmpUnCheck,fColor3DUnCheck,fStyle3D);
end;

procedure TnrSemaphore.RedrawBmp;
begin

  try
    fBmpCheck.FreeImage;
    fBmpCheck.Dormant;
    fBmpUnCheck.FreeImage;
    fBmpUnCheck.Dormant;
    if fStyle3D = nrs3DNone
      then Redraw2D
      else Redraw3D;
    ChangeBitmap(fChecked);
  except
  end;

end;

procedure TnrSemaphore.Draw3DBall(AQuad: GLUquadricObj);
var Radius : real;
begin
//  glBegin(GL_SPHERE_MAP);
  if fFrame3D
    then Radius := 6
    else Radius := 8;
  gluSphere(AQuad, Radius, 64, 64);
  if fFrame3D then
    gluCylinder(AQuad, Radius +2, Radius - 0.1,1,64,64);
//  glEnd();
end;

procedure TnrSemaphore.Draw3DBox(AQuad: GLUquadricObj);
var w,h,d,dH:real;
//    LightDiffuse : array [0..3] of GLfloat;
//    LightPosition : array [0..3] of GLfloat;
begin

//  glRotatef(0.0, 1.0, 1.0, 0.0);

{  w := 2;
  d := 3;

  h := 9;
  dH := -15; }

  w := 2;
  d := 3;

  h := 10;
  dH := -15;


  if fFrame3D then begin
    w := w+d+2;
//    dH := -4;//-dH - 5;
    glBegin(GL_QUADS);
    glVertex3f (-w, w, h-dH-2);
    glVertex3f (w, w, h-dH-2);
    glVertex3f (w, -w, h-dH-2);
    glVertex3f (-w, -w, h-dH-2);
    glEnd;
  end;
  

{  glBegin(GL_QUADS);
  glVertex3f (-w, w, h);
  glVertex3f (w, w, h);
  glVertex3f (w, -w, h);
  glVertex3f (-w, -w, h);

  glVertex3f (-w-d, w+d, h-dH);
  glVertex3f (w+d, w+d, h-dH);
  glVertex3f (w, w, h);
  glVertex3f (-w, w, h);

  glVertex3f (w, w, h);
  glVertex3f (w+d, w+d, h-dH);
  glVertex3f (w+d, -w-d, h-dH);
  glVertex3f (w, -w, h);

  glVertex3f (-w, -w, h);
  glVertex3f (w, -w, h);
  glVertex3f (w+d, -w-d, h-dH);
  glVertex3f (-w-d, -w-d, h-dH);

  glVertex3f (-w, w, h);
  glVertex3f (-w, -w, h);
  glVertex3f (-w-d, -w-d, h-dH);
  glVertex3f (-w-d, w+d, h-dH);
  glEnd;
  }
  glBegin(GL_TRIANGLES);

  glVertex3f (0, 0, h+dH);
  glVertex3f (-w-d, w+d, h-dH);
  glVertex3f (w+d, w+d, h-dH);


  glVertex3f (0, 0, h+dH);
  glVertex3f (w+d, w+d, h-dH);
  glVertex3f (w+d, -w-d, h-dH);

  glVertex3f (0, 0, h+dH);
  glVertex3f (w+d, -w-d, h-dH);
  glVertex3f (-w-d, -w-d, h-dH);

  glVertex3f (0, 0, h+dH);
  glVertex3f (-w-d, -w-d, h-dH);
  glVertex3f (-w-d, w+d, h-dH);
  glEnd;

{
  if fFrame3D then begin
    w := w+d+2;
//    dH := -4;//-dH - 5;
    glBegin(GL_QUADS);
    glVertex3f (-w, w, h-dH-2);
    glVertex3f (w, w, h-dH-2);
    glVertex3f (w, -w, h-dH-2);
    glVertex3f (-w, -w, h-dH-2);
    glEnd;
  end;

//                  }
//   glEnd;
end;

function TnrSemaphore.GetOnDraw3D: TNotifyEvent;
begin
  Result := fOnDraw3D;
end;

procedure TnrSemaphore.SetOnDraw3D(const Value: TNotifyEvent);
begin
  fOnDraw3D := Value;
end;

initialization
  Blinker:=TnrBlink.Create(nil);

finalization
  Blinker.Free;

end.
