QB64.org Forum

Active Forums => Programs => Topic started by: loudar on August 13, 2020, 06:55:20 am

Title: Gradients!
Post by: loudar on August 13, 2020, 06:55:20 am

Hey folks, wrote a little program to make some cool gradients:

Code: QB64: [Select]

1. 'GRADIENTS
2. 'by Loudar
3. DIM SHARED maxgradients
4. DIM SHARED maxcolors
5. maxgradients = 20
6. maxcolors = 20 'per gradient
7. DIM SHARED gcol&(maxgradients, maxcolors) 'saves color in gradient
8. DIM SHARED gpos(maxgradients, maxcolors) 'saves position of color in gradient
9. DIM SHARED maxgcol&(maxgradients) 'saves maximum amount of colors in gradients
10.  
11. SCREEN _NEWIMAGE(500, 500, 32)
12.  
13. 'test gradient 1
14. newgcolor 1, 1, 0, colour&("white")
15. newgcolor 1, 2, 20, colour&("red")
16. newgcolor 1, 3, 100, colour&("blue")
17. newgradient 1, 3
18. drawgradient 1, 0, 500, 0, 50, "h"
19.  
20. 'test gradient 2
21. newgcolor 2, 1, 0, colour&("green")
22. newgcolor 2, 2, 20, _RGBA(249, 105, 255, 255)
23. newgcolor 2, 3, 40, _RGBA(127, 255, 127, 255)
24. newgcolor 2, 4, 60, _RGBA(194, 0, 188, 255)
25. newgcolor 2, 5, 80, _RGBA(0, 255, 255, 255)
26. newgcolor 2, 6, 100, colour&("white")
27. newgradient 2, 6
28. drawgradient 2, 0, 500, 50, 100, "h"
29.  
30. 'test gradient 3
31. newgcolor 3, 1, 0, _RGBA(255, 172, 0, 255)
32. newgcolor 3, 2, 50, _RGBA(255, 44, 83, 255)
33. newgcolor 3, 3, 100, _RGBA(100, 155, 255, 255)
34. newgradient 3, 3
35. drawgradient 3, 0, 500, 100, 150, "v"
36.  
37. SLEEP
38. SYSTEM
39.  
40. '--------------------------------------------------------------------------------------------
41.  
42. SUB newgcolor (gradient, gcolor, gpos, col&)
43.     IF gcolor > 0 AND gcolor <= maxcolors THEN
44.         gcol&(gradient, gcolor) = col&
45.         gpos(gradient, gcolor) = gpos
46.     END IF
47. END SUB
48.  
49. SUB newgradient (gradient, maxgrcolors)
50.     IF gradient > 0 AND gradient <= maxgradients AND maxgrcolors > 0 AND maxgrcolors <= maxcolors THEN
51.         maxgcol&(gradient) = maxgrcolors
52.     END IF
53. END SUB
54.  
55. FUNCTION gradientcolor& (gradient, grposition)
56.     IF maxgcol&(gradient) > 0 THEN
57.         grcolor = 0: DO: grcolor = grcolor + 1
58.             IF grposition = gpos(gradient, grcolor) THEN
59.                 gradientcolor& = gcol&(gradient, grcolor)
60.             ELSE
61.                 IF grcolor < maxgcol&(gradient) THEN
62.                     IF grposition > gpos(gradient, grcolor) AND grposition < gpos(gradient, grcolor + 1) THEN
63.                         r1 = _RED(gcol&(gradient, grcolor))
64.                         g1 = _GREEN(gcol&(gradient, grcolor))
65.                         b1 = _BLUE(gcol&(gradient, grcolor))
66.                         a1 = _ALPHA(gcol&(gradient, grcolor))
67.                         r2 = _RED(gcol&(gradient, grcolor + 1))
68.                         g2 = _GREEN(gcol&(gradient, grcolor + 1))
69.                         b2 = _BLUE(gcol&(gradient, grcolor + 1))
70.                         a2 = _ALPHA(gcol&(gradient, grcolor + 1))
71.                         p1 = gpos(gradient, grcolor)
72.                         p2 = gpos(gradient, grcolor + 1)
73.                         f = (grposition - p1) / (p2 - p1)
74.                         IF r1 > r2 THEN
75.                             r = r1 - ((r1 - r2) * f)
76.                         ELSEIF r1 = r2 THEN
77.                             r = r1
78.                         ELSE
79.                             r = r1 + ((r2 - r1) * f)
80.                         END IF
81.                         IF g1 > g2 THEN
82.                             g = g1 - ((g1 - g2) * f)
83.                         ELSEIF g1 = g2 THEN
84.                             g = g1
85.                         ELSE
86.                             g = g1 + ((g2 - g1) * f)
87.                         END IF
88.                         IF b1 > b2 THEN
89.                             b = b1 - ((b1 - b2) * f)
90.                         ELSEIF b1 = b2 THEN
91.                             b = b1
92.                         ELSE
93.                             b = b1 + ((b2 - b1) * f)
94.                         END IF
95.                         IF a1 > a2 THEN
96.                             a = a1 - ((a1 - a2) * f)
97.                         ELSEIF a1 = a2 THEN
98.                             a = a1
99.                         ELSE
100.                             a = a1 + ((a2 - a1) * f)
101.                         END IF
102.                         gradientcolor& = _RGBA(INT(r), INT(g), INT(b), INT(a))
103.                     END IF
104.                 END IF
105.             END IF
106.         LOOP UNTIL grcolor = maxgcol&(gradient)
107.     ELSE
108.         gradientcolor& = _RGBA(0, 0, 0, 0)
109.     END IF
110. END FUNCTION
111.  
112. SUB drawgradient (gradient, lx, ux, ly, uy, orientation$)
113.     SELECT CASE orientation$
114.         CASE "h"
115.             IF ux - lx > 0 THEN
116.                 rx = 0: DO: rx = rx + 1
117.                     LINE (lx + rx, ly)-(lx + rx, uy), gradientcolor&(gradient, rx / (ux - lx) * 100)
118.                 LOOP UNTIL rx >= ux - lx
119.             END IF
120.         CASE "v"
121.             IF uy - ly > 0 THEN
122.                 ry = 0: DO: ry = ry + 1
123.                     LINE (lx, ly + ry)-(ux, ly + ry), gradientcolor&(gradient, ry / (uy - ly) * 100)
124.                 LOOP UNTIL ry >= uy - ly
125.             END IF
126.     END SELECT
127. END SUB
128.  
129. FUNCTION colour& (color$)
130.     SELECT CASE color$
131.         CASE "white"
132.             colour& = _RGBA(255, 255, 255, 255)
133.         CASE "black"
134.             colour& = _RGBA(15, 15, 15, 255)
135.         CASE "red"
136.             colour& = _RGBA(255, 30, 30, 255)
137.         CASE "yellow"
138.             colour& = _RGBA(249, 194, 0, 255)
139.         CASE "green"
140.             colour& = _RGBA(94, 233, 61, 255)
141.         CASE "blue"
142.             colour& = _RGBA(6, 150, 255, 255)
143.         CASE "dark grey"
144.             colour& = _RGBA(50, 50, 50, 255)
145.         CASE "light grey"
146.             colour& = _RGBA(170, 170, 170, 255)
147.         CASE "transparent"
148.             colour& = _RGBA(0, 0, 0, 0)
149.     END SELECT
150. END SUB

 

Title: Re: Gradients!
Post by: bplus on August 13, 2020, 12:44:48 pm

@loudar

Beautiful color mixing, I never really mastered mixing more than 2 colors as gradient and am curious how you would fill a circle with more than 2 color bases as I do here with 2 color bases?

Code: QB64: [Select]

1. OPTION _EXPLICIT
2. _TITLE "MidInk test with circle" 'b+ 2020-08-13
3.  
4. CONST xmax = 500, ymax = 500, xc = 400, yc = 300
5. SCREEN _NEWIMAGE(xmax, ymax, 32)
6. _DELAY .1 'need time for screen to load before attempting to move it.
7. _SCREENMOVE _MIDDLE
8. RANDOMIZE TIMER
9. DIM r, r1, r2, g1, g2, b1, b2
10. DO
11.     r1 = RND * 255: r2 = RND * 255: g1 = RND * 255: g2 = RND * 255: b1 = RND * 255: b2 = RND * 255
12.     FOR r = 200 TO 0 STEP -1
13.         fcirc 250, 250, r, midInk~&(r1, g1, b1, r2, g2, b2, r / 250)
14.     NEXT
15.     _DISPLAY
16.     _LIMIT 1 ' slow down to avoid too much color flash
17. LOOP UNTIL _KEYDOWN(27)
18.  
19. 'often I need it as Function as opposed color setting SUB,
20. ' fr## is a fraction (0-1) towards the 2nd color you want
21. FUNCTION midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
22.     midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
23. END FUNCTION
24.  
25. 'from Steve Gold standard
26. SUB fcirc (CX AS INTEGER, CY AS INTEGER, R AS INTEGER, C AS _UNSIGNED LONG)
27.     DIM Radius AS INTEGER, RadiusError AS INTEGER
28.     DIM X AS INTEGER, Y AS INTEGER
29.     Radius = ABS(R): RadiusError = -Radius: X = Radius: Y = 0
30.     IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
31.     LINE (CX - X, CY)-(CX + X, CY), C, BF
32.     WHILE X > Y
33.         RadiusError = RadiusError + Y * 2 + 1
34.         IF RadiusError >= 0 THEN
35.             IF X <> Y + 1 THEN
36.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
37.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
38.             END IF
39.             X = X - 1
40.             RadiusError = RadiusError - X * 2
41.         END IF
42.         Y = Y + 1
43.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
44.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
45.     WEND
46. END SUB
47.  
48.  

Title: Re: Gradients!
Post by: loudar on August 13, 2020, 02:08:32 pm

Oh this is nice! I like it a lot :D I thought about being able to make it circular too, but I'd have to whip out some of the sin/cos code I wrote...will do that in the following days!

Title: Re: Gradients!
Post by: bplus on August 13, 2020, 03:02:44 pm

Keybone did a nice one for diagonal:

Code: QB64: [Select]

1. 'diagonal gradient by keybone 2018-08-03
2. SCREEN _NEWIMAGE(800, 600, 32)
3.  
4. gradientDiagonal 0, 0, _WIDTH, _HEIGHT, _RGB(255, 255, 0), _RGB(255, 0, 255), 255
5.  
6. SUB gradientDiagonal (x0, y0, w, h, c1 AS _UNSIGNED LONG, c2 AS _UNSIGNED LONG, a AS _UNSIGNED _BYTE)
7.     DIM mr AS DOUBLE, mg AS DOUBLE, mb AS DOUBLE
8.     dw = w + h
9.     mr = (_RED(c2) - _RED(c1)) / dw
10.     mg = (_GREEN(c2) - _GREEN(c1)) / dw
11.     mb = (_BLUE(c2) - _BLUE(c1)) / dw
12.     FOR d = 0 TO dw - 1
13.         r = _RED(c2) + (d - dw) * mr
14.         g = _GREEN(c2) + (d - dw) * mg
15.         b = _BLUE(c2) + (d - dw) * mb
16.         IF d <= h - 1 THEN
17.             LINE (x0 + d, y0)-(x0, y0 + d), _RGBA32(r, g, b, a)
18.         ELSEIF d >= h AND d <= w - 1 THEN
19.             LINE (x0 + d, y0)-(x0 + (d - h), y0 + h), _RGBA32(r, g, b, a)
20.         ELSEIF d >= w AND d <= dw - 1 THEN
21.             LINE (x0 + w, y0 + (d - w))-(x0 + (d - h), y0 + h), _RGBA32(r, g, b, a)
22.         END IF
23.     NEXT d
24. END SUB
25.  
26.  

Text Only | Text with Attachments