Colorful Triangle Geometry

[Ashish]

Hi everyone!
I made a program which makes colorful and beautiful pattern full of triangles.
I hope you will like like it. :)

Code: QB64: [Select]

1. 'Coded By Ashish
2. '4 may, 2021
3. 'edited : 9 may,2021
4. _Title "Triangular Geometry"
5. Screen _NewImage(800, 600, 32)
6. Randomize Timer
7. 404 pattern 400, 0, 0, 600, 800, 600, 600, Int(Rnd * 255), 50 + Int(Rnd * 205)
8. _Display
9. _Delay 0.25
10. GoTo 404
11. Sub pattern (x0, y0, x1, y1, x2, y2, d_max, s_min, s_width)
12.     mx = (x1 + x2) / 2: my = (y1 + y2) / 2
13.     d = Int(Sqr((mx - x0) ^ 2 + (my - y0) ^ 2))
14.     drawTriangleSolid x0, y0, x1, y1, x2, y2, hsb(map(d, 10, d_max, s_min, (s_max + s_width) Mod 255), 255, 128, map(d, 10, d_max, 50, 255))
15.     If d > 10 Then
16.         If d >= d_max Then
17.             pattern mx, my, x0, y0, x1, y1, d_max, s_min, s_width
18.             pattern mx, my, x0, y0, x2, y2, d_max, s_min, s_width
19.  
20.         Else
21.             If Rnd > 0.5 Then pattern mx, my, x0, y0, x1, y1, d_max, s_min, s_width Else pattern mx, my, x0, y0, x2, y2, d_max, s_min, s_width
22.         End If
23.     End If
24. End Sub
25.  
26. Sub drawTriangleSolid (x1, y1, x2, y2, x3, y3, c~&)
27.     Static temp_color_img As Long, drawTriangle_init As _Byte
28.     If drawTriangle_init = 0 Then
29.         temp_color_img = _NewImage(1, 1, 32)
30.         drawTriangle_init = 1
31.     End If
32.     preDest = _Dest
33.     _Dest temp_color_img
34.     PSet (0, 0), c~&
35.     _Dest preDest
36.  
37.     _MapTriangle (0, 0)-(0, 0)-(0, 0), temp_color_img To(x1, y1)-(x2, y2)-(x3, y3), 0, _Smooth
38.  
39. End Sub
40.  
41. Sub drawTriangle (x1, y1, x2, y2, x3, y3, c~&)
42.     Line (x1, y1)-(x2, y2), c~&
43.     Line (x2, y2)-(x3, y3), c~&
44.     Line (x3, y3)-(x1, y1), c~&
45. End Sub
46.  
47. 'method adapted form http://stackoverflow.com/questions/4106363/converting-rgb-to-hsb-colors
48. Function hsb~& (__H As _Float, __S As _Float, __B As _Float, A As _Float)
49.     Dim H As _Float, S As _Float, B As _Float
50.  
51.     H = map(__H, 0, 255, 0, 360)
52.     S = map(__S, 0, 255, 0, 1)
53.     B = map(__B, 0, 255, 0, 1)
54.  
55.     If S = 0 Then
56.         hsb~& = _RGBA32(B * 255, B * 255, B * 255, A)
57.         Exit Function
58.     End If
59.  
60.     Dim fmx As _Float, fmn As _Float
61.     Dim fmd As _Float, iSextant As Integer
62.     Dim imx As Integer, imd As Integer, imn As Integer
63.  
64.     If B > .5 Then
65.         fmx = B - (B * S) + S
66.         fmn = B + (B * S) - S
67.     Else
68.         fmx = B + (B * S)
69.         fmn = B - (B * S)
70.     End If
71.  
72.     iSextant = Int(H / 60)
73.  
74.     If H >= 300 Then
75.         H = H - 360
76.     End If
77.  
78.     H = H / 60
79.     H = H - (2 * Int(((iSextant + 1) Mod 6) / 2))
80.  
81.     If iSextant Mod 2 = 0 Then
82.         fmd = (H * (fmx - fmn)) + fmn
83.     Else
84.         fmd = fmn - (H * (fmx - fmn))
85.     End If
86.  
87.     imx = _Round(fmx * 255)
88.     imd = _Round(fmd * 255)
89.     imn = _Round(fmn * 255)
90.  
91.     Select Case Int(iSextant)
92.         Case 1
93.             hsb~& = _RGBA32(imd, imx, imn, A)
94.         Case 2
95.             hsb~& = _RGBA32(imn, imx, imd, A)
96.         Case 3
97.             hsb~& = _RGBA32(imn, imd, imx, A)
98.         Case 4
99.             hsb~& = _RGBA32(imd, imn, imx, A)
100.         Case 5
101.             hsb~& = _RGBA32(imx, imn, imd, A)
102.         Case Else
103.             hsb~& = _RGBA32(imx, imd, imn, A)
104.     End Select
105.  
106. End Function
107.  
108.  
109. 'from p5js.bas
110. Function map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
111.     map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
112. End Function
113.  
114.  

