FreeBasic

Данный пример создает очень симпатичные деревья.

Платформа: Windows, Linux
Автор: Zamaster

#DEFINE SCRX 1280
#DEFINE SCRY 1024

Const MaxTrees   As Integer = 20
Const Iterations As Integer = 800000

Screenres SCRX, SCRY, 32,,1

Dim As Double A, B, C, D, E, F, x, y, ox, oy, col
Dim Shared As Double DTree(1 To 6, 1 To 6)
Dim As Integer r, i, hx, hy, p, cnt
hx = SCRX/2
hy = SCRY - 10

Dim As Double RX, RY

DTree(1,1) =  0.0500: DTree(1,2) =  0.6000: DTree(1,3) =  0.0000: DTree(1,4) =  0.0000: DTree(1,5) =  0.0000: DTree(1,6) =  0.0000 
DTree(2,1) =  0.0500: DTree(2,2) = -0.5000: DTree(2,3) =  0.0000: DTree(2,4) =  0.0000: DTree(2,5) =  0.0000: DTree(2,6) =  1.0000 
DTree(3,1) =  0.6000: DTree(3,2) =  0.5000: DTree(3,3) =  0.6980: DTree(3,4) =  0.6980: DTree(3,5) =  0.0000: DTree(3,6) =  0.6000 
DTree(4,1) =  0.5000: DTree(4,2) =  0.4500: DTree(4,3) =  0.3490: DTree(4,4) =  0.3492: DTree(4,5) =  0.0000: DTree(4,6) =  1.1000 
DTree(5,1) =  0.5000: DTree(5,2) =  0.5500: DTree(5,3) = -0.5240: DTree(5,4) = -0.5240: DTree(5,5) =  0.0000: DTree(5,6) =  1.0000 
DTree(6,1) =  0.6500: DTree(6,2) =  0.4000: DTree(6,3) = -0.6980: DTree(6,4) = -0.6980: DTree(6,5) =  0.0000: DTree(6,6) =  0.7000 

Randomize Timer

#DEFINE SplitR(col1) ((col1 Shr 16) And &HFF)
#DEFINE SplitG(col1) ((col1 Shr 8) And &HFF)
#DEFINE SplitB(col1) (col1 And &HFF)
#DEFINE RGBF(RR,GG,BB) (((RR)Shl 16) Or ((GG)Shl 8) Or (BB)) 
#MACRO SATURATE()
    If r > 255 Then 
        r = 255
    Elseif r < 0 Then
        r = 0
    Endif
    If g > 255 Then 
        g = 255
    Elseif g < 0 Then
        g = 0
    Endif
    If b > 255 Then 
        b = 255
    Elseif b < 0 Then
        b = 0
    Endif
#endmacro

Function AdditiveMix(colr1 As Integer, rr As Integer, gg As Integer, bb As Integer) As Integer
    Dim As Integer r,g,b
    r = (SplitR(colr1) + rr)
    g = (SplitG(colr1) + gg)
    b = (SplitB(colr1) + bb)
    SATURATE()
    Return RGBF(r,g,b)
End Function

Type TreeType
    As Double  ox, oy, mul, px, py, Sets(1 To 6, 1 To 6)
    As Integer r,g,b, exist
End Type

Redim Shared As TreeType Trees(1 To MaxTrees)

Sub AddTree(x As Double, y As Double, m As Double, r As Integer, g As Integer, b As Integer, offs As Double)
    Dim As Integer i, xs, ys
    For i = 1 To MaxTrees
        If Trees(i).exist = 0 Then
            Trees(i).exist = 1
            Trees(i).px   = x
            Trees(i).py   = y
            Trees(i).mul  = m 
            For ys = 1 To 6
                For xs = 1 To 6
                    Trees(i).Sets(xs,ys) = DTree(xs,ys)+((Rnd * offs)-offs/2)
                Next xs
            Next ys
            Trees(i).r = r
            Trees(i).g = g
            Trees(i).b = b
            Exit For
        Endif
    Next i
End Sub

Do
If cnt = 6 Then
    Cls
    cnt = 0
Endif
Redim As TreeType Trees(1 To MaxTrees)

For i = 1 To Int(Rnd * 3)
    AddTree Rnd * SCRX, 500+ Rnd * (SCRY-500), Rnd * 300+100, 16+int(Rnd * 16), 16+int(Rnd * 16), 16, 0.05
Next i


For i = 1 To Iterations
    For p = 1 To MaxTrees
        If Trees(p).exist = 1 Then
            With Trees(p)
                r = Int(Rnd * 6) + 1
                A = .Sets(r,1): B = .Sets(r,2): C = .Sets(r,3)
                D = .Sets(r,4): E = .Sets(r,5): F = .Sets(r,6)
                x = (A*COS(C)*.ox)-(B*SIN(D)*.oy)+E
                y = (A*SIN(C)*.ox)+(B*COS(D)*.oy)+F
                .ox = x
                .oy = y 
                RX = .px-x*.mul
                RY = .py-y*.mul
                Pset (RX, RY), AdditiveMix(Point(RX,RY), .r,.g,.b)
                If Multikey(&h01) Then End
            End With
        Endif
    Next p
Next i

cnt += 1
Loop