Avalanche - falling letters

[tsh73]

Here is About box. It tells whole story.

So I wanted to watch letters falling

But really, I've got 3-in-a-row clone
While doing I found some options that could be changed
and put them to Preferences dialog

And provided colored 3d balls instead of letters


Now brave ones could add dictionary check and get W.E.L.D.E.R. clone

'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


[dkl]

This great tsh73:)) Not so sure I'll be up to taking on your challenge though. So much learning at the moment, what with your 1st bmpbutton's code, Walt's alternative bmpbuttons code, Rod's Scrabble Assistant. I can't keep up!

I've been working with your original 5x5 bmpbuttons code and added highlighted letters, blanks letters + GUI to change letter, some sound, a 'geofence' to limit movement and at present I'm working on the dictionary/word search to check grid horizontally and vertically for words. Its working and has to pick up all words within the row eg EATEN produces EAT, ATE, TEN, EATEN.

I'm a bit baffled at the moment as when using seekpos it takes me to the wrong position. The code I wrote appears to produce the correct seekpos position relevant to the dictionary I'm using, but in practise isn't working. It starts me half way through the letter BEFORE the one I want to go to.

d$ = ".\345 letter words - Collins Scrabble Words.txt" '<- put file path and name here

Dim letterPos$(26)
c = 65
open d$ for binary as #dic
Print "CHR$","ASC","COUNTER","SEEK","DICTIONARY"
while 1
if eof(#dic) then exit while
line input #dic,dictData$:dd = dd + 1

       if asc(left$(dictData$,1)) > c then letterPos$(lp) = str$(fpos-2):lp = lp +1:c = c +1:Print chr$(c),asc(left$(dictData$,1)),dd,letterPos$(lp-1),dictData$
fpos = loc(#dic)
       'print fpos,dictData$
       wend
close #dic
end

here is the code it all appears correct (and yes....I did add zero to the beginning of the seekpos code, when adding it to my programme)

here's is the link if anyone wants to give it a look. ln5.sync.com/dl/4e43cde60/pig76u76-euysdqq8-yyxfn8si-sgxvqrd5

PS All words in this file have been padded to be 5 characters long

If I get stuck, I may have to ask for some help. But after the festive season

Have a great Festive Season everyone

[tsh73]

I tried to add read-back part
and it started working then I removed "-2" from
then letterPos$(lp) = str$(fpos-2)
What was the idea behind that decrement?

BTW

PS All words in this file have been padded to be 5 characters long

just don't seems to hold in the file you linked. I see no padding, no spaces at all.
May be this is the reason you hit mid-words?

d$ = ".\345 letter words - Collins Scrabble Words.txt" '<- put file path and name here

Dim letterPos$(26)
c = 65
open d$ for binary as #dic
Print "CHR$","ASC","COUNTER","SEEK","DICTIONARY"
while 1
if eof(#dic) then exit while
line input #dic,dictData$:dd = dd + 1

       'if asc(left$(dictData$,1)) > c then letterPos$(lp) = str$(fpos-2):lp = lp +1:c = c +1:Print chr$(c),asc(left$(dictData$,1)),dd,letterPos$(lp-1),dictData$
       'so WHY fpos-2?
       if asc(left$(dictData$,1)) > c then letterPos$(lp) = str$(fpos):lp = lp +1:c = c +1:Print chr$(c),asc(left$(dictData$,1)),dd,letterPos$(lp-1),dictData$
fpos = loc(#dic)
       'print fpos,dictData$
       wend
close #dic

''now read back
print
open d$ for binary as #dic
   for i = 0 to 26
       pos=val(letterPos$(i))
       seek #dic, pos
       line input #dic,dictData$
       print i, letterPos$(i), dictData$
   next
close #dic

end


[dkl]

Thank you for looking at the file. The reason behind the '-2' was I noticed that in the code that you sent the seekpos for each new letter started a littler nit before the beginning of the actual file. So just thought I had to start the seekpos a bit earlier!!

Perhaps I uploaded the incorrect file? in my version all 3 letter words have 2 extra spaces as do 4 letter words (but not 5 letter words)

just checked uploaded file - yes, I uploaded the incorrect file, sorry! I've try again. I have just replace it.

I have succeeded in doing a complete horizontal and vertical search of the grid now which works well. just have to add it to the full programme (I trialed it as a separate module first) It seems to work better without seekpos engaged, but that's my coding, I'm sure!

Thanks for adding the read back check

[Carl Gundel]

Very cool stuff.

Falling letters makes my think of the Matrix movie out today. Anyone have a Matrix screensaver in Liberty BASIC handy for the ocassion?

[tsh73]

Suprisingly enough I did not found any code of mine.
(probably have something from other folks at old forum dump, though - but it needs to be excavated and converted to useful form.)

Created a contest page
libertybasiccom.proboards.com/thread/1851/chellenge-matrix-screensaver