Post by tsh73 on Dec 20, 2021 18:18:54 GMT
So first it was a grid of BMPBUTTONs
With letters on it
justbasiccom.proboards.com/thread/763/magic-square
Next I wondered if I already have grid with letters - could make letters falling?
So that falling letters produced more falling letters?
Then I realised I got "Jewels" or "3-in-a-row" clone.
So I just moved all parameters I encountered while programming it to Preferences dialog
and of cource allowed to change letters for color balls
Enjoy.
With letters on it
justbasiccom.proboards.com/thread/763/magic-square
Next I wondered if I already have grid with letters - could make letters falling?
So that falling letters produced more falling letters?
Then I realised I got "Jewels" or "3-in-a-row" clone.
So I just moved all parameters I encountered while programming it to Preferences dialog
and of cource allowed to change letters for color balls
Enjoy.
'playing with bmpbuttons
'tsh73 dec 2021
'now add logic over mechanics
'using same mechanics to do other stuff
' 8x8
' swaps restricted to ajacent
' "fit" sections annigiate
' avalanches down, filled up with randoms
' afraid I'll get Jewels (!)
'adding game interface (score, options menu)
nomainwin
openedMain=0 'prevents creating winodw again
'game setting should be set before restart point
global numLtrs 'different pieces
global minFit 'shortest acceptable "word"
global piecesLetters 'letters of color balls
global diagonalSwaps 'allow diagonal swaps
global nonResSwaps 'allow swaps what do not result in removing
call readIni
[rstart]
if openedMain then close #main
cs=60 'cellSize
global numC,numR
numC=8:numR=8 'rows and columns
dim c$(numR,numC) 'letters for swapping
dim a(numR,numC) '1 - marked (fit, to be removed)
global code$, ltrs$
' code$="FNGBENERCBGRARGBCRENEBGNF"
' ltrs$="AAAAEEEENOOOOPPRRRRSSTTTT"
' ltrs$="ABCDEFGH" '8 different letters
' ltrs$="ABCDEF" '6 different letters
'3? 4? I think Jevels had 5, but again there lots of variants
ltrs$=""
for i = 0 to numLtrs-1
ltrs$=ltrs$+chr$(i+asc("A"))
next
global selI, selJ, score, busy
selI=-1: selJ=-1
busy=0
score=0
desiredWidth = cs*numC
desiredHeight = cs*numR+25+10
gosub [ajustWindowMkTiles]
'now, center window
UpperLeftX = (DisplayWidth - WindowWidth)/2
UpperLeftY = (DisplayHeight - WindowHeight)/2
'now, open your window with desired size
'BackgroundColor$ = "darkblue"
'of cource this is BASIC-generated code
' qq$=chr$(34)
' ;qq$;
' for i = 0 to numC-1
' for j = 0 to numR-1
' print "bmpbutton #main.lttr";i;j;", ";qq$;"letr.bmp";qq$;", btnClick, UL, ";cs*j ;", ";cs*i
' next
' next
' input "press Enter to quit" ;dummy$
bmpbutton #main.lttr00, "letr.bmp", btnClick, UL, 0, 0
bmpbutton #main.lttr01, "letr.bmp", btnClick, UL, 60, 0
bmpbutton #main.lttr02, "letr.bmp", btnClick, UL, 120, 0
bmpbutton #main.lttr03, "letr.bmp", btnClick, UL, 180, 0
bmpbutton #main.lttr04, "letr.bmp", btnClick, UL, 240, 0
bmpbutton #main.lttr05, "letr.bmp", btnClick, UL, 300, 0
bmpbutton #main.lttr06, "letr.bmp", btnClick, UL, 360, 0
bmpbutton #main.lttr07, "letr.bmp", btnClick, UL, 420, 0
bmpbutton #main.lttr10, "letr.bmp", btnClick, UL, 0, 60
bmpbutton #main.lttr11, "letr.bmp", btnClick, UL, 60, 60
bmpbutton #main.lttr12, "letr.bmp", btnClick, UL, 120, 60
bmpbutton #main.lttr13, "letr.bmp", btnClick, UL, 180, 60
bmpbutton #main.lttr14, "letr.bmp", btnClick, UL, 240, 60
bmpbutton #main.lttr15, "letr.bmp", btnClick, UL, 300, 60
bmpbutton #main.lttr16, "letr.bmp", btnClick, UL, 360, 60
bmpbutton #main.lttr17, "letr.bmp", btnClick, UL, 420, 60
bmpbutton #main.lttr20, "letr.bmp", btnClick, UL, 0, 120
bmpbutton #main.lttr21, "letr.bmp", btnClick, UL, 60, 120
bmpbutton #main.lttr22, "letr.bmp", btnClick, UL, 120, 120
bmpbutton #main.lttr23, "letr.bmp", btnClick, UL, 180, 120
bmpbutton #main.lttr24, "letr.bmp", btnClick, UL, 240, 120
bmpbutton #main.lttr25, "letr.bmp", btnClick, UL, 300, 120
bmpbutton #main.lttr26, "letr.bmp", btnClick, UL, 360, 120
bmpbutton #main.lttr27, "letr.bmp", btnClick, UL, 420, 120
bmpbutton #main.lttr30, "letr.bmp", btnClick, UL, 0, 180
bmpbutton #main.lttr31, "letr.bmp", btnClick, UL, 60, 180
bmpbutton #main.lttr32, "letr.bmp", btnClick, UL, 120, 180
bmpbutton #main.lttr33, "letr.bmp", btnClick, UL, 180, 180
bmpbutton #main.lttr34, "letr.bmp", btnClick, UL, 240, 180
bmpbutton #main.lttr35, "letr.bmp", btnClick, UL, 300, 180
bmpbutton #main.lttr36, "letr.bmp", btnClick, UL, 360, 180
bmpbutton #main.lttr37, "letr.bmp", btnClick, UL, 420, 180
bmpbutton #main.lttr40, "letr.bmp", btnClick, UL, 0, 240
bmpbutton #main.lttr41, "letr.bmp", btnClick, UL, 60, 240
bmpbutton #main.lttr42, "letr.bmp", btnClick, UL, 120, 240
bmpbutton #main.lttr43, "letr.bmp", btnClick, UL, 180, 240
bmpbutton #main.lttr44, "letr.bmp", btnClick, UL, 240, 240
bmpbutton #main.lttr45, "letr.bmp", btnClick, UL, 300, 240
bmpbutton #main.lttr46, "letr.bmp", btnClick, UL, 360, 240
bmpbutton #main.lttr47, "letr.bmp", btnClick, UL, 420, 240
bmpbutton #main.lttr50, "letr.bmp", btnClick, UL, 0, 300
bmpbutton #main.lttr51, "letr.bmp", btnClick, UL, 60, 300
bmpbutton #main.lttr52, "letr.bmp", btnClick, UL, 120, 300
bmpbutton #main.lttr53, "letr.bmp", btnClick, UL, 180, 300
bmpbutton #main.lttr54, "letr.bmp", btnClick, UL, 240, 300
bmpbutton #main.lttr55, "letr.bmp", btnClick, UL, 300, 300
bmpbutton #main.lttr56, "letr.bmp", btnClick, UL, 360, 300
bmpbutton #main.lttr57, "letr.bmp", btnClick, UL, 420, 300
bmpbutton #main.lttr60, "letr.bmp", btnClick, UL, 0, 360
bmpbutton #main.lttr61, "letr.bmp", btnClick, UL, 60, 360
bmpbutton #main.lttr62, "letr.bmp", btnClick, UL, 120, 360
bmpbutton #main.lttr63, "letr.bmp", btnClick, UL, 180, 360
bmpbutton #main.lttr64, "letr.bmp", btnClick, UL, 240, 360
bmpbutton #main.lttr65, "letr.bmp", btnClick, UL, 300, 360
bmpbutton #main.lttr66, "letr.bmp", btnClick, UL, 360, 360
bmpbutton #main.lttr67, "letr.bmp", btnClick, UL, 420, 360
bmpbutton #main.lttr70, "letr.bmp", btnClick, UL, 0, 420
bmpbutton #main.lttr71, "letr.bmp", btnClick, UL, 60, 420
bmpbutton #main.lttr72, "letr.bmp", btnClick, UL, 120, 420
bmpbutton #main.lttr73, "letr.bmp", btnClick, UL, 180, 420
bmpbutton #main.lttr74, "letr.bmp", btnClick, UL, 240, 420
bmpbutton #main.lttr75, "letr.bmp", btnClick, UL, 300, 420
bmpbutton #main.lttr76, "letr.bmp", btnClick, UL, 360, 420
bmpbutton #main.lttr77, "letr.bmp", btnClick, UL, 420, 420
statictext #main.statictext1, "Score:", 5, cs*numR+10, 60, 20
textbox #main.txtScore, 65, cs*numR+5, 70, 25
statictext #main.status, "*BUSY*", cs*numC-50-10, cs*numR+10, 50, 20
MENU #main, "File", "New", [rstart], |, "Exit", [quit]
MENU #main, "Options", "Preferences", [prefs]
MENU #main, "Help", "About", [about]
open "*Avalanche*" for window_nf as #main
openedMain=1
#main, "trapclose [quit]"
#main.txtScore "!font courier_new 10"
#main.txtScore "!disable" 'read-only
#main.txtScore using("######", score)'123456
'initial placement
for i = 0 to numR-1
for j = 0 to numC-1
pos=i*numR+j +1
r=int(rnd(0)*len(ltrs$))+1
c$=mid$(ltrs$,r,1)
c$(i,j)=c$ 'array to do swapping
'this removes letters one by one - don't need that now
'ltrs$=left$(ltrs$, r-1)+mid$(ltrs$,r+1)
handle$="#main.lttr";i;j
' if mid$(code$,pos,1)=rot13$(c$) then
' bmp$="ltr";"R";c$
' a(i,j)=0 'should not be moved
''#handle$ "disable" 'it is right but not interesting
' else
bmp$="ltr";"N";c$
a(i,j)=0
' end if
'print c$;
'print i, j, r, c$, ltrs$
#handle$ "bitmap ";bmp$
next
'print
next
call mainLoop
score=0
#main.txtScore using("######", score)
wait
'-----------------------
[quit]
timer 0
call saveIni
close #main
end
[prefs]
if showPrefs() then [rstart]
wait
[about]
notice "Avalanche"+chr$(13) _
+" Started from a wish to see"+chr$(13) _
+"letters avalanche."+chr$(13) _
+" Ends up as another Jewels"+chr$(13) _
+"(three-in-a-row) clone."+chr$(13) _
+" Look into Options|Preferences"+chr$(13) _
+"for current settings"+chr$(13) _
+"and some customisation."
wait
'-------------------------------------------------
[ajustWindowMkTiles]
UpperLeftX = 20
UpperLeftY = 20
WindowWidth = 200 '100 seems to be too much - works different
WindowHeight = 200
MENU #gr, "dummy"
open "Ajusting..." for graphics_nsb_nf as #gr
' graphics
' graphics_nsb
' graphics_nsb_nf
#gr, "home ; down ; posxy x y"
'x, y give us width, height
width = 2*x : height = 2*y
slackX = 200-width
slackY = 200-height
WindowWidth = desiredWidth + slackX
WindowHeight = desiredHeight + slackY
'ajustWindow ends here.
'below is Making Tiles
#gr "backcolor white"
' #gr "font times_new_roman bold 30 80"
' #gr "font times_new_roman 30 80"
' #gr "place 10 65"
' #gr "\";"M"
cs$=" ";cs
csM4$=" ";cs-4
csM1$=" ";cs-1
cs1$=" ";cs+1
fntSz$=" ";int(3/8*cs);" ";cs
fntY$=" ";int(65/80*cs)
gosub [btn]
#gr "getbmp blank 1 1";cs$;cs$
bmpsave "blank", "letr.bmp"
#gr "font times_new_roman";fntSz$
base$="ltrN"
r=cs/2/1.5 'normal
'for i = asc("A") to asc("Z")
'in case we do not need all letters- faster
for j = 1 to len(ltrs$)
i=asc(mid$(ltrs$,j,1))
#gr "place 1 1; boxfilled";cs1$;cs1$
if piecesLetters then
c$=chr$(i)
#gr "stringwidth? c$ w"
#gr "place ";(cs-w)/2;fntY$
#gr "\";c$
gosub [btn]
else
gosub [btn]
baseCol$=rainbow$((j-1)/numLtrs) 'colorcircle hiew
Top=1
Left=1
call ball3d baseCol$, Left, Top, r, cs, 0
end if
#gr "getbmp ";base$;chr$(i);" 1 1";cs$;cs$
next
#gr "font times_new_roman";fntSz$
base$="ltrR"
r=cs/4 'smaller (marked for removing)
'for i = asc("A") to asc("Z")
for j = 1 to len(ltrs$)
i=asc(mid$(ltrs$,j,1))
#gr "place 1 1; boxfilled";cs1$;cs1$
if piecesLetters then
c$=chr$(i)
#gr "stringwidth? c$ w"
#gr "place ";(cs-w)/2;fntY$
#gr "color red"
#gr "\";chr$(i)
gosub [btn]
else
gosub [btn]
baseCol$=rainbow$((j-1)/numLtrs) 'colorcircle hiew
Top=1
Left=1
call ball3d baseCol$, Left, Top, r, cs, 0
end if
#gr "getbmp ";base$;chr$(i);" 1 1";cs$;cs$
next
#gr "color black"
#gr "font times_new_roman bold";fntSz$
base$="ltrB"
r=cs/2/1.3 'BIG
' for i = asc("A") to asc("Z")
for j = 1 to len(ltrs$)
i=asc(mid$(ltrs$,j,1))
#gr "place 1 1; boxfilled";cs1$;cs1$
if piecesLetters then
c$=chr$(i)
#gr "stringwidth? c$ w"
#gr "place ";(cs-w)/2;fntY$
#gr "\";c$
gosub [btn]
else
gosub [btn]
baseCol$=rainbow$((j-1)/numLtrs) 'colorcircle hiew
Top=1
Left=1
call ball3d baseCol$, Left, Top, r, cs, 0
end if
#gr "getbmp ";base$;chr$(i);" 1 1";cs$;cs$
next
close #gr
return
[btn]
#gr "size 3; color lightgray"
#gr "place 3 3; box";cs$;cs$
#gr "color darkgray"
#gr "place 6 6; box";csM1$;csM1$
#gr "color white; place 6 6; box";csM4$;csM4$
#gr "size 1; color black"
#gr "place 1 1; box";cs1$;cs1$
return
'====================================
sub btnClick handle$
if busy then exit sub
i=val(mid$(handle$,11,1))
j=val(mid$(handle$,12,1))
'notice handle$;":";i;j
'print i, j, c$(i,j), selI, selJ
' if not(a(i,j)) then exit sub
if selI=-1 then 'do select
selI=i:selJ=j
bmp$="ltr";"B";c$(i,j)
#handle$ "bitmap ";bmp$
exit sub
else 'do swap
'only adjacent
if diagonalSwaps then
'this is King's move
if abs(selI-i)>1 or abs(selJ-j)>1 then exit sub
else
'this is 1-cross move
if abs(selI-i) + abs(selJ-j)>1 then exit sub
end if
tmp$=c$(i,j)
c$(i,j)=c$(selI,selJ)
c$(selI,selJ)=tmp$
c$=c$(i,j)
bmp$="ltr";"N";c$
'moved there move accepted
'#handle$ "bitmap ";bmp$
c$=c$(selI, selJ)
bmp2$="ltr";"N";c$
handle2$="#main.lttr";selI;selJ
'#handle2$ "bitmap ";bmp2$
'check if new letters fit
fit1=markFit(i, j)
'same for selI, selJ
fit2=markFit(selI, selJ)
'if no things marked reverse move
if nonResSwaps or (fit1+fit2)>0 then 'accepted - change bitmaps
#handle$ "bitmap ";bmp$
#handle2$ "bitmap ";bmp2$
else 'rejected
tmp$=c$(i,j)
c$(i,j)=c$(selI,selJ)
c$(selI,selJ)=tmp$
'reset bold one
#handle2$ "bitmap ";bmp$
end if
'now remove marked and do drop??
'clear selection
selI=-1: selJ=-1
call mainLoop
end if
end sub
function rot13$(a$) 'toy code. But it hides from a plain sight.
rot13$ = ""
A0=asc("A")
for i = 1 to len(a$)
c0=asc(mid$(a$,i,1))
c = (c0-A0 +13) mod 26
c1 = c+A0
'print i, c0, c, c1
rot13$=rot13$+chr$(c1)
next
end function
function markFit(sI, sJ)
sel$=c$(sI, sJ)
'horisontally
'left
startP=sJ
while startP-1>=0
if sel$<>c$(sI, startP-1) then exit while
startP=startP-1
wend
'right
endP=sJ
while endP+1<numC
if sel$<>c$(sI, endP+1) then exit while
endP=endP+1
wend
'print sI,sJ,startP,endP,endP-startP+1
if endP-startP+1>=minFit then 'mark
i=sI
for j = startP to endP
if a(i,j)=0 then
c$=c$(i,j)
bmp$="ltr";"R";c$
handle$="#main.lttr";i;j
#handle$ "bitmap ";bmp$
a(i,j)=1 'to be removed
end if
next
markFit=endP-startP+1
end if
'same vertically
'up
startP=sI
while startP-1>=0
if sel$<>c$(startP-1,sJ) then exit while
startP=startP-1
wend
'down
endP=sI
while endP+1<numR
if sel$<>c$(endP+1,sJ) then exit while
endP=endP+1
wend
if endP-startP+1>=minFit then 'mark
j=sJ
for i = startP to endP
if a(i,j)=0 then
c$=c$(i,j)
bmp$="ltr";"R";c$
handle$="#main.lttr";i;j
#handle$ "bitmap ";bmp$
a(i,j)=1 'to be removed
end if
next
markFit=markFit+endP-startP+1
end if
end function
sub checkAll
for i = 0 to numR-1
for j = 0 to numC-1
dummy=markFit(i, j) 'likely non efficient
'but it takes 16 ms so I will not change it.
next
next
end sub
function clearAll()
for i = 0 to numR-1
for j = 0 to numC-1
if a(i,j) then
clearAll=clearAll+1
handle$="#main.lttr";i;j
#handle$ "bitmap blank"
a(i,j)=0
c$(i,j)=""
end if
next
next
end function
function dropAll() '0 if nothing dropped
'drops one cell down, fills upper cell randomly
for j = 0 to numC-1
dropped=0
for i = numR-1-1 to 0 step -1 'upwards
if c$(i+1,j)="" then
dropAll=dropAll+1
dropped=1
c$(i+1,j)=c$(i,j)
handle$="#main.lttr";i+1;j
if c$(i,j)="" then
bmp$="blank"
else
bmp$="ltr";"N";c$(i,j)
end if
#handle$ "bitmap ";bmp$
c$(i,j)=""
handle$="#main.lttr";i;j
#handle$ "bitmap blank"
end if
next
'generate upper one
'if dropped then
if c$(0,j)="" then
r=int(rnd(0)*len(ltrs$))+1
c$=mid$(ltrs$,r,1)
c$(0,j)=c$
handle$="#main.lttr";0;j
bmp$="ltr";"N";c$
#handle$ "bitmap ";bmp$
end if
next
end function
sub mainLoop
busy=1
#main.status, "*BUSY*"
while 1
'call pause 100
call checkAll
call pause 200
numClear=clearAll()
if not(numClear) then exit while
'score=score+numClear 'some more then linear function?
score=score+numClear^3/5
#main.txtScore using("######", score)
dropPause=256
while 1
if not(dropAll()) then exit while
call pause dropPause
dropPause=dropPause/1.5
wend
wend
busy=0
#main.status, "-Ready-"
end sub
sub pause mil
t=time$("ms")+mil
on error goto [quit]' ignore interface requiests for labels
while time$("ms")<t
scan
wend
[quit]
end sub
'------------------------------------------------
function iif(test, valYes, valNo)
iif = valNo
if test then iif = valYes
end function
function iif$(test, valYes$, valNo$)
iif$ = valNo$
if test then iif$ = valYes$
end function
'========================================
function showPrefs() 'true if changed
WindowWidth = 256
WindowHeight = 295
statictext #prefs.statictext1, "Accepted word length", 22, 101, 144, 20
statictext #prefs.statictext2, "Different pieces", 22, 131, 144, 20
groupbox #prefs.groupbox3, " Pieces ", 14, 11, 216, 70
radiobutton #prefs.rbLetters, "Letters", [rbDummy],[rbDummy], 38, 31, 72, 20
radiobutton #prefs.rbColorBalls, "Color balls", [rbDummy],[rbDummy], 38, 51, 104, 20
textbox #prefs.txtWordLen, 198, 96, 32, 25
textbox #prefs.txtNumPieces, 198, 126, 32, 25
CHECKBOX #prefs.chNonResSwaps, "Non-resultive swaps", [rbDummy],[rbDummy], 22, 161, 144, 20
CHECKBOX #prefs.chDiagonalSwaps, "Diagonal swaps", [rbDummy],[rbDummy], 22, 186, 144, 20
button #prefs.default, "Ok", [btnOkClick], UL, 22, 216, 96, 35
button #prefs.btnCancel, "Cancel", [btnCancel], UL, 134, 216, 96, 35
open "Preferences" for dialog_nf_modal as #prefs
#prefs "trapclose [quit.prefs]"
#prefs.rbLetters "setfocus"
if piecesLetters then
#prefs.rbLetters "set"
else
#prefs.rbColorBalls "set"
end if
#prefs.txtWordLen minFit
#prefs.txtNumPieces numLtrs
#prefs.chNonResSwaps iif$(nonResSwaps,"set","reset")
#prefs.chDiagonalSwaps iif$(diagonalSwaps,"set","reset")
print #prefs, "font ms_sans_serif 10"
wait
[quit.prefs]
Close #prefs
exit function 'returns false if not set
[rbDummy]
'no action needed
wait
[btnOkClick] 'Perform action for the button named 'btnOk'
'validate input
#prefs.txtWordLen "!contents? valWordLen"
if valWordLen<3 or valWordLen> 5 then notice "Acceptable values for wordLen are 3..5":wait
#prefs.txtNumPieces "!contents? valNumPieces"
if valNumPieces<3 or valNumPieces> 8 then notice "Acceptable values for numPieces are 3..8":wait
#prefs.rbLetters "value? isLetters$"
#prefs.chNonResSwaps "value? isNonResSwaps$"
#prefs.chDiagonalSwaps "value? isDiagonalSwaps$"
'print valWordLen, valNumPieces, isLetters$
valPiecesLetters = (isLetters$="set")
valNonResSwaps = (isNonResSwaps$="set")
valDiagonalSwaps = (isDiagonalSwaps$="set")
'true if changed
showPrefs= (valPiecesLetters<>piecesLetters) _
or (valNonResSwaps<>nonResSwaps) or (valNumPieces<>numLtrs) _
or (valWordLen<>minFit) or (valDiagonalSwaps<>diagonalSwaps)
piecesLetters=valPiecesLetters
minFit=valWordLen
numLtrs=valNumPieces
nonResSwaps=valNonResSwaps
diagonalSwaps=valDiagonalSwaps
goto [quit.prefs]
wait
[btnCancel]
goto [quit.prefs]
wait
end function
sub saveIni
iniFile$="avalanche.ini"
open iniFile$ for output as #1
#1 "piecesLetters";"=";piecesLetters
#1 "minFit";"=";minFit
#1 "numLtrs";"=";numLtrs
#1 "nonResSwaps";"=";nonResSwaps
#1 "diagonalSwaps";"=";diagonalSwaps
close #1
end sub
sub readIni
'set defauts
numLtrs=3
'minFit=4
minFit=3 'usually shows lot's of awalanches on startup
piecesLetters=1
'piecesLetters=0
nonResSwaps=0
diagonalSwaps=0
iniFile$="avalanche.ini"
if fileExists(DefaultDir$, iniFile$)=0 then exit sub
open iniFile$ for input as #1
while not(eof(#1))
line input #1, aLine$
if instr(aLine$, "=")<>0 then
parName$=word$(aLine$,1,"=")
parVal$=word$(aLine$,2,"=")
select case parName$
case "numLtrs"
numLtrs=val(parVal$) 'could be just parVal$ for string val
case "minFit"
minFit=val(parVal$)
case "piecesLetters"
piecesLetters=val(parVal$)
case "diagonalSwaps"
diagonalSwaps=val(parVal$)
case "nonResSwaps"
nonResSwaps=val(parVal$)
'everything else is IGNORED
end select
end if
wend
close #1
end sub
function fileExists(path$, filename$)
dim info$(1,1)
files path$, filename$, info$()
fileExists = val(info$(0, 0)) 'non zero is true
end function
'============================================
'3d balls stuff
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