XProfan

Título de la ventana " H Ä N G M Ä N (Alemán)"
'(CL) Copyleft 2019 by p.specht, Vienna/EU
Ventana de Estilo 24
CLS
font 2
randomize
declarar auswahl$,wort$,ok$,bu$,alph$
declarar versuche&,hang&,good&,bad&,gelöst&,anz&
'Um Spaß a obtener, Absatz no lesen!:
auswahl$=upper$(\
"Heizöl,Rückstoss,Dampfschiff,"+\
"Typ,Lokomotive,Dampfkessel,Druckventil,"+\
"Verschlussklappe,Kirschkernweitspuckwettbewerb,"+\
"Recycling,Weihnachtsmann,Schok olade,"+\
"Atmosphäre,Lebenszyklus,Flugmodell,Desarrollo,"+\
"Urlaubsort,Entdeckung,Pionier,Massentourismus,"+\
"Verfallsdatum,Riese,Zyklop,Gymnastik,Rhythmus,"+\
"Desoxyribonukleinsäure,Metapher,Indikatorpapier,"+\
"Papierschnipsel,Krankschreibung,Hundehalsband,"+\
"Haftpflichtversicherung,Vorsorgeuntersuchung")

whileloop len(auswahl$)

    caso mid$(auswahl$,&Loop,1)=",":inc anz&

endwhile

caso auswahl$>"":inc anz&

proc spac :parámetros wor$:var spaced$=" "

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

        endwhile:volver spaced$

    ENDPROC

    outerlup:
    CLS
    wort$=Substr$(auswahl$,1+rnd(anz&),",")
    ok$=mkstr$("=",len(wort$))
    alph$="ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜß "
    bad&=0
    nochma:
    locate 3,1
    'imprimir spac(wort$) 'cheat mode para Testzwecke
    imprimir tab(12);spac(ok$)
    locate 6,1:imprimir " A Wahl: ";spac(alph$)
    locate 9,1:Imprimir " Welchen Buchstaben vermutest du?:      ";
    locate %csrlin,36:input bu$:bu$=upper$(bu$)
    casenot instr(bu$,alph$):bu$=""
    imprimir "\n\n Zuletzt geraten: ";bu$

    if 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(wort$)

        if mid$(Wort$,&Loop,1)=bu$

            ok$=del$(ok$,&Loop,1)
            ok$=en el$(bu$,ok$,&Loop)
            good&=1

        endif

    endwhile

    Ifnot good&

        inc bad&
        sound 75,150
        locate 18,1:imprimir " Fehlversuche: ";bad&,
        imprimir ". Noch ";int(13-bad&);if(bad&=12," Intento! "," Versuche!")
        caso HANGMAN(bad&):goto "hung"

    más

        sound 1000,100'correcto geraten

    endif

    gelöst&=0

    whileloop len(ok$)

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

    endwhile

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

    IF gelöst&=100'%

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

        if (ok$="j") or (ok$="y") or (ok$="ja") or (ok$="1") or (ok$="")

            goto "outerlup"

        más

            Imprimir "\n\n War bastante spannend! Tschüss!"
            waitinput 2500
            FIN

        endif

    ENDIF

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

    if (ok$="j") or (ok$="y") or (ok$="ja") or (ok$="1") or (ok$="")

        CLS

    más

        Imprimir "\n\n Na entonces: Tschüss!"
        waitinput 3000
        FIN

    Endif

    goto "outerlup"

    proc hangman :parámetros level&

        caso level&<=0:volver
        var x&=450:var y&=400:var r&=50

        if level&>=1

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

            whileloop 20,160,3

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

                    más:       lineto x&+r&*cos(pi()/180*&Loop),y&-r&*sin(pi()/180*&Loop)

                endif

            endwhile

        endif

        if level&>=2

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

        endif

        if level&>=3

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

        endif

        if level&>=4

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

        endif

        if (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

        if level&>=6

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

        endif

        if 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

        if 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

        if level&>=9

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

        endif

        if level&>=10

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

        endif

        if 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

        if 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

        if 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:imprimir spac(" HANGMAN!")
            sound 100,200:waitinput 200
            sound 100,100:waitinput 100
            sound 100,100:waitinput 100
            sound 100,300:waitinput 400
            volver 1'Hangman-Indikator

        endif

        volver 0

    ENDPROC