Le jeu du SOLITAIRE

    if Nb_coup = 31 then Bravo()

Nb_coup = Cpt_Sol then Bravo()

rem ============================================================================
rem          Jeu du Solitaire par Papydall modifié par Jicehel
rem                  V2.0 réalisée le 26/01/2015
rem ============================================================================

' ===============================================================================
rem Programme principal
rem ============================================================================

init()

end

rem ============================================================================


'===============================================================================
SUB Init()

rem ============================================================================
    label clic,choix,stopper
rem ============================================================================
    dim n%: ' Choix aléatoire du plateaux
    dim p : ' Numéro du picture cliqué (la case)
    dim w : w = 40 : ' Taille de l'image d'un pion
    dim hi, li :  hi = 100 : li = 600 : ' hauteur et largeur du chronomètre
    dim nbc_max, nbl_max : nbc_max = 15 : nbl_max = 9 : ' nombre de colonnes et de lignes maximales
    dim case$(nbc_max*nbl_max) : ' Etat des cases
    ' 3 états possibles :      - " " => Case impossible (les pions ne peuvent pas y aller)
    '                          - "x" => Case occupée par un pion
    '                          - "." => Il y a un trou
    dim a$,f$,f2$(7) : ' Variable temporaire stockant le nom du fichier sur lequel on travaille
    dim h,l
    dim coup
    dim dep      :  ' La case de départ
    dim arriv    :  ' La case d'arrivée
    dim mang    :  ' Position du pion mangé
    dim Nb_coup  : ' Nombre de coups joués
    dim Nb_col, Nb_l : ' Nombre de lignes e
    dim Sol      : ' Marqueur indiquant si la Solution est renseignée dans la définition du solitaire
    dim T_sol(200,3) : ' Tableau pour stocker la solution (200 coups max ...)
    dim Cpt_Sol  : ' Nombre de coup de la solution

    ' Déclarations des noms des plateaux
    f2$(1)="Solitaire_anglais.txt"
    f2$(2)="diamant.txt"
    f2$(3)="holicron.txt"
    f2$(4)="Le_rectangle.txt"
    f2$(5)="Noeud_papillon.txt"
    f2$(6)="Sphere.txt"
    f2$(7)="S.txt"

rem ============================================================================
    color 0,255,255,255 :  width 0,700 :  height 0,700
    border_small 0 : left 0,(screen_x/2)-(width(0)/2) : top 0,(screen_y/2)-(height(0)/2)

    form 400 : left 400,50 : top 400,10 : width 400,700 : height 400,700 : hide 400
    alpha 500 : parent 500,400 : top 500,height(400)-80 : left 500,50
    font_bold 500 : font_size 500,22 : caption 500," !!! BRAVO !!! TU ES UN CHAMPION !"

    alpha 520 : top 520,10 : left 520, 220 : font_bold 520 : font_size 520,24
    font_color 520, 0,0,255 : caption 520,"Jeu du Solitaire"

    button 550 : top 550,460 : left 550,20 : caption 550,"Nouveau"
    font_bold 550 : font_size 550,16 : width 550,100 : on_click 550,clic : inactive 550

    button 600 : top 600,460 : left 600,140 : caption 600,"Autorun"
    font_bold 600 : font_size 600,16 : width 600,100 : on_click 600,clic : inactive 600

    button 700 : top 700,460 : left 700,260 : caption 700,"Quitter"
    font_bold 700 : font_size 700,16 : width 700,100 : on_click 700,clic

    button 800 : : top 800,460 : left 800,560 : caption 800,"Info"
    font_bold 800 : font_size 800,16 : width 800,100 : on_click 800,clic

    combo 900 : : top 900,460 : left 900,380 : text 900,"Choix Piste"
    font_bold 900 : font_size 900,12 : width 900,160 : on_click 900,choix
    for n%=1 to 7:item_add 900,f2$(n%):next n%

    dll_on "KGF.dll" : f$ = "chronometre.swf" : Flash_In_HTML(f$,0,10,500,li,hi)
