Text Only | Text with Attachments

QB64.org Forum

Active Forums => Programs => Topic started by: bplus on February 28, 2018, 09:46:20 am

Title: Persian Carpets
Post by: bplus on February 28, 2018, 09:46:20 am
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]
  2. CONST xmax = 700
  3. CONST ymax = 600
  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
  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
  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
  76.  

Well if it made an impression, then must be Golden Oldie from NET
Title: Re: Persian Carpets
Post by: bplus on February 28, 2018, 09:51:44 am
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.  
  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
  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
  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
  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)
  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
  146.  
  147.  
Title: Re: Persian Carpets
Post by: Donald Foster on February 28, 2018, 12:44:12 pm
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
Title: Re: Persian Carpets
Post by: bplus on February 28, 2018, 02:15:13 pm
The mighty bplus strikes again! :D

Thanks Donald!
Text Only | Text with Attachments