Originallisting auf Englisch mit deutschem Kommentar

'===================
'
' NAME: Master.vbs
'
' AUTHOR: Listing: Tim en Paul  // Komments: Daniela Klein-Harmeyer (c) 2001
' DATE : 06/10/2001 // 04.06.2003
‘
‘Support:
‘ Hotline: 0170 / 86 250 79
‘ E-Mail: service@informatikpower.de
'
' USAGE : wscript.exe <path>master.vbs
'
' COMMENT: Game: mastermind. 2 players, 6 colours, 4 fields
'     Colors: R(ot), O(range), G(rün), B(lau), Y(ellow), P(urple)
'
'===================
'Option Explicit

Dim WshShell
Dim eStr, mCode, iCodes(13), codeFound, zaehler, DisplayStr
'
Const Enter = 0
Const Play = 1
Const NotFound = 0
Const Found = 1
Const Failed = 2
Set WshShell = Wscript.CreateObject("Wscript.Shell")
'
zaehler = 1
DisplayStr = "R(ed), O(range), G(reen), B(lue), Y(ellow), P(urple)"
'
mCode = ReadCode(Enter)	‘ in mCode wird der Wert der Support-    Routine ReadCode(Enter) gespeichert
While zaehler < 13          					' code muss in 12 Versuchen 
  								' gefunden werden
BuildDisplay NotFound	‘generell wird gesagt, der Code wurde nicht gefunden
  iCodes(zaehler) = ReadCode(Play)				‘iCodes(zaehler) = ReadCode(Play)
  If iCodes(zaehler) = mCode Then 				‘ Wurde der Code gefunden?
    BuildDisplay Found 	‘ Dann wird BuildDisplay Found und gefragt, ob nochmal gespielt werden soll
    WshShell.PopUp DisplayStr, , "MasterMind"
    QuitRestart							
  End If
  zaehler = zaehler + 1						‘ der Zähler wird um 1 erhöht
WEnd
BuildDisplay Failed	‘ nach Abbruch der Schleife nach 13 Tipps ist das Spiel verloren. Deswegen wird der „Failed“ – String ausgegeben. Danach wird dann wieder gefragt, ob noch mal gespielt werden soll.
WshShell.PopUp DisplayStr, , "MasterMind"
QuitRestart

' ------------------
' Support routines
' ------------------
' ==========
Function ReadCode(mode)
'
' Code einlesen und schauen, ob er in Ordnung ist
' Möglich ist ein “Mode” of Enter (for enter the code to find) or Play
'
' ==========
Dim rCode, i, j, cc, cStr
Dim CodeOK
codeOK = False

If mode = Enter Then
cStr = "Type the code to be found."	‘ gibt an, was in der Titelzeile steht, 
’ beim Start erstes und im weiteren 
’ Spiel zweiteres (unter else)
Else
  cStr = "Type a code."
End If

While Not codeOK	‘ solange der Code noch nicht OK ist 
’ wird eine Eingabeaufforderung 
’ gezeigt, in der dann gezeigt wird, 
’ was ROGBYP heißt eStr für 
’ Anleitung was man eingeben muss 
’ und der String der drinsteht, ebenso 
’ wird der Titel deklariert

    rCode = InputBox(DisplayStr & vbCrLf & eStr & "Type the Code (C for computer generated code):", "MasterMind: " & cStr)

    If rCode = "" Then Wscript.Quit		‘falls nicht eingegeben wird endet das Script
    eStr = ""					‘ in eStr steht erstmal nichts drin
    rCode = Trim(UCase(rCode))		‘ Trim gibt die Kopie einer Zeichenfolge zurück, ohne
’ vorgestellte oder nachgestellte Leerzeichen
’ UCase gibt eine Zeichenfolge zurück, die in
’ Großbuchstaben umgewandelt wurde

If Len(rCode) = 4 Then	‘hier wird abgefragt, wie lang der eingegebene Code
’ ist, falls er die Länge 4 hat wird codeOK = True 
’ ausgegeben.
      codeOK = True

      For i = 1 to 4				‘ for Schleife die von 1- 4 zählt
        cc = Mid(rCode, i, 1)		‘ in der Variable cc wird jeweils ein Zeichen des 
‘ Codes gespeichert (also Zeichen 1 - 4) der Reihe 
‘ nach

        For j = i+1 to 4				‘ For Schleife, die 2 – 3 – 4 // 3 – 4 // 4 zählt

If Mid(rCode, j, 1) = cc Then     			' hier wird sichergestellt, dass jeder Buchstabe 
    						' (Farbe) nur einmal vorkommt –   
   						'  Beispielprogramm cc.vbs
            eStr = "'" & cc & "' more then once in '" & rCode & "'" & vbCrLf
            codeOK = False

            Exit For

          End If

        Next

If InStr("ROGBYP", cc) = 0 Then			‘ hier werden die einzelnen Werte, die in “cc” 
 							‘ gespeichert wurden mit der Zeichenfolge 
  							‘ „ROGBYP“ abgeglichen. Falls ein anderes 
    							‘ Zeichen z.B. T in cc gespeichert ist gibt InStr 
  							‘ 0 zurück. Dann wird der folgende String  
  							‘ ausgegeben.
          eStr = "Code may only contain 'ROGBYP'" & vbCrLf
          codeOK = False

          Exit For

        End If

      Next

    Else
      If rCode = "C" Then					‘ falls C eingegeben wird wird die 
  							‘ Codeerstellung an „GenerateCode“ 
   							‘ weitergegeben, in dem ein gültiger Code 
   							‘ erstellt wird.
        rCode = GenerateCode
        codeOK = True
      Else
        eStr = "!!! Your Code: '" & rCode & "' is too long, only four letters!!!" & vbCrLf 
    								‘ falls der eingegebene Code länger 
 								‘ ist als 4 Zeichen wird dieser String 
   								‘ ausgegeben
      End If

    End If

  WEnd