END_SUB
rem ============================================================================

choix:
    a$=item_index$(900)
    for n% = 1 to 7
      if a$= f2$(n%) then exit_for
    next n%
    active 550 : set_focus 550 : inactive 900 : Solitaire()
return

' ===============================================================================
' Intégrer un objet Flash dans un objet HTML
' Anim$ est le nom du fichier Flash d'extension SWF
' fo est le numéro du form
' xo,yo coordonnées du coin supérieur gauche
' Larg et Haut sont les dimensions de la fenêtre de vision
rem ============================================================================

SUB Flash_In_HTML(Anim$,fo,xo,yo,larg,haut)
    dim_local  hnd%, res%, url$,q$ ,WB1%
    q$ = chr$(34)
    caption fo,Anim$
    file_open_write 9999,"flash.html"
    file_writeln 9999,"<embed src='"+Anim$+"'"+q$+" width="+q$+str$(larg)+q$+" height="+q$+str$(haut)+q$+">"
    file_close 9999
    hnd% = handle(fo)
    url$ = "file://"+dir_current$+"/flash.html"
    WB1% = dll_call1("WB_Create",hnd%)
    res% = dll_call5("WB_Locate",WB1%,xo,yo,larg+50,haut+50)
    res% = dll_call2("WB_Url",WB1%,adr(url$))
    file_delete "flash.html"
END_SUB
rem ============================================================================

' ===============================================================================
' Solitaire anglais de 33 cases.
' La case 17 est vide

SUB Solitaire()

    dim_local l1, Ligne_lue$, s$, indice, Parcours_Ligne
    text 900,"Choix Piste"
    vider()
    FILE_OPEN_READ 1, "Plateaux\"+f2$(n%)
    FILE_READLN 1, Ligne_lue$ : ' Première ligne: Nb de colonnes; Nb de lignes; Solution disponible
    s$ = right$(left$(Ligne_lue$,4),2) : Nb_col = val(s$) : Ligne_lue$ = right$(Ligne_lue$,len(Ligne_lue$)-5)
    s$ = right$(left$(Ligne_lue$,3),1) : Nb_l = val(s$)  : Ligne_lue$ = right$(Ligne_lue$,len(Ligne_lue$)-4)
    s$ = right$(left$(Ligne_lue$,5),1) : Sol = val(s$)
    FILE_READLN 1, Ligne_lue$
    FILE_READLN 1, Ligne_lue$
    p=1 : l1 = 1
    for Parcours_Ligne= 1 to Nb_l
      FILE_READLN 1, Ligne_lue$
      Ligne_lue$ = right$(Ligne_lue$,len(Ligne_lue$)-2)
      Ligne_lue$ = left$(Ligne_lue$ + string$(Nb_col," "),Nb_col)
      for indice = 1 to Nb_col
          picture p : width p,w : height p,w
          if left$(Ligne_lue$,1)<>" "
            on_click p, clic
            hint p,str$(p)
          end_if
          top p, 10
          top p,10+(w+2)* (l1 + int((9 - Nb_l)/2)) : left p,10+(w+2)*( indice + int((14 - Nb_Col)/2))
          case$(p) = left$(Ligne_lue$,1) : Ligne_lue$ = right$(Ligne_lue$,len(Ligne_lue$)-1)
          p=p+1
      next indice
      l1 = l1+1
    next Parcours_Ligne
    if Sol = 1
          FILE_READLN 1, Ligne_lue$
          FILE_READLN 1, Ligne_lue$
          indice = -1
          while file_eof(1) <> 1
            FILE_READLN 1, Ligne_lue$
            while len(Ligne_lue$) >=4
                indice = indice + 1
                s$ = left$(Ligne_lue$,2) : dep = (val(right$(s$,1))-1) * Nb_col + asc(left$(s$,1)) - asc("a") +1
                Ligne_lue$ = right$(Ligne_lue$,len(Ligne_lue$)-2)
                s$ = left$(Ligne_lue$,2) : arriv = (val(right$(s$,1))-1) * Nb_col + asc(left$(s$,1)) - asc("a") +1
                if len(Ligne_lue$) > 2 then Ligne_lue$ = right$(Ligne_lue$,len(Ligne_lue$)-3)
                if arriv = dep-2 then mang = dep-1
                if arriv = dep+2 then mang = dep+1
                if arriv = dep-2*Nb_col then mang=dep-Nb_col
                if arriv = dep+2*Nb_col then mang=dep+Nb_col
                T_sol(indice,1) = dep : T_sol(indice,2) = mang : T_sol(indice,3) = arriv
            end_while
          end_while
          Cpt_Sol = indice : active 600
    end_if
    FILE_CLOSE 1
    if object_exists(250) = 0 then picture 250 :  parent 250, 400 : width 250,width(400)-50 : height 250,height(400)-50
    file_load 250,"bravo.bmp"
    coup = 0 : Nb_coup = 0 : caption 0,""
    for indice = 1 to Nb_col * Nb_l
      if case$(indice) = "x" then file_load indice,"sphere.bmp"
      if case$(indice) = "." then file_load indice,"pion.bmp"
    next indice
    active 900
