Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Kreiswolke
| Uploader: |  grindstone |
| Datum/Zeit: | 18.07.2014 06:58:10 |
#Include "fbgfx.bi"
Type Kreis
x As Single
y As Single
r As Single
End Type
Const pi As Double = ACos(0)*2
Const pi2 As Double = 2 * pi
Declare Function Quad OverLoad (s As Double) As Double
Declare Function Quad(s As Single) As Single
Declare Sub Kreiszeichnen(k() As kreis,index As Integer)
Dim As Integer i
Dim Shared As Any Ptr hg
Dim k(1 To ...) As kreis => { (125, 130, 10), (240, 175, 15), (412, 176, 10), _
(375, 320, 10) }
Dim As Integer p(UBound(k))
ScreenRes 640,480,32,,FB.GFX_ALPHA_PRIMITIVES
hg = ImageCreate(640,480) 'pufferspeicher für hintergrundbild anlegen
Randomize Timer
For x As Integer = 1 To 20 'mit zufälligem streifenmuster füllen
Line hg,(0,24*x)-(640,24*x+47),RGB(Int(Rnd*255),Int(Rnd*255),Int(Rnd*255)),bf
Next
Put (0,0),hg 'hintergrundbild auf bildschirm schreiben
Do 'kreise zeichnen
For i = 1 To UBound(k) 'alle kreise
Kreiszeichnen(k(),i)
Next
For i = 1 To UBound(k) 'radien vergrößern
k(i).r += .1
Next
Sleep 10
Loop While InKey = ""
ImageDestroy hg 'speicher freigeben
Function Quad(s As Single) As Single
Return s * s
End Function
Function Quad(s As Double) As Double
Return s * s
End Function
Sub Kreiszeichnen(k() As kreis,i As Integer)
Dim As Integer p(UBound(k))
Dim As Integer x,z,j,sichtbar,xp,yp
Dim As Double w,s,c
Dim As Single r
r = k(i).r
'feststellen, welche Kreise berührt werden
z = 0
For x = 1 To UBound(k)
If x <> i Then
If (Quad(k(i).x - k(x).x) + Quad(k(i).y - k(x).y)) < (Quad(r + k(x).r)) Then 'kreise überschneiden sich
z += 1
p(z) = x 'index des kreises in liste schreiben
EndIf
EndIf
Next
For w = 0 To pi2 Step 1/(r * 1.2) 'schrittweite so wählen, daß eine geschlossene linie entsteht
s = Sin(w)
c = Cos(w)
xp = k(i).x + c * r 'kreispunktkoordinaten
yp = k(i).y + s * r
sichtbar = 1 'flag für "punkt setzen"
For j = 1 To z 'alle überschneidenden kreise
If Quad(xp - k(p(j)).x) + Quad(yp - k(p(j)).y) < Quad(k(p(j)).r) Then 'abstand vom mittelpunkt ist kleiner als der radius
sichtbar = 0 'punkt nicht setzen
Put(xp-1,yp-1),hg,(xp-1,yp-1)-(xp+1,yp+1),PSet 'eventuelle artefakte beseitigen
Exit For 'prüfung abbrechen
EndIf
Next
If sichtbar Then
PSet(k(i).x + c * (r + 4),k(i).y + s * (r + 4)),RGBA(255,255,255,5) 'aussenkreise mit
PSet(k(i).x + c * (r + 3),k(i).y + s * (r + 3)),RGBA(255,255,255,5) ' abnehmender
PSet(k(i).x + c * (r + 2),k(i).y + s * (r + 2)),RGBA(255,255,255,10)' transparenz
PSet(k(i).x + c * (r + 1),k(i).y + s * (r + 1)),RGBA(255,255,255,10)
PSet(k(i).x + c * r,k(i).y + s * r),RGBA(255,255,255,255) 'kreis in vollfarbe
xp = k(i).x + c * (r - 1)
yp = k(i).y + s * (r - 1)
Put(xp,yp),hg,(xp,yp)-(xp,yp),Alpha,10 'hintergrundbild mit abnehmender transparenz
xp = k(i).x + c * (r - 2) ' wiederherstellen
yp = k(i).y + s * (r - 2)
Put(xp,yp),hg,(xp,yp)-(xp,yp),Alpha,20
xp = k(i).x + c * (r - 3)
yp = k(i).y + s * (r - 3)
Put(xp,yp),hg,(xp,yp)-(xp,yp),Alpha,30
xp = k(i).x + c * (r - 5)
yp = k(i).y + s * (r - 5)
Put(xp-1,yp-1),hg,(xp-1,yp-1)-(xp+1,yp+1),PSet 'hintergrundbild mit vollfarbe wiederherstellen
EndIf
Next
End Sub