+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Programs (https://staging.qb64phoenix.com/forumdisplay.php?fid=7)
+---- Thread: A Persian Carpet Cloth Simulation (/showthread.php?tid=660)
A Persian Carpet Cloth Simulation - bplus - 07-21-2022
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 SubRE: A Persian Carpet Cloth Simulation - bplus - 07-21-2022
@dbox, QBJS sure didn't like this one!
OK I dim'd everything, still freezes no error
Code: (Select All)
' Wavy Persian Carpets.bas SmallBASIC 0.12.9 (B+=MGA) 2017-09-27
' originally based on Anne M Burns Persian Carpet
'Option _Explicit
Dim As Long xo, yo, lft, rght, top, bot, y, x, spacer, dir, xBall, yBall
Dim r&, da#, aInc#, a#, bOrbit!, walk!, br!, bAngle#
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)
Dim middleCol, middleRow, c&
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)
Dim p&, r%, g%, b%
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)
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)
Line (CX - Y, CY + X)-(CX + Y, CY + X)
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y)
Line (CX - X, CY + Y)-(CX + X, CY + Y)
Wend
End SubRE: A Persian Carpet Cloth Simulation - dbox - 07-21-2022
Interesting @bplus, I'll have to add this one to my list of examples for testing performance improvements. Here is a version that will run, although the rug looks wrong and it waves painfully slow:
View in QBJS
... and you found a bug for me. Looks like the optional color parameter in the Line method isn't working when a value is specified for the style (e.g. B or BF).
RE: A Persian Carpet Cloth Simulation - Kernelpanic - 07-21-2022
Nice program, bplus! If I was that good with graphics, I would try to write an old QuickC program about financials in QB64.
In QC never had a problem with the graphics but in QuickBasic it did. . . In QuickC I also had two excellent books by Kris Jamsa for stuff like this.
Kris Jamsa, Graphics Programming with Microsoft C and QuickC, and Microsoft C Programming Guide.
A corresponding book in Basic is not available, not even as a PDF file.
RE: A Persian Carpet Cloth Simulation - bplus - 07-21-2022
@dbox yeah it is building the carpet incorrectly, along with too slow.
@KernelPanic thanks
RE: A Persian Carpet Cloth Simulation - SierraKen - 07-21-2022
I tried around 5 rugs and it seems to work fine on my computer. The designs are unbelievable, how did you figure that out with so little code?
RE: A Persian Carpet Cloth Simulation - bplus - 07-21-2022
Well Anne Burns came up with the Persian Carpet fractal and "wavy" I picked up from somewhere else, I am thinking JB, possibly John T.