unit Radio; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  ExtCtrls; 
 
type 
  TRadioColor = (trcRed, trcBlue, trcGreen, trcYellow, trcFuchsia, trcOrange); 
  TRadio = class(TGraphicControl) 
  private 
    Fh, FCheck, FSperr, Flck: boolean; 
    Fchange: TNotifyEvent; 
    Fbm, FPt: TBitmap; 
    Fc: TRadioColor; 
    Fgr: Word; 
  protected 
    procedure laden; 
    procedure ladpk; 
    procedure suchen; 
    procedure ecken(b: byte); 
    procedure setindex(w: word); 
    procedure sethell(b: boolean); 
    procedure setcheck(b: boolean); 
    procedure setPunkt(c: TRadioColor); 
  public 
    procedure Click; override; 
    procedure paint; override; 
    procedure Resize; override; 
    destructor Destroy; override; 
    procedure setenabled(Value: boolean); override; 
    constructor Create(Owner: TComponent); override; 
  published 
    property OnChange: TNotifyEvent read Fchange write Fchange; 
    property PointColor: TRadioColor read Fc write setPunkt; 
    property BrightGround: boolean read Fh write sethell; 
    property Checked: boolean read FCheck write setcheck; 
    property GroupIndex: word read Fgr write setindex; 
    property GroupLock: boolean read Flck write Flck; 
    property ParentShowHint; 
    property ShowHint; 
    property OnClick; 
    property Enabled; 
    property Visible; 
  end; 
 
procedure Register; 
 
implementation 
 
