XProfan

Titre de la fenêtre " H Ä N G M Ä N (allemande)"
'(CL) Copyleft 2019 by p.specht, Vienna/EU
Fenêtre Style 24
CLS
font 2
randomize
declare sélection$,mot$,ok$,bu$,alph$
declare versuche&,hang&,good&,bad&,gelöst&,anz&
'Um Amusement trop conservé, paragraphe pas lesen!:
auswahl$=upper$(\
"Heizöl,Rückstoss,bateau à vapeur,"+\
"Typ,Lokomotive,Dampfkessel,Druckventil,"+\
"Verschlussklappe,Kirschkernweitspuckwettbewerb,"+\
"Recycling,Weihnachtsmann,Schok olade,"+\
"Atmosphäre,Lebenszyklus,Flugmodell,Entwicklung,"+\
"Urlaubsort,Entdeckung,Pionier,Massentourismus,"+\
"Verfallsdatum,Riese,Zyklop,Gymnastik,Rhythmus,"+\
"Desoxyribonukleinsäure,Metapher,Indikatorpapier,"+\
"Papierschnipsel,Krankschreibung,Hundehalsband,"+\
"Haftpflichtversicherung,Vorsorgeuntersuchung")

whileloop len(sélection$)

    cas mid$(sélection$,&Boucle,1)=»:inc anz&

endwhile

cas sélection$>»:inc anz&

