'===================
'
' NAME: Master.vbs
'
' AUTHOR: Tim en Paul mailto:PvdElst@admail.nl
' (c) 2001
' DATE : 06/10/2001
'
' 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), L(ila), S(ilber)
'
'===================
'
Option Explicit

Dim WshShell
Dim eStr, mCode, iCodes(13), codeFound, teller, DisplayStr
'
Const Enter = 0
Const Play = 1
Const NotFound = 0
Const Found = 1
Const Failed = 2
Set WshShell = Wscript.CreateObject("Wscript.Shell")
'
teller = 1
DisplayStr = "R(ot), O(range), G(rün), B(lau), L(ila), S(ilber)"
'
mCode = ReadCode(Enter)
While teller < 13          ' code must be found within 13 turns
  BuildDisplay NotFound
  iCodes(teller) = ReadCode(Play)
  If iCodes(teller) = mCode Then ' code found?
    BuildDisplay Found
    WshShell.PopUp DisplayStr, , "MasterMind"
    QuitRestart
  End If
  teller = teller + 1
WEnd
BuildDisplay Failed
WshShell.PopUp DisplayStr, , "MasterMind"
QuitRestart
' ------------------
' Support routines
' ------------------
' ==========
Function ReadCode(mode)
'
' read and validate the code
' mode is one 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 = "Gib den zu findenden Code ein."
Else
  cStr = "Such den Farbcode."
End If
  While Not codeOK
    rCode = InputBox(DisplayStr & vbCrLf & eStr & "Gib einen Code ein (C für Computergeneriert):", "MasterMind: " & cStr)
    If rCode = "" Then Wscript.Quit
    eStr = ""
    rCode = Trim(UCase(rCode))
    If Len(rCode) = 4 Then
      codeOK = True
      For i = 1 to 4
        cc = Mid(rCode, i, 1)
        For j = i+1 to 4
          If Mid(rCode, j, 1) = cc Then     ' a color cannot occur more then once in the code
            eStr = "'" & cc & "' ist öfter als einmal in '" & rCode & "'" & vbCrLf
            codeOK = False
            Exit For
          End If
        Next
        If InStr("ROGBLS", cc) = 0 Then
          eStr = "Code may only contain 'ROGBLS'" & vbCrLf
          codeOK = False
          Exit For
        End If
      Next
    Else
      If rCode = "C" Then
        rCode = GenerateCode
        codeOK = True
      Else
        eStr = "'" & rCode & "' ist nicht gleich 4 Zeichen" & vbCrLf
      End If
    End If
  WEnd
ReadCode = rCode
End Function
'
' ==========
Function GenerateCode
'
' Generate a code
'
' ==========
  Dim lCode, i, j, k, gc
  lCode = ""
  Randomize
  While Len(lCode) <> 4
    k = Int((6* Rnd) + 1)
    gc = Mid("ROGBLS", k, 1)
    If InStr(lCode, gc) = 0 Then lCode = lCode & gc
  WEnd
  GenerateCode = lCode
End Function
' ==========
Sub BuildDisplay(status)
'
' Display codes. Status is one of: Found, NotFound or Failed.
'
' ==========
Dim i, whites, blacks
DisplayStr = "R(ot), O(range), G(rün), B(lau), L(ila), S(ilber)" & vbCrLf
DisplayStr = DisplayStr & vbTab & "w = 1 richtige Farbe, falscher Platz" & vbCrLf
DisplayStr = DisplayStr & vbTab & "b = 1 richtige Farbe, richtiger Platz"
  For i = 1 to teller
    If Not iCodes(i) = "" Then
      DisplayStr = DisplayStr & vbCrLf & i & vbTab & iCodes(i) & vbTab
      whites = FindWhites(iCodes(i))
      blacks = FindBlacks(iCodes(i))
      If whites > 0 Then DisplayStr = DisplayStr & Mid("wwww", 1, whites) & vbTab
      If blacks > 0 Then DisplayStr = DisplayStr & Mid("bbbb", 1, blacks)
    End If
  Next
If status = Found Then DisplayStr = DisplayStr & vbTab & "Ja! Code gefunden! Glückwunsch!"
If status = Failed Then DisplayStr = DisplayStr & vbTab & "Schade verloren! Nächstes mal klappt es sicher!" & vbCrLf & "Der Code war:" & mCode
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
    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
Next
FindBlacks = rVal
End Function
'
' ==========
Sub QuitRestart
'
' Quit or Restart Master
'
' ==========
Dim iVal
  iVal = MsgBox("nochmal Spielen?", vbYesNo, "MasterMind")
  If iVal = vbYes Then WshShell.Run "Wscript.exe " & Wscript.ScriptFullName
  Wscript.Quit
End Sub