QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Programs v
A Persian Carpet Cloth Simulation

Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Threaded Mode
A Persian Carpet Cloth Simulation
bplus Offline
Mini-Mod
***
Posts: 3,548
Threads: 165
Joined: Apr 2022
Reputation: 172
#1
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


Attached Files Image(s)
   
b = b + ...
Find
Reply
bplus Offline
Mini-Mod
***
Posts: 3,548
Threads: 165
Joined: Apr 2022
Reputation: 172
#2
07-21-2022, 07:53 PM (This post was last modified: 07-21-2022, 08:07 PM by bplus.)
@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 Sub
b = b + ...
Find
Reply
dbox Offline
Mini-Mod
***
Posts: 252
Threads: 21
Joined: Apr 2022
Reputation: 53
#3
07-21-2022, 08:47 PM
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).
Find
Reply
Kernelpanic Offline
Posting Freak
*****
Posts: 918
Threads: 44
Joined: May 2022
Reputation: 18
#4
07-21-2022, 09:31 PM
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.
Find
Reply
bplus Offline
Mini-Mod
***
Posts: 3,548
Threads: 165
Joined: Apr 2022
Reputation: 172
#5
07-21-2022, 09:47 PM
@dbox yeah it is building the carpet incorrectly, along with too slow.

@KernelPanic thanks
b = b + ...
Find
Reply
SierraKen Offline
Senior Member
****
Posts: 323
Threads: 46
Joined: Apr 2022
Reputation: 11
#6
07-21-2022, 10:24 PM
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?
Find
Reply
bplus Offline
Mini-Mod
***
Posts: 3,548
Threads: 165
Joined: Apr 2022
Reputation: 172
#7
07-21-2022, 11:08 PM
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.
b = b + ...
Find
Reply




Users browsing this thread: 1 Guest(s)