Graphic Code Challenge

[B+]

Make similar:

[ZXDunny]

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!

[Tomaaz]

Yeah... This is not a code challenge. It's more "how did he manage to get this colors" challenge.

[B+]

Here is code for the "bricks":

Code: [Select]

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:

Code: [Select]

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).

[ZXDunny]

I assume you're talking about this algorithm:

https://web.archive.org/web/20020331211006/http://www.oup-usa.org/sc/0195133420/ch50.bas.txt

Code: [Select]

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:

Code: [Select]

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.



You can add more variety by retaining the MOD 16 (as that constrains to the lower palette) and setting BC to RND*somelargenumber.

D.

[B+]

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.

[B+]

These things are gorgeous! But the size is very sensitive to multiples of 2, else you get junk.

Code: [Select]

'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


[B+]

Oh the variety! But unless I use 513x401 I loose the perfect symmetry. Look carefully

[ZXDunny]

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.

[B+]

Some updates to this code: from radial symmetry to bilateral, brighter colors, centered on screen, random element for unique runs...

Code: [Select]

'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