XProfan

WindowTitle " H Ä N G M Ä N (deutsch)"
'(CL) Copyleft 2019 by p.specht, Vienna/EU
WindowStyle 24
CLS
font 2
randomize
declare auswahl$,wort$,ok$,bu$,alph$
declare versuche&,hang&,good&,bad&,gelöst&,anz&
'Um Spaß zu erhalten, Absatz nicht lesen!:
auswahl$=upper$(\
"Heizöl,Rückstoss,Dampfschiff,"+\
"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(auswahl$)

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

endwhile

case auswahl$>"":inc anz&

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

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

        endwhile:return spaced$

    endproc

    outerlup:
    CLS
    wort$=Substr$(auswahl$,1+rnd(anz&),",")
    ok$=mkstr$("=",len(wort$))
    alph$="ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜß "
    bad&=0
    nochma:
    locate 3,1
    'print spac(wort$) 'cheat mode für Testzwecke
    print tab(12);spac(ok$)
    locate 6,1:print " Zur Wahl: ";spac(alph$)
    locate 9,1:Print " Welchen Buchstaben vermutest du?:      ";
    locate %csrlin,36:input bu$:bu$=upper$(bu$)
    casenot instr(bu$,alph$):bu$=""
    print "\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$=ins$(bu$,ok$,&Loop)
            good&=1

        endif

    endwhile

    Ifnot good&

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

    else

        sound 1000,100'richtig geraten

    endif

    gelöst&=0

    whileloop len(ok$)

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

    endwhile

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

    IF gelöst&=100'%

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

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

            goto "outerlup"

        else

            Print "\n\n War recht spannend! Tschüss!"
            waitinput 2500
            END

        endif

    ENDIF

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

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

        CLS

    else

        Print "\n\n Na dann: Tschüss!"
        waitinput 3000
        END

    Endif

    goto "outerlup"

    proc hangman :parameters level&

        case level&<=0:return
        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)

                    else:       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:print 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