Sand Screensaver

Ich war ja nie ein Fan von Screensaver, doch dieser ist besonders gut.

Der Desktop fällt praktisch als Sandhaufen auf den Boden.

Der Effekt überträgt sich auf alle Monitore oder auf erweiterte Desktops.

Projekt Datei sand.dpr

program sand;

uses
  Forms,
  windows,
  SysUtils,
  graphics,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.res}
{$E scr}

function Screenshot(var bmp: TBitmap; MonitorNumber: Integer): Boolean;
const
  CAPTUREBLT = $40000000;
var
  DC: HDC;
  Left, Top: Integer;
begin
  Result := False;
  if (MonitorNumber >= Screen.MonitorCount) then  Exit;
  DC:= GetDC(0);
  try
    if (DC = 0) then  Exit;
    Bmp.Width := Screen.Monitors[MonitorNumber].Width;
    Bmp.Height := Screen.Monitors[MonitorNumber].Height;
    Left := Screen.Monitors[MonitorNumber].Left;
    Top := Screen.Monitors[MonitorNumber].Top;
    try
      Result := BitBlt(
        Bmp.Canvas.Handle,
        0, 0, Bmp.Width, Bmp.Height,
        DC, Left,Top,
        SRCCOPY or CAPTUREBLT);
      Result:= True;
    finally
    end;
  finally
    if (DC <> 0) then  ReleaseDC(0, DC);
  end;
end;


var
 i:integer;
 bmp:tbitmap;
 
begin
  Param1 := Copy(UpperCase(ParamStr(1)),1,2);
  Param2 := UpperCase(ParamStr(2));
  If (Length(Param1)>0)And Not (Param1[1] In ['A'..'Z']) Then
    Param1 := Copy(Param1,2,1);

  ssMode := ssAffiche;
  If Param1='P' Then ssMode := ssPrevisu;
  If Param1='C' Then ssMode := ssConfig;
  If Param1='S' Then ssMode := ssAffiche;
  If Param1='A' Then ssMode := ssMotDePasse;

  SetLastError(NO_ERROR);
  CreateMutex (nil, False, 'MONSCREENSAVER');
  if GetLastError = ERROR_ALREADY_EXISTS Then Exit;

  case ssMode of
  ssAffiche:
   begin
    SystemParametersInfo(SPI_SCREENSAVERRUNNING,1,@i,0);
    Application.Initialize;
    bmp:=tbitmap.Create;
    for i:=0 to screen.MonitorCount-1 do
     begin
      Application.CreateForm(TForm1, Form1);
  Form1.Cursor:=-1;
      Screenshot(Form1.bitmap,i);
      if not form1.Visible then Form1.Show;
      Form1.BoundsRect:=screen.Monitors[i].BoundsRect;
      Form1.iniPicture;
     end;
    bmp.Free;
    Application.Run;
    SystemParametersInfo(SPI_SCREENSAVERRUNNING,0,@i,0);
   end;
  ssPrevisu:
   begin
    Application.Initialize;
    Application.CreateForm(TForm1, Form1);
    Form1.bitmap.assign(Form1.image1.picture.bitmap);
    Form1.iniPicture;
    Form1.ParentWindow := StrToInt(paramstr(2));
    Form1.WindowState:=wsMaximized;
    Application.Run;
   end;
  ssConfig:
   begin
    Application.Initialize;
    Application.CreateForm(TForm1, Form1);
    Form1.bitmap.assign(Form1.image1.picture.bitmap);
    Form1.iniPicture;
    ssmode:=ssPrevisu;
    Form1.WindowState:=wsMaximized;
    Form1.Show;
    Application.Run;
   end;
  ssMotDePasse:
   begin
   end;
  end;
end.

Unit1 :

uses Math

Type TssMode = ( ssAffiche , ssConfig , ssMotDePasse , ssPrevisu );
Const
 Vitesse_Maxi=200;
 Ralentissement=10;

Var
  ssMode      : TssMode = ssAffiche;
  Param1      : String;
  Param2      : String;
  
private
    w,h:integer;
    dx:integer;
    count:integer;
    BackColor:integer;
    WallColor:integer;
    palette:array[0..360] of longint;
    v:array of integer;
    LastN:integer;
    CountN:integer;
    procedure DoSand;
    function GetBackGround:integer;
    function countMoving:integer;
  public
    bitmap:tbitmap;
    procedure iniPicture;
  end;
  
var
  Form1:TForm1;
  mousepos:tpoint;

