XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
RGH-Müllspiel
windowtitle DAS MÜLLSPIEL
windowstyle 10
window 92,10-450,424
declare mx%,my%       Mausposition
declare fx%,fy%       Figurposition
declare px%,py%       neue Müllposition
declare dx%,dy%       Abstände
declare i%,j%         Zählvariablen
declare anz%,vorg%    Anzahl gesammelt/Vorgabe
declare ende%,ok%     Endeschalter, Zug-Ok-Schalter
declare ton%          Sound-Flag
declare scan%         Tastencode
declare tflag%        transparentes Icon?
declare f$,figur$
dim$ 12

PROC SPIELFELD

    case ton%:playsound toccata.wav,1
    list$  1=SSSSSSSSSSSSSS
    list$  2=SBBBBBBBBBBBBS
    list$  3=SBB   BB  GBBS
    list$  4=SBB M BB  MBBS
    list$  5=SBSS  BB    BS
    list$  6=SBB BBBBSSSSBS
    list$  7=SB     S    BS
    list$  8=SB S   S S  BS
    list$  9=SB SBM S BBBBS
    list$ 10=SB BB  S   EBS
    list$ 11=SBBBBBBBBBBBBS
    list$ 12=SSSSSSSSSSSSSS
    i%=12
    j%=14
    cls
    usecursor 2
    vorg%=0
    anz% =0

    while i%

        while j%

            f$=@mid$(@list$(i%),j%,1)
            tflag% = 0

            if @instr(f$,B)

                figur$=BAUM

            elseif @instr(f$, )

                figur$=WEG

            elseif @instr(f$,S)

                figur$=STEIN

            elseif @instr(f$,E)

                figur$=EIMER
                tflag% = 1

            elseif @instr(f$,M)

                figur$=MUELL
                tflag% = 1
                inc vorg%

            elseif @instr(f$,G)

                figur$=GESICHT
                tflag% = 1
                fx%=j%
                fy%=i%

            endif

            dec j%
            case tflag%:drawicon WEG,(j% * 32),((i% - 1) * 32)
            drawicon figur$,(j% * 32),((i% - 1) * 32)

        wend

        j%=14
        dec i%

    wend

    useicon GESICHT
    usecursor 4

ENDPROC

PROC TON

    ton% = 1 - ton%

    if ton%

        checkmenu 190,1

    else

        checkmenu 190,0

    endif

ENDPROC

PROC SPIEL

    ok% = 1
    dx% = mx% - fx%
    dy% = my% - fy%
    px% = dx% + mx%
    py% = dy% + my%
    case @abs(dx%) = @abs(dy%):ok% = 0
    case (@abs(dx%) + @abs(dy%)) > 1:ok% = 0

    ifnot ok%

        case ton%:beep
        messagebox Da gehts nicht lang!,FEHLER!,16
        return

    endif

    f$=@mid$(@list$(my%),mx%,1)
    case @instr(f$,BE):ok% = 0

    if @instr(f$,S)

        case @instr(@mid$(@list$(py%),px%,1),BMES):ok%=0

        if ok%

            case ton%:playsound pop.wav,1
            list$ py% = @del$(@list$(py%),px%,1)
            list$ py% = @ins$(S,@list$(py%),px%)
            list$ my% = @del$(@list$(my%),mx%,1)
            list$ my% = @ins$( ,@list$(my%),mx%)
            drawicon STEIN,((px% - 1) *32),((py% - 1) * 32)
            drawicon WEG,  ((mx% - 1) *32),((my% - 1) * 32)

        endif

    endif

    if @instr(f$,M)

        case @instr(@mid$(@list$(py%),px%,1),BSE):ok%=0

        if ok%

            case ton%:playsound bloop.wav,1
            list$ py% = @del$(@list$(py%),px%,1)
            list$ py% = @ins$(M,@list$(py%),px%)
            list$ my% = @del$(@list$(my%),mx%,1)
            list$ my% = @ins$( ,@list$(my%),mx%)
            drawicon MUELL,((px% - 1) *32),((py% - 1) * 32)
            drawicon WEG,  ((mx% - 1) *32),((my% - 1) * 32)

        endif

        if @instr(@mid$(@list$(py%),px%,1),E)

            ok%=1
            anz%=@add(anz%,1)
            list$ my% = @del$(@list$(my%),mx%,1)
            list$ my% = @ins$( ,@list$(my%),mx%)
            drawicon WEG,  ((mx% - 1) *32),((my% - 1) * 32)
            case ton%:playsound laser.wav,0

        endif

    endif

    ifnot ok%

        case ton%:playsound vault.wav,1
        return

    endif

    drawicon GESICHT,((mx% - 1) *32),((my% - 1) * 32)
    drawicon WEG,    ((fx% - 1) *32),((fy% - 1) * 32)
    i%  = mx%
    mx% = fx%
    fx% = i%
    i%  = my%
    my% = fy%
    fy% = i%

    if @equ(anz%,vorg%)

        copysizedbmp ((fx% - 1) * 32),((fy% - 1) * 32) - 32,32 > 32,32-384,320;0
        case ton%:playsound applaus2.wav,1
        messagebox(Du hast es geschafft!,G E W O N N E N !,48)
        ende%=1

    endif

