'---------------------------------------------------------------'
' SavedGameDecoder.vbs                                          '
' Version 1.0 - May 21, 2008                                    '
' Written by Christophe Fontanel                                '
'                                                               '
' Please visit The Dungeon Master & Chaos Strikes Back          '
' Encyclopaedia at http://dmweb.free.fr/ for more information   '
'---------------------------------------------------------------'


Option Explicit

Const ForReading = 1
Const ForWriting = 2
Const LITTLE_ENDIAN = 0
Const BIG_ENDIAN = 1

Dim intEndian

' Sections of the saved game file
Dim intInitialWord
Dim arrBlock1(127)
Dim arrBlock2(127)
Dim arrBlock3(63)
Dim arrCreaturesData()
Dim arrChampionData()
Dim arrTimersData()
Dim arrTimersQueue()
Dim strChampionPortraits
Dim strDungeonData

Dim arrScriptArguments
Set arrScriptArguments = WScript.Arguments
If arrScriptArguments.Count = 0 Then
  MsgBox "This tool decrypts saved game files and creates a file for each section of the input saved game file." & vbCrLf & vbCrLf & _
         "Usage example: at a command prompt, type the following command line:" & vbCrLf & _
         "   SavedGameDecoder.vbs CSBSAVE.DAT" & vbCrLf & _
         "You can also drag and drop a saved game file on SavedGameDecoder.vbs in Windows Explorer." & vbCrLf & vbCrLf &  _
         "The decrypted sections of the saved game file will be saved in the saved game's folder.", vbOKOnly + vbInformation, "SavedGameDecoder Help"


Else
  Dim strSourceFileName
  strSourceFileName = arrScriptArguments(0)
  Dim objFileSystemObject
  Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
  If Not objFileSystemObject.FileExists(strSourceFileName) Then
    MsgBox "File not found: " & strSourceFileName, vbOKOnly + vbCritical, "SavedGameDecoder Error"
  Else
    Dim objSourceFile
    Set objSourceFile = objFileSystemObject.GetFile(strSourceFileName)
    Dim intSourceFileSize
    intSourceFileSize = objSourceFile.Size

    Err.Clear
    Set objSourceFile = objFileSystemObject.OpenTextFile(strSourceFileName, ForReading)
    If Err.Number <> 0 Then
      MsgBox "Unable to open file: " & strSourceFileName & vbCrLf & Err.Number & ": " & Err.Description, vbOKOnly + vbCritical, "SavedGameDecoder Error"
    Else
      ProcessFile

      objSourceFile.Close
    End If
  End If
End If


Function ReadWord
  If intEndian = LITTLE_ENDIAN Then
    ReadWord = Asc(objSourceFile.Read(1)) + 256 * Asc(objSourceFile.Read(1))
  Else
    ReadWord = Asc(objSourceFile.Read(1)) * 256 + Asc(objSourceFile.Read(1))
  End If
End Function

Function Decrypt(arrSection, Key)
'msgbox arrSection(0) & vbcrlf & arrSection(1) & vbcrlf & arrSection(126) & vbcrlf & arrSection(127)
  Dim TempValue, i, NumberOfWords
  NumberOfWords = UBound(arrSection) + 1

  TempValue = Key
  Decrypt = Key
  For i = 0 To NumberOfWords - 1
    Decrypt = (Decrypt + arrSection(i)) Mod 65536
    arrSection(i) = arrSection(i) xor TempValue
    Decrypt = (Decrypt + arrSection(i)) Mod 65536
    TempValue = (TempValue + NumberOfWords - i) Mod 65536
  Next
End Function