type
  PQuadArray = ^TQuadArray;
  TQuadArray = array [Byte] of longint;
  TGrain =record Pt:tpoint;V:TPoint;color:integer;actif:boolean; end;
type
 PArbreCouleur=^TArbreCouleur;
 TArbreCouleur=record
                count:integer;
                bit0,bit1:PArbreCouleur;
               end;
               
//

procedure nouvellefeuille(var feuille:PArbreCouleur);
begin
 new(feuille);
 feuille.count:=0;
 feuille.bit0:=nil;
 feuille.bit1:=nil;
end;

function ClasseCouleur(c:dword;level:byte;feuille:PArbreCouleur):integer;
begin
 if level=0 then
  begin
   inc(feuille.count);
   result:=feuille.count;
   exit;
  end;
 if c and 1=0 then
  begin
   if feuille.bit0=nil then nouvellefeuille(feuille.bit0);
   result:=ClasseCouleur(c shr 1,level-1,feuille.bit0);
  end
 else
  begin
   if feuille.bit1=nil then nouvellefeuille(feuille.bit1);
   result:=ClasseCouleur(c shr 1,level-1,feuille.bit1);
  end;
end;

procedure EffaceArbre(feuille:PArbreCouleur);
begin
 if feuille=nil then exit;
 EffaceArbre(feuille.bit0);
 EffaceArbre(feuille.bit1);
 dispose(feuille);
end;

function Tform1.GetBackGround:integer;
var
 i:integer;
 n,m:integer;
 q:PQuadArray;
 arbre:PArbreCouleur;
begin
 m:=0;
 result:=$FFFFFF;
 nouvellefeuille(arbre);
 q:=bitmap.scanline[h-1];
 for i:=0 to w*h-1 do
  begin
   n:=ClasseCouleur(q[i],32,arbre);
   if n>m then begin m:=n;result:=q[i]; end;
  end;
 EffaceArbre(arbre);
end;

function Tform1.countMoving:integer;
var
 i,n:integer;
begin
 n:=0;
 for i:=0 to w*h-1 do if v[i]<>0 then inc(n);
 result:=n;
end;

procedure TForm1.DoSand;
var
 x,y,tx,ox:integer;
 a,b,c,d,e,ia,ib,ic,id:integer;
 bg,wc:integer;
 q:PQuadArray;
 px1,py1,px2,py2:integer;
 tv:integer;
 function tombe(index,n:integer):integer;
 var
  pe,i,linedown:integer;
 begin
  linedown:=index-w;
  if n=0 then
   begin
    result:=index;
   end
  else
  if q[linedown]<>BG then
   begin
    pe:=0;
    if q[linedown-1]<>bg then pe:=pe+1;
    if q[linedown+1]<>bg then pe:=pe+2;
    if pe=0 then pe:=random(2)+1;
    case pe of
     1: result:=tombe(linedown+1,n-1);
     2: result:=tombe(linedown-1,n-1);
     3: begin tv:=0; result:=index; end;
    end;
   end
  else
   begin
    result:=tombe(linedown,n-1);
   end;
 end;
 procedure tombeN(ida:integer);
 var
  r:integer;
 begin
  tv:=v[ida]+1;
  r:=tombe(ida,tv div Ralentissement+1);
  if r<>-1 then
   begin
    if tv>Vitesse_Maxi then tv:=Vitesse_Maxi;
    q[r]:=q[ida];
    v[r]:=tv;
    q[ida]:=BG;
    v[ida]:=0;
   end
  else
   v[ida]:=0;
 end;
 procedure tombeAB(ida,idb:integer);
 begin
  v[idb]:=v[ida];
  q[idb]:=q[ida];
  v[ida]:=0;
  q[ida]:=BG;
 end;