[johnno56]

I was all set to ask, "Does it come in blue?".... Never mind.... Bonus: I like it...

[_vince]

nice use of recursion, reminds me of

Code: QB64: [Select]

1. dim shared pi
2. dim shared c
3. dim shared cc
4. pi = 4*atn(1)
5. c = 2*sqr(3)/9
6. cc = sqr(12) / 6
7.  
8. sw = 1024
9. sh = 768
10.  
11. screen _newimage(sw, sh, 12)
12. tri sw/2, sh/2, 600, 0
13. tri sw/2, sh/2, 600, pi
14. kock sw/2, sh/2, 600, 3
15. sleep
16. system
17.  
18. sub kock(x, y, s, i)
19.         if i = 0 then exit sub
20.         for a = pi/6 to 2*pi + pi/6 step pi/3
21.                 xx = s*c*cos(a) + x
22.                 yy = s*c*sin(a) + y
23.        
24.                 tri xx, yy, s/3, a+pi/6
25.                 tri xx, yy, s/3, a+pi/6+pi
26.  
27.                 kock xx, yy, s/3, i - 1
28.         next
29. end sub
30.  
31. sub tri(x, y, s, a)
32.         line (x,y)-(x+s*cc*cos(pi/6 + a),y+s*cc*sin(pi/6 + a)),8
33.         line (x,y)-(x+s*cc*cos(5*pi/6 + a),y+s*cc*sin(5*pi/6 + a)),8
34.         line (x,y)-(x-s*cc*cos(pi/2 + a),y-s*cc*sin(pi/2 + a)),8
35.  
36.         line (x+s*cc*cos(pi/6 + a),y+s*cc*sin(pi/6 + a))-(x+s*cc*cos(5*pi/6 + a),y+s*cc*sin(5*pi/6 + a))
37.         line-(x-s*cc*cos(pi/2 + a),y-s*cc*sin(pi/2 + a))
38.         line-(x+s*cc*cos(pi/6 + a),y+s*cc*sin(pi/6 + a))
39. end sub
40.  

[Ashish]

Thank you Johnno and Vince!
I like that program Vince!, Thanks for sharing

[TempodiBasic]

@Ashish
cool ! speedy maptriangles colors.
I find it very good.
Just a feedback....
 it sometimes uses color very near in the spectrum of visible and my old eyes cannot distinguish them
 like in this screenshot
 

[TempodiBasic]

@vince
hey man with your math geometry I'm loosing my mind in its different prospectives
se here
 

... I'm thinking how it can appear if it uses  many colors

[Ashish]

@TempodiBasic
Thanks! I have updated the code now... I hope it works fine for you now

[Ashish]

Here's a little modification I made to this -

Code: QB64: [Select]