proc spac :parameters wor$:var spaced$=" "

    whileloop len(wor$):spaced$=spaced$+mid$(wor$,&Boucle,1)+" "

        endwhile:return spaced$

    endproc

    outerlup:
    CLS
    mot$=Substr$(sélection$,1+rnd(anz&),»)
    ok$=mkstr$("=",len(mot$))
    alph$="ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜß "
    bad&=0
    nochma:
    locate 3,1
    'imprimer spac(mot$) 'cheat mode pour Testzwecke
    imprimer tab(12);spac(ok$)
    locate 6,1:imprimer " Zur l'élection: ";spac(alph$)
    locate 9,1:Imprimer " Welchen Buchstaben vermutest du?:      ";
    locate %csrlin,36:input bu$:bu$=upper$(bu$)
    casenot instr(bu$,alph$):bu$=»
    imprimer "\n\n Zuletzt geraten: ";bu$

    si bu$>»

        alph$=left$(alph$,instr(bu$,alph$)-1)+" "+\
        mid$(alph$,instr(bu$,alph$)+1,len(alph$)-instr(bu$,alph$)+1)

    endif

    good&=0

    whileloop len(mot$)

        si mid$(mot$,&Boucle,1)=bu$

            ok$=del$(ok$,&Boucle,1)
            ok$=ins$(bu$,ok$,&Boucle)
            good&=1

        endif

    endwhile

    Ifnot good&

        inc bad&
        sound 75,150
        locate 18,1:imprimer " Fehlversuche: ";bad&,
        imprimer ". encore ";int(13-bad&);si(bad&=12," Versuch! "," Versuche!")
        cas HANGMAN(bad&):goto "hung"

    d'autre

        sound 1000,100'richtig geraten

    endif

    gelöst&=0

    whileloop len(ok$)

        cas mid$(ok$,&loop,1)<>"=":inc gelöst&

    endwhile

    gelöst&= gelöst&/len(ok$) * 100
    locate 15,1:imprimer " Gelöst: ";format$("##0",gelöst&);" %"

    IF gelöst&=100'%

        locate 3,1:imprimer tab(12);spac(ok$)
        locate 15,20:imprimer " BRAVO, RECHTZEITIG GELÖST !"
        sound 500,100:sound 580,100:sound 700,100:sound 1000,200
        waitinput 1000
        locate 23,1:imprimer " NOCHMAL ? ";:input ok$

        si (ok$="j") or (ok$="y") or (ok$="ja") or (ok$="1") or (ok$=»)

            goto "outerlup"

        d'autre

            Imprimer "\n\n était droite spannend! Tschüss!"
            waitinput 2500
            FIN

        endif

    ENDIF

    goto "nochma"
    hung:
    locate 3,1:imprimer tab(12);spac(mot$)
    locate 15,20:imprimer " LEIDER NICHT ERRATEN! "
    waitinput 1000
    locate 23,1:imprimer " NOCHMAL ? ";:input ok$

    si (ok$="j") or (ok$="y") or (ok$="ja") or (ok$="1") or (ok$=»)

        CLS

    d'autre

        Imprimer "\n\n Na ensuite: Tschüss!"
        waitinput 3000
        FIN

    Endif

    goto "outerlup"

    proc hangman :parameters level&

        cas level&<=0:return
        var x&=450:var y&=400:var r&=50

        si level&>=1

            usepen 0,5,rgb(0,0,200)

            whileloop 20,160,3

                si &Boucle=20:moveto x&+r&*cos(pi()/180*&Boucle),y&-r&*sin(pi()/180*&Boucle)

                    d'autre:       lineto x&+r&*cos(pi()/180*&Boucle),y&-r&*sin(pi()/180*&Boucle)

                endif

            endwhile

        endif

        si level&>=2

            usepen 0,5,rgb(0,0,200)
            line x&,(y&-r&) - x&,y&-4*r&

        endif

        si level&>=3

            usepen 0,5,rgb(0,0,200)
            line x&,(y&-4*r&) - x&+2.5*r&,y&-4*r&

        endif

        si level&>=4

            usepen 0,5,rgb(0,0,200)
            line x&,(y&-3*r&) - x&+r&,y&-4*r&

        endif

        si (level&>=5) and (level&<>13)

            usepen 0,5,rgb(0,0,200)
            line x&+1.5*r&,(y&-r&) - x&+2.5*r&,y&-r&
            line x&+1.5*r&,(y&-r&) - x&+1.5*r&,y&-r&/2
            line x&+2.5*r&,(y&-r&) - x&+2.5*r&,y&-r&/2

        endif

        si level&>=6

            usepen 0,3,rgb(0,0,200)
            line x&+2*r&,(y&-3*r&) - x&+2*r&,y&-4*r&

        endif

        si level&>=7

            usepen 0,3,rgb(0,0,200)
            ellipse x&+1.8*r&,(y&-2.5*r&) - x&+2.2*r&,y&-3*r&

        endif

        si level&>=8

            usepen 0,3,rgb(0,0,200)
            line x&+2*r&,(y&-2.5*r&) - x&+2*r&,y&-1.8*r&

        endif

        si level&>=9

            usepen 0,3,rgb(0,0,200)
            line x&+2*r&,(y&-1.8*r&) - x&+1.7*r&,y&-r&

        endif

        si level&>=10

            usepen 0,3,rgb(0,0,200)
            line x&+2*r&,(y&-1.8*r&) - x&+2.3*r&,y&-r&

        endif

        si level&>=11

            usepen 0,3,rgb(0,0,200)
            line x&+2*r&,(y&-2.2*r&) - x&+1.7*r&,y&-1.7*r&

        endif

        si level&>=12

            usepen 0,3,rgb(0,0,200)
            line x&+2*r&,(y&-2.2*r&) - x&+2.3*r&,y&-1.7*r&

        endif

        si level&>=13

            usepen 0,5,rgb(255,255,255)
            line x&+1.5*r&,(y&-r&) - x&+2.5*r&,y&-r&
            line x&+1.5*r&,(y&-r&) - x&+1.5*r&,y&-r&/2
            line x&+2.5*r&,(y&-r&) - x&+2.5*r&,y&-r&/2
            locate 15,1:imprimer spac(" HANGMAN!")
            sound 100,200:waitinput 200
            sound 100,100:waitinput 100
            sound 100,100:waitinput 100
            sound 100,300:waitinput 400
            return 1'Hangman-Indikator

        endif

        return 0

    endproc