var 
  bld: array[0..431] of byte = ( 
    $00, $FF, $FF, $00, $FF, $FF, $00, $FF, $FF, $BA, $BA, $B9, $72, $72, $71, 
    $8D, $8D, $8C, $8D, $8D, $8C, $72, $72, $71, $BA, $BA, $B9, $00, $FF, $FF, 
    $00, $FF, $FF, $00, $FF, $FF, $00, $FF, $FF, $00, $FF, $FF, $79, $79, $78, 
    $BA, $BA, $B9, $DB, $DB, $DB, $F2, $F2, $F2, $F2, $F2, $F2, $DB, $DB, $DB, 
    $BA, $BA, $B9, $79, $79, $78, $00, $FF, $FF, $00, $FF, $FF, $00, $FF, $FF, 
    $7A, $7A, $79, $C3, $C3, $C3, $EE, $ED, $ED, $CD, $C9, $C6, $BF, $BA, $B5, 
    $BF, $BA, $B5, $CE, $CB, $C8, $EE, $EE, $ED, $C3, $C3, $C3, $7A, $7A, $79, 
    $00, $FF, $FF, $BA, $BA, $B9, $BA, $BA, $B9, $EB, $EA, $E9, $BD, $B8, $B3, 
    $C7, $C2, $BD, $D2, $CD, $C8, $D3, $CE, $C9, $CC, $C8, $C5, $C5, $C1, $BE, 
    $EC, $EC, $EB, $BA, $BA, $B9, $BA, $BA, $B9, $73, $73, $73, $DC, $DC, $DC, 
    $CC, $C8, $C5, $C9, $C3, $BE, $D5, $CF, $CB, $D7, $D2, $CE, $DC, $D8, $D5, 
    $E0, $DE, $DC, $D7, $D4, $D3, $D5, $D5, $D4, $DC, $DC, $DC, $73, $73, $73, 
    $8D, $8D, $8C, $F2, $F2, $F2, $BD, $B9, $B4, $D6, $D1, $CD, $DA, $D6, $D3, 
    $DF, $DD, $DB, $E5, $E4, $E4, $E9, $E9, $E9, $E9, $E8, $E8, $D2, $D1, $D0, 
    $F2, $F2, $F2, $8D, $8D, $8C, $8D, $8D, $8C, $F2, $F2, $F2, $C2, $BE, $BB, 
    $DD, $DA, $D7, $E3, $E1, $E0, $E9, $E9, $E9, $EF, $EF, $EF, $F0, $F0, $F0, 
    $F0, $EF, $EF, $DC, $DC, $DB, $EF, $EF, $EF, $89, $89, $88, $75, $75, $74, 
    $DD, $DD, $DD, $D3, $D1, $CF, $D8, $D6, $D5, $E9, $E9, $E9, $EF, $EF, $EF, 
    $F4, $F4, $F4, $F5, $F5, $F5, $EE, $EE, $EE, $E8, $E8, $E8, $DD, $DD, $DD, 
    $75, $75, $74, $BA, $BA, $B9, $BB, $BB, $BA, $ED, $EC, $EC, $CF, $CE, $CD, 
    $E2, $E2, $E1, $F0, $F0, $F0, $F4, $F4, $F4, $F1, $F1, $F1, $EB, $EB, $EB, 
    $F2, $F2, $F2, $BB, $BB, $BA, $BA, $BA, $B9, $00, $FF, $FF, $7A, $7A, $79, 
    $C3, $C3, $C3, $F1, $F0, $F0, $E3, $E3, $E2, $E5, $E4, $E4, $EA, $EA, $E9, 
    $EF, $EE, $EE, $F3, $F3, $F3, $C3, $C3, $C3, $7A, $7A, $79, $00, $FF, $FF, 
    $00, $FF, $FF, $00, $FF, $FF, $7A, $7A, $79, $BB, $BB, $BA, $DB, $DB, $DB, 
    $F4, $F4, $F4, $F4, $F4, $F4, $DC, $DC, $DC, $BB, $BB, $BA, $7A, $7A, $79, 
    $00, $FF, $FF, $00, $FF, $FF, $00, $FF, $FF, $00, $FF, $FF, $00, $FF, $FF, 
    $BA, $BA, $B9, $72, $72, $71, $8F, $8F, $8E, $8F, $8F, $8E, $73, $73, $73, 
    $BA, $BA, $B9, $00, $FF, $FF, $00, $FF, $FF, $00, $FF, $FF); 
  hll: array[0..7] of word = ( 
    9, 24, 108, 141, 288, 321, 405, 420); 
  pkt: array[0..191] of byte = ( 
    $00, $00, $00, $00, $00, $00, $D7, $D7, $D7, $A9, $A9, $A9, $A9, $A9, $A9, 
    $D8, $D8, $D8, $00, $00, $00, $00, $00, $00, $00, $00, $00, $AC, $AC, $AC, 
    $9C, $9C, $9C, $AB, $AB, $AB, $99, $99, $99, $9C, $9C, $9C, $B0, $B0, $B0, 
    $00, $00, $00, $D8, $D8, $D8, $9C, $9C, $9C, $FF, $FF, $FF, $FF, $FF, $FF, 
    $E5, $E5, $E5, $9C, $9C, $9C, $9C, $9C, $9C, $D8, $D8, $D8, $A2, $A2, $A2, 
    $92, $92, $92, $FF, $FF, $FF, $FF, $FF, $FF, $D0, $D0, $D0, $BB, $BB, $BB, 
    $9C, $9C, $9C, $B2, $B2, $B2, $A6, $A6, $A6, $9C, $9C, $9C, $E5, $E5, $E5, 
    $CA, $CA, $CA, $C5, $C5, $C5, $B5, $B5, $B5, $9C, $9C, $9C, $B9, $B9, $B9, 
    $D8, $D8, $D8, $9C, $9C, $9C, $9C, $9C, $9C, $B5, $B5, $B5, $B3, $B3, $B3, 
    $9C, $9C, $9C, $85, $85, $85, $D8, $D8, $D8, $00, $00, $00, $B9, $B9, $B9, 
    $9C, $9C, $9C, $9C, $9C, $9C, $9C, $9C, $9C, $84, $84, $84, $CE, $CE, $CE, 
    $00, $00, $00, $00, $00, $00, $00, $00, $00, $D8, $D8, $D8, $C6, $C6, $C6, 
    $CA, $CA, $CA, $D8, $D8, $D8, $00, $00, $00, $00, $00, $00); 
 
constructor TRadio.Create(Owner: TComponent); 
begin 
  inherited Create(Owner); 
  Fsperr := false; 
  FCheck := true; 
  Flck := false; 
  Fh := true; 
  Fgr := 0; 
  Fbm := TBitmap.create; 
  Fbm.pixelformat := pf24bit; 
  Fbm.width := 12; 
  Fbm.height := 12; 
  FPt := TBitmap.create; 
  FPt.pixelformat := pf24bit; 
  FPt.width := 8; 
  Fpt.height := 8; 
  laden; 
  ladpk; 
  Fbm.transparent := true; 
  FPt.transparent := true; 
  setpunkt(trcBlue); 
