Persian Carpets

[bplus]

Maybe Persian wash clothes ;)

I heard a call from the wilderness for the Mighty bplus carpets (inspired so by Cellular Automata).

Yeah I guess they might look similar in still shots, totally different process though, Persian Carpets uses POINT:

Code: QB64: [Select]

1. RANDOMIZE TIMER
2. CONST xmax = 700
3. CONST ymax = 600
4. COMMON SHARED mixer
5. SCREEN _NEWIMAGE(xmax, ymax, 32)
6. _TITLE "RECURSIVE FILL TESTER by bplus"
7.  
8. xoff = (xmax - 512) / 2: yoff = (ymax - 512) / 2 + 20
9. seedSpacer = 16
10. WHILE 1
11.     seedColor& = _RGB(RND * 100 + 155, RND * 100 + 155, RND * 100 + 155)
12.     WHILE 1
13.         IF k$ = " " THEN
14.             EXIT WHILE
15.         ELSEIF k$ = "h" THEN
16.             seedSpacer = seedSpacer \ 2
17.             IF seedSpacer = 1 THEN seedSpacer = 2
18.         ELSEIF k$ = "d" THEN
19.             seedSpacer = seedSpacer * 2
20.             IF seedSpacer = 512 THEN seedSpacer = 256
21.         END IF
22.         CLS
23.         PRINT "            seed spacer:"; seedSpacer; "  seed color: "; seedColor&; "  Rnd mixer: "; mixer
24.         FOR y = 0 TO 512 STEP seedSpacer
25.             FOR x = 0 TO 512 STEP seedSpacer
26.                 PSET (x + xoff, y + yoff), seedColor&
27.             NEXT
28.         NEXT
29.         mixer = RND * 10
30.         rfill 0 + xoff, 0 + yoff, 512 + xoff, 512 + yoff
31.         _DISPLAY
32.         LOCATE 3, 1
33.         INPUT " Seed spacer: h=half, d=double   seed color: spacebar to change,  enter next screen > ", k$
34.     WEND
35. WEND
36. SUB rfill (l, t, r, b)
37.     IF l < r - 2 AND t < b - 2 THEN
38.         mx = INT((r - l) / 2) + l: my = INT((b - t) / 2) + t
39.         pc& = INT((POINT(l, t) + POINT(r, t) + POINT(l, b) + POINT(r, b)) * mixer)
40.         IF _RED32(pc&) / 255 < .25 THEN
41.             r% = 0
42.         ELSEIF _RED32(pc&) / 255 < .5 THEN
43.             r% = 128
44.         ELSEIF _RED(pc&) / 255 < .75 THEN
45.             r% = 192
46.         ELSE
47.             r% = 255
48.         END IF
49.         IF _GREEN32(pc&) / 255 < .25 THEN
50.             g% = 0
51.         ELSEIF _GREEN32(pc&) / 255 < .5 THEN
52.             g% = 128
53.         ELSEIF _GREEN32(pc&) / 255 < .75 THEN
54.             g% = 192
55.         ELSE
56.             g% = 255
57.         END IF
58.         IF _BLUE32(pc&) / 255 < .5 THEN
59.             b% = 0
60.         ELSEIF _BLUE32(pc&) / 255 < .5 THEN
61.             b% = 128
62.         ELSEIF _BLUE32(pc&) / 255 < .75 THEN
63.             b% = 192
64.         ELSE
65.             b% = 255
66.         END IF
67.         LINE (mx - 1, my - 1)-(mx + 1, my + 1), _RGB(r%, g%, b%), BF
68.         rfill l, t, mx, my
69.         rfill mx, t, r, my
70.         rfill l, my, mx, b
71.         rfill mx, my, r, b
72.     ELSE
73.         EXIT SUB
74.     END IF
75. END SUB
76.  

Well if it made an impression, then must be Golden Oldie from NET

[bplus]

How about a magic Carpet ride?

Code: QB64: [Select]

