FreeBasic

Симпатичная заставка - фейерверк. Для использования скомпилировать, изменить расширение файла на scr , положить в системную папку C:\Windows\System32, в панели управления\экран\изменение заставки выставить нужную заставку.

Платформа: Windows
Автор: Volta   Оф.сайт

#INCLUDE "windows.bi"
#INCLUDE "fbgfx.bi"
Using fb 'Namespace fb

Declare Sub ConfigureScreensaver
Declare Sub ShowScreensaver
Declare Function calc (Byval t As Single) As Integer
Declare Sub render 
Declare Sub rocket
Declare Sub rocket3 (Byval a As Single, Byval e As Single)
Declare Sub rocket2
Declare Function stern2 (Byval m As Integer) As Integer
Const PI = 3.1415926
Const maxp = 240                'max. particel
Const lifetime = 2500           'max. time of live
Const ppblast = 100             'number of points in one blast

Type blast                      'type point
  x As Single                   'x position
  y As Single                   'y position
  vx As Single                  'horizontal speed
  vy As Single                  'vertical speed
  live As Integer               'is this point alive?
  farbe As Integer              'color
  top As Integer                'type of point 1-3
End Type
Dim Shared rakete(0 To maxp) As blast 'array
Dim Shared As Integer breite, hoehe, bpp, pitch

Dim As String Param
' Kein Parameter?
If Command(1) = "" Then
  If MessageBox(0, "Sreensaver testen?", " ", MB_ICONQUESTION Or MB_YESNO) = IDYES Then
    ShowScreensaver
  End If
  End
End If

' Gewьnschtes Kommando isolieren
Param = Mid(Command(1), 2, 1)
Select Case Param
Case "s","S"
  ShowScreensaver
Case "c"
  ConfigureScreensaver
End Select

End


Sub ConfigureScreensaver
  MessageBox(0, "Es gibt nichts zu konfigurieren! ;)", " ", MB_ICONINFORMATION)
End Sub

Sub ShowScreensaver
  Dim evt As EVENT
  ' Vollbild, kein weiterer Moduswechsel
  Screen 19,32,, 1 Or 4
  ' Maussymbol nicht anzeigen
  Setmouse ,,0
  
  Dim As Single t, r
  Screeninfo breite, hoehe, bpp,,pitch
  If ((fb_CpuDetect And &h800000) = 0) Or (bpp < 32) Then
    MessageBox(0, " only MMX-CPU and true Color!", "Error", MB_ICONERROR)
    Exit Sub
  End If
  Do
    t = Timer  
    render
    ' Zur Senkung der Prozessorlast immer ein bisschen warten
    Sleep 1,1
    If calc(Timer - t) > ppblast Then 
      r= Rnd *3
      If r < 1.9 Then rocket
      If (r > 1.9) And (r<2.2) Then rocket2
      If (r > 2.2) Then rocket3 (1.2,2)
    End If
    
    'wurde die Maus bewegt oder Taste gedrьckt
    If (Screenevent(@evt)) Then
      If evt.type>0 And evt.type<9 Then
        Exit Sub
      End If
    End If
  Loop
End Sub

Sub rocket ()
  Dim As Single v, richtung
  Dim As Integer n, poc, farbe, ax, ay
  poc = Int(Rnd * (ppblast \2))
  ax = 50 + Int(Rnd * (breite -100))
  ay = 50 + Int(Rnd * (hoehe \2))
  farbe = Rgb(120 +Int(Rnd *135),Int(Rnd *256),Int(Rnd *135))
  n = 0
  Do
    If rakete(n).live = 0 Then
      richtung = Rnd *2 *PI
      v = Rnd * 80
      With rakete(n)
        .x = ax
        .y = ay
        .vx = Cos(richtung) * v
        .vy = Sin(richtung) * v
        .top = Int(1 + 2 * Rnd)
        .live = 100 + Int(Rnd * lifetime)
        .farbe = farbe
      End With
      poc += 1
    End If
    n += 1
  Loop Until (poc = ppblast) Or (n = maxp)
End Sub