ENDPROC

PROC ENDE

    case (ton% = 1):BEEP
    case messagebox(Willst Du wirklich aufhören?,SPIELENDE,36) = 6:ende% = 1

ENDPROC

PROC HILFE

    f$ = DAS MÜLLSPIEL
    + Ihre Aufgabe als Parkwächter ist es, den Müll in den
    + bereitstehenden Mülleimer zu schieben. Der direkte Weg
    + wird leider durch Bäume und Steine versperrt. Während
    + die Bäume fest stehen, können die Steine verschoben werden.
    case messagebox(f$,ANLEITUNG 1/3,65) = 2:return
    f$ = Bewegung:
    + Sie können ein Feld waagrecht oder senkrecht laufen,
    + nicht aber diagonal. Klicken Sie mit der Maus auf das
    + Feld, auf das Sie wollen. Liegt dort Müll oder ein Stein,
    + so wird dieser in Laufrichtung weitergeschoben.
    case messagebox(f$,ANLEITUNG 2/3,65) = 2:return
    f$ = Übrige Funktionen:
    + Über den Menüpunkt Ton können Sie den Sound an- und
    + ausschalten. Mit Ende können Sie das Spiel beenden.
    + Das Spiel ist komplett in XProfan geschrieben.
    messagebox(f$,ANLEITUNG 3/3,64)

ENDPROC

popup &Spiel
appendmenu 180,&Neues Spiel
appendmenu 190,&Ton	F2
appendmenu 200,&Ende	F3
popup &Hilfe
appendmenu 210,&Hilfe	F1
appendmenu 220,Über
ton%=1
checkmenu 190,1
SPIELFELD
ende% = 0

whilenot ende%

    waitinput
    mx%=fx%
    my%=fy%

    ifnot %mousekey

        case @scankey(39):inc mx%
        case @scankey(37):dec mx%
        case @scankey(40):inc my%
        case @scankey(38):dec my%

    else

        mx%=(%mousex  32) + 1
        my%=(%mousey  32) + 1

    endif

    case @menuitem(180):SPIELFELD
    case @menuitem(190):TON
    case @menuitem(200):ENDE
    case @menuitem(210):HILFE

    if @or(@menuitem(220),@menuitem(254))

        playsound fanfare.wav,1
        messagebox(© 1992-2003 Roland G. Hülsmann,DAS MÜLLSPIEL - DEMO,48)

    endif

    If (%scankey > 110)

        case @scankey(113):TON
        case @scankey(112):HILFE
        case @scankey(114):ENDE

    Else

        case @menuitem(0):SPIEL

    Endif

Wend

usecursor 0
end