Function DecodeSavedGame(pblnInitialWord, pintEndian, pintKeyOffset, pintChampionDataSize, pblnDMAppleIIGS)
' This function tries to decode a saved game. It returns true if decoding succeeds or false if it fails.
  DecodeSavedGame = False

  objSourceFile.Close
  Set objSourceFile = objFileSystemObject.OpenTextFile(strSourceFileName, ForReading)

  intEndian = pintEndian

  If pblnInitialWord Then
    intInitialWord = ReadWord
  Else
    intInitialWord = ""
  End If

  Dim i
  For i = 0 To UBound(arrBlock1)
    arrBlock1(i) = ReadWord
  Next
  For i = 0 To UBound(arrBlock2)
    arrBlock2(i) = ReadWord
  Next
  For i = 0 To UBound(arrBlock3)
    arrBlock3(i) = ReadWord
  Next

  ' Compute the Block2 stored checksum based on Block1 content
  Dim intBlock2StoredChecksum
  intBlock2StoredChecksum = 0
  i = 0
  Do
    intBlock2StoredChecksum = (intBlock2StoredChecksum + arrBlock1(i)) Mod 65536
    intBlock2StoredChecksum = intBlock2StoredChecksum Xor arrBlock1(i + 1)
    intBlock2StoredChecksum = (intBlock2StoredChecksum - arrBlock1(i + 2) + 65536) Mod 65536
    intBlock2StoredChecksum = intBlock2StoredChecksum Xor arrBlock1(i + 3)
    i = i + 4
  Loop Until i = 128

  ' Decrypt Block2
  intBlock2ComputedChecksum = Decrypt(arrBlock2, arrBlock1(pintKeyOffset))

  ' The value returned by the Decrypt function is meaningless for Block2,
  ' the Block 2 checksum must be computed using another algorithm
  Dim intBlock2ComputedChecksum
  intBlock2ComputedChecksum = 0
  For i = 0 To 127
    intBlock2ComputedChecksum = (intBlock2ComputedChecksum + arrBlock2(i)) Mod 65536
  Next

  If intBlock2StoredChecksum <> intBlock2ComputedChecksum Then
    'Msgbox "Expected: " & intBlock2StoredChecksum & vbCrLf & "Computed: " & intBlock2ComputedChecksum
    Exit Function
  End If

  ' Decryption keys and Stored checksum values of subsequent blocks are stored at different offsets in DM and CSB
  Dim intBlock3Key, intCreaturesDataKey, intChampionDataKey, intTimersDataKey, intTimersQueueKey
  Dim intBlock3StoredChecksum, intCreaturesDataStoredChecksum, intChampionDataStoredChecksum, intTimersDataStoredChecksum, intTimersQueueStoredChecksum
  If (pintKeyOffset = 29) Then      ' Chaos Strikes Back
    intBlock3Key = arrBlock2(28)
    intCreaturesDataKey = arrBlock2(29)
    intChampionDataKey = arrBlock2(30)
    intTimersDataKey = arrBlock2(31)
    intTimersQueueKey = arrBlock2(32)
    intBlock3StoredChecksum = arrBlock2(44)
    intCreaturesDataStoredChecksum = arrBlock2(45)
    intChampionDataStoredChecksum = arrBlock2(46)
    intTimersDataStoredChecksum = arrBlock2(47)
    intTimersQueueStoredChecksum = arrBlock2(48)
  Else                              ' Dungeon Master
    intBlock3Key = arrBlock2(27)
    intCreaturesDataKey = arrBlock2(28)
    intChampionDataKey = arrBlock2(29)
    intTimersDataKey = arrBlock2(30)
    intTimersQueueKey = arrBlock2(31)
    intBlock3StoredChecksum = arrBlock2(43)
    intCreaturesDataStoredChecksum = arrBlock2(44)
    intChampionDataStoredChecksum = arrBlock2(45)
    intTimersDataStoredChecksum = arrBlock2(46)
    intTimersQueueStoredChecksum = arrBlock2(47)
  End If

  Dim intBlock3ComputedChecksum
  intBlock3ComputedChecksum = Decrypt(arrBlock3, intBlock3Key)
  If intBlock3ComputedChecksum <> intBlock3StoredChecksum Then
    'Msgbox "Expected: " & arrBlock2(27) & vbCrLf & "Computed: " & intBlock3ComputedChecksum
    Exit Function
  End If

  ReDim arrCreaturesData(arrBlock3(23) * 8 - 1)
  For i = 0 To UBound(arrCreaturesData)
    arrCreaturesData(i) = ReadWord
  Next
  Dim intCreaturesDataComputedChecksum
  intCreaturesDataComputedChecksum = Decrypt(arrCreaturesData, intCreaturesDataKey)
  If intCreaturesDataComputedChecksum <> intCreaturesDataStoredChecksum Then
    'Msgbox "Expected: " & arrBlock2(28) & vbCrLf & "Computed: " & intCreaturesDataComputedChecksum
    Exit Function
  End If

  ReDim arrChampionData(pintChampionDataSize / 2 - 1)
  For i = 0 To UBound(arrChampionData)
    arrChampionData(i) = ReadWord
  Next
  Dim intChampionDataComputedChecksum
  intChampionDataComputedChecksum = Decrypt(arrChampionData, intChampionDataKey)
  If intChampionDataComputedChecksum <> intChampionDataStoredChecksum Then
    'Msgbox "Expected: " & arrBlock2(29) & vbCrLf & "Computed: " & intChampionDataComputedChecksum
    Exit Function
  End If

  If pblnDMAppleIIGS Then
    ReDim arrTimersData(3735)
  Else
    ReDim arrTimersData(arrBlock3(14) * 5 - 1)
  End If
  For i = 0 To UBound(arrTimersData)
    arrTimersData(i) = ReadWord
  Next
  Dim intTimersDataComputedChecksum
  intTimersDataComputedChecksum = Decrypt(arrTimersData, intTimersDataKey)
  ' The checksum of the Timers Data section is incorrect in the original MINIG.DAT file from CSB for Amiga Utility Disk German
  ' The following condition detects this specific file and does not perform validation of the checksum in this very specific case.
  If Not ((intTimersDataComputedChecksum = 63854) And _
          (intTimersDataStoredChecksum = 33878) And _
          (pblnInitialWord) And _
          (pintEndian = BIG_ENDIAN) And _
          (pintKeyOffset = 29) And _
          (pintChampionDataSize = 1408)) Then
    If (intTimersDataComputedChecksum <> intTimersDataStoredChecksum) Then
      Msgbox "Expected: " & arrBlock2(30) & vbCrLf & "Computed: " & intTimersDataComputedChecksum
      Exit Function
    End If
  End If

  ReDim arrTimersQueue(arrBlock3(14) - 1)
  For i = 0 To UBound(arrTimersQueue)
    arrTimersQueue(i) = ReadWord
  Next
  Dim intTimersQueueChecksum
  intTimersQueueChecksum = Decrypt(arrTimersQueue, intTimersQueueKey)
  If intTimersQueueChecksum <> intTimersQueueStoredChecksum Then
    'Msgbox "Expected: " & arrBlock2(47) & vbCrLf & "Computed: " & intTimersQueueChecksum
    Exit Function
  End If

  If (pintChampionDataSize = 1404) Or (pintChampionDataSize = 1408) Then
    strChampionPortraits = objSourceFile.Read(4 * 464)
  Else
    strChampionPortraits = ""
  End If

  ' Dungeon Data is stored at the end of the file. Reading enough bytes ensures that all dungeon data is read.
  strDungeonData = objSourceFile.Read(intSourceFileSize)

  DecodeSavedGame = True
