Forum Liberty Basic France

Le 30/06/2012 à 11h33

Libertynaute Expert

Groupe: Membre

Inscrit le: 19/02/2011
Messages: 767
Reprise du message précédent

Ultime tentative d'amélioration du comportement de Scrat :siffle

Cresus_V2.zip

Mais pas d'inquiétude, on gagne facilement quand même... :mat



Edité par cassiope01 Le 30/06/2012 à 12h07
____________________
Devise Shadocks : "Mieux vaut mobiliser son intelligence pour des conneries, que mobiliser sa connerie pour des choses intelligentes"
Coluche disait : "C'est parce que la vitesse de la lumière est plus rapide que celle du son que certains peuvent paraîtrent brillants jusqu'à ce qu'ils ouvrent la bouche."

Web    
Le 01/07/2012 à 12h07

Libertynaute Expert

Groupe: Membre

Inscrit le: 19/02/2011
Messages: 767
Dernier BUG résolu. C'était sur la fonction "Back".
+ signalisation du joueur qui gagne,
+ celui qui perd commence.

Cresus_V2.zip
____________________
Devise Shadocks : "Mieux vaut mobiliser son intelligence pour des conneries, que mobiliser sa connerie pour des choses intelligentes"
Coluche disait : "C'est parce que la vitesse de la lumière est plus rapide que celle du son que certains peuvent paraîtrent brillants jusqu'à ce qu'ils ouvrent la bouche."

Web    
Le 01/07/2012 à 13h08

Administrateur

Groupe: Administrateur

Inscrit le: 04/03/2012
Messages: 2264
Moi, j'aime bien quand Scrat se retrouve avec plus rien à prendre autour.
Son expression est alors tout à fait adaptée.... :lol
Et si le dessin n'était pas si petit, et si j'arrivais à piger se qui se passe à ce moment là, je lui ferait se gratter la tete, en regardant à droite et à gauche...et ça serait bien marrant.....
...Disont une: CA ( connerie artificielle ) ----> Scrat hum hum.zip
Il pourrait faire une ou deux sequences puis disparaitre.



Edité par Roland Le 01/07/2012 à 15h28
____________________
Roro

   
Le 01/07/2012 à 19h35

Administrateur

Groupe: Administrateur