ReadCode= rCode		‘ sobald CodeOK = True ausgegeben wird 
’ wird rCode in „Read Code“ gespeichert 
’ (rCode ist der Code, den man eingegeben 
’ hat)
' ==========

End Function

Function GenerateCode
'
' Generate a code
'
' ==========
  Dim lCode, i, j, k, gc
  lCode = ""
  Randomize
  While Len(lCode) <> 4                                                   ’ Während die Länge des Codes 4 über oder
’ unterschreitet
    k = Int((6* Rnd) + 1)  					’ hier wird eine Zufallszahl ermittelt
    gc = Mid("ROGBYP", k, 1) 		’ die hier für das Zeichen steht, welches 
             ’hinterher im Code steht
    If InStr(lCode, gc) = 0 Then lCode = lCode & gc	’ Hier wird geprüft, dass keine Farbe 2 Mal im   
   							’ Code ist und der Code zusammengeführt
  WEnd
  GenerateCode = lCode
End Function

' ==========
Sub BuildDisplay(status)
'
' Display codes. Status is one of: Found, NotFound or Failed.
'
' ==========
Dim i, whites, blacks
DisplayStr = "R(ed), O(range), G(reen), B(lue), Y(ellow), P(urple)" & vbCrLf 	‘ Hier werden die 
‘ vielen
‘ Strings gebündelt
DisplayStr = DisplayStr & vbTab & "w = 1 colorOK, wrong place" & vbCrLf
DisplayStr = DisplayStr & vbTab & "b = 1 colorOK, placeOK"
  For i = 1 to zaehler 								’ for Schleife
    If Not iCodes(i) = "" Then 							’ falls der 
  										’ Eingabestring nicht 
   										’ leer ist
DisplayStr = DisplayStr & vbCrLf & i & vbTab & iCodes(i) & vbTab		‘ wird das obere 
  										’ ausgegeben und 
  										’ zusätzlich der 
   										’ eingegebene Code 
  										’ mit den “b” oder „w“
      whites = FindWhites(iCodes(i))
      blacks = FindBlacks(iCodes(i))
      If whites > 0 Then DisplayStr = DisplayStr & Mid("wwww", 1, whites) & vbTab ‘ hier wird gesagt, 
 										  ’ dass da, wo die 
    										  ’ Bedinungung zutrifft    
    		 								  ’ aus find Blacks / 
    										  ’ Whites wird ein w 
   										  ’ oder b eingetragen
      If blacks > 0 Then DisplayStr = DisplayStr & Mid("bbbb", 1, blacks)
    End If
  Next
If status = Found Then DisplayStr = DisplayStr & vbTab & "Yes! code found!" ‘ hier wird gesagt, was 
 									        ’ ausgegeben wird, falls 
  									        ’ der Code korrekt ist
If status = Failed Then DisplayStr = DisplayStr & vbTab & "Too bad! Better luck next time!" & vbCrLf & "Code was:" & mCode  						‘ dies wird ausgegeben, wenn der 
     								’ Zähler auf 13 steht, zu viele 
  								’ Versuche
End Sub

' ==========
Function FindWhites(lCode)
'
' find 'whites' (correct color, wrong place)
'
' ==========
Dim i, j, cc, rVal
rVal = 0
For i = 1 to 4
  cc = Mid(mCode, i, 1)
  For j = 1 to 4
    If i <> j Then
      If Mid(lCode, j, 1) = cc Then rVal = rVal + 1 		‘ in diesem Programmabschnitt werden die 
’ Codes verglichen und der Zähler erhöht sich ’ je mehr richtige dabei sind. Dies wirkt sich 	‘ auf BuildDisplay aus
    End If
  Next
Next
FindWhites = rVal
End Function

' ==========
Function FindBlacks(lCode)
'
' find 'blacks' (correct color, correct place)
'
' ==========
Dim i, rVal
rVal = 0
For i = 1 to 4
If Mid(mCode, i, 1) = Mid(lCode, i, 1) Then rVal = rVal + 1	‘ in diesem Programmabschnitt 
 								‘ werden die Codes verglichen und 
  								‘ der Zähler erhöht sich je mehr 
  								‘ richtige dabei sind. Dies wirkt sich 
  								‘ auf BuildDisplay aus
Next
FindBlacks = rVal
End Function

' ==========
Sub QuitRestart
'
' Quit or Restart Master
'
' ==========
Dim iVal
iVal = MsgBox("nochmal Spielen?", vbYesNo, "MasterMind")	 ’ Abfrage, ob noch mal gespielt 
’ werden soll
If iVal = vbYes Then WshShell.Run "Wscript.exe " & Wscript.ScriptFullName 	’ falls Ja geclickt wird 
  										’ wird das Script neu 
  										’ gestartet
Wscript.Quit 											 		’ und es wird in jedem 
   					’ Falle beendet
End Sub