'http://libertybasic.fr/forum/topic-162-1+code-en-cours-de-defrichage.php
   'http://libertybasic.fr/forum/topic-163+chutes.php
   'with coolFractal.bas contributed by Rod extract of JB exemples
   ' with help of tsh73 and NJames : http://justbasic.conforums.com/index.cgi?board=games&action=display&num=1342514807

    nomainwin
 
    GLOBAL ncx, ncy, dc, mm, bb, midx, midy
    global ro, di, oldro, oldi, coup, tscore
 
    ncx = 16   ' nbr of cells X
    ncy = 9    ' nbr of cells Y
    dc = 42    ' size of a cell in pixels
    MapWidth = (ncx+2)*dc+int(dc/ncx)
    MapHeight = 378  ' (ncy)*dc+int(dc/ncy)  '378

    midx=int(MapWidth/2)-80
    midy=int(MapHeight/2)
 
    WindowWidth  = MapWidth + 65
    WindowHeight = MapHeight + 75  ' 498  ' 75
    UpperLeftX = (DisplayWidth-WindowWidth) / 3
    UpperLeftY = (DisplayHeight-WindowHeight) / 2
 
   ' mois$ = "January February March April May June July August September October November December"
    mois$ = "Janvier Février Mars Avril Mai Juin Juillet Août Septembre Octobre Novembre Décembre"   ' french
    today$ = date$("mm/dd/yyyy")
    j = date$(today$)
   ' jsem$ = word$("Tuesday Wednesday Thursday x Friday Saturday x Sunday Monday",int((j/7-int(j/7))*10)+1)
    jsem$ = word$("Mardi Mercredi Jeudi x Vendredi Samedi x Dimanche Lundi",int((j/7-int(j/7))*10)+1)   ' french
    date$ = jsem$+" "+mid$(today$,4,2)+" "+word$(mois$, val(today$))+" "+right$(today$,4)+"  "+left$(time$(),5)
 
    DIM cell(ncx,ncy): DIM quoi(ncx+1,ncy)
 
    button #w.bi "Bille", [bi], UL, 40, 5, 60, 25
    button #w.mu "Mur", [mu], UL, 120, 5, 60, 25
    statictext #w.txt "",460,10,200,30
    button #w.ni "Niveau: 1", [niv], UL, 310, 5, 80, 25
    statictext #w.tt "Triche", 40+17*dc, 40+(8*dc)+7,50,20
    graphicbox #w.map, 5+dc, 40, MapWidth-2*dc, MapHeight
    button #w.bt11 "", boutons, UL, 775, 44+(1*dc), dc, dc-10  '  à droite
    button #w.bt21 "", boutons, UL, 775, 44+(2*dc)+1, dc, dc-10
    button #w.bt31 "", boutons, UL, 775, 44+(3*dc)+2, dc, dc-10
    button #w.bt41 "", boutons, UL, 775, 44+(4*dc)+3, dc, dc-10
    button #w.bt51 "", boutons, UL, 775, 43+(5*dc)+4, dc, dc-10
    button #w.bt61 "", boutons, UL, 775, 43+(6*dc)+5, dc, dc-10
    button #w.bt71 "", boutons, UL, 775, 41+(7*dc)+6, dc, dc-10
    button #w.bt81 "", boutons, UL, 775, 54+(8*dc)+7, dc, 20 ' 775, 46+(8*dc)+7, dc, dc-10

    button #w.bt12 "", boutons, UL, 9+17*dc, 44+(1*dc), dc, dc-10  '  à gauche
    button #w.bt22 "", boutons, UL, 9+17*dc, 44+(2*dc)+1, dc, dc-10
    button #w.bt32 "", boutons, UL, 9+17*dc, 44+(3*dc)+2, dc, dc-10
    button #w.bt42 "", boutons, UL, 9+17*dc, 44+(4*dc)+3, dc, dc-10
    button #w.bt52 "", boutons, UL, 9+17*dc, 43+(5*dc)+4, dc, dc-10
    button #w.bt62 "", boutons, UL, 9+17*dc, 43+(6*dc)+5, dc, dc-10
    button #w.bt72 "", boutons, UL, 9+17*dc, 41+(7*dc)+6, dc, dc-10
    button #w.bt82 "", boutons, UL, 9+17*dc, 54+(8*dc)+7, dc, 20 ' 9+17*dc, 46+(8*dc)+7, dc, dc-10
    button #w.new "New",[new],UL,MapWidth-20,6,60,27
    OPEN "    TEST Chute(s)... "+space$(15)+date$ for window_nf as #w  'graphics_nf_nsb
    #w "trapclose quit"
    #w.map "setfocus"
    #w.map "down; backcolor black; fill black"
    #w.map "getbmp p0 0 0 ";dc;" ";dc  ' empty cell for deleting
    #w.new "!font Arial 12 bold"
    #w.txt "!font Arial 11 bold"
    for bt = 1 to 16
        btn$ = "#w.bt"+word$("11 21 31 41 51 61 71 81 12 22 32 42 52 62 72 82",bt)
        #btn$ "!font Arial 16 bold"
        if bt<9 then #btn$ ">" else #btn$ "<"
    next
 
    for im = 1 to 5         '  chargement en mémoire des fichiers BMP qui pourront ensuite être utilisés.
        loadbmp "mur";im, "Mur";im;".bmp"
        loadbmp "bille";im, "Bille";im;".bmp"
    next
 
    bb=4: mm=5: niv=2
 
    [niv]
      niv=niv+1
      if niv=4 then niv=1
      #w.ni, "Niveau: ";word$("1 2 RND",niv)
 
    [new]
    call AllButtonsActivate 1  ' active tous les bouttons
    coup=0
    print #w.txt, coup;" coup(s)"
    print #w.bi, "Bille: ";bb
    print #w.mu, "Mur: ";mm
 
    if niv=1 then RESTORE [niveau1]
    if niv=2 then RESTORE [niveau2]
    for y=1 to ncy      ' mise en place du niveau courrant ( cell(x,y) -> 0 = trou, 1 = mur, 2 = bille )
        [trou]
        cm = 0
        for x=1 to ncx
          if niv<3 then
            read val  ' read ne peut pas affecter directement une var. tableau.
          else
            val = int(rnd(0)*2)  ' 1 sur 3 peut être un trou (=0)
            if val>1 then val=1
            if y=1 then val = 2 else if y=ncy then val = 0
          end if
          cell(x,y) = val
          if val = 0 then cm = 1
        next
        if cm = 0 and y > 1 then [trou]
        call drawRow y
    next
 
    call fall  ' première chute dès la mise en place

    WAIT
 
    sub fall   ' gère toutes les chutes potentielles dans toute la grille
        for cy = ncy-1 to 1 step -1 ' en partant du bas bien sûr !
            for cx = 1 to ncx
                by = cy
                while by+1 <= ncy
                    if cell(cx,by) = 2 and cell(cx,by+1) = 0 then
                        cell(cx,by) = 0
                        #w.map "drawbmp p0 ";(cx-1)*dc;" ";(by-1)*dc
                        cell(cx,by+1) = 2
                        #w.map "drawbmp bille";bb;" ";(cx-1)*dc;" ";by*dc
                    end if
                    by = by + 1
                wend
            next
        next
        #w.map "flush; discard"
    end sub
 
    [bi]                   ' change bille
      bb=bb+1
      if bb =6 then bb=1
      #w.bi, "Bille: ";bb
      for y = 1 to ncy :call drawRow y :next
    wait
 
    [mu]                   ' change mur
      mm=mm+1
      if mm =6 then mm=1
      #w.mu, "Mur: ";mm
      for y = 1 to ncy :call drawRow y :next
    wait
 
    sub boutons handle$  ' décalage d'une ligne en fonction du bouton pressé (vers la droite ou vers la gauche)
       ' la règle : les billes ne se déplacent que poussées par un mur, et ne peuvent pas dépasser les bords.
        row = val(mid$(handle$,6,1))+1 'extraction de la ligne grace aux noms des boutons (judicieusement nommés ;) )
        dir = val(mid$(handle$,7,1))   'et extraction du sens
        ro=row-1: di=dir
        if olro<>0 or oldi<>0 then    ' secur premier coup
            han$ = "#w.bt" + STR$(oldro)+STR$(oldi)
            #han$, "!enable"             'réactive bouton
        end if
 
        call slide row, dir   ' slide management of row

        call drawRow row
        call fall
        call ButtonsRow  ' désactive les bouttons d'une ligne sans bille à partir du haut.

        hand$ = "#w.bt" + STR$(ro)+STR$(di)
        #hand$, "!disable"         ' désactive bouton
        oldro=ro: oldi=di                'memorise ligne direction
        coup=coup+1
        #w.txt, coup;" coup(s)"
        tscore=0
        for xx=1 to ncx
          if cell(xx,ncy)=2 then tscore=tscore+1
        next xx
        if tscore=16 then
            timer 1000, [temp]
            wait
            [temp]
            timer 0
            call frac
        end if
    end sub       ' c'est ici que le prog attend le coup suivant******************************

    SUB slide Rw, Dr   ' slide management of Rw
        s = 1 :ax = ncx
        if Dr=1 then s = 0-1 :ax = 1
        o = ok(Rw,Dr)  ' = première case déplaçable
        if o then
            temp = cell(o,Rw)
            for x=o to ax-s step s :cell(x,Rw) = cell(x+s,Rw) :next    ' tout décaler
            if temp<>2 then cell(ax,Rw) = temp
            if Rw < ncy then  ' exception ligne du bas...
                for x=ax to o+s step 0-s     ' recherche les billes qui doivent être remisent à leur place
                    if cell(x,Rw) = 0 and cell(x-s,Rw) = 2 then cell(x,Rw) = cell(x-s,Rw) :cell(x-s,Rw)=0
                next
            end if
        end if
    END SUB
 
    FUNCTION ok(rw,d)  ' renvoi la première case déplaçable
        s = 1  :x = 1
        if d=1 then s = 0-1 :x = ncx
        while cell(x,rw)=2 :x=x+s :wend
        ok = x :if x>1 and x<ncx and cell(x,rw)=1 then ok=0
    END FUNCTION
 
    SUB ButtonsRow   ' désactive les bouttons d'une ligne sans bille à partir du haut.
        for cy = 1 to ncy-1  'on commence à partir de la 1ère qui n'a pas de boutons
            if emptyRow(cy) = 0 then exit for
            if cy > 1 then  ' verifie si c'est une ligne qui comporte des boutons
                btn$ = "#w.bt";cy-1;1 : #btn$ "!disable"    ' cy-1 car les boutons commence à 1 et le 1er cy avec boutons = 2 !
                btn$ = "#w.bt";cy-1;2 : #btn$ "!disable"
            end if
        next
    end sub
 
    function emptyRow(rw)  ' retourne 1 si la ligne 'rw' est vide, 0 si non.
        emptyRow = 1
        for xx=1 to ncx
           if cell(xx,rw)=2 then emptyRow = 0 :exit function
        next xx
    end function
 
    SUB AllButtonsActivate OnOff  ' si OnOff = 1 "!enable" , 0 = ""!disable"
        action$ = word$("!disable !enable",OnOff+1)
        #w.new action$ ' réactiver TOUS les boutons avant de sortir...
        #w.ni action$
        #w.mu action$
        #w.bi action$
        for bt = 1 to 16
            btn$ = "#w.bt"+word$("11 21 31 41 51 61 71 81 12 22 32 42 52 62 72 82",bt)
            #btn$ action$
        next
    end sub
 
 sub frac
    call AllButtonsActivate 0
    #w.map, "down ; fill black"
    #w.txt "Clic sur la fractale = Retour"
    #w.map "when leftButtonDown [out]"   ' pour sortir de la SUB frac quand clic dans #w.map
    [draw]
    'set up some random colors
    redim col$(12)
    for c=0 to 12
        col$(c)=str$(int(rnd(0)*256))+" "+str$(int(rnd(0)*256))+" "+str$(int(rnd(0)*256))
    next c
 
    'set up some random starting positions
    a=rnd(0)
    b=0.9998
    c=2-2*a
    dots=12000
    x=j=0
    y=rnd(0)*12+0.1
    'calculate and draw the points
    for i=0 to dots
        scan
        z=x
        x=b*y+j
        j=a*x+c*(x^2)/(1+x^2)
        y=j-z
        xp=(x*20)+midx
        yp=(y*20)+midy
        #w.map, "color ";col$(i/1000)
        #w.map, "set ";xp;" ";yp
    next i
    goto [draw]
    [out]
    call AllButtonsActivate 1
 end sub
 
    sub drawRow r    ' dessine le contenu d'une ligne
       ' #w.map "place 0 ";(r-1)*dc;" ; boxfilled ";(ncx-1)*dc;" ";r*dc
        for x=1 to ncx
            select case cell(x,r)
            case 0 :#w.map "drawbmp p0 ";(x-1)*dc;" ";(r-1)*dc
            case 1 :#w.map "drawbmp mur";mm;" ";(x-1)*dc;" ";(r-1)*dc
            case 2 :#w.map "drawbmp bille";bb;" ";(x-1)*dc;" ";(r-1)*dc
            end select
        next
    end sub
 
    [niveau1]
    data 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2    ' 2 = boule, 1 = mur, 0 = trou
    data 0,1,1,1,0,1,1,1,1,0,1,1,1,0,1,1
    data 1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,1
    data 0,1,1,1,0,1,0,1,0,1,0,1,0,1,1,1
    data 1,1,0,1,1,1,1,0,1,0,1,1,1,0,1,1
    data 0,1,1,1,1,0,1,1,0,1,0,1,1,1,1,1
    data 1,0,1,1,0,1,1,0,1,1,1,1,0,1,1,1
    data 0,1,1,0,1,1,0,1,1,1,0,1,1,1,0,1
    data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
 
    [niveau2]
    data 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2    ' 2 = boule, 1 = mur, 0 = trou
    data 1,1,0,1,1,0,1,1,0,1,1,0,1,1,1,1
    data 1,1,1,0,1,1,1,0,1,1,1,1,1,0,1,1
    data 1,0,1,1,1,0,1,1,1,1,1,0,1,1,1,1
    data 1,1,0,0,1,1,1,0,1,0,1,1,1,1,0,1
    data 1,1,0,1,1,0,1,1,1,1,0,1,1,1,1,1
    data 1,0,1,1,0,1,1,0,1,1,1,1,0,1,1,1
    data 1,1,1,0,1,1,1,1,0,1,1,1,1,0,1,1
    data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
 
    sub quit handle$
        for im = 1 to 5
            unloadbmp "mur";im
            unloadbmp "bille";im
        next
        close #handle$
        end
    end sub