Inscrit le: 04/03/2012
Messages: 2264
Cassiope, s'il te plait...explique ce qui fait que le prog s'arrete au wait de [play] quand Scrat n'a plus rien autour...s'il te plait... :(
____________________
Roro

   
Le 02/07/2012 à 08h06

Libertynaute Expert

Groupe: Membre

Inscrit le: 19/02/2011
Messages: 767
Dans [play] il y a l'exécution du coup du joueur puis le lancement de [computer] qui doit trouver un coup à jouer pour Scrat.
Si [computer] ne trouve rien à jouer : il ne fait rien, tout simplement.
Le programme se retrouve donc en attente du [play] c'est à dire du coup du joueur, qui n'a rien à jouer non plus... cqfd.

Prend la dernière version, j'ai corrigé un dernier petit bug.

Je vais essayer d'inclure les 4 images que tu donnes... ;) :siffle

@+
____________________
Devise Shadocks : "Mieux vaut mobiliser son intelligence pour des conneries, que mobiliser sa connerie pour des choses intelligentes"
Coluche disait : "C'est parce que la vitesse de la lumière est plus rapide que celle du son que certains peuvent paraîtrent brillants jusqu'à ce qu'ils ouvrent la bouche."

Web    
Le 02/07/2012 à 11h09

Administrateur

Groupe: Administrateur

Inscrit le: 04/03/2012
Messages: 2264
Hey ! on dirait que Scrat n'aime pas etre compressé.
Chez moi il manque du pognon à l'ouverture de la derniere version que je viens de recharger
en: 7,6 et en: 8,5 ...... au "new" le pognon reviens
Décidement ce code est loin d'étre simple. :heink....




Edité par Roland Le 02/07/2012 à 11h39
____________________
Roro

   
Le 02/07/2012 à 12h04

Administrateur

Groupe: Administrateur

Inscrit le: 04/03/2012
Messages: 2264
C'est bon, la dernière version est mieux, je suis arrivé à mettre Scrat "Maigre" en place quand il est isolé;
Je fais la séquence ( hum ! j'essaie.....)........à+ ;)
____________________
Roro

   
Le 02/07/2012 à 12h48

Libertynaute Expert

Groupe: Membre

Inscrit le: 19/02/2011
Messages: 767
Pas de soucis : lances toi, c'est fait pour, tu le sais bien.
____________________
Devise Shadocks : "Mieux vaut mobiliser son intelligence pour des conneries, que mobiliser sa connerie pour des choses intelligentes"
Coluche disait : "C'est parce que la vitesse de la lumière est plus rapide que celle du son que certains peuvent paraîtrent brillants jusqu'à ce qu'ils ouvrent la bouche."

Web    
Le 02/07/2012 à 14h49

Administrateur

Groupe: Administrateur

Inscrit le: 04/03/2012
Messages: 2264
JE L'AI FAIT !!! :miam :miam :miam en 20 lignes avec une do while, le time$, et le timer.
dans le gif, il y a 5 images Sgauche, Sdroite, Shdroite, Shgauche et Shdroite 800 milli chaque, 2 séquences et disparition.
j'était sur une version antérieure, j'ai cru devenir chèvre . Avec celle là c'est plus clair, mais il manque de plus en plus de pognon à l'ouverture. :heink Heureusement que le "new" remets de l'ordre.
____________________
Roro

   
Le 02/07/2012 à 16h01

Libertynaute Expert

Groupe: Membre

Inscrit le: 19/02/2011
Messages: 767
12 lignes pour moi ;)
J'ai trouvé qu'avec 500 comme pause c'était pas mal ;)

Code VB :
 ' based on an old game named "cresus"
 ' cassiope01 June, 20 2012

    nomainwin
 
    GLOBAL ncx, ncy, player
 
    ncx = 16   ' nbr of cells X
    ncy = 8    ' nbr of cells Y
    dc = 60    ' size of a cell in pixels
    MapWidth = ncx*dc+int(dc/ncx)
    MapHeight = ncy*dc+int(dc/ncy)
 
    WindowWidth  = MapWidth + 15
    WindowHeight = MapHeight + 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 info$(10,10)
    DIM dirX(8), dirY(8)
    DIM cell(ncx,ncy)
    DIM mem(ncx,ncy)
    DIM score(2)
    DIM amount(8)
    DIM player$(2)
    fcl$ = "68 130 188"  ' must be the same color as in pieces.bmp
    curs.symbol$ = "€"
    ft = int(dc/3)+1
    ft$ = "Courier_New ";ft;" bold"
    player$(1) = "You"
    player$(2) = "Scrat"
    dirX(1) = 0  : dirY(1) = -1  'up
    dirX(2) = 1  : dirY(2) = 0   'right
    dirX(3) = 0  : dirY(3) = 1   'down
    dirX(4) = -1 : dirY(4) = 0   'left
    dirX(5) = 1  : dirY(5) = -1  'up right     diagonals
    dirX(6) = 1  : dirY(6) = 1   'down right
    dirX(7) = -1 : dirY(7) = 1   'down left
    dirX(8) = -1 : dirY(8) = -1  'up left
    d2$(1) = "8 1 5"
    d2$(2) = "5 2 6"
    d2$(3) = "6 3 7"
    d2$(4) = "7 4 8"
    d2$(5) = "8 1 5 2 6"    ' second level around (n° of dirX(),dirY() )
    d2$(6) = "5 2 6 3 7"
    d2$(7) = "6 3 7 4 8"
    d2$(8) = "7 4 8 1 5"
 
    statictext #w.txt "",5,10,370,25  ' just for debug
    statictext #w.sc1 player$(1),380,10,80,25
    statictext #w.sc2 player$(2),715,10,90,25
    graphicbox #w.gsc1, 462,6,116,28
    graphicbox #w.gsc2, 590,6,116,28
    button #w.bck "Undo",[back],UL,MapWidth-130,6,60,27
    button #w.new "New",[new],UL,MapWidth-55,6,60,27
    graphicbox #w.map, 5, 40, MapWidth, MapHeight
    OPEN "    Scrat Crésus... "+space$(15)+date$ for window_nf as #w  'graphics_nf_nsb
    #w "trapclose [quit]"
    #w.bck "!font Comic_Sans_MS 12 bold"
    #w.new "!font Comic_Sans_MS 12 bold"
    #w.txt "!font Courier_New 14 bold"
    #w.sc1 "!font Courier_New 14 bold"
    #w.sc2 "!font Courier_New 14 bold"
    #w.gsc1 "font Courier_New 18 bold"
    #w.gsc2 "font Courier_New 18 bold"
    #w.map "down; font ";ft$;" ; fill ";fcl$
    #w.map "backcolor ";fcl$
    #w.gsc1 "down; backcolor lightgray ; fill lightgray"
    #w.gsc2 "down; backcolor lightgray ; fill lightgray"
 
    loadbmp "pieces", "pieces_V2.bmp"
    loadbmp "scrat1", "Scrat2_60x60Gg.bmp"
    loadbmp "scrat2", "Scrat2_60x60Gg.bmp"
    loadbmp "scrat3", "Shgau.bmp"
    loadbmp "scrat4", "Sgau.bmp"
    loadbmp "scrat5", "Shdroi.bmp"
    loadbmp "scrat6", "Sdroi.bmp"
 
    #w.map "getbmp p0 0 0 ";dc;" ";dc  ' empty cell for deleting
    #w.map "drawbmp pieces ";MapWidth-dc-2;" 2"
    for p = 1 to 8
        #w.map "getbmp p";p;" ";MapWidth-dc-2;" ";2+(p-1)*dc;" ";dc;" ";dc  ' make bmps needed
        amount(p) = val(word$("2 1 0.5 0.2 0.1 0.05 0.02 0.01",p))  ' its values
    next
    player = 1
 
    if fileExist(DefaultDir$, "saved.ini") then      ' load the last game...
        #w.map "fill ";fcl$
        open "saved.ini" for input as #gb
        LINE INPUT #gb, score(1)
        LINE INPUT #gb, score(2)
        LINE INPUT #gb, cx
        LINE INPUT #gb, cy
        for y=1 to ncy
            LINE INPUT #gb, load$
            for x=1 to ncx
                mem(x,y)=val(mid$(load$,x,1))  ' for mem(x,y)
            next
        next
        for y=1 to ncy
            LINE INPUT #gb, load$
            for x=1 to ncx
                cell(x,y)=val(mid$(load$,x,1))  ' for cell(x,y)
                #w.map "drawbmp p";cell(x,y);" ";2+(x-1)*dc;" ";(y-1)*dc
            next
        next
        close #gb
        goto [game]
    end if
 
    [new]
    redim score(2)
    #w.map "fill ";fcl$
    for cy=1 to ncy
        for cx=1 to ncx
            cell(cx,cy) = int(rnd(0)*8)+1 : mem(cx,cy) = cell(cx,cy)
            #w.map "drawbmp p";cell(cx,cy);" ";2+(cx-1)*dc;" ";(cy-1)*dc
        next
    next
    cx = 8  'starting Scrat's position
    cy = 5
    cell(cx,cy) = 0
    mem(cx,cy) = 0
    [game]
    gosub [DispScore]
    oldcx = cx
    oldcy = cy
    memo$ = str$(player)+nocell$(cx,cy)
    #w.map "drawbmp scrat3 ";2+(cx-1)*dc;" ";(cy-1)*dc
    #w.map "flush ; discard"
    #w.txt "Player = ";player;"  (";player$(player);")"  ' just for debug
    if player = 2 then gosub [computer]
 
    #w.map "when leftButtonDown [play]"    ' x,y cell
   ' #w.map "when mouseMove [infos]"    ' x,y cell

    animation = 1
    animate = 3   ' car le début des bmp d'animation commence à scrat3
    interval = 500
 
    timer interval, [anim]
    wait
 
    [anim]
        animate = animate + 1 - 4*(animate=6)  ' scrat3 scrat4 scrat5 scrat6 scrat3 scrat4 etc...
        if animation = 1 then
            #w.map "drawbmp scrat";animate;" ";2+(oldcx-1)*dc;" ";(oldcy-1)*dc
        end if
    wait
 
    [DispScore]
        score.color$(1) = "blue"
        score.color$(2) = "blue"
        if score(1)<score(2) then score.color$(1) = "red"
        if score(1)>score(2) then score.color$(2) = "red"
        #w.gsc1 "fill lightgray ; color ";score.color$(1);" ; place 8 21 ;|";using("##.##",score(1));" ";curs.symbol$
        #w.gsc2 "fill lightgray ; color ";score.color$(2);" ; place 8 21 ;|";using("##.##",score(2));" ";curs.symbol$
        #w.gsc1 "flush ; discard"
        #w.gsc2 "flush ; discard"
    Return
 
    [back]  ' back move (button)
      if len(memo$)>4 then
        bck = 0
        DO
            bck = bck + 1
            cx = X(right$(memo$,3))
            cy = Y(right$(memo$,3))
            player = val(left$(right$(memo$,4),1))
    #w.txt "Player = ";player;"  (";player$(player);")"  ' just for debug
            cell(cx,cy) = mem(cx,cy)
            score(player) = score(player) - amount(cell(cx,cy)) ' re-calc score
            gosub [DispScore]
            #w.map "drawbmp p";cell(cx,cy);" ";2+(cx-1)*dc;" ";(cy-1)*dc  ' restore last
            memo$ = left$(memo$,len(memo$)-4)
            oldcx = X(right$(memo$,3))
            oldcy = Y(right$(memo$,3))
            player = val(left$(right$(memo$,4),1))
    #w.txt "Player = ";player;"  (";player$(player);")"  ' just for debug
            cell(oldcx,oldcy) = 0
            #w.map "drawbmp scrat1 ";2+(oldcx-1)*dc;" ";(oldcy-1)*dc   ' cursor
            #w.map "flush ; discard"
            timer 200, [temp2]
            wait
            [temp2]
            timer 0
        LOOP UNTIL bck = 2 or len(memo$) = 4
        if player = 2 and len(memo$) = 4 then gosub [computer]
      end if
    wait
 
    [play]  ' player game
        cx = int(MouseX/dc)+1 :if cx>ncx then cx=ncx
        cy = int(MouseY/dc)+1 :if cy>ncy then cy=ncy
        if cell(cx,cy)>0 and abs(oldcx-cx)<2 and abs(oldcy-cy)<2 then
            gosub [action]
            player = player + 1 -2 * (player = 2)
    #w.txt "Player = ";player;"  (";player$(player);")"  ' just for debug
            gosub [computer]
            if neighbors(cx,cy) = 0 then
                select case
                case score(1)>score(2) :#w.txt space$(10);player$(1);" WIN." :player = 2
                case score(2)>score(1) :#w.txt space$(10);player$(2);" WIN." :player = 1
                case else  :#w.txt space$(10);"Egality...!"
                end select
            end if
            #w.map "flush ; discard"
            timer interval, [anim]
        end if
    wait
 
    [action]  ' play current cx,cy
        #w.map "drawbmp p0 ";2+(oldcx-1)*dc;" ";(oldcy-1)*dc
        if cx-oldcx>0 then
            #w.map "drawbmp scrat2 ";2+(cx-1)*dc;" ";(cy-1)*dc   ' cursor
        else
            #w.map "drawbmp scrat1 ";2+(cx-1)*dc;" ";(cy-1)*dc   ' cursor
        end if
        oldcx = cx
        oldcy = cy
        score(player) = score(player) + amount(cell(cx,cy))
        gosub [DispScore]
        cell(cx,cy) = 0
        memo$ = memo$ + str$(player)+nocell$(cx,cy)  ' record for back
    return
 
    [computer]
        #w.map "when leftButtonDown"    ' x,y cell
       ' #w.map "when mouseMove"    ' x,y cell
        ok$ = Around$(oldcx,oldcy)  'chaine des cellules autour + quelques caractéristiques pour chacune
        if ok$ <> "" then
            h = maxi(ok$)  ' extraction du coup à jouer.
            n$ = mid$(ok$,h*9+1,3)
            cx = X(n$)
            cy = Y(n$)
            timer 500, [temp3]
            wait
            [temp3]
            timer 0
            gosub [action]
        end if
        player = player + 1 -2 * (player = 2)
    #w.txt "Player = ";player;"  (";player$(player);")"  ' just for debug
        #w.map "when leftButtonDown [play]"    ' x,y cell
       ' #w.map "when mouseMove [infos]"    ' x,y cell
      '  timer 500, [anim]
    return
 
    function maxi(c$) ' extrait de c$ l'endroit de la case la plus judicieuse
    redim p(8)
    redim vl(8)
    i = int(len(c$)/9)
    WHILE i>0
        lc = instr("0.01 0.02 0.05 0.10 0.20 0.50 1.00 2.00 3.00",mid$(c$,(i-1)*9+5,4))
        vl(i) = int(lc/5)+1
        p(i) = val(mid$(c$,(i-1)*9+4,1))
        if p(i)>0 then p(i)=1
        cf$ = "------"+str$(vl(i))+str$(p(i))+"-" + cf$
        i=i-1
    WEND
    ' trouver le maxi dans la direction la plus bénéfique
    v = 90
    DO
        l = instr(cf$,str$(v))
        if l>0 then maxi = int((l+2)/9)-1 :exit DO
        l = instr(cf$,str$(v+1))
        if l>0 then maxi = int((l+2)/9)-1 :exit DO
        v = v-10
        if v < 70 then
            DO
                l = instr(cf$,str$(v))
                if l>0 then
                    maxi = int((l+2)/9)-1 :stp = 1 :exit DO
                end if
                v = v-10
                if v=0 then v=61
            LOOP UNTIL v=1
            if stp then exit DO
        end if
    LOOP UNTIL v=0 or v=1
    end function
 
    function Around$(x,y)
        redim d(8)
        redim c$(8)
        redim vv(8)
        op = player + 1 -2 * (player = 2)
        for n = 1 to 8
            nx = x + dirX(n)
            ny = y + dirY(n)
            if nx>0 and nx<=ncx and ny>0 and ny<=ncy then
                if cell(nx,ny) > 0 then
                    vv(n) = amount(cell(nx,ny))
                    neibs = neighbors(nx,ny) ' how many neighbors have this cell ?
                    if neibs = 0 then  ' it's a "dead end"
                        if score(player)+vv(n) >= score(op) then
                            ' 3.00 is a value to be sure that this cell will be chosen
                            vv(n) = 3.00 :d(n) = 0 :c$(n) = nocell$(nx,ny) :exit for
                        else
                            vv(n) = 0.01 :d(n) = 8
                        end if
                    else
                        if len(d2$(n)) = 5 then c = 3 else c = 5
                        for n2 = 1 to c
                            nn = val(word$(d2$(n),n2))
                            nnx = nx+dirX(nn)
                            nny = ny+dirY(nn)
                            if nnx>0 and nnx<=ncx and nny>0 and nny<=ncy then
                              ' d(i) = nbre de 1€ ou 2€ qu'il y a dans la direction de cette case
                                if amount(cell(nnx,nny)) > 0.5 then d(n) = d(n) + 1
                            end if
                        next
                    end if
                    c$(n) = nocell$(nx,ny)
                end if
            end if
        next
        WHILE vv(1)+vv(2)+vv(3)+vv(4)+vv(5)+vv(6)+vv(7)+vv(8)>0
            i = int(rnd(0)*8)+1
            if vv(i)>0 then
                Around$ = c$(i)+str$(d(i))+using("#.##",vv(i))+"-"+Around$
                vv(i)=0
            end if
        WEND
    end function
 
    function neighbors(bx,by)  ' nb of neighbors around bx,by
        for n = 1 to 8
            nx = bx + dirX(n)
            ny = by + dirY(n)
            if nx>0 and nx<=ncx and ny>0 and ny<=ncy then
                if cell(nx,ny)>0 then neighbors = neighbors + 1
            end if
        next
    end function
 
    function nocell$(vx,vy)
        nocell$ = right$(str$(100+vx),2)+str$(vy)  '  "xxy"
    end function
 
    function X(nocell$)
        X = val(left$(nocell$,2))
    end function
 
    function Y(nocell$)
        Y = val(right$(nocell$,1))
    end function
 
    [infos]
        cx = int(MouseX/dc)+1 :if cx>ncx then cx=ncx
        cy = int(MouseY/dc)+1 :if cy>ncy then cy=ncy
        #w.txt MouseX;",";MouseY;"  cell(";cx;",";cy;") = ";amount(cell(cx,cy));" ";curs.symbol$
    wait
 
    function fileExist(path$, filename$)
        files path$, filename$, info$()
        fileExist = val(info$(0, 0))
    end function
 
    [quit]
        CONFIRM "QUIT THE GAME ?"; answer$
        if answer$ = "yes" then
            open "saved.ini" for output as #gb   ' save current game
            #gb, score(1)
            #gb, score(2)
            #gb, oldcx
            #gb, oldcy
            for y=1 to ncy
                for x=1 to ncx
                    sav$ = sav$;mem(x,y)
                next
                #gb, sav$ : sav$ = ""
            next
            for y=1 to ncy
                for x=1 to ncx
                    sav$ = sav$;cell(x,y)
                next
                #gb, sav$ : sav$ = ""
            next
            close #gb
            unloadbmp "pieces"
            unloadbmp "scrat1"
            unloadbmp "scrat2"
            for im = 0 to 8 :unloadbmp "p";im :next
            close #w
            end
        end if
    wait
 




Edité par cassiope01 Le 02/07/2012 à 16h08
____________________
Devise Shadocks : "Mieux vaut mobiliser son intelligence pour des conneries, que mobiliser sa connerie pour des choses intelligentes"
Coluche disait : "C'est parce que la vitesse de la lumière est plus rapide que celle du son que certains peuvent paraîtrent brillants jusqu'à ce qu'ils ouvrent la bouche."

Web    
Le 02/07/2012 à 16h18

Administrateur

Groupe: Administrateur

Inscrit le: 04/03/2012
Messages: 2264
Le mien , je l'ai mis qu'à la fin, quand il n'y a plus rien autour...c'est plus mieux.
A t-on des nouvelles des Euros manquants au premier lancement ( je suis con... c'est peut-etre voulu.... :p )

Code JB :
 
 
 ' based on an old game named "cresus"
 ' cassiope01 June, 20 2012
 
    nomainwin
 
    GLOBAL ncx, ncy, player
 
    ncx = 16   ' nbr of cells X
    ncy = 8    ' nbr of cells Y
    dc = 60    ' size of a cell in pixels
    MapWidth = ncx*dc+int(dc/ncx)
    MapHeight = ncy*dc+int(dc/ncy)
 
    WindowWidth  = MapWidth + 15
    WindowHeight = 650
    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 info$(10,10)
    DIM dirX(8), dirY(8)
    DIM cell(ncx,ncy)
    DIM mem(ncx,ncy)
    DIM score(2)
    DIM amount(8)
    DIM player$(2)
    fcl$ = "68 130 188"  ' must be the same color as in pieces.bmp
    curs.symbol$ = "€"
    ft = int(dc/3)+1
    ft$ = "Courier_New ";ft;" bold"
    player$(1) = "You"
    player$(2) = "Scrat"
    dirX(1) = 0  : dirY(1) = -1  'up
    dirX(2) = 1  : dirY(2) = 0   'right
    dirX(3) = 0  : dirY(3) = 1   'down
    dirX(4) = -1 : dirY(4) = 0   'left
    dirX(5) = 1  : dirY(5) = -1  'up right     diagonals
    dirX(6) = 1  : dirY(6) = 1   'down right
    dirX(7) = -1 : dirY(7) = 1   'down left
    dirX(8) = -1 : dirY(8) = -1  'up left
    d2$(1) = "8 1 5"
    d2$(2) = "5 2 6"
    d2$(3) = "6 3 7"
    d2$(4) = "7 4 8"
    d2$(5) = "8 1 5 2 6"    ' second level around (n° of dirX(),dirY() )
    d2$(6) = "5 2 6 3 7"
    d2$(7) = "6 3 7 4 8"
    d2$(8) = "7 4 8 1 5"
 
    statictext #w.tta "Action AAA",10,530,130,20
    statictext #w.ttb "Comput BBB",10,545,130,20
    statictext #w.ttc "CCC",10,565,130,20
    statictext #w.ttg "G",200,530,60,25
    statictext #w.ttt "time",200,550,100,25
 
    statictext #w.txt "",5,10,370,25  ' just for debug
    statictext #w.sc1 player$(1),380,10,80,25
    statictext #w.sc2 player$(2),715,10,90,25
    graphicbox #w.gsc1, 462,6,116,28
    graphicbox #w.gsc2, 590,6,116,28
    button #w.bck "Undo",[back],UL,MapWidth-130,6,60,27
    button #w.new "New",[new],UL,MapWidth-55,6,60,27
    graphicbox #w.map, 5, 40, MapWidth, MapHeight
    OPEN "    Scrat Crésus... "+space$(15)+date$ for window_nf as #w  'graphics_nf_nsb
    #w "trapclose [quit]"
    #w.bck "!font Comic_Sans_MS 12 bold"
    #w.new "!font Comic_Sans_MS 12 bold"
    #w.txt "!font Courier_New 14 bold"
    #w.sc1 "!font Courier_New 14 bold"
    #w.sc2 "!font Courier_New 14 bold"
    #w.gsc1 "font Courier_New 18 bold"
    #w.gsc2 "font Courier_New 18 bold"
    #w.map "down; font ";ft$;" ; fill ";fcl$
    #w.map "backcolor ";fcl$
    #w.gsc1 "down; backcolor lightgray ; fill lightgray"
    #w.gsc2 "down; backcolor lightgray ; fill lightgray"
 
    loadbmp "pieces", "pieces_V2.bmp"
    loadbmp "scrat1", "Scrat2_60x60Gg.bmp"
    loadbmp "scrat2", "Scrat2_60x60Gg.bmp"
    loadbmp "Sdroi", "Sdroi.bmp"
    loadbmp "Sgau", "Sgau.bmp"
    loadbmp "Shdroi", "Shdroi.bmp"
    loadbmp "Shgau", "Shgau.bmp"
 
    #w.map "getbmp p0 0 0 ";dc;" ";dc  ' empty cell for deleting
    #w.map "drawbmp pieces ";MapWidth-dc-2;" 2"
    for p = 1 to 8
        #w.map "getbmp p";p;" ";MapWidth-dc-2;" ";2+(p-1)*dc;" ";dc;" ";dc  ' make bmps needed
        amount(p) = val(word$("2 1 0.5 0.2 0.1 0.05 0.02 0.01",p))  ' its values
    next
    player = 1
 
    if fileExist(DefaultDir$, "saved.ini") then      ' load the last game...
        #w.map "fill ";fcl$
        open "saved.ini" for input as #gb
        LINE INPUT #gb, score(1)
        LINE INPUT #gb, score(2)
        LINE INPUT #gb, cx
        LINE INPUT #gb, cy
        for y=1 to ncy
            LINE INPUT #gb, load$
            for x=1 to ncx
                mem(x,y)=val(mid$(load$,x,1))  ' for mem(x,y)
            next
        next
        for y=1 to ncy
            LINE INPUT #gb, load$
            for x=1 to ncx
                cell(x,y)=val(mid$(load$,x,1))  ' for cell(x,y)
                #w.map "drawbmp p";cell(x,y);" ";2+(x-1)*dc;" ";(y-1)*dc
            next
        next
        close #gb
        goto [game]
    end if
    fn=0
 
    [new]
    redim score(2)
    #w.map "fill ";fcl$
    for cy=1 to ncy
        for cx=1 to ncx
            cell(cx,cy) = int(rnd(0)*8)+1 : mem(cx,cy) = cell(cx,cy)
            #w.map "drawbmp p";cell(cx,cy);" ";2+(cx-1)*dc;" ";(cy-1)*dc
        next
    next
    cx = 8  'starting Scrat's position
    cy = 5
    cell(cx,cy) = 0
    mem(cx,cy) = 0
    [game]
    gosub [DispScore]
    oldcx = cx
    oldcy = cy
    memo$ = str$(player)+nocell$(cx,cy)
    #w.map "drawbmp scrat1 ";2+(cx-1)*dc;" ";(cy-1)*dc
    #w.map "flush ; discard"
 
    #w.txt "Player = ";player;"  (";player$(player);")"  ' just for debug
    if player = 2 then gosub [computer]
 
    #w.map "when leftButtonDown [play]"    ' x,y cell
   ' #w.map "when mouseMove [infos]"    ' x,y cell
    if fn=0 then fn=1: goto [new]
    wait
 
    [DispScore]
        score.color$(1) = "blue"
        score.color$(2) = "blue"
        if score(1)<score(2) then score.color$(1) = "red"
        if score(1)>score(2) then score.color$(2) = "red"
        #w.gsc1 "fill lightgray ; color ";score.color$(1);" ; place 8 21 ;|";using("##.##",score(1));" ";curs.symbol$
        #w.gsc2 "fill lightgray ; color ";score.color$(2);" ; place 8 21 ;|";using("##.##",score(2));" ";curs.symbol$
        #w.gsc1 "flush ; discard"
        #w.gsc2 "flush ; discard"
    Return
 
    [back]  ' back move (button)
      if len(memo$)>4 then
        bck = 0
        DO
            bck = bck + 1
            cx = X(right$(memo$,3))
            cy = Y(right$(memo$,3))
            player = val(left$(right$(memo$,4),1))
    #w.txt "Player = ";player;"  (";player$(player);")"  ' just for debug
            cell(cx,cy) = mem(cx,cy)
            score(player) = score(player) - amount(cell(cx,cy)) ' re-calc score
            gosub [DispScore]
            #w.map "drawbmp p";cell(cx,cy);" ";2+(cx-1)*dc;" ";(cy-1)*dc  ' restore last
            memo$ = left$(memo$,len(memo$)-4)
            oldcx = X(right$(memo$,3))
            oldcy = Y(right$(memo$,3))
            player = val(left$(right$(memo$,4),1))
    #w.txt "Player = ";player;"  (";player$(player);")"  ' just for debug
            cell(oldcx,oldcy) = 0
            #w.map "drawbmp scrat1 ";2+(oldcx-1)*dc;" ";(oldcy-1)*dc   ' cursor
            #w.map "flush ; discard"
            timer 200, [temp2]
            wait
            [temp2]
            timer 0
        LOOP UNTIL bck = 2 or len(memo$) = 4
        if player = 2 and len(memo$) = 4 then gosub [computer]
      end if
    wait
 
    [play]  ' player game
        cx = int(MouseX/dc)+1 :if cx>ncx then cx=ncx
        cy = int(MouseY/dc)+1 :if cy>ncy then cy=ncy
        if cell(cx,cy)>0 and abs(oldcx-cx)<2 and abs(oldcy-cy)<2 then
            gosub [action]
            player = player + 1 -2 * (player = 2)
    #w.txt "Player = ";player;"  (";player$(player);")"  ' just for debug
            gosub [computer]
    print #w.ttb, "Retour de Computer" '------------------TTB
            if neighbors(cx,cy) = 0 then goto [gloups]  'then  'voisins
               ' select case
              '  case score(1)>score(2) :#w.txt space$(10);player$(1);" WIN." :player = 2
              '  case score(2)>score(1) :#w.txt space$(10);player$(2);" WIN." :player = 1
               ' case else  :#w.txt space$(10);"Egality...!"
               ' end select
           ' end if
            #w.map "flush ; discard"
        end if
 
        if ok$ = "" then goto [gloups]
    wait
 
    [gloups]    '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    print #w.ttg, " GLOUPS"
    #w.map "drawbmp p0 ";2+(oldcx-1)*dc;" ";(oldcy-1)*dc 'efface
   '
   t0=time$("seconds")
  do while t<t0+8
    if f=1 then exit do
    #w.map "drawbmp Sgau ";2+(oldcx-1)*dc;" ";(oldcy-1)*dc'g'
    gosub [pause]
    #w.map "drawbmp Sdroi ";2+(oldcx-1)*dc;" ";(oldcy-1)*dc'dr'
    gosub [pause]
    #w.map "drawbmp Shdroi ";2+(oldcx-1)*dc;" ";(oldcy-1)*dc'hdr'
    gosub [pause]
    #w.map "drawbmp Shgau ";2+(oldcx-1)*dc;" ";(oldcy-1)*dc' hg'
    gosub [pause]
    #w.map "drawbmp Sdroi ";2+(oldcx-1)*dc;" ";(oldcy-1)*dc'hdr
    gosub [pause]
    t=time$("seconds")
     print #w.ttt, t
  loop
    #w.map "flush ; discard"
    #w.map "drawbmp p0 ";2+(oldcx-1)*dc;" ";(oldcy-1)*dc 'efface
    wait
 
    [action]  ' play current cx,cy
    print #w.tta, ""
        #w.map "drawbmp p0 ";2+(oldcx-1)*dc;" ";(oldcy-1)*dc
        if cx-oldcx>0 then
            #w.map "drawbmp scrat2 ";2+(cx-1)*dc;" ";(cy-1)*dc   ' cursor
        else
            #w.map "drawbmp scrat1 ";2+(cx-1)*dc;" ";(cy-1)*dc   ' cursor
        end if
        oldcx = cx
        oldcy = cy
        score(player) = score(player) + amount(cell(cx,cy))
        gosub [DispScore]
        cell(cx,cy) = 0
        memo$ = memo$ + str$(player)+nocell$(cx,cy)  ' record for back
    return
 
    [computer]
    print #w.ttb, ""
        #w.map "when leftButtonDown"    ' x,y cell
       ' #w.map "when mouseMove"    ' x,y cell
        ok$ = Around$(oldcx,oldcy)  'chaine des cellules autour + quelques caractéristiques pour chacune
        if ok$ <> "" then
            h = maxi(ok$)  ' extraction du coup à jouer.
            n$ = mid$(ok$,h*9+1,3)
            cx = X(n$)
            cy = Y(n$)
            timer 500, [temp3]
            wait
            [temp3]
            timer 0
            gosub [action]
            print #w.tta, "retour d'action"  '----------------TTA
        end if
        player = player + 1 -2 * (player = 2)
    #w.txt "Player = ";player;"  (";player$(player);")"  ' just for debug
        #w.map "when leftButtonDown [play]"    ' x,y cell
       ' #w.map "when mouseMove [infos]"    ' x,y cell
    return
 
    function maxi(c$) ' extrait de c$ l'endroit de la case la plus judicieuse
    redim p(8)
    redim vl(8)
    i = int(len(c$)/9)
    WHILE i>0
        lc = instr("0.01 0.02 0.05 0.10 0.20 0.50 1.00 2.00 3.00",mid$(c$,(i-1)*9+5,4))
        vl(i) = int(lc/5)+1
        p(i) = val(mid$(c$,(i-1)*9+4,1))
        if p(i)>0 then p(i)=1
        cf$ = "------"+str$(vl(i))+str$(p(i))+"-" + cf$
        i=i-1
    WEND
    ' trouver le maxi dans la direction la plus bénéfique
    v = 90
    DO
        l = instr(cf$,str$(v))
        if l>0 then maxi = int((l+2)/9)-1 :exit DO
        l = instr(cf$,str$(v+1))
        if l>0 then maxi = int((l+2)/9)-1 :exit DO
        v = v-10
        if v < 70 then
            DO
                l = instr(cf$,str$(v))
                if l>0 then
                    maxi = int((l+2)/9)-1 :stp = 1 :exit DO
                end if
                v = v-10
                if v=0 then v=61
            LOOP UNTIL v=1
            if stp then exit DO
        end if
    LOOP UNTIL v=0 or v=1
    end function
 
    function Around$(x,y)
        redim d(8)
        redim c$(8)
        redim vv(8)
        op = player + 1 -2 * (player = 2)
        for n = 1 to 8
            nx = x + dirX(n)
            ny = y + dirY(n)
            if nx>0 and nx<=ncx and ny>0 and ny<=ncy then
                if cell(nx,ny) > 0 then
                    vv(n) = amount(cell(nx,ny))
                    neibs = neighbors(nx,ny) ' how many neighbors have this cell ?
                    if neibs = 0 then  ' it's a "dead end"
                        if score(player)+vv(n) >= score(op) then
                            ' 3.00 is a value to be sure that this cell will be chosen
                            vv(n) = 3.00 :d(n) = 0 :c$(n) = nocell$(nx,ny) :exit for
                        else
                            vv(n) = 0.01 :d(n) = 8
                        end if
                    else
                        if len(d2$(n)) = 5 then c = 3 else c = 5
                        for n2 = 1 to c
                            nn = val(word$(d2$(n),n2))
                            nnx = nx+dirX(nn)
                            nny = ny+dirY(nn)
                            if nnx>0 and nnx<=ncx and nny>0 and nny<=ncy then
                              ' d(i) = nbre de 1€ ou 2€ qu'il y a dans la direction de cette case
                                if amount(cell(nnx,nny)) > 0.5 then d(n) = d(n) + 1
                            end if
                        next
                    end if
                    c$(n) = nocell$(nx,ny)
                end if
            end if
        next
        WHILE vv(1)+vv(2)+vv(3)+vv(4)+vv(5)+vv(6)+vv(7)+vv(8)>0
            i = int(rnd(0)*8)+1
            if vv(i)>0 then
                Around$ = c$(i)+str$(d(i))+using("#.##",vv(i))+"-"+Around$
                vv(i)=0
            end if
        WEND
    end function
 
    function neighbors(bx,by)  ' nb of neighbors around bx,by
        for n = 1 to 8
            nx = bx + dirX(n)
            ny = by + dirY(n)
            if nx>0 and nx<=ncx and ny>0 and ny<=ncy then
                if cell(nx,ny)>0 then neighbors = neighbors + 1
            end if
        next
    end function
 
    function nocell$(vx,vy)
        nocell$ = right$(str$(100+vx),2)+str$(vy)  '  "xxy"
    end function
 
    function X(nocell$)
        X = val(left$(nocell$,2))
    end function
 
    function Y(nocell$)
        Y = val(right$(nocell$,1))
    end function
 
    [infos]
        cx = int(MouseX/dc)+1 :if cx>ncx then cx=ncx
        cy = int(MouseY/dc)+1 :if cy>ncy then cy=ncy
        #w.txt MouseX;",";MouseY;"  cell(";cx;",";cy;") = ";amount(cell(cx,cy));" ";curs.symbol$
    wait
 
    function fileExist(path$, filename$)
        files path$, filename$, info$()
        fileExist = val(info$(0, 0))
    end function
 
    [quit]
        CONFIRM "QUIT THE GAME ?"; answer$
        if answer$ = "yes" then
            open "saved.ini" for output as #gb   ' save current game
            #gb, score(1)
            #gb, score(2)
            #gb, oldcx
            #gb, oldcy
            for y=1 to ncy
                for x=1 to ncx
                    sav$ = sav$;mem(x,y)
                next
                #gb, sav$ : sav$ = ""
            next
            for y=1 to ncy
                for x=1 to ncx
                    sav$ = sav$;cell(x,y)
                next
                #gb, sav$ : sav$ = ""
            next
            close #gb
            unloadbmp "pieces"
            unloadbmp "scrat1"
            unloadbmp "scrat2"
            unloadbmp "Sdroi"
            unloadbmp "Sgau"
            unloadbmp "Shdroi"
            unloadbmp "Shgau"
            for im = 0 to 8 :unloadbmp "p";im :next
            close #w
            end
        end if
    wait
 
[pause]
        timer 800, [temps]  ' timer du gloups
        wait
        [temps]
        timer 0
return
 
 




Edité par Roland Le 02/07/2012 à 20h38
____________________
Roro

   
Le 02/07/2012 à 18h07

Libertynaute Expert

Groupe: Membre

Inscrit le: 19/02/2011
Messages: 767
Oui, au début j'avais mis l'animation comme toi, mais c'est mon pote de Paris qui m'a dit "pourquoi tu ne mettrais pas cette animation pendant que tu dois jouer, comme si Scrat était impatient ? ce serait plus sympa !"

Je n'ose pas te montrer comment il faudrait faire ta boucle dans [gloups] mais sache qu'il y a au moins 8 lignes de trop et une utilisation de time$("seconds") inutile puisque tu as fait la sub [pause] qui va bien ;)
Pourquoi ne pas mettre goto [gloups] juste après end select ?
Là tu supprimes des fonctionnalités qui n'ont rien à voir avec ton animation !?!?

@+
____________________
Devise Shadocks : "Mieux vaut mobiliser son intelligence pour des conneries, que mobiliser sa connerie pour des choses intelligentes"
Coluche disait : "C'est parce que la vitesse de la lumière est plus rapide que celle du son que certains peuvent paraîtrent brillants jusqu'à ce qu'ils ouvrent la bouche."

Web    
Le 02/07/2012 à 19h43

Administrateur

Groupe: Administrateur

Inscrit le: 04/03/2012
Messages: 2264
Tu a du voir les statictext's en bas. C'est le restant d'une dizaine de tests que j'avais mis dans la version d'avant pour essayer de comprendre ce qui se passait.
Je mets des trucs en trop ? C'est nouveau ça ! ;) ;)
Je vais décortiquer tes douze lignes. Pour le peu que j'en ai vu... c'est encore pas piqué des vers. :heink
Le changement de corps en cours de jeu, je l'ai tenté, pour que ça soit acceptable, il faut diminuer le volume de la queue pour pouvoir augmenter le volume du corps de Scrat maigre. Mais bon, c'est pas trop mal comme ça.
Ton ami de Paris invite le à mettre les mains dans le camboui..Heu..dans les octets...c'est pas si difficile...
Comme tu n'a rien dis des Euros manquants, j'ai ajouté un tour de "new" au premier lancement pour ceux qui auraient le phénomène. ( pc trop ou pas assez rapide ? )



Edité par Roland Le 02/07/2012 à 20h41
____________________
Roro

   
Le 03/07/2012 à 11h44

Libertynaute Expert

Groupe: Membre

Inscrit le: 19/02/2011
Messages: 767
à part dans mon porte-monnaie, je n'ai pas d'€uros manquants. :heink

Efface l'éventuel fichier "saved.ini" puis relance le jeu !?

Sinon dans le genre jeu de grille (tant que je baigne encore dedans), un pote m'a parlé de Boulder Dash sur C64, tu connais ?


-



Edité par cassiope01 Le 03/07/2012 à 11h46
____________________
Devise Shadocks : "Mieux vaut mobiliser son intelligence pour des conneries, que mobiliser sa connerie pour des choses intelligentes"
Coluche disait : "C'est parce que la vitesse de la lumière est plus rapide que celle du son que certains peuvent paraîtrent brillants jusqu'à ce qu'ils ouvrent la bouche."

Web    
Le 03/07/2012 à 13h04

Administrateur

Groupe: Administrateur

Inscrit le: 04/03/2012
Messages: 2264
Non, ça ne me dit rien, je n'ai pas possédé de "Commodore" ( un Atari, mais c'était de l'assembleur).
____________________
Roro

   
Le 04/07/2012 à 08h51

Libertynaute Expert

Groupe: Membre

Inscrit le: 19/02/2011
Messages: 767
Si cela peut t'être utile !?
C'est juste ton [gloups] légèrement optimisé et son appel.
Code VB :
 ....
           if neighbors(cx,cy) = 0 then 'goto [gloups]  'then  'voisins
                select case
                case score(1)>score(2) :#w.txt space$(10);player$(1);" WIN." :player = 2
                case score(2)>score(1) :#w.txt space$(10);player$(2);" WIN." :player = 1
                case else  :#w.txt space$(10);"Egality...!"
                end select
                goto [gloups]
            end if
            #w.map "flush ; discard"
        end if
 
        if ok$ = "" then goto [gloups]
    wait
 
    [gloups]    '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    for sq = 1 to 3
        for bmps = 1 to 5
            bmp$ = word$("Sgau Sdroi Shdroi Shgau Sdroi",bmps)
            #w.map "drawbmp ";bmp$;" ";2+(oldcx-1)*dc;" ";(oldcy-1)*dc
            gosub [pause]
        next
    next
    #w.map "drawbmp p0 ";2+(oldcx-1)*dc;" ";(oldcy-1)*dc 'efface
    #w.map "flush ; discard"
    wait       '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

 




Edité par cassiope01 Le 04/07/2012 à 08h53
____________________
Devise Shadocks : "Mieux vaut mobiliser son intelligence pour des conneries, que mobiliser sa connerie pour des choses intelligentes"
Coluche disait : "C'est parce que la vitesse de la lumière est plus rapide que celle du son que certains peuvent paraîtrent brillants jusqu'à ce qu'ils ouvrent la bouche."

Web    
Le 04/07/2012 à 09h29

Administrateur

Groupe: Administrateur

Inscrit le: 04/03/2012
Messages: 2264
Mais pour sur que je suis preneur :miam ....Remerciements.... :)
......trés bon..( le for seq)... :top



Edité par Roland Le 04/07/2012 à 09h46
____________________
Roro

   

 |  |

1 Utilisateur en ligne : 0 Administrateur, 0 Modérateur, 0 Membre et 1 Visiteur
Utilisateur en ligne : Aucun membre connecté
Répondre
Vous n'êtes pas autorisé à écrire dans cette catégorie