1. 'Coded By Ashish
2. '4 may, 2021
3. 'edited : 9 may,2021
4. _Title "Triangular Geometry"
5. Screen _NewImage(800, 600, 32)
6. Randomize Timer
7. '404 pattern 400, 0, 0, 600, 800, 600, 600, Int(Rnd * 255), 50 + Int(Rnd * 205)
8. Dim vx(2), vy(2)
9. Dim ox, oy, r, start_ang, h, clr_start, clr_width
10. Do
11.     'creating new set of vertices of equilateral triangle
12.     ox = Int(Rnd * 800): oy = Int(Rnd * 600)
13.     r = 50 + Int(Rnd * 200)
14.     start_ang = Rnd * _Pi(2)
15.     n = 0
16.     'Print start_ang, start_ang + _Pi(2)
17.     For i = start_ang To start_ang + _Pi(2) Step _Pi(0.67)
18.         'Print i
19.         vx(n) = ox + r * Cos(i): vy(n) = oy + r * Sin(i)
20.         n = n + 1
21.     Next
22.     h = r * 1.5
23.     'color settings
24.     clr_start = Int(Rnd * 255): clr_width = 50 + Int(Rnd * 255)
25.     pattern vx(0), vy(0), vx(1), vy(1), vx(2), vy(2), h, clr_start, clr_width
26.     _Display
27.     _Limit 10
28. Loop
29. '_Display
30. '_Delay 0.25
31. 'GoTo 404
32. Sub pattern (x0, y0, x1, y1, x2, y2, d_max, s_min, s_width)
33.     mx = (x1 + x2) / 2: my = (y1 + y2) / 2
34.     d = Int(Sqr((mx - x0) ^ 2 + (my - y0) ^ 2))
35.     drawTriangleSolid x0, y0, x1, y1, x2, y2, hsb(map(d, 10, d_max, s_min, (s_max + s_width) Mod 255), 255, 128, map(d, 10, d_max, 50, 255))
36.     If d > 10 Then
37.         If d >= d_max Then
38.             pattern mx, my, x0, y0, x1, y1, d_max, s_min, s_width
39.             pattern mx, my, x0, y0, x2, y2, d_max, s_min, s_width
40.  
41.         Else
42.             If Rnd > 0.5 Then pattern mx, my, x0, y0, x1, y1, d_max, s_min, s_width Else pattern mx, my, x0, y0, x2, y2, d_max, s_min, s_width
43.         End If
44.     End If
45. End Sub
46.  
47. Sub drawTriangleSolid (x1, y1, x2, y2, x3, y3, c~&)
48.     Static temp_color_img As Long, drawTriangle_init As _Byte
49.     If drawTriangle_init = 0 Then
50.         temp_color_img = _NewImage(1, 1, 32)
51.         drawTriangle_init = 1
52.     End If
53.     preDest = _Dest
54.     _Dest temp_color_img
55.     PSet (0, 0), c~&
56.     _Dest preDest
57.  
58.     _MapTriangle (0, 0)-(0, 0)-(0, 0), temp_color_img To(x1, y1)-(x2, y2)-(x3, y3), 0, _Smooth
59.  
60. End Sub
61.  
62. Sub drawTriangle (x1, y1, x2, y2, x3, y3, c~&)
63.     Line (x1, y1)-(x2, y2), c~&
64.     Line (x2, y2)-(x3, y3), c~&
65.     Line (x3, y3)-(x1, y1), c~&
66. End Sub
67.  
68. 'method adapted form http://stackoverflow.com/questions/4106363/converting-rgb-to-hsb-colors
69. Function hsb~& (__H As _Float, __S As _Float, __B As _Float, A As _Float)
70.     Dim H As _Float, S As _Float, B As _Float
71.  
72.     H = map(__H, 0, 255, 0, 360)
73.     S = map(__S, 0, 255, 0, 1)
74.     B = map(__B, 0, 255, 0, 1)
75.  
76.     If S = 0 Then
77.         hsb~& = _RGBA32(B * 255, B * 255, B * 255, A)
78.         Exit Function
79.     End If
80.  
81.     Dim fmx As _Float, fmn As _Float
82.     Dim fmd As _Float, iSextant As Integer
83.     Dim imx As Integer, imd As Integer, imn As Integer
84.  
85.     If B > .5 Then
86.         fmx = B - (B * S) + S
87.         fmn = B + (B * S) - S
88.     Else
89.         fmx = B + (B * S)
90.         fmn = B - (B * S)
91.     End If
92.  
93.     iSextant = Int(H / 60)
94.  
95.     If H >= 300 Then
96.         H = H - 360
97.     End If
98.  
99.     H = H / 60
100.     H = H - (2 * Int(((iSextant + 1) Mod 6) / 2))
101.  
102.     If iSextant Mod 2 = 0 Then
103.         fmd = (H * (fmx - fmn)) + fmn
104.     Else
105.         fmd = fmn - (H * (fmx - fmn))
106.     End If
107.  
108.     imx = _Round(fmx * 255)
109.     imd = _Round(fmd * 255)
110.     imn = _Round(fmn * 255)
111.  
112.     Select Case Int(iSextant)
113.         Case 1
114.             hsb~& = _RGBA32(imd, imx, imn, A)
115.         Case 2
116.             hsb~& = _RGBA32(imn, imx, imd, A)
117.         Case 3
118.             hsb~& = _RGBA32(imn, imd, imx, A)
119.         Case 4
120.             hsb~& = _RGBA32(imd, imn, imx, A)
121.         Case 5
122.             hsb~& = _RGBA32(imx, imn, imd, A)
123.         Case Else
124.             hsb~& = _RGBA32(imx, imd, imn, A)
125.     End Select
126.  
127. End Function
128.  
129.  
130. 'from p5js.bas
131. Function map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
132.     map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
133. End Function
134.  
135.  