END_SUB
rem ============================================================================

' ===============================================================================
clic:
  p = number_click
  if p = 550 then Solitaire() : return
  if p = 600 then Autorun() : return
  if p = 700 then Quitter() : return
  if p = 800 then info() : return
  if coup = 0 and case$(p) = "." then return
  Decode_Clic(p)
return
rem ============================================================================

' ===============================================================================
SUB Decode_Clic(p)

    if case$(p) = "x"
          if coup = 1 then file_load dep,"sphere.bmp"
          dep = p : brightness p,50 : coup = 1
          exit_sub
    end_if

    arriv = p  :' case d'arrivée
    if dep = arriv then exit_sub
    mang = 0
    if arriv = dep-2 then mang = dep-1
    if arriv = dep+2 then mang = dep+1
    if arriv = dep-2*Nb_col then mang=dep-Nb_col
    if arriv = dep+2*Nb_col then mang=dep+Nb_col
    if mang > 0 then Jouer_Le_Coup(arriv,dep,mang)
END_SUB

rem ============================================================================

' ===============================================================================
SUB Jouer_Le_Coup(arriv,dep,mang)
    if case$(mang) = "x"
 '  occuper l'arrivée
      file_load arriv,"sphere.bmp"
      case$(arriv) = "x"
 '  Libérer le départ
      file_load dep,"pion.bmp"
      case$(dep) = "."
 '  Manger le pion
      file_load mang,"pion.bmp"
      case$(mang) = "."
      Nb_coup = Nb_coup + 1
      caption 0,"Nombre de coups joués : " + str$(Nb_coup)
      coup = 0
    end_if
    if Nb_coup = Cpt_Sol then Bravo()
END_SUB
rem ============================================================================

' ===============================================================================
SUB Info()
    dim_local t$
    t$ = " Le solitaire est un jeu de tablier." + chr$(13)
    t$ = t$ + " Il s'agit ici du solitaire anglais en forme de croix grecque à 33 trous." + chr$(13)
    t$ = t$ + " Au départ tous les trous contienent une bille (ou pion ou boule) à l'exception" + chr$(13)
    t$ = t$ + "du trou central qui est vide." + chr$(13)
    t$ = t$ + "Le but du jeu est de 'manger' toutes les pièces pour ne conserver qu'une seule." + chr$(13)
    t$ = t$ + "Pour supprimer une pièce, il faut que 2 pièces soient adjacentes et qu'elles" + chr$(13)
    t$ = t$ + "soient suivies d'une case vide." + chr$(13)
    t$ = t$ + "La 1ère pièce saute par-dessus la seconde pour rejoindre la case vide." + chr$(13)
    t$ = t$ + "La seconde pièce est alors retirée du tablier." + chr$(13)
    t$ = t$ + "Les sauts ne peuvent se faire qu'horizontalement ou verticalement et non en diagonale " + chr$(13)
    t$ = t$ + "------------------------------------------------------------------------------" + chr$(13)
    t$ = t$ + "Pour jouer, utilisez votre souris." + chr$(13)
    t$ = t$ + "Cliquez d'abord sur la boule à déplacer, puis sur la case d'arrivée qui doit" + chr$(13)
    t$ = t$ + "être nécessairement vide, en sautant par dessus une case contenant une boule."+chr$(13)
    t$ = t$ + "------------------------------------------------------------------------------" + chr$(13)
    t$ = t$ + "Vous pouvez démarrer/arrêter le chronomètre à l'aide des boutons adéquats" + chr$(13)+chr$(13)
    t$ = t$ + "************* B O N    D I V E R T I S S E M E N T ***********************"
    message t$
