QB64.org Forum

Active Forums => Programs => Topic started by: bplus on May 04, 2021, 05:23:30 pm

Title: Yin Yang - Rosetta Code
Post by: bplus on May 04, 2021, 05:23:30 pm

But Yin Yang was never meant to be static:

Code: QB64: [Select]

1. _Title "Ying Yang Color Balls" 'b+ 2020-08-19 balls mod 2021-05-04
2. ' 2020-08-19 pulled this one out of my files for QB64 trans
3. 'Ying yang color.bas 2015-07-08 I know I updated sdlbas version how about SmallBASIC?
4. 'from Ying Yang v3.sdlbas 2015-06-03 MGA
5.  
6. Const sq = 500, rc = sq / 4 - 40, xc = sq / 2, yc = sq / 2
7. Screen _NewImage(sq, sq, 32)
8. _Delay .25
9. _ScreenMove _Middle
10.  
11. Dim c As _Unsigned Long
12. nc = 1
13. d = .1
14. dir = 1
15. i = 0
16. acc = .01 'radians
17. Do
18.     x1 = xc + rc * Sin(i)
19.     y1 = yc + rc * Cos(i)
20.     If nc > 254 Then d = -1 * d
21.     If nc < 1 Then d = -1 * d
22.     nc = nc + d * dir
23.     If nc > 255 Then dir = dir * -1: d = d * dir
24.     If nc < 1 Then dir = dir * -1: d = d * dir
25.     c = _RGB32(nc, 0, 255 - nc)
26.     drawBall x1, y1, rc, c
27.     c = _RGB32(0, 255 - nc, nc)
28.     drawBall x1, y1, rc / 3, c
29.     x2 = xc + rc * Sin(i + 3.1415)
30.     y2 = yc + rc * Cos(i + 3.1415)
31.     drawBall x2, y2, rc, c
32.     c = _RGB32(nc, 0, 255 - nc)
33.     drawBall x2, y2, rc / 3, c
34.     i = i + acc
35.     _Display
36. Loop Until _KeyDown(27)
37.  
38. Sub drawBall (x, y, r, c As _Unsigned Long)
39.     Dim rred As Long, grn As Long, blu As Long, rr As Long, f
40.     rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
41.     For rr = r To 0 Step -4
42.         f = 1 - (rr / r) * .5
43.         fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
44.     Next
45. End Sub
46.  
47. 'from Steve Gold standard
48. Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
49.     Dim Radius As Integer, RadiusError As Integer
50.     Dim X As Integer, Y As Integer
51.     Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
52.     If Radius = 0 Then PSet (CX, CY), C: Exit Sub
53.     Line (CX - X, CY)-(CX + X, CY), C, BF
54.     While X > Y
55.         RadiusError = RadiusError + Y * 2 + 1
56.         If RadiusError >= 0 Then
57.             If X <> Y + 1 Then
58.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
59.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
60.             End If
61.             X = X - 1
62.             RadiusError = RadiusError - X * 2
63.         End If
64.         Y = Y + 1
65.         Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
66.         Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
67.     Wend
68. End Sub
69.  
70.  
71.  

Title: Re: Yin Yang - Rosetta Code
Post by: Ashish on May 05, 2021, 02:27:37 am

Nice one! I like it! very smooth

Title: Re: Yin Yang - Rosetta Code
Post by: bplus on May 05, 2021, 02:29:38 pm

Thanks Ashish, been playing around with Yin Yang 6 years yesterday I gave it balls.

Text Only | Text with Attachments