Sub render ()
  Dim As Integer i, x, y, farbe
  Dim  As Byte Ptr ScrPtr = Screenptr
  Screenlock
  ScrPtr += pitch
  For i = 1 To hoehe-16
    ScrPtr += pitch
    For y = 8 To pitch-8 Step 4
      Asm
        mov eax, [ScrPtr]
        Add eax, [y]
        mov ebx, [pitch]
        pxor mm2, mm2       'mm2 [00000000]
        movd mm0, [eax +ebx]'mm0 [    rgba]<-pixel unten
        punpcklbw mm0, mm2  'mm0 [0r0g0b0a]
        movd mm1, [eax]     'mm1 [    rgba]<-pixel
        punpcklbw mm1, mm2  'mm1 [0r0g0b0a]
        paddw mm0, mm1      'mm0 [ r g b a] =(mm0 + mm1)
        movd mm1, [eax -4]  'mm1 [    rgba]<-pixel-1
        punpcklbw mm1, mm2  'mm1 [0r0g0b0a]
        paddw mm0, mm1      'mm0 [ r g b a] =(mm0 + mm1)
        movd mm1, [eax +4]  'mm1 [    rgba]<-pixel+1
        punpcklbw mm1, mm2  'mm1 [0r0g0b0a]
        paddw mm0, mm1      'mm0 [ r g b a] =(mm0 + mm1)
        psrlw mm0, 2        'mm0 [0r0g0b0a] =(mm0 \ 4)
        packuswb mm0, mm0   'mm0 [rgbargba]
        movd [eax], mm0     'mm0 [    rgba]->pixel
      End Asm
    Next y
  Next i
  Asm emms 'Register fьr FPU freigeben
  For i = 0 To maxp
    If rakete(i).live > 0 Then
      x = Int(rakete(i).x)
      y = Int(rakete(i).y)
      farbe = rakete(i).farbe
      Pset (x, y), farbe
      If rakete(i).top =2 Then
        Pset (x + 1, y), farbe
        Pset (x, y + 1), farbe
        Pset (x - 1, y), farbe
        Pset (x, y - 1), farbe
      End If
    End If
  Next
  Screenunlock
End Sub

Function calc (Byval t As Single) As Integer
  Dim As Integer I, n=0
  For I = 0 To maxp
    If rakete(I).live > 0 Then
      With rakete(I)
        .vy = .vy + ((.y/8) * t)
        .x = .x + (.vx * t)
        .y = .y + (.vy * t)
        .live = .live - Int(t * 1000)
        If (.live < 0) Or _
        (.x <= 3) Or _
        (.y <= 3) Or _
        (.x > breite-3) Or _
        (.y > hoehe-15) Then .live = 0
      End With
      If rakete(I).top =3 Then
        If rakete(I).live < 800 Then
          If rakete(I).live > 0 Then n -= stern2(I)
        End If
      End If
      n += 1
    End If
  Next
  calc = maxp - n
End Function

Sub rocket3 (Byval a As Single, Byval e As Single)
  Dim As Single v, richtung
  Dim As Integer n, poc, farbe, ax, ay
  poc = (ppblast\2) + Int(Rnd *(ppblast\4))
  ax = 50 + Int(Rnd * (breite -100))
  ay = 100 + Int(Rnd * (hoehe\2))
  n = 0
  Do
    If rakete(n).live = 0 Then
      richtung = (Pi*a) +Rnd *PI/e
      farbe = Rgb(120 +Int(Rnd *135),Int(Rnd *256),Int(Rnd *135))
      v = Rnd * 100
      With rakete(n)
        .x = ax
        .y = ay
        .vx = Cos(richtung) * v
        .vy = Sin(richtung) * v
        .top = Int(1 + 2 * Rnd)
        .live = 1500 + Int(Rnd * poc*10)
        .farbe = farbe
      End With
      poc += 1
    End If
    n += 1
  Loop Until (poc = ppblast) Or (n = maxp)
End Sub

Sub rocket2 ()
  Dim As Single v, richtung
  Dim As Integer n, poc, farbe, ax, ay
  poc = 0
  ax = 50 + Int(Rnd * (breite -100))
  ay = 50 + Int(Rnd * (hoehe\4))
  farbe = Rgb(120 +Int(Rnd *136),Int(Rnd *256),0)
  n = 0
  Do
    If rakete(n).live = 0 Then
      richtung = PI/10*poc
      v = 60+Int(Rnd * 15)
      With rakete(n)
        .x = ax
        .y = ay
        .vx = Cos(richtung) * v
        .vy = Sin(richtung) * v
        .top = 3
        .live = 100 + Int(Rnd * lifetime)
        .farbe = farbe
      End With
      poc += 1
    End If
    n += 1
  Loop Until (poc = 20) Or (n = maxp)
End Sub

Function stern2 (Byval m As Integer) As Integer
  Dim As Single v, richtung
  Dim As Integer n, poc, farbe, ax, ay
  poc = 0
  ax = rakete(m).x
  ay = rakete(m).y
  farbe = Rgb(255,Int(Rnd *256),0) Or rakete(m).farbe
  n = 0
  Do
    If rakete(n).live = 0 Then
      richtung = PI/9*poc
      v = 15+Int(Rnd * 25)
      With rakete(n)
        .x = ax
        .y = ay
        .vx = Cos(richtung) * v
        .vy = Sin(richtung) * v
        .top = Int(1 + 2 * Rnd)
        .live = 100 + Int(Rnd * 1200)
        .farbe = farbe
      End With
      poc += 1
    End If
    n += 1
  Loop Until (poc = 18) Or (n = maxp)
  rakete(m).live = 0
  stern2 = poc
End Function