[TempodiBasic]

@Ashish
very funny!
It works well.

[bplus]

Well @Ashish color and recursive subs, you know I had to join the fun!

Here is my rendition:

Code: QB64: [Select]

1. _Title "Recursively Divide a Triangle into 2" 'b+ 2021-05-11
2. ' inspired by Ashish post here:  https://www.qb64.org/forum/index.php?topic=3867.msg132129#msg132129
3. ' Find the longest side middle point and draw line from that to angle point opposite that side.
4. ' Then pass the 2 new tri's back to recursive sub until the longest side < 20, not 10
5. ' See what happens... Ok way way to boring we need random filling and color!
6. Randomize Timer
7. Screen _NewImage(1200, 600, 32)
8. _Delay .25
9. _ScreenMove _Middle
10. Do
11.     Cls
12.     DivideTriTo2 600, 0, 0, 600, 1200, 600
13.     _Delay 2
14. Loop
15.  
16. Sub DivideTriTo2 (x1, y1, x2, y2, x3, y3)
17.     s1 = _Hypot(x1 - x2, y1 - y2)
18.     s2 = _Hypot(x3 - x2, y3 - y2)
19.     s3 = _Hypot(x1 - x3, y1 - y3)
20.     ftri x1, y1, x2, y2, x3, y3, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 255)
21.     _Delay .002
22.     If s1 >= s2 And s1 >= s3 And s1 > 20 Then
23.         ptx = x3: pty = y3
24.         mx = (x1 + x2) / 2: my = (y1 + y2) / 2
25.         If Rnd < .75 Then DivideTriTo2 mx, my, ptx, pty, x1, y1
26.         If Rnd < .75 Then DivideTriTo2 mx, my, ptx, pty, x2, y2
27.     ElseIf s2 >= s1 And s2 >= s3 And s2 > 20 Then
28.         ptx = x1: pty = y1
29.         mx = (x3 + x2) / 2: my = (y3 + y2) / 2
30.         If Rnd < .75 Then DivideTriTo2 mx, my, ptx, pty, x2, y2
31.         If Rnd < .75 Then DivideTriTo2 mx, my, ptx, pty, x3, y3
32.     ElseIf s3 >= s1 And s3 >= s2 And s3 > 20 Then
33.         ptx = x2: pty = y2
34.         mx = (x1 + x3) / 2: my = (y1 + y3) / 2
35.         If Rnd < .75 Then DivideTriTo2 mx, my, ptx, pty, x1, y1
36.         If Rnd < .75 Then DivideTriTo2 mx, my, ptx, pty, x3, y3
37.     End If
38. End Sub
39.  
40. '2019-12-16 fix by Steve saves some time with STATIC and saves and restores last dest
41. Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
42.     Dim D As Long
43.     Static a&
44.     D = _Dest
45.     If a& = 0 Then a& = _NewImage(1, 1, 32)
46.     _Dest a&
47.     _DontBlend a& '  '<<<< new 2019-12-16 fix
48.     PSet (0, 0), K
49.     _Blend a& '<<<< new 2019-12-16 fix
50.     _Dest D
51.     _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
52. End Sub
53.