END_SUB
rem ============================================================================

' ===============================================================================
' Régler le volume du haut-parleur
SUB Bravo()
    dim_local q$
    q$ = chr$(34)
    show 400
    if file_exists("bravo.vbs")= 0
      file_open_write 9999,"bravo.vbs"
      file_writeln 9999,"Dim speaks, speech"
      file_writeln 9999,"speaks="+q$+"Bravo.... Tu es un champion !!!"+q$
      file_writeln 9999,"Set speech=CreateObject("+q$+"sapi.spvoice"+q$+")"
      file_writeln 9999,"speech.Speak speaks"
      file_close 9999
      pause 500
    end_if
    if file_exists("bravo.vbs")=1 then execute_wait "bravo.vbs"
    pause 1500 : hide 400

END_SUB
rem ============================================================================

' ===============================================================================
stopper:
  inactive 600 :  Nb_coup = Cpt_Sol
return
rem ====================================================================

' ===============================================================================
SUB Quitter()
    dim_local termine%
    if message_confirmation_yes_no("Vous voulez vraiment quitter ?") = 1
      termine% = dll_call1("KillProcessByHandle",handle(0))
    end_if
END_SUB
rem ============================================================================

' ===============================================================================
SUB Autorun()
    dim_local depart, arrivee, mange
    solitaire() :  Desactiver()
    inactive 700 : inactive 600 : inactive 550 : inactive 800
    caption 600,"Arréter" : on_click 600,stopper : active 600
    while Nb_coup <= Cpt_Sol
        brightness T_sol(Nb_coup,1),50: wait 300
        file_load T_sol(Nb_coup,1),"pion.bmp"  : ' effacer
        file_load T_sol(Nb_coup,3),"sphere.bmp" : ' deplacer
        file_load T_sol(Nb_coup,2),  "pion.bmp"  : ' manger
        brightness T_sol(Nb_coup,3),50: wait 300
        file_load T_sol(Nb_coup,3),"sphere.bmp" : ' remettre normal
        Nb_coup = Nb_coup + 1 : wait 300
      caption 0,"Nombre de coups joués : " + str$(Nb_coup)
    pause 800
    end_while
    active 700 : active 550 : active 800  : inactive 600
    caption 600,"Autorun" : : on_click 600,clic
    pause 500
END_SUB
rem ============================================================================

' ===============================================================================
SUB Vider()
    dim_local  indice, Parcours_Ligne
    p=1
    for Parcours_Ligne= 1 to Nbl_max
      for indice = 1 to Nbc_max
          if object_exists(p) = 1 then delete p
          p=p+1
      next indice
    next Parcours_Ligne
END_SUB
rem ============================================================================

' ===============================================================================
SUB Desactiver()
    dim_local  indice, Parcours_Ligne
    p=1
    for Parcours_Ligne= 1 to Nbl_max
      for indice = 1 to Nbc_max
          if object_exists(p) = 1 then inactive p
          p=p+1
      next indice
    next Parcours_Ligne
END_SUB
rem ============================================================================