RetroBASIC
Basicprogramming(.org) => Code and examples => Topic started by: B+ on February 08, 2016, 06:45:18 PM
-
Make similar:
-
It's a recursive subdivision, with three colours per level (outline and two fill colours). Not sure how the colours are chosen, mind. I suspect we're heading further into a small palette (with wrap around) as get deeper?
Nice image, puzzling how you got it though!
-
Yeah... This is not a code challenge. It's more "how did he manage to get this colors" challenge. ;)
-
Here is code for the "bricks":
func cr 'color reds
if i mod 2 then cr=12 else cr=rgb(125,0,0)
endlight red or dark red
Here is code for the mortar:
rgb(int(rnd*2)*255,int(rnd*2)*255,int(rnd*2)*255) '2^3 possible colors including B&W
Put the still drawing in a loop and it is quite colorful!
Yes, recursively divides a screen section into 4 subsections.
This was an attempt at a Persian carpet, I was trying to follow a text description of the algorithm. Doesn't quite match the B&W in book (Wonders of Numbers).
-
I assume you're talking about this algorithm:
https://web.archive.org/web/20020331211006/http://www.oup-usa.org/sc/0195133420/ch50.bas.txt
REM BASIC Code: Persian Carpet Designs
REM A modification of original concept from Anne Burns
REM Try colorborder=15, a=3
DECLARE FUNCTION DetermineColor! (left!, right!, top!, bot!, a!)
DECLARE FUNCTION f! (left!, right!, top!, bot!, a!)
INPUT "Enter the border color, 1 - 15:", colorborder
INPUT "Enter a value >", a
SCREEN 12
CLS
left = 1
right = 513
top = 1
bot = 401
LINE (left, top)-(right, top), colorborder
LINE (left, bot)-(right, bot), colorborder
LINE (left, top)-(left, bot), colorborder
LINE (right, top)-(right, bot), colorborder
k = DetermineColor(left, right, top, bot, a)
END
REM Determine the color based on function f
FUNCTION DetermineColor (left, right, top, bot, a)
IF left < right - 1 THEN
c = f(left, right, top, bot, a)
middlecol = (left + right) / 2
middlerow = (top + bot) / 2
LINE (left + 1, middlerow)-(right - 1, middlerow), c
LINE (middlecol, top + 1)-(middlecol, bot - 1), c
DetermineColor = DetermineColor(left, middlecol, top, middlerow, a)
DetermineColor = DetermineColor(middlecol, right, top, middlerow, a)
DetermineColor = DetermineColor(left, middlecol, middlerow, bot, a)
DetermineColor = DetermineColor(middlecol, right, middlerow, bot, a)
END IF
END FUNCTION
REM When b=4, this function takes an average.
FUNCTION f (left, right, top, bot, a)
p = POINT(left, top) + POINT(right, top) + POINT(left, bot) + POINT(right, bot)
'Try values of b = 4 or b = 7
b=7
f = (p /b + a) MOD 16
END FUNCTION
In which case, here is the SpecBAS equivalent:
ZXBASIC
10 REM Persian Carpet
20 DEF FN f(l,r,t,b,a)=((POINT(l,t)+POINT(r,t)+POINT(l,b)+POINT(r,b))/4+a) MOD 16
30 DEF PROC dc(l,r,t,b,a)
40 IF l<r-1 THEN LOCAL c=FN f(l,r,t,b,a),mc=(l+r)/2,mr=(t+b)/2: DRAW INK c;l+1,mr TO r-1,mr: DRAW INK c;mc,t+1 TO mc,b-1: PROC dc(l,mc,t,mr,a): PROC dc(mc,r,t,mr,a): PROC dc(l,mc,mr,b,a): PROC dc(mc,r,mr,b,a)
50 END PROC
60 bc=INT(RND*15)+1,a=3,l=1,r=513,t=1,b=401: RECTANGLE INK bc;l,t TO r,b
70 PROC dc(l,r,t,b,a)
80 PAUSE 0: GO TO 60
Which produces some quite nice images (though I can't help but think that a better palette would be in order!), even if the variations appear to be limited.
(http://s12.postimg.org/c2lidd899/persian.png)
You can add more variety by retaining the MOD 16 (as that constrains to the lower palette) and setting BC to RND*somelargenumber.
D.
-
Hi D,
Yes very nice! That is much better pattern/algorithm.
I was adding a Sierpinski tile to my graphic and noticed an inconsistency in my brick coloring. Here is corrected version without cr function using:
rgb((i mod 4)*80,0,0) for 4 color bricks
Sierpinski Tile worked out OK too.
-
These things are gorgeous! But the size is very sensitive to multiples of 2, else you get junk.
'Persian Carpet.bas for SmallBASIC 0.12.2 [B+=MGA] 2016-02-08
'modified from copy from Retrogamecoding link 2016-02-08
REM BASIC Code: Persian Carpet Designs
REM A modification of original concept from Anne Burns
REM Try colorborder=15, a=3
while 1
cls
INPUT "Enter the border color, 1 - 15 (try 15): ", colorborder
INPUT "Enter a value (try 3) > ", a
CLS
lft = 1
'rght = 513
rght=1025
top = 1
'bot = 401
bot=801
LINE lft,top,rght,top,colorborder
LINE lft,bot,rght,bot,colorborder
LINE lft,top,lft,bot,colorborder
LINE rght,top,rght,bot,colorborder
DetermineColor lft, rght, top, bot, a
showpage
pause
wEND
REM Determine the color based on function f
sub DetermineColor(lft, rght, top, bot, a)
local c,middlerow,middlecol
IF (lft < rght - 1) THEN
c = f(lft, rght, top, bot, a)
middlecol = (lft + rght) / 2
middlerow = (top + bot) / 2
LINE lft + 1, middlerow,rght - 1, middlerow, c
LINE middlecol, top + 1, middlecol, bot - 1, c
DetermineColor lft, middlecol, top, middlerow, a
DetermineColor middlecol, rght, top, middlerow, a
DetermineColor lft, middlecol, middlerow, bot, a
DetermineColor middlecol, rght, middlerow, bot, a
else
exit
END IF
END
REM When b=4, this function takes an average.
FUNC f(lft, rght, top, bot, a)
local p,b
p = POINT(lft, top) + POINT(rght, top) + POINT(lft, bot) + POINT(rght, bot)
'Try values of b = 4 or b = 7
b=7
f = (p /b + a) MOD 16
END
-
Oh the variety! But unless I use 513x401 I loose the perfect symmetry. Look carefully
-
Yeah - it's a very sensitive algorithm but the carpets are nice! Just need to figure out a way to generate random but pleasing palettes that simulate the weave...
I googled the book you were talking about - "wonder of numbers" and got a google books result. Found a persian carpet-alike black and white image, then went through archive.org looking for the BASIC code he referred to. That's the code that produced the black and white image, as far as I can tell.
D.
-
Some updates to this code: from radial symmetry to bilateral, brighter colors, centered on screen, random element for unique runs...
'Persian Carpet v2.bas for SmallBASIC 0.12.9 (B+=MGA)
'modified from copy from Retrogamecoding link 2016-02-08
' 2017-09-23 mod for brighter colors and centered
' alas, some blank screens but much brighter!
' 2017-09-24 eliminate radial symmerty and most blank screens
REM BASIC Code: Persian Carpet Designs
REM A modification of original concept from Anne Burns
colorborder = 0 : a = 1
xo = (xmax - 512) / 2 : yo = (ymax - 512) / 2
while 1
CLS
lft = 1 + xo : rght = 513 + xo : top = 1 + yo: bot = 513 + yo
cb2 = rnd * 16 \ 1
LINE lft, top, rght, top, cb2
LINE lft, bot, rght, bot, cb2
LINE lft, top, lft, bot, colorborder
LINE rght, top, rght, bot, colorborder
DetermineColor lft, rght, top, bot, a
at 10, 10 : ? "colorboarder = ";colorborder;" cb 2 = ";cb2;" a = ";a
showpage
pause
a = a + 1
if a >= 16 then a = 1 : colorborder += 1
if colorborder >= 16 then colorborder = 0
wend
rem Determine the color based on function f
sub DetermineColor(lft, rght, top, bot, a)
local c, middlerow, middlecol
IF (lft < rght - 2) THEN
c = f(lft, rght, top, bot, a)
middlecol = int((lft + rght) / 2)
middlerow = int((top + bot) / 2)
LINE lft + 1, middlerow,rght - 1, middlerow, c
LINE middlecol, top + 1, middlecol, bot - 1, c
DetermineColor lft, middlecol, top, middlerow, a
DetermineColor middlecol, rght, top, middlerow, a
DetermineColor lft, middlecol, middlerow, bot, a
DetermineColor middlecol, rght, middlerow, bot, a
else
exit
end if
end
func f(lft, rght, top, bot, a)
local p, b
p = point(lft, top) + POINT(rght, top) + POINT(lft, bot) + POINT(rght, bot)
'Try values of b = 4 or b = 7
b = 60
f = int(p / b + a) mod 9 + 7
end
and yet not all that different ;)