begin
 bg:=BackColor;
 wc:=WallColor;
 q:=bitmap.scanline[h-1];
 dx:=-dx;
 if dx=1 then ox:=1 else ox:=w-2;
 for y:=0 to h-3 do
  begin
   x:=ox;
   for tx:=0 to w-3 do
    begin
        ib:=x+w*y;
        ia:=ib+w;
        ic:=ib-1;
        id:=ia-1;
        a:=q[ia];
        b:=q[ib];
        c:=q[ic];
        d:=q[id];
        e:=0;
        if (a<>bg) then e:=e+1;
        if (b<>bg) then e:=e+2;
        if (c<>bg) then e:=e+4;
        if (d<>bg) then e:=e+8;
        if (a=wc)  then e:=e+100-1;
        if (b=wc)  then e:=e+200-2;
        if (c=wc)  then e:=e+400-4;
        if (d=wc)  then e:=e+800-8;
        if (e>=100) and (e<=199) then e:=e-100;
        if (e>=800) and (e<=899) then e:=e-800;
        if (e>=900) and (e<=999) then e:=e-900;
        case e of
          2,4,6,402,403,204,212,800,1500,1400,1300,1100,700,1302,1104,
          300,1200,500,1000,304,1202,502,1004:;
          601,7,205,1401,1203,1001,1005:begin v[ia]:=0;  end;
          608,14,410,708,312,508,510:begin v[ib]:=0; end;
          609,15,411,213:begin v[ia]:=0; v[id]:=0; end;
          201: begin tombeAB(ia,ic); end;
          408: begin tombeAB(id,ib); end;
          5,401,409,1201: begin tombeN(ia); end;
          13:
           if random(2)=0 then
            begin tombeN(ia); end
           else
            begin tombeAB(ic,ib);tombeAB(id,ic); end;
          10,208,209,308: begin tombeN(id); end;
          11:
           if random(2)=0 then
            begin tombeN(id); end
           else
            begin tombeAB(ib,ic);tombeAB(ia,ib); end;
          3:
           if random(2)=0 then
            begin tombeAB(ia,ic); end
           else
            begin tombeAB(ib,ic);tombeAB(ia,ib); end;
          12:
           if random(2)=0 then
            begin tombeAB(id,ib); end
           else
            begin tombeAB(ic,ib);tombeAB(id,ic); end;
          1:begin tombeN(ia); end;
          8:begin tombeN(id); end;
          9:begin tombeN(ia); tombeN(id); end;
        end;
        x:=x+dx;
    end;
  end;
end;

procedure Tform1.iniPicture;
begin
 w:=Bitmap.Width;
 h:=Bitmap.Height;
 bitmap.PixelFormat:=pf32bit;
 BackColor:=GetBackGround;
 if BackColor=0 then WallColor:=$FFFFFF else WallColor:=0;
 Bitmap.Width:=Bitmap.Width+2;
 Bitmap.Height:=Bitmap.Height+2;
 Bitmap.Canvas.Draw(1,1,Bitmap);
 w:=w+2;
 h:=h+2;
 bitmap.Canvas.Brush.Color:=WallColor;
 bitmap.Canvas.FrameRect(rect(0,0,w,h));
 bitmap.Canvas.Brush.Color:=0;
 setlength(v,w*h);
 timer.Enabled:=true;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
 Paintbox1.canvas.draw(-1,-1,bitmap);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
 i:integer;
begin
 bitmap:=tbitmap.Create;
 DoubleBuffered:=true;
 dx:=1;
 count:=0;
 BackColor:=$FFFFFF;
 WallColor:=$000000;
 GetCursorPos(mousepos);
  for i:=0 to 360 do
   Case (i div 60) of
      0,6:palette[i]:=rgb(255,(i Mod 60)*255 div 60,0);
      1: palette[i]:=rgb(255-(i Mod 60)*255 div 60,255,0);
      2: palette[i]:=rgb(0,255,(i Mod 60)*255 div 60);
      3: palette[i]:=rgb(0,255-(i Mod 60)*255 div 60,255);
      4: palette[i]:=rgb((i Mod 60)*255 div 60,0,255);
      5: palette[i]:=rgb(255,0,255-(i Mod 60)*255 div 60);
   end;
end;

procedure TForm1.FormClick(Sender: TObject);
begin
 if ssmode=ssPrevisu then exit;
 Close;
end;

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
 if ssmode=ssPrevisu then exit;
 Close;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 inherited;
 bitmap.Free;
end;

procedure TForm1.TimerTimer(Sender: TObject);
var
 n:integer;
 q:pquadarray;
 tmp:tbitmap;
 i:integer;
begin
 DoSand;
 Paintbox1.canvas.draw(-1,-1,bitmap);
 n:=countMoving;
 if lastN=n then
  begin
   inc(CountN);
   if CountN>30*5 then
    begin
     bitmap.Canvas.CopyRect(rect(0,h-1,w-1,0),bitmap.Canvas,rect(0,0,w-1,h-1));
     CountN:=0;
     LastN:=0;
    end;
  end
 else
  begin
   LastN:=n;
   CountN:=0;
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 timer.Enabled:=false;
 application.Terminate;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
pt:tpoint;
begin
 if ssmode=ssPrevisu then exit;
 GetCursorPos(pt);
 if abs(sqr(pt.x-mousepos.X)+sqr(pt.y-mousepos.Y))>25 then close;
end;