1. ' Wavy Persian Carpets.bas SmallBASIC 0.12.9 (B+=MGA) 2017-09-27
2. ' originally based on Anne M Burns Persian Carpet
3.  
4. _DEFINE A-Z AS INTEGER
5. RANDOMIZE TIMER
6. CONST xmax = 1000
7. CONST ymax = 700
8.  
9. CONST W = 128
10. CONST H = 128
11.  
12. SCREEN _NEWIMAGE(xmax, ymax, 32)
13. _TITLE "Wavy Persian Carpets by bplus, press spacebar to wave another"
14. xo = (xmax - W) / 2: yo = (ymax - H) / 2
15. lft = xo: rght = W + xo: top = yo: bot = H + yo
16. WHILE 1
17.     REDIM carpet&(W, H)
18.     r& = _RGB(RND * 200 + 55, RND * 200 + 55, RND * 200 + 55)
19.     LINE (lft, top)-(rght, top), r&
20.     LINE (lft, bot)-(rght, bot), r&
21.     LINE (lft, top)-(lft, bot), r&
22.     LINE (rght, top)-(rght, bot), r&
23.     DetermineColor lft, rght, top, bot
24.     _DISPLAY
25.     FOR y = 0 TO H
26.         FOR x = 0 TO W
27.             carpet&(x, y) = POINT(xo + x, yo + y)
28.         NEXT
29.     NEXT
30.     'check point worked
31.     CLS
32.     PRINT "Check graphic, press any (except spacebar) to continue..."
33.     FOR y = 0 TO H
34.         FOR x = 0 TO W
35.             PSET (x + 100, y + 100), carpet&(x, y)
36.         NEXT
37.     NEXT
38.     _DISPLAY
39.     SLEEP
40.  
41.     da# = _PI(2) / 30: aInc# = _PI(2) / 50: a# = 0
42.     bOrbit! = .1: br! = 4: spacer = 5: walk! = 0: dir = 1
43.     WHILE 1
44.         IF _KEYHIT = 32 THEN EXIT WHILE
45.         a# = a# + aInc#
46.         bOrbit! = bOrbit! + .1 * dir
47.         IF bOrbit! >= 15.1 THEN bOrbit! = 15.0: dir = dir * -1
48.         IF bOrbit! <= 0 THEN bOrbit! = .1: dir = dir * -1
49.         CLS
50.         FOR y = 0 TO H
51.             FOR x = 0 TO W
52.                 bAngle# = (x + y) * da# + a#
53.                 xBall = (2 * SIN(bAngle#) + COS(bAngle#)) / 2 * bOrbit! + x * spacer
54.                 yBall = (COS(bAngle#) + SIN(bAngle#)) / 2 * bOrbit! + y * spacer
55.                 COLOR carpet&(x, y)
56.                 fcirc (xBall + 10 + walk!) MOD (xmax + 640), (yBall + 10 + .12 * walk!) MOD (ymax + 640), br!
57.             NEXT
58.         NEXT
59.         walk! = walk! + .1 * bOrbit!
60.         _DISPLAY
61.         _LIMIT 60
62.     WEND
63. WEND
64.  
65. REM Determine the color based on function f, and draw cross in quadrant
66. SUB DetermineColor (lft, rght, top, bot)
67.     IF (lft < rght - 1) THEN
68.         middlecol = INT((lft + rght) / 2)
69.         middlerow = INT((top + bot) / 2)
70.         c& = f&(lft, rght, top, bot)
71.         LINE (lft + 1, middlerow)-(rght - 1, middlerow), c&
72.         LINE (middlecol, top + 1)-(middlecol, bot - 1), c&
73.         DetermineColor lft, middlecol, top, middlerow
74.         DetermineColor middlecol, rght, top, middlerow
75.         DetermineColor lft, middlecol, middlerow, bot
76.         DetermineColor middlecol, rght, middlerow, bot
77.     ELSE
78.         EXIT SUB
79.     END IF
80. END SUB
81.  
82. 'create 4x4x4 very bright contrasting colors
83. FUNCTION f& (lft, rght, top, bot)
84.     p& = POINT(lft, top) + POINT(rght, top) + POINT(lft, bot) + POINT(rght, bot)
85.     IF _RED32(p&) / 255 < .25 THEN
86.         r% = 0
87.     ELSEIF _RED32(p&) / 255 < .5 THEN
88.         r% = 128
89.     ELSEIF _RED32(p&) / 255 < .75 THEN
90.         r% = 192
91.     ELSE
92.         r% = 255
93.     END IF
94.     IF _GREEN32(p&) / 255 < .25 THEN
95.         g% = 0
96.     ELSEIF _GREEN32(p&) / 255 < .5 THEN
97.         g% = 128
98.     ELSEIF _GREEN32(p&) / 255 < .75 THEN
99.         g% = 192
100.     ELSE
101.         g% = 255
102.     END IF
103.     IF _BLUE32(p&) / 255 < .5 THEN
104.         b% = 0
105.     ELSEIF _BLUE32(p&) / 255 < .5 THEN
106.         b% = 128
107.     ELSEIF _BLUE32(p&) / 255 < .75 THEN
108.         b% = 192
109.     ELSE
110.         b% = 255
111.     END IF
112.     f& = _RGB(r, g, b)
113. END FUNCTION
114.  
115. 'Steve McNeil's  copied from his forum   note: Radius is too common a name
116. SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
117.     DIM subRadius AS LONG, RadiusError AS LONG
118.     DIM X AS LONG, Y AS LONG
119.  
120.     subRadius = ABS(R)
121.     RadiusError = -subRadius
122.     X = subRadius
123.     Y = 0
124.  
125.     IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
126.  
127.     ' Draw the middle span here so we don't draw it twice in the main loop,
128.     ' which would be a problem with blending turned on.
129.     LINE (CX - X, CY)-(CX + X, CY), , BF
130.  
131.     WHILE X > Y
132.         RadiusError = RadiusError + Y * 2 + 1
133.         IF RadiusError >= 0 THEN
134.             IF X <> Y + 1 THEN
135.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
136.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
137.             END IF
138.             X = X - 1
139.             RadiusError = RadiusError - X * 2
140.         END IF
141.         Y = Y + 1
142.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
143.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
144.     WEND
145. END SUB
146.  
147.  

[Donald Foster]

bplus,

Those are amazing. I have no clue how they are done. The images that you and Walter makes with your demos are incredible.

Donald

[bplus]

The mighty bplus strikes again! :D

Thanks Donald!