Proggies

[bplus]

Persian Carpets

Code: (Select All)

_Title "Persian Carpets" 'b+ revisit JB code 2020-04-26
DefInt A-Z
'Persian Carpets.txt for Just Basic v1.01 [B+=MGA] 2017-10-01
'based on orig by Anne M Burns
'2017-10-04 bi-lateral symmetry fixed! thanks tsh73 for help!
'2017-10-05 add varaibles report at bottom of screen, ask for help finding bad combos
'2020-04-26 translate to QB64

Const XMAX = 512, YMAX = 512
Dim Shared vScreen(XMAX, YMAX)
Dim Shared qb(15) As _Unsigned Long
qb(0) = &HFF000000
qb(1) = &HFF000088
qb(2) = &HFF008800
qb(3) = &HFF008888
qb(4) = &HFF880000
qb(5) = &HFF880088
qb(6) = &HFF888800
qb(7) = &HFFCCCCCC
qb(8) = &HFF888888
qb(9) = &HFF0000FF
qb(10) = &HFF00FF00
qb(11) = &HFF00FFFF
qb(12) = &HFFFF0000
qb(13) = &HFFFF00FF
qb(14) = &HFFFFFF00
qb(15) = &HFFFFFFFF

Screen _NewImage(XMAX, YMAX, 32)
Randomize Timer
a = 5: b = 7
While _KeyDown(27) = 0
    Cls
    Erase vScreen
    lft = 1: rght = 512: top = 1: bot = 512
    'a = INT(RND * 16)
    'b = (INT(RND * 16) + a) MOD 16
    'c = INT(RND * 16)
    vLINE lft + 1, top, rght - 1, top, a
    vLINE lft + 1, bot, rght - 1, bot, a
    vLINE lft, top, lft, bot, b
    vLINE rght, top, rght, bot, b
    DetermineColr lft, rght, top, bot, c
    c = c + 1
    If c = 16 Then
        b = Int(Rnd * 16): a = Int(Rnd * 16)
        If c = 16 Then c = 0
    End If
    _Display
    _Delay 2
Wend

' Determine the color based on function f
Sub DetermineColr (lft, rght, top, bot, a)
    If lft < rght - 1 Then '<<<< if you like intricate paterns go -1, for speed go -5
        c = findClr(lft, rght, top, bot, a)
        middlecol = Int(lft + rght) / 2
        middlerow = Int(top + bot) / 2
        If c = 0 Then c = 1
        If c = 14 Then c = 9

        vLINE lft, middlerow, rght, middlerow, c
        vLINE middlecol, top, middlecol, bot, c
        DetermineColr lft, middlecol, top, middlerow, a
        DetermineColr middlecol, rght, top, middlerow, a
        DetermineColr lft, middlecol, middlerow, bot, a
        DetermineColr middlecol, rght, middlerow, bot, a
    Else
        Exit Sub
    End If
End Sub

Function findClr (lft, rght, top, bot, a)
    'dang no POINT(x, y) oh well...
    p = (vScreen(lft, top) + vScreen(rght, top) + vScreen(lft, bot) + vScreen(rght, bot)) * 33
    'Try values of b = 4 or b = 7
    'b = 4
    'findClr = INT(p + a) MOD 16 'too much
    'findClr = INT(p / 13 + a) MOD 8 'less is more, yellow, green, red, brown theme
    findClr = Int(p / 17 + a) Mod 15 'less is more, blue and white theme
End Function

Sub vLINE (x0, y0, x1, y1, QBc)
    'record our line on the virtual screen
    If x0 = x1 Then
        If y0 > y1 Then start = y1: fini = y0 Else start = y0: fini = y1
        For i = start + 1 To fini - 1
            vScreen(x0, i) = QBc
        Next
    Else
        If x0 > x1 Then start = x1: fini = x0 Else start = x0: fini = x1
        For i = start + 1 To fini - 1
            vScreen(i, y0) = QBc
        Next
    End If
    Line (x0, y0)-(x1, y1), qb(QBc)
End Sub