End Function

Function ProcessFile
' This function tries to decrypt the saved game file by using all known cases
' until one case succeeds or all cases fail.
  Dim arrParameters
  arrParameters = Array(Array(False, BIG_ENDIAN,    10, 3328, False, "DM Atari ST, DM Amiga 2.0"), _
                        Array(False, BIG_ENDIAN,    10, 1408, False, "DM X68000, DM Amiga 3.6"), _
                        Array(False, LITTLE_ENDIAN, 10, 3324, True,  "DM Apple IIGS"), _
                        Array(False, LITTLE_ENDIAN, 10, 1404, False, "DM PC-9801, DM FM-Towns EN, DM PC 3.4"), _
                        Array(False, BIG_ENDIAN,    29, 3328, False, "CSB Atari ST"), _
                        Array(False, LITTLE_ENDIAN, 29, 1404, False, "CSB PC-9801, CSB FM-Towns"), _
                        Array(False, LITTLE_ENDIAN, 29, 1408, False, "CSB Amiga, CSB X68000"), _
                        Array(False, BIG_ENDIAN,    29, 1408, False, "MINI.DAT CSB Amiga Utility Disk English RX"), _
                        Array(True,  BIG_ENDIAN,    29, 1408, False, "MINI.DAT CSB X68000, CSB Amiga Utility Disk English R1 R2 R3, French, German"))
  Dim blnSuccess, index
  blnSuccess = False
  index = 0
  Do
    blnSuccess = DecodeSavedGame(arrParameters(index)(0), arrParameters(index)(1), arrParameters(index)(2), arrParameters(index)(3), arrParameters(index)(4))
    index = index + 1
  Loop Until (index > UBound(arrParameters)) Or blnSuccess
  If blnSuccess Then
    MsgBox "Successfully decoded using parameters: " & index - 1 & vbCrLf & arrParameters(index - 1)(5)
    ' Write files
    Dim strFileNamePrefix
    strFileNamePrefix = strSourceFileName
    If intInitialWord <> "" Then
      WriteWordsArrayToFile strFileNamePrefix & "-01-InitialWord" & ".bin", Array(intInitialWord)
    End If
    WriteWordsArrayToFile strFileNamePrefix & "-02-Block1" & ".bin", arrBlock1
    WriteWordsArrayToFile strFileNamePrefix & "-03-Block2" & ".bin", arrBlock2
    WriteWordsArrayToFile strFileNamePrefix & "-04-Block3" & ".bin", arrBlock3
    WriteWordsArrayToFile strFileNamePrefix & "-05-CreaturesData" & ".bin", arrCreaturesData
    WriteWordsArrayToFile strFileNamePrefix & "-06-ChampionData" & ".bin", arrChampionData
    WriteWordsArrayToFile strFileNamePrefix & "-07-TimersData" & ".bin", arrTimersData
    WriteWordsArrayToFile strFileNamePrefix & "-08-TimersQueue" & ".bin", arrTimersQueue
    Dim objOutputFile
    Set objOutputFile = objFileSystemObject.OpenTextFile(strFileNamePrefix & "-09-ChampionPortraits" & ".bin", ForWriting, True)
    objOutputFile.Write strChampionPortraits
    objOutputFile.Close
    Set objOutputFile = objFileSystemObject.OpenTextFile(strFileNamePrefix & "-10-DungeonData" & ".bin", ForWriting, True)
    objOutputFile.Write strDungeonData
    objOutputFile.Close
  Else
    MsgBox "Failed to decode file as a saved game file."
  End If
End Function

Sub WriteWordsArrayToFile(pstrFileName, parrWordsArray)
  Dim objOutputFile

  Set objOutputFile = objFileSystemObject.OpenTextFile(pstrFileName, ForWriting, True)

  Dim i, Char1, Char2
  For i = 0 To UBound(parrWordsArray)
    Char1 = Chr((parrWordsArray(i) And &HFF00) \ 256)
    Char2 = Chr(parrWordsArray(i) And &H00FF)

    If intEndian = LITTLE_ENDIAN Then
      objOutputFile.Write Char2 & Char1
    Else
      objOutputFile.Write Char1 & Char2
    End If
  Next

  objOutputFile.Close
End Sub