end; 
 
destructor TRadio.Destroy; 
begin 
  Fpt.free; 
  Fbm.free; 
  inherited Destroy; 
end; 
 
procedure TRadio.ecken(b: byte); 
var 
  x: integer; 
begin 
  for x := 0 to 7 do begin 
    bld[hll[x]] := b; 
    bld[hll[x] + 1] := b; 
    bld[hll[x] + 2] := b; 
  end; 
end; 
 
procedure TRadio.paint; 
begin 
  canvas.draw(0, 0, Fbm); 
  if FCheck then 
    canvas.draw(2, 2, FPt); 
end; 
 
procedure TRadio.resize; 
begin 
  width := 12; 
  height := 12; 
end; 
 
procedure TRadio.laden; 
var 
  x: integer; 
  pb: ^byte; 
begin 
  pb := @bld; 
  for x := 0 to 11 do begin 
    copymemory(Fbm.scanline[x], pb, 36); 
    inc(pb, 36); 
  end; 
end; 
 
procedure TRadio.ladpk; 
var 
  x: integer; 
  pb: ^byte; 
begin 
  pb := @pkt; 
  for x := 0 to 7 do begin 
    copymemory(FPt.scanline[x], pb, 24); 
    inc(pb, 24); 
  end; 
end; 
 
procedure TRadio.sethell(b: boolean); 
begin 
  if Fh = b then exit; 
  Fh := b; 
  ecken($71 + ord(b) * $48); 
  laden; 
  invalidate; 
end; 
 
procedure TRadio.setpunkt(c: TRadioColor); 
var 
  x, y: integer; 
  p: PByteArray; 
  r, g, b: byte; 
begin 
  ladpk; 
  FC := c; 
  if enabled then begin 
    case c of 
      trcRed: begin 
          r := 255; 
          g := 135; 
          b := 135; 
        end; 
      trcGreen: begin 
          r := 140; 
          g := 250; 
          b := 140; 
        end; 
      trcYellow: begin 
          r := 255; 
          g := 255; 
          b := 30; 
        end; 
      trcFuchsia: begin 
          r := 255; 
          g := 150; 
          b := 255; 
        end; 
      trcOrange: begin 
          r := 252; 
          g := 185; 
          b := 0; 
        end; 
    else begin 
        r := 140; 
        g := 150; 
        b := 255; 
      end; 
    end; 
    for y := 0 to 7 do begin 
      x := 0; 
      p := FPt.scanline[y]; 
      while x < 24 do begin 
        if (p[x] > 0) or (p[x + 1] > 0) or (p[x + 2] > 0) 
          then begin 
          p[x] := b * p[x] div 255; 
          p[x + 1] := g * p[x + 1] div 255; 
          p[x + 2] := r * p[x + 2] div 255; 
        end; 
        Inc(x, 3); 
      end; 
    end; 
  end; 
  invalidate; 
end; 
 
procedure TRadio.suchen; 
var 
  x: integer; 
begin 
  for x := 0 to owner.componentcount - 1 do 
    if (owner.components[x] is TRadio) and (componentindex <> x) 
      and (TRadio(owner.components[x]).Fgr = Fgr) then begin 
      TRadio(owner.components[x]).Fsperr := true; 
      TRadio(owner.components[x]).setcheck(false); 
      TRadio(owner.components[x]).Fsperr := false; 
    end; 
end; 
 
procedure TRadio.setcheck(b: boolean); 
begin 
  if FCheck = b then exit; 
  if (Fgr > 0) then begin 
    if b then suchen 
    else if FCheck and Flck and not Fsperr 
      then exit; 
  end; 
  FCheck := b; 
  repaint; 
  if not Fsperr and not (csLoading in componentstate) then 
    if assigned(Fchange) then Fchange(self); 
end; 
 
procedure TRadio.Click; 
begin 
  setcheck(not FCheck); 
  inherited;
end; 
 
procedure TRadio.setenabled(Value: boolean); 
begin 
  inherited; 
  setpunkt(Fc); 
end; 
 
procedure TRadio.setindex(w: word); 
begin 
  if w = Fgr then exit; 
  Fgr := w; 
  if Fcheck then suchen; 
end; 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TRadio]); 
end; 
 
end.