07-21-2022, 07:45 PM
Code: (Select All)
' Wavy Persian Carpets.bas SmallBASIC 0.12.9 (B+=MGA) 2017-09-27
' originally based on Anne M Burns Persian Carpet
_Define A-Z As INTEGER
Randomize Timer
Const xmax = 1000
Const ymax = 700
Const W = 128
Const H = 128
Screen _NewImage(xmax, ymax, 32)
_Title "Wavy Persian Carpets by bplus, press spacebar to wave another"
xo = (xmax - W) / 2: yo = (ymax - H) / 2
lft = xo: rght = W + xo: top = yo: bot = H + yo
While 1
ReDim carpet&(W, H)
r& = _RGB(Rnd * 200 + 55, Rnd * 200 + 55, Rnd * 200 + 55)
Line (lft, top)-(rght, top), r&
Line (lft, bot)-(rght, bot), r&
Line (lft, top)-(lft, bot), r&
Line (rght, top)-(rght, bot), r&
DetermineColor lft, rght, top, bot
_Display
For y = 0 To H
For x = 0 To W
carpet&(x, y) = Point(xo + x, yo + y)
Next
Next
'check point worked
Cls
Print "Check graphic, press any (except spacebar) to continue..."
For y = 0 To H
For x = 0 To W
PSet (x + 100, y + 100), carpet&(x, y)
Next
Next
_Display
Sleep
da# = _Pi(2) / 30: aInc# = _Pi(2) / 50: a# = 0
bOrbit! = .1: br! = 4: spacer = 5: walk! = 0: dir = 1
While 1
If _KeyHit = 32 Then Exit While
a# = a# + aInc#
bOrbit! = bOrbit! + .1 * dir
If bOrbit! >= 15.1 Then bOrbit! = 15.0: dir = dir * -1
If bOrbit! <= 0 Then bOrbit! = .1: dir = dir * -1
Cls
For y = 0 To H
For x = 0 To W
bAngle# = (x + y) * da# + a#
xBall = (2 * Sin(bAngle#) + Cos(bAngle#)) / 2 * bOrbit! + x * spacer
yBall = (Cos(bAngle#) + Sin(bAngle#)) / 2 * bOrbit! + y * spacer
Color carpet&(x, y)
fcirc (xBall + 10 + walk!) Mod (xmax + 640), (yBall + 10 + .12 * walk!) Mod (ymax + 640), br!
Next
Next
walk! = walk! + .1 * bOrbit!
_Display
_Limit 60
Wend
Wend
Rem Determine the color based on function f, and draw cross in quadrant
Sub DetermineColor (lft, rght, top, bot)
If (lft < rght - 1) Then
middlecol = Int((lft + rght) / 2)
middlerow = Int((top + bot) / 2)
c& = f&(lft, rght, top, bot)
Line (lft + 1, middlerow)-(rght - 1, middlerow), c&
Line (middlecol, top + 1)-(middlecol, bot - 1), c&
DetermineColor lft, middlecol, top, middlerow
DetermineColor middlecol, rght, top, middlerow
DetermineColor lft, middlecol, middlerow, bot
DetermineColor middlecol, rght, middlerow, bot
Else
Exit Sub
End If
End Sub
'create 4x4x4 very bright contrasting colors
Function f& (lft, rght, top, bot)
p& = Point(lft, top) + Point(rght, top) + Point(lft, bot) + Point(rght, bot)
If _Red32(p&) / 255 < .25 Then
r% = 0
ElseIf _Red32(p&) / 255 < .5 Then
r% = 128
ElseIf _Red32(p&) / 255 < .75 Then
r% = 192
Else
r% = 255
End If
If _Green32(p&) / 255 < .25 Then
g% = 0
ElseIf _Green32(p&) / 255 < .5 Then
g% = 128
ElseIf _Green32(p&) / 255 < .75 Then
g% = 192
Else
g% = 255
End If
If _Blue32(p&) / 255 < .5 Then
b% = 0
ElseIf _Blue32(p&) / 255 < .5 Then
b% = 128
ElseIf _Blue32(p&) / 255 < .75 Then
b% = 192
Else
b% = 255
End If
f& = _RGB(r, g, b)
End Function
'Steve McNeil's copied from his forum note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
Dim subRadius As Long, RadiusError As Long
Dim X As Long, Y As Long
subRadius = Abs(R)
RadiusError = -subRadius
X = subRadius
Y = 0
If subRadius = 0 Then PSet (CX, CY): Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (CX - X, CY)-(CX + X, CY), , BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), , BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
Wend
End Sub
b = b + ...