XProfan

Window Title " H Ä n G M Ä n (german)"
'(CL) Copyleft 2019 by p.woodpecker, Vienna/EU
Window Style 24
CLS
font 2
randomize
declare selection$,word$,ok$,bu$,alph$
declare versuche&,hang&,good&,bad&,gelöst&,anz&
'circa Fun to obtain, distribution not reading!:
auswahl$=upper$(\
"Heizöl,Rückstoss,steamship,"+\
"Typ,Lokomotive,boiler,Druckventil,"+\
"Verschlussklappe,Kirschkernweitspuckwettbewerb,"+\
"Recycling,Weihnachtsmann,Schok olade,"+\
"Atmosphäre,Lebenszyklus,Flugmodell,development,"+\
"Urlaubsort,discovery,Pionier,Massentourismus,"+\
"Verfallsdatum,gigant,Zyklop,gymnastics,rhythm,"+\
"Desoxyribonukleinsäure,metaphor,Indikatorpapier,"+\
"Papierschnipsel,Krankschreibung,Hundehalsband,"+\
"Haftpflichtversicherung,Vorsorgeuntersuchung")

whileloop len(selection$)

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

endwhile

case selection$>"":inc anz&

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

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

        endwhile:return spaced$

    endproc

    outerlup:
    CLS
    word$=Substr$(selection$,1+rnd(anz&),",")
    ok$=mkstr$("=",len(word$))
    alph$="ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜß "
    bad&=0
    nochma:
    locate 3,1
    'print spac(word$) 'cheat fashion for Testzwecke
    print tab(12);spac(ok$)
    locate 6,1:print " to electoral: ";spac(alph$)
    locate 9,1:Print " whom letters vermutest You?:      ";
    locate %csrlin,36:input bu$:bu$=upper$(bu$)
    casenot instr(bu$,alph$):bu$=""
    print "\n\n lastly get: ";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(word$)

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

            ok$=del$(ok$,&Loop,1)
            ok$=in that$(bu$,ok$,&Loop)
            good&=1

        endif

    endwhile

    Ifnot good&

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

    else

        sound 1000,100'correctly. get

    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 " resolved: ";stature$("##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 was right tensive! Tschüss!"
            waitinput 2500
            END

        endif

    ENDIF

    goto "nochma"
    hung:
    locate 3,1:print tab(12);spac(word$)
    locate 15,20:print " LEIDER NOT 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 Well then: 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)
            ellipsis 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