(faked) 3d color balls generator

[tsh73]

3d color balls
Of cource faked 3d :)
Any size, any color.
Inside is a function to smoothly transit from color to color
- so given base color is shifted to dark (for shades) and to white (to highligths), and smoothly translated between.
Made to be used in games like 3-in-a-row.
Of cource rendered 3d balls could look better, but these allows to make a program single BAS file.

So if you have idea where it could be useful - go ahead and use it.

'color balls in faked 3d
'to be used as tiles for ball moving games
'3 in a row etc
'tsh73 December 2021

nomainwin
cs=60    'really, bigger looks better
'cs=80
'cs=100

   WindowWidth = cs*9
   WindowHeight = cs*9+50

open "Making color balls" for graphics_nsb_nf as #gr
#gr "trapclose [quit]"
#gr "down"
'#gr "fill white; flush"
#gr "home; posxy cx cy"

#gr "home"
'#gr "size 3"


baseCol$="0 0 255"
row=0    '
for j = 0 to 2
   select case j
       case 0:r=cs/2-5      'bigger (active, selected)
       case 1:r=cs/2/1.3     'normal
       case 2:r=cs/4          'smaller (marked for removing)
   end select

   Top=row*cs
   Left=j*cs
   call ball3d baseCol$, Left, Top, r, cs, 1
next

r=cs/2/1.3     'normal

row=row+1
data "255 0 0"
data "0 255 0"
data "0 0 255"
data "0 0 0"
data "127 127 127"
data "255 255 255"
data "xyzzy"
j=0
while 1
   read baseCol$
   if baseCol$="xyzzy" then exit while
   Top=row*cs
   Left=j*cs
   call ball3d baseCol$, Left, Top, r, cs, 1
   j=j+1
wend

row=row+1
'rainbow colors
'sampled from a picture, because 255 etc are too harsh
data R, "226 0 17"
data O, "255 94 60"
data Y, "252 247 82"
data G, "0 188 56"
data B, "0 157 245"
data I, "8 7 124"
data V, "50 9 148"
data "xyzzy", "xyzzy"
j=0
while 1
   read dummy$, baseCol$
   'print dummy$, baseCol$
   if baseCol$="xyzzy" then exit while
   Top=row*cs
   Left=j*cs
   call ball3d baseCol$, Left, Top, r, cs, 1
   j=j+1
wend

for numCols = 3 to 8
   row=row+1
   for j=0 to numCols-1
       baseCol$=rainbow$(j/numCols) 'colorcircle hiew
       Top=row*cs
       Left=j*cs
       call ball3d baseCol$, Left, Top, r, cs, 1
   next
next
wait

#gr "flush"
wait

[quit]
   timer 0
   close #gr
end


'============================================

function linInterp(x1,x2,a)    'a supposed to be 0..1
   linInterp=x1*(1-a)+x2*a    '0 returns x1, 1 -> x2
end function

function linInterpC(x1$,x2$,a)    'a supposed to be 0..1
   linInterpC=int(val(x1$)*(1-a)+val(x2$)*a)    '0 returns x1, 1 -> x2
end function

function linInterpColor$(col1$,col2$,a)    'a supposed to be 0..1
   linInterp=x1*(1-a)+x2*a    '0 returns x1, 1 -> x2
   linInterpColor$ = linInterpC(word$(col1$,1),word$(col2$,1),a);" "; _
       linInterpC(word$(col1$,2),word$(col2$,2),a);" "; _
       linInterpC(word$(col1$,3),word$(col2$,3),a)
end function

'---------------------------------------------
' 0..1 into red-green-blue-red continuous colors
function rainbow$(x)
   hi = int((x*6) mod 6)+ 5*(x<0)  'fixed to 0..5
   f = (x*6) mod 1 + (x<0)         'frac, 0..1
   q = (1-f)
   select case hi
   case 0
       r = 1: g = f: b = 0
   case 1
       r = q: g = 1: b = 0
   case 2
       r = 0: g = 1: b = f
   case 3
       r = 0: g = q: b = 1
   case 4
       r = f: g = 0: b = 1
   case 5
       r = 1: g = 0: b = q
   end select
   R = int(r*255)
   G = int(g*255)
   B = int(b*255)
   rainbow$= R;" ";G;" ";B
end function

'------------------------------------------------
sub    ball3d baseCol$, Left, Top, r, cs, showBorder
   black$="0 0 0"
   white$="255 255 255"

   outerCol$=linInterpColor$(baseCol$, black$, .2)
   innerCol$=linInterpColor$(baseCol$, white$, .7)

   'showBorder=0
   if showBorder then
       #gr "size 1"
       #gr "color black";
       #gr "place ";Left;" ";Top
       #gr "box ";Left+cs;" ";Top+cs
   end if

   #gr "size 3"
   ' #gr "place 0 0";
   ' #gr "\\";r
   xx=Left+cs/2
   yy=Top+cs/2
   for i = r to 1 step -1
       c$=linInterpColor$(innerCol$, outerCol$,i/r)
       #gr "color ";c$
       #gr "place ";xx-(r-i)/3;" ";yy-(r-i)/2
       #gr "circle ";i
   next
end sub