Post by tsh73 on Jan 3, 2022 15:22:56 GMT -5
Used to be very popular in DOS days 
Click on ball, then click on a empty space.
If it will find a path it will move.
5 same colors in a row disappears.
Click on ball, then click on a empty space.
If it will find a path it will move.
5 same colors in a row disappears.
'playing with bmpbuttons
'tsh73 dec 2021
'now add logic over mechanics
'using same mechanics to do other stuff
'color lines ('5 or more' gnome games)
'https://help.gnome.org/users/five-or-more/stable/
' 9x9
' ball moved to free pos if there is a path
' "fit" sections annigilate
' if not fit, add 3 new on empty places
nomainwin
'game parameters, not changeable (or it will be another game)
global numLtrs 'different pieces
global minFit 'shortest acceptable "word"
global piecesLetters 'letters of color balls
'game parameters (in preferences)
global instantMove 'ball travel to new point or teleport instantly
global showNext 'show next 3 colors
call readIni
cs=60 'cellSize
global numC,numR
numC=9:numR=9 'rows and columns
offX=0
offY=cs
dim c$(numR,numC) 'letters for swapping
dim a(numR,numC) '1 - marked (fit, to be removed)
global code$, ltrs$
for i = 0 to numLtrs-1
ltrs$=ltrs$+chr$(i+asc("A"))
next
dim di(4), dj(4) 'line orientation
data 0,1, 1,0, 1,1, 1,-1
for i =1 to 4: read di, dj: di(i)=di:dj(i)=dj: next
'for pathfinding
dim dirFrom(numR,numC) 'for getting path
dim path(10,2) 'the path, to be redimmed as needed
dim dx(4), dy(4)
DATA 0,1, 1,0, 0,-1, -1,0
for i = 1 to 4: read dx, dy: dx(i)=dx:dy(i)=dy: next
global selI, selJ, score, busy, free
selI=-1: selJ=-1
busy=0
score=0
desiredWidth = cs*numC
desiredHeight = cs*numR+25+10+offY
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)
' REM ;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+offX ;", ";cs*i+offY
' next
' next
' input "press Enter to quit" ;dummy$
'hint block
statictext #main.statictext0, "Next:", 3*cs-50, cs/2-5, 45, 20
bmpbutton #main.hint0, "letr.bmp", btnClick, UL, 180, 0
bmpbutton #main.hint1, "letr.bmp", btnClick, UL, 240, 0
bmpbutton #main.hint2, "letr.bmp", btnClick, UL, 300, 0
bmpbutton #main.lttr00, "letr.bmp", btnClick, UL, 0, 60
bmpbutton #main.lttr01, "letr.bmp", btnClick, UL, 60, 60
bmpbutton #main.lttr02, "letr.bmp", btnClick, UL, 120, 60
bmpbutton #main.lttr03, "letr.bmp", btnClick, UL, 180, 60
bmpbutton #main.lttr04, "letr.bmp", btnClick, UL, 240, 60
bmpbutton #main.lttr05, "letr.bmp", btnClick, UL, 300, 60
bmpbutton #main.lttr06, "letr.bmp", btnClick, UL, 360, 60
bmpbutton #main.lttr07, "letr.bmp", btnClick, UL, 420, 60
bmpbutton #main.lttr08, "letr.bmp", btnClick, UL, 480, 60
bmpbutton #main.lttr10, "letr.bmp", btnClick, UL, 0, 120
bmpbutton #main.lttr11, "letr.bmp", btnClick, UL, 60, 120
bmpbutton #main.lttr12, "letr.bmp", btnClick, UL, 120, 120
bmpbutton #main.lttr13, "letr.bmp", btnClick, UL, 180, 120
bmpbutton #main.lttr14, "letr.bmp", btnClick, UL, 240, 120
bmpbutton #main.lttr15, "letr.bmp", btnClick, UL, 300, 120
bmpbutton #main.lttr16, "letr.bmp", btnClick, UL, 360, 120
bmpbutton #main.lttr17, "letr.bmp", btnClick, UL, 420, 120
bmpbutton #main.lttr18, "letr.bmp", btnClick, UL, 480, 120
bmpbutton #main.lttr20, "letr.bmp", btnClick, UL, 0, 180
bmpbutton #main.lttr21, "letr.bmp", btnClick, UL, 60, 180
bmpbutton #main.lttr22, "letr.bmp", btnClick, UL, 120, 180
bmpbutton #main.lttr23, "letr.bmp", btnClick, UL, 180, 180
bmpbutton #main.lttr24, "letr.bmp", btnClick, UL, 240, 180
bmpbutton #main.lttr25, "letr.bmp", btnClick, UL, 300, 180
bmpbutton #main.lttr26, "letr.bmp", btnClick, UL, 360, 180
bmpbutton #main.lttr27, "letr.bmp", btnClick, UL, 420, 180
bmpbutton #main.lttr28, "letr.bmp", btnClick, UL, 480, 180
bmpbutton #main.lttr30, "letr.bmp", btnClick, UL, 0, 240
bmpbutton #main.lttr31, "letr.bmp", btnClick, UL, 60, 240
bmpbutton #main.lttr32, "letr.bmp", btnClick, UL, 120, 240
bmpbutton #main.lttr33, "letr.bmp", btnClick, UL, 180, 240
bmpbutton #main.lttr34, "letr.bmp", btnClick, UL, 240, 240
bmpbutton #main.lttr35, "letr.bmp", btnClick, UL, 300, 240
bmpbutton #main.lttr36, "letr.bmp", btnClick, UL, 360, 240
bmpbutton #main.lttr37, "letr.bmp", btnClick, UL, 420, 240
bmpbutton #main.lttr38, "letr.bmp", btnClick, UL, 480, 240
bmpbutton #main.lttr40, "letr.bmp", btnClick, UL, 0, 300
bmpbutton #main.lttr41, "letr.bmp", btnClick, UL, 60, 300
bmpbutton #main.lttr42, "letr.bmp", btnClick, UL, 120, 300
bmpbutton #main.lttr43, "letr.bmp", btnClick, UL, 180, 300
bmpbutton #main.lttr44, "letr.bmp", btnClick, UL, 240, 300
bmpbutton #main.lttr45, "letr.bmp", btnClick, UL, 300, 300
bmpbutton #main.lttr46, "letr.bmp", btnClick, UL, 360, 300
bmpbutton #main.lttr47, "letr.bmp", btnClick, UL, 420, 300
bmpbutton #main.lttr48, "letr.bmp", btnClick, UL, 480, 300
bmpbutton #main.lttr50, "letr.bmp", btnClick, UL, 0, 360
bmpbutton #main.lttr51, "letr.bmp", btnClick, UL, 60, 360
bmpbutton #main.lttr52, "letr.bmp", btnClick, UL, 120, 360
bmpbutton #main.lttr53, "letr.bmp", btnClick, UL, 180, 360
bmpbutton #main.lttr54, "letr.bmp", btnClick, UL, 240, 360
bmpbutton #main.lttr55, "letr.bmp", btnClick, UL, 300, 360
bmpbutton #main.lttr56, "letr.bmp", btnClick, UL, 360, 360
bmpbutton #main.lttr57, "letr.bmp", btnClick, UL, 420, 360
bmpbutton #main.lttr58, "letr.bmp", btnClick, UL, 480, 360
bmpbutton #main.lttr60, "letr.bmp", btnClick, UL, 0, 420
bmpbutton #main.lttr61, "letr.bmp", btnClick, UL, 60, 420
bmpbutton #main.lttr62, "letr.bmp", btnClick, UL, 120, 420
bmpbutton #main.lttr63, "letr.bmp", btnClick, UL, 180, 420
bmpbutton #main.lttr64, "letr.bmp", btnClick, UL, 240, 420
bmpbutton #main.lttr65, "letr.bmp", btnClick, UL, 300, 420
bmpbutton #main.lttr66, "letr.bmp", btnClick, UL, 360, 420
bmpbutton #main.lttr67, "letr.bmp", btnClick, UL, 420, 420
bmpbutton #main.lttr68, "letr.bmp", btnClick, UL, 480, 420
bmpbutton #main.lttr70, "letr.bmp", btnClick, UL, 0, 480
bmpbutton #main.lttr71, "letr.bmp", btnClick, UL, 60, 480
bmpbutton #main.lttr72, "letr.bmp", btnClick, UL, 120, 480
bmpbutton #main.lttr73, "letr.bmp", btnClick, UL, 180, 480
bmpbutton #main.lttr74, "letr.bmp", btnClick, UL, 240, 480
bmpbutton #main.lttr75, "letr.bmp", btnClick, UL, 300, 480
bmpbutton #main.lttr76, "letr.bmp", btnClick, UL, 360, 480
bmpbutton #main.lttr77, "letr.bmp", btnClick, UL, 420, 480
bmpbutton #main.lttr78, "letr.bmp", btnClick, UL, 480, 480
bmpbutton #main.lttr80, "letr.bmp", btnClick, UL, 0, 540
bmpbutton #main.lttr81, "letr.bmp", btnClick, UL, 60, 540
bmpbutton #main.lttr82, "letr.bmp", btnClick, UL, 120, 540
bmpbutton #main.lttr83, "letr.bmp", btnClick, UL, 180, 540
bmpbutton #main.lttr84, "letr.bmp", btnClick, UL, 240, 540
bmpbutton #main.lttr85, "letr.bmp", btnClick, UL, 300, 540
bmpbutton #main.lttr86, "letr.bmp", btnClick, UL, 360, 540
bmpbutton #main.lttr87, "letr.bmp", btnClick, UL, 420, 540
bmpbutton #main.lttr88, "letr.bmp", btnClick, UL, 480, 540
statictext #main.statictext1, "Score:", 5, cs*numR+10+offY, 60, 20
textbox #main.txtScore, 65, cs*numR+5+offY, 70, 25
statictext #main.status, "*BUSY*", cs*numC-50-10, cs*numR+10+offY, 50, 20
MENU #main, "File", "New", [rstart], |, "Exit", [quit]
MENU #main, "Options", "Preferences", [prefs]
MENU #main, "Help", "About", [about]
open "Color lines" for window_nf as #main
#main, "trapclose [quit]"
#main.txtScore "!font courier_new 10"
#main.txtScore "!disable" 'read-only
#main.hint0 "disable"
#main.hint1 "disable"
#main.hint2 "disable"
[rstart]
#main.txtScore using("######", score)'123456
'initial placement
'clear arrays
redim c$(numR,numC) 'letters for swapping
redim a(numR,numC)
'clear free space
free=numC*numR
'clear buttons
for i = 0 to numR-1
for j = 0 to numC-1
handle$="#main.lttr";i;j
#handle$ "bitmap blank"
next
next
'put 6 random balls on empty places
call mk3Next
call add3New
call mk3Next
call mainLoop
score=0
#main.txtScore using("######", score)
wait
'-----------------------
[quit]
call quit
sub quit
timer 0
call saveIni
close #main
end
end sub
[prefs]
'if showPrefs() then [rstart]
dummy=showPrefs() 'no need to restart
wait
[about]
notice "Color lines"+chr$(13) _
+" Once very popular DOS game"+chr$(13) _
+"Now included in Gnome Games"+chr$(13) _
+"as '5 or more'"+chr$(13) _
+" New balls added by 3 at random."+chr$(13) _
+"On your turn, you can move ball "+chr$(13) _
+"to empty cell (path should exist)."+chr$(13) _
+"Verical, horisontal or diagonal"+chr$(13) _
+" lines of '5 or more' disappear."
wait
'-------------------------------------------------
sub mk3Next
for k = 1 to 3
r(k)=int(rnd(0)*len(ltrs$))+1
if showNext then
r=r(k)
else
r=0
end if
c$=mid$(ltrs$,r,1)
handle$="#main.hint";k-1
bmp$="ltr";"N";c$
if r=0 then bmp$="blank"
#handle$ "bitmap ";bmp$
next
end sub
sub add3New
for k = 1 to 3
r=r(k)
gosub [addNew]
next
exit sub
[addNew]
if not(free) then notice "No more moves!":call quit
'need better algorithm for getting free piece
while 1
j=int(rnd(0)*numR)
i=int(rnd(0)*numC)
if c$(i,j)="" then exit while
wend
'r=int(rnd(0)*len(ltrs$))+1
c$=mid$(ltrs$,r,1)
c$(i,j)=c$
handle$="#main.lttr";i;j
bmp$="ltr";"N";c$
a(i,j)=0
#handle$ "bitmap ";bmp$
free=free-1
return
end sub
[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
if c$(i,j)="" then exit sub
selI=i:selJ=j
bmp$="ltr";"B";c$(i,j)
#handle$ "bitmap ";bmp$
exit sub
else 'do jump
'deselect
if selI=i and selJ=j then
bmp$="ltr";"N";c$(i,j)
#handle$ "bitmap ";bmp$
selI=-1: selJ=-1
exit sub
end if
'only if
'there is a free space
if c$(i,j)<>"" then exit sub
'there is a path
pathLen=waveFront(selI,selJ,i,j)
if not(pathLen) then exit sub
busy=1
#main.status, "*BUSY*"
if instantMove then
tmp$=c$(i,j) 'should be empty
c$(i,j)=c$(selI,selJ)
c$(selI,selJ)=tmp$
c$=c$(i,j)
bmp$="ltr";"N";c$
handle2$="#main.lttr";i;j
#handle$ "bitmap ";bmp$
c$=c$(selI, selJ)
bmp2$="ltr";"N";c$
handle2$="#main.lttr";selI;selJ
#handle2$ "bitmap blank"
else 'move selI, selJ to i,j along path
for k = 1 to pathLen '0-th is Start, last is Fin
i=path(k, 1):j=path(k, 2)
print k, i, j,c$(i,j),c$(selI,selJ)
tmp$=c$(i,j) 'should be empty
c$(i,j)=c$(selI,selJ)
c$(selI,selJ)=tmp$
c$=c$(i,j)
bmp$="ltr";"N";c$
handle$="#main.lttr";i;j
#handle$ "bitmap ";bmp$
c$=c$(selI, selJ)
bmp2$="ltr";"N";c$
handle2$="#main.lttr";selI;selJ
#handle2$ "bitmap blank"
selI=i: selJ=j
call pause 50
next
end if
'clear selection
selI=-1: selJ=-1
call mainLoop
end if
end sub
function hasPath(i,j,i1,j1)
hasPath=waveFront(i,j,i1,j1)
end function
function markFit(sI, sJ)
sel$=c$(sI, sJ)
if sel$="" then exit function
for k=1 to 4'line orientation
startP=0:endP=0
'-1
m=1
while inRange(sI-m*di(k), numR) and inRange(sJ-m*dj(k), numC)
if sel$<>c$(sI-m*di(k), sJ-m*dj(k)) then exit while
m=m+1
startP=startP-1
wend
'+1
m=1
while inRange(sI+m*di(k), numR) and inRange(sJ+m*dj(k), numC)
if sel$<>c$(sI+m*di(k), sJ+m*dj(k)) then exit while
m=m+1
endP=endP+1
wend
'print sI,sJ,startP,endP,endP-startP+1
if endP-startP+1>=minFit then 'mark
for m = startP to endP
i=sI+m*di(k)
j=sJ+m*dj(k)
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
next
end function
sub checkAll
redim a(numC,numR) 'clear to 0
for i = 0 to numR-1
for j = 0 to numC-1
dummy=markFit(i, j)
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)=""
free=free+1
end if
next
next
end function
sub mainLoop
busy=1
#main.status, "*BUSY*"
'no avalanche effect in here, so no loop
'call pause 100
call checkAll
call pause 200
numClear=clearAll()
'call pause 1000
if not(numClear) then 'add next 3
call add3New
call mk3Next
'!But! this could start new things?
call checkAll
call pause 200
dummy=clearAll()
else
'trend line equation from Excel graph
score=score+2.38*numClear^2-22*numClear+58
#main.txtScore using("######", score)
end if
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 inRange(x, maxX)
inRange = 0<=x and x<maxX
end function
'========================================
function showPrefs() 'true if changed
WindowWidth = 256
WindowHeight = 295-150
CHECKBOX #prefs.chInstantMove, "Instant move (or jump along)", [rbDummy],[rbDummy], 22, 161-150, 200, 20
CHECKBOX #prefs.chShowNext, "Show next 3 colors", [rbDummy],[rbDummy], 22, 186-150, 144, 20
button #prefs.default, "Ok", [btnOkClick], UL, 22, 216-150, 96, 35
button #prefs.btnCancel, "Cancel", [btnCancel], UL, 134, 216-150, 96, 35
open "Preferences" for dialog_nf_modal as #prefs
#prefs "trapclose [quit.prefs]"
#prefs.chInstantMove "setfocus"
#prefs.chInstantMove iif$(instantMove,"set","reset")
#prefs.chShowNext iif$(showNext,"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.chInstantMove "value? isInstantMove$"
#prefs.chShowNext "value? isShowNext$"
'print valWordLen, valNumPieces, isLetters$
valInstantMove = (isInstantMove$="set")
valShowNext = (isShowNext$="set")
'true if changed
showPrefs= (valInstantMove<>instantMove) _
or (valShowNext<>showNext)
instantMove=valInstantMove
showNext=valShowNext
goto [quit.prefs]
wait
[btnCancel]
goto [quit.prefs]
wait
end function
sub saveIni
iniFile$="colorLines.ini"
open iniFile$ for output as #1
#1 "instantMove";"=";instantMove
#1 "showNext";"=";showNext
close #1
end sub
sub readIni
'set defauts
'game parameters, not changeable (or it will be another game)
numLtrs=7
minFit=5
piecesLetters=0
'game parameters (in preferences)
instantMove=0
showNext=1
iniFile$="colorLines.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 "instantMove"
instantMove=val(parVal$) 'could be just parVal$ for string val
case "showNext"
showNext=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
'mase solver --------------------------------
function waveFront(startI,startJ,endI,endJ)
q$=startI;",";startJ;" " 'queue on a string - init
redim a(numR,numC) 'should do if many runs
'print "Q_:";q$
a(startI,startJ)=1
while 1
if q$="" then exit function 'print "No way": gosub [showA]: goto [quit]
'pop from a queue
pos=instr(q$, " ")
curr$=left$(q$, pos-1)
q$=mid$(q$, pos+1)
'print "Q-:";q$
i=val(word$(curr$,1,","))
j=val(word$(curr$,2,","))
v=a(i,j)
'mark neighbours
for d = 1 to 4
ni=i+dy(d):nj=j+dx(d)
'print d, ni, nj', a(ni,nj), c$(ni,nj)
if ni>=0 and ni <numR and nj>=0 and nj <numC then
'if c$(ni,nj)="F" then
if ni=endI and nj=endJ then
a(ni,nj)=v+1
dirFrom(ni,nj)=d
found = 1
exit for
end if
'if c$(ni,nj)<>"#" and a(ni,nj)=0 then
if c$(ni,nj)="" and a(ni,nj)=0 then
a(ni,nj)=v+1
dirFrom(ni,nj)=d
'add to queue
q$=q$;ni;",";nj;" "
'print "Q+:";q$
end if
end if
next
if found then exit while
wend
'next we'll need to get path from S to F...
'construct a path
pathLen=a(endI,endJ)-1
redim path(pathLen,2)
j=endJ:i=endI
'print i, j, a(i,j), dirFrom(i,j)
path(pathLen, 1)=i 'last is Fin, 0-th is Start
path(pathLen, 2)=j
for k = 1 to pathLen
d=dirFrom(i,j)
ni=i-dy(d):nj=j-dx(d) 'going back, hence '-'
path(pathLen-k, 1)=ni
path(pathLen-k, 2)=nj
'print k, ni, nj, dirFrom(ni,nj), a(ni,nj)
if a(ni, nj)=1 then exit for
i=ni:j=nj
next
waveFront=pathLen
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
