VERSION 5.00 Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx" Begin VB.Form Form1 AutoRedraw = -1 'True Caption = "Form1" ClientHeight = 7080 ClientLeft = 60 ClientTop = 345 ClientWidth = 11610 KeyPreview = -1 'True LinkTopic = "Form1" ScaleHeight = 7080 ScaleWidth = 11610 StartUpPosition = 3 'Windows Default Begin MSComDlg.CommonDialog CommonDialog1 Left = 5580 Top = 3300 _ExtentX = 847 _ExtentY = 847 _Version = 393216 End Begin VB.PictureBox Picture1 Appearance = 0 'Flat AutoRedraw = -1 'True BackColor = &H00800000& BeginProperty Font Name = "Times New Roman" Size = 9.75 Charset = 162 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00FFC0C0& Height = 6525 Left = 0 ScaleHeight = 6495 ScaleWidth = 11535 TabIndex = 1 Top = 0 Width = 11565 End Begin VB.CommandButton Command1 Caption = "Run Game" Height = 525 Left = 60 TabIndex = 0 Top = 6540 Width = 1245 End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private DebugOn As Boolean Private StoryDic As New zDictionary Private fso As New FileSystemObject Private ts As TextStream Private PropertyDefaults() As Long Private OutPutStream(4) As Boolean Private ExpectingInput As Boolean Private RoutineOffset As Long Private StringOffset As Long Private OriginalStory As String Public InputStream As String Private ObjectCache(1024) As New zObject Private Output3Tables(16) As Long Private Output3CharCount(16) As Long Private Output3Pointer As Integer Enum OpCodes '2OP Codes zJE = 1 zJL = 2 zJG = 3 zDEC_CHK = 4 zINC_CHK = 5 zJIN = 6 zTEST = 7 zOR = 8 zAND = 9 zTEST_ATTR = 10 zSET_ATTR = 11 zCLEAR_ATTR = 12 zSTORE = 13 zINSERT_OBJ = 14 zLOADW = 15 zLOADB = 16 zGET_PROP = 17 zGET_PROP_ADDR = 18 zGET_NEXT_PROP = 19 zADD = 20 zSUB = 21 zMUL = 22 zDIV = 23 zMOD = 24 zCALL_2S = 25 zCALL_2N = 26 zSET_COLOUR = 27 zTHROW = 28 '1OP Codes zJZ = 0 zGET_SIBLING = 1 zGET_CHILD = 2 zGET_PARENT = 3 zGET_PROP_LEN = 4 zINC = 5 zDEC = 6 zPRINT_ADDR = 7 zCALL_1S = 8 zREMOVE_OBJ = 9 zPRINT_OBJ = 10 zRET = 11 zJUMP = 12 zPRINT_PADDR = 13 zLOAD = 14 zNOT = 15 zCALL_1N = 15 '0OP Codes zRTRUE = 0 zRFALSE = 1 zPRINTLIT = 2 zPRINT_RET = 3 zNOP = 4 zSAVE = 5 zRESTORE = 6 zRESTART = 7 zRET_POPPED = 8 zPOP = 9 zCATCH = 9 zQUIT = 10 zNEW_LINE = 11 zSHOW_STATUS = 12 zVERIFY = 13 zPIRACY = 15 'VAR Opcodes zCALL = 0 zCALL_VS = 0 zSTOREW = 1 zSTOREB = 2 zPUT_PROP = 3 zSREAD = 4 zAREAD = 4 zPRINT_CHAR = 5 zPRINT_NUM = 6 zRANDOM = 7 zPUSH = 8 zPULL = 9 zSPLIT_WINDOW = 10 zSET_WINDOW = 11 zCALL_VS2 = 12 zERASE_WINDOW = 13 zERASE_LINE = 14 zSET_CURSOR = 15 zGET_CURSOR = 16 zSET_TEXT_STYLE = 17 zBUFFER_MODE = 18 zOUTPUT_STREAM = 19 zINPUT_STREAM = 20 zSOUND_EFFECT = 21 zREAD_CHAR = 22 zSCAN_TABLE = 23 zNOT_VAR = 24 zCALL_VN = 25 zCALL_VN2 = 26 zTOKENISE = 27 zENCODE_TEXT = 28 zCOPY_TABLE = 29 zPRINT_TABLE = 30 zCHECK_ARG_COUNT = 31 'EXT OpCodes zSAVE_EXT = 0 zRESTORE_EXT = 1 zLOG_SHIFT = 2 zART_SHIFT = 3 zSET_FONT = 4 zDRAW_PICTURE = 5 zPICTURE_DATA = 6 zERASE_PICTURE = 7 zSET_MARGINS = 8 zSAVE_UNDO = 9 zRESTORE_UNDO = 10 zPRINT_UNICODE = 11 zCHECK_UNICODE = 12 zMOVE_WINDOW = 16 zWINDOW_SIZE = 17 zWINDOW_STYLE = 18 zGET_WIND_PROP = 19 zSCROLL_WINDOW = 20 zPOP_STACK = 21 zREAD_MOUSE = 22 zMOUSE_WINDOW = 23 zPUSH_STACK = 24 zPUT_WIND_PROP = 25 zPRINT_FORM = 26 zMAKE_MENU = 27 zPICTURE_TABLE = 28 End Enum Enum OpCodeTypes z0OP = 0 z1OP = 1 z2OP = 2 zvar = 3 zEXT = 4 End Enum Enum OperandTypes zSmallConstant = 1 zLargeConstant = 0 zvariable = 2 zNoOperand = 3 End Enum Private Type ZChar zA As Byte zB As Byte End Type Private Type ZString zCh(10000) As Byte Length As Long End Type Dim zBuffer As ZString Dim Ver As Integer Dim alp(2) As String Dim Abb(96) As String Dim Story() As Byte Dim StoryLoaded As Boolean Private RoutineCounter As Long Private Stack(1024) As Long 'Private Globals(255) As Long Private StackPointer As Integer Private Routines(90) As zRoutine Private RoutinePointer As Integer Public PC As Long Public CurrentRoutine As zRoutine Private scr As New zScreen Private Sub Command1_Click() Dim i As Integer Dim sz As String Dim zInstr As New zInstruction Dim zob As zObject Command1.Enabled = False DoEvents Me.Width = Screen.Width * 0.8 Me.Height = Screen.Height * 0.8 Me.Picture1.Width = Me.Width - Me.Picture1.Left Me.Picture1.Height = Me.Height - 3 * Me.Picture1.Top - Me.Command1.Height Me.Command1.Top = Me.Height - Me.Command1.Height Me.Left = (Screen.Width - Me.Width) / 2 Me.Top = (Screen.Height - Me.Height) / 2 scr.hdc = Me.Picture1.hdc scr.hWnd = Me.Picture1.hWnd Me.Picture1.ScaleMode = 3 scr.ScreenHeight = Me.Picture1.ScaleHeight - 5 scr.ScreenWidth = Me.Picture1.ScaleWidth - 5 Me.Picture1.ScaleMode = 1 scr.EraseWindow -1 CommonDialog1.ShowOpen If CommonDialog1.FileName <> "" Then OriginalStory = CommonDialog1.FileName StoryLoaded = LoadStory(Story(), OriginalStory) End If SetByte Story(), 33, scr.ScreenWidth \ scr.CharWidth SetByte Story(), 32, scr.ScreenHeight \ scr.CharHeight SetByte Story(), 39, scr.CharHeight SetByte Story(), 38, scr.CharWidth scr.BufferMode 1 Select Case Ver Case 1 To 3 scr.SplitWindow 1 SetByte Story(), 1, (GetByte(Story(), 1) And 135) Or 96 Case 4 To 8 SetByte Story(), 1, 253 End Select If StoryLoaded Then 'DebugOn = True If DebugOn Then Set ts = fso.CreateTextFile(App.Path & "\allroadsdump.txt", True) DebugOn = False OutPutStream(1) = True Set Routines(RoutinePointer) = New zRoutine Set CurrentRoutine = Routines(RoutinePointer) If Ver = 6 Then PerformCall PackAddr(GetWord(Story(), 6, True), True), 0, -1, 0, Output3CharCount() Else PC = GetWord(Story(), 6, True) End If Set zInstr = GetInstruction(Story(), PC) Do While RunInstruction(zInstr) = 1 Set zInstr = GetInstruction(Story(), PC) Loop End If For i = 1 To 1024 Set ObjectCache(i) = New zObject Next Command1.Enabled = True ts.Close DoEvents End Sub Private Function zRanslate(ach() As Byte, Optional Offset As Long) 'As ZString 'On Error GoTo handler Dim EOS As Boolean Dim zA As Byte Dim zB As Byte Dim i As Long Dim zcounter As Long For i = Offset To UBound(ach) - 1 Step 2 zA = ach(i) zB = ach(i + 1) EOS = ((zA And 128) = 128) zBuffer.zCh(zcounter) = (zA And 124) \ 4 zBuffer.zCh(zcounter + 2) = zB And 31 zBuffer.zCh(zcounter + 1) = ((zA And 3) * 8) + (zB And 224) \ 32 zcounter = zcounter + 3 If EOS Then zBuffer.Length = zcounter Exit Function End If Next Exit Function handler: If MsgBox("Runtime Error: " & Err.Number & vbCrLf & Err.Description, vbExclamation + vbOKCancel) = vbCancel Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext End Function Private Function ZPrint(zs As ZString) As String ' On Error GoTo handler Dim alph As Byte Dim abbr As Byte Dim cnt As Long Dim shift As Byte Dim shiftlock As Byte Dim i As Long Dim t As Byte For i = 0 To zs.Length - 1 t = zs.zCh(i) Select Case t Case 0 ZPrint = ZPrint + " " Case 1 If Ver = 1 Then ZPrint = ZPrint + vbCrLf Else i = i + 1 ZPrint = ZPrint + Abb(zs.zCh(i)) End If Case 2 To 3 Select Case Ver Case 1 To 2 shift = t - 1 Case 3 To 9 i = i + 1 ZPrint = ZPrint + Abb(32 * (t - 1) + zs.zCh(i)) End Select Case 4 To 5 Select Case Ver Case 1 To 2 shiftlock = t - 3 Case 3 To 9 shift = t - 3 End Select Case 6 To 31 alph = (alph + 3 + shift) Mod 3 alph = (alph + 3 + shiftlock) Mod 3 shiftlock = 0 If alph = 2 And t = 6 Then ZPrint = ZPrint + Chr(32 * zs.zCh(i + 1) + zs.zCh(i + 2)) i = i + 2 Else If Mid(alp(alph), t - 5, 1) = "^" Then ZPrint = ZPrint + vbCrLf Else ZPrint = ZPrint + Mid(alp(alph), t - 5, 1) End If End If alph = (alph + 3 - shift) Mod 3 shift = 0 End Select Next Exit Function handler: If MsgBox("Runtime Error: " & Err.Number & vbCrLf & Err.Description, vbExclamation + vbOKCancel) = vbCancel Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext End Function Private Function LoadAbbrev() Dim tmp As String Dim TableStart As Long Dim i As Long Dim AbbCount As Integer TableStart = GetWord(Story(), 24) If Ver > 2 Then AbbCount = 95 Else AbbCount = 31 For i = 0 To AbbCount Abb(i) = PrintZString(Story(), 2 * GetWord(Story(), TableStart + i * 2, True)) Next End Function Private Function GetInstruction(ach() As Byte, ByVal Address As Long) As zInstruction Dim i As Integer Dim fm As Byte Dim opcount As Byte Set GetInstruction = New zInstruction GetInstruction.Address = Address If (ach(Address) And 128) = 128 Then If (ach(Address) And 64) = 64 Then 'Variable Form GetInstruction.OpCode = ach(Address) And 31 If (ach(Address) And 32) = 32 Then GetInstruction.OpCodeType = zvar Else GetInstruction.OpCodeType = z2OP Address = Address + 1 GetInstruction.OperandCount = 0 GetInstruction.SetOperandCount (0) For i = 7 To 1 Step -2 If ((2 ^ i + 2 ^ (i - 1)) And ach(Address)) = (2 ^ i + 2 ^ (i - 1)) Then Exit For GetInstruction.OperandCount = 1 + GetInstruction.OperandCount GetInstruction.SetOperandCount GetInstruction.OperandCount, True Select Case ((2 ^ i + 2 ^ (i - 1)) And ach(Address)) Case 0 GetInstruction.OperandType(GetInstruction.OperandCount) = zLargeConstant Case 2 ^ (i - 1) GetInstruction.OperandType(GetInstruction.OperandCount) = zSmallConstant Case 2 ^ i GetInstruction.OperandType(GetInstruction.OperandCount) = zvariable End Select Next If GetInstruction.OpCodeType = zvar And (GetInstruction.OpCode = zCALL_VN2 Or GetInstruction.OpCode = zCALL_VS2) Then Address = Address + 1 For i = 7 To 1 Step -2 If ((2 ^ i + 2 ^ (i - 1)) And ach(Address)) = (2 ^ i + 2 ^ (i - 1)) Then Exit For GetInstruction.OperandCount = 1 + GetInstruction.OperandCount GetInstruction.SetOperandCount GetInstruction.OperandCount, True Select Case ((2 ^ i + 2 ^ (i - 1)) And ach(Address)) Case 0 GetInstruction.OperandType(GetInstruction.OperandCount) = zLargeConstant Case 2 ^ (i - 1) GetInstruction.OperandType(GetInstruction.OperandCount) = zSmallConstant Case 2 ^ i GetInstruction.OperandType(GetInstruction.OperandCount) = zvariable End Select Next End If For i = 1 To GetInstruction.OperandCount Address = Address + 1 Select Case GetInstruction.OperandType(i) Case zLargeConstant GetInstruction.Operand(i) = GetWord(ach(), Address) Address = Address + 1 Case Else GetInstruction.Operand(i) = ach(Address) End Select Next Else 'Short Form GetInstruction.OpCode = ach(Address) And 15 Select Case ach(Address) And 240 Case 128 GetInstruction.OperandCount = 1 GetInstruction.OpCodeType = z1OP GetInstruction.SetOperandCount (1) GetInstruction.Operand(1) = GetWord(ach(), Address + 1, True) GetInstruction.OperandType(1) = zLargeConstant Address = Address + 2 Case 144 GetInstruction.OperandCount = 1 GetInstruction.OpCodeType = z1OP GetInstruction.SetOperandCount (1) GetInstruction.Operand(1) = ach(Address + 1) GetInstruction.OperandType(1) = zSmallConstant Address = Address + 1 Case 160 GetInstruction.OperandCount = 1 GetInstruction.OpCodeType = z1OP GetInstruction.SetOperandCount (1) GetInstruction.Operand(1) = ach(Address + 1) GetInstruction.OperandType(1) = zvariable Address = Address + 1 Case 176 If ach(Address) <> 190 Then GetInstruction.OperandCount = 0 GetInstruction.OpCodeType = z0OP GetInstruction.SetOperandCount (0) Else 'Extended form GetInstruction.OpCodeType = zEXT GetInstruction.OpCode = ach(Address + 1) Address = Address + 2 GetInstruction.OperandCount = 0 GetInstruction.SetOperandCount (0) For i = 7 To 1 Step -2 If ((2 ^ i + 2 ^ (i - 1)) And ach(Address)) = (2 ^ i + 2 ^ (i - 1)) Then Exit For GetInstruction.OperandCount = 1 + GetInstruction.OperandCount GetInstruction.SetOperandCount GetInstruction.OperandCount, True Select Case ((2 ^ i + 2 ^ (i - 1)) And ach(Address)) Case 0 GetInstruction.OperandType(GetInstruction.OperandCount) = zLargeConstant Case 2 ^ (i - 1) GetInstruction.OperandType(GetInstruction.OperandCount) = zSmallConstant Case 2 ^ i GetInstruction.OperandType(GetInstruction.OperandCount) = zvariable End Select Next For i = 1 To GetInstruction.OperandCount Address = Address + 1 Select Case GetInstruction.OperandType(i) Case zLargeConstant GetInstruction.Operand(i) = GetWord(ach(), Address, True) Address = Address + 1 Case Else GetInstruction.Operand(i) = ach(Address) End Select Next End If End Select End If Else 'Long form GetInstruction.OpCodeType = z2OP GetInstruction.OperandCount = 2 GetInstruction.OpCode = ach(Address) And 31 GetInstruction.SetOperandCount (2) GetInstruction.Operand(1) = ach(Address + 1) GetInstruction.Operand(2) = ach(Address + 2) Select Case ach(Address) And 96 Case 0 GetInstruction.OperandType(1) = zSmallConstant GetInstruction.OperandType(2) = zSmallConstant Case 32 GetInstruction.OperandType(1) = zSmallConstant GetInstruction.OperandType(2) = zvariable Case 64 GetInstruction.OperandType(1) = zvariable GetInstruction.OperandType(2) = zSmallConstant Case 96 GetInstruction.OperandType(1) = zvariable GetInstruction.OperandType(2) = zvariable End Select Address = Address + 2 End If If HasStore(GetInstruction.OpCodeType, GetInstruction.OpCode) Then Address = Address + 1 GetInstruction.Store = ach(Address) End If If HasBranch(GetInstruction.OpCodeType, GetInstruction.OpCode) Then Address = Address + 1 If (ach(Address) And 128) = 128 Then GetInstruction.BranchCond = True If (ach(Address) And 64) = 64 Then GetInstruction.Branch = Address + (ach(Address) And 63) - 1 If GetInstruction.Branch <= Address Then GetInstruction.Branch = ach(Address) And 63 Else GetInstruction.Branch = 256 * (ach(Address) And 63) + ach(Address + 1) If (GetInstruction.Branch And 8192) = 8192 Then GetInstruction.Branch = (GetInstruction.Branch And 8191) - 8192 GetInstruction.Branch = Address + GetInstruction.Branch Address = Address + 1 End If End If If GetInstruction.OpCodeType = z0OP And (GetInstruction.OpCode = zPRINTLIT Or GetInstruction.OpCode = zPRINT_RET) Then GetInstruction.Text = PrintZString(ach(), Address + 1) zRanslate ach(), Address + 1 Address = Address + zBuffer.Length * 2 / 3 End If GetInstruction.NextInstr = Address + 1 End Function Public Function PrintZString(Story() As Byte, Offset As Long) As String zRanslate Story(), Offset PrintZString = ZPrint(zBuffer) End Function Public Function LoadStory(StoryArray() As Byte, FileName As String) As Boolean 'On Error GoTo handler Dim fso As New FileSystemObject Dim ts As TextStream Dim Counter As Long Dim i As Integer Dim c As Long Dim a As String Dim proptablelen As Byte Set ts = fso.OpenTextFile(FileName, ForReading, False) ReDim StoryArray(fso.GetFile(FileName).Size) Open FileName For Binary As 1 Get 1, , StoryArray Close 1 'Do Until ts.AtEndOfStream 'a = ts.ReadAll 'StoryArray(Counter) = Asc(ts.Read(1)) 'SetByte StoryArray(), Counter, Asc(ts.Read(1)) 'Counter = Counter + 1 'Loop Ver = GetByte(StoryArray(), 0) c = GetWord(StoryArray(), 52) If Ver > 4 And c <> 0 Then alp(0) = Space(26) alp(1) = Space(26) alp(2) = Space(26) For i = 0 To 77 Mid(alp(i \ 26), 1 + (i Mod 26), 1) = Chr(GetByte(StoryArray(), c + i)) Next Mid(alp(2), 1, 2) = "~^" Else alp(0) = "abcdefghijklmnopqrstuvwxyz" alp(1) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" If Ver = 1 Then alp(2) = "~0123456789.,!?_#'" & Chr(34) & "/\<-:()" Else alp(2) = "~^0123456789.,!?_#'" & Chr(34) & "/\-:()" End If End If RoutineOffset = GetWord(StoryArray(), 40, True) StringOffset = GetWord(StoryArray(), 42, True) StoryDic.LoadDictionary StoryArray(), GetWord(StoryArray(), 8, True) LoadAbbrev Select Case Ver Case 1 To 3 proptablelen = 62 Case 4 To 6 proptablelen = 126 End Select LoadStory = True Exit Function handler: If MsgBox("Runtime Error: " & Err.Number & vbCrLf & Err.Description, vbExclamation + vbOKCancel) = vbCancel Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext End Function Public Function HasStore(typ As OpCodeTypes, opcod As OpCodes) As Boolean Select Case typ Case z2OP If opcod = zOR Or opcod = zAND Or opcod = zLOADW Or opcod = zLOADB Or opcod = zGET_PROP Or opcod = zGET_PROP_ADDR Or opcod = zGET_NEXT_PROP Or opcod = zADD Or opcod = zSUB Or opcod = zMUL Or opcod = zDIV Or opcod = zMOD Or opcod = zCALL_2S Then HasStore = True: Exit Function Case z1OP If opcod = zGET_CHILD Or opcod = zGET_PARENT Or opcod = zGET_SIBLING Or opcod = zGET_PROP_LEN Or opcod = zCALL_1S Or opcod = zLOAD Or (opcod = zNOT And Ver < 5) Then HasStore = True: Exit Function Case z0OP If opcod = zCATCH Then HasStore = True: Exit Function Case zvar If opcod = zCALL Or (opcod = zAREAD And Ver > 4) Or opcod = zRANDOM Or (opcod = zPULL And Ver = 6) Or opcod = zCALL_VS2 Or opcod = zREAD_CHAR Or opcod = zSCAN_TABLE Or opcod = zNOT_VAR Then HasStore = True: Exit Function Case zEXT If opcod < 5 Or opcod = zSAVE_EXT Or opcod = zRESTORE_EXT Or opcod = zGET_WIND_PROP Or opcod = zSAVE_UNDO Then HasStore = True: Exit Function End Select End Function Public Function HasBranch(typ As OpCodeTypes, opcod As OpCodes) As Boolean Dim Lookup As String Lookup = "012345678901234567890123456789012" Select Case typ Case z2OP Lookup = "X9999999XX9XXXXXXXXXXXXXXXXXXXXX" If Mid(Lookup, opcod + 1, 1) <> "X" And Val(Mid(Lookup, opcod + 1, 1)) > Ver Then HasBranch = True: Exit Function Case z1OP Lookup = "999XXXXXXXXXXXXXX" If Mid(Lookup, opcod + 1, 1) <> "X" And Val(Mid(Lookup, opcod + 1, 1)) > Ver Then HasBranch = True: Exit Function Case z0OP Lookup = "XXXXX4XX4XXXXX9X9" If Mid(Lookup, opcod + 1, 1) <> "X" And Val(Mid(Lookup, opcod + 1, 1)) > Ver Then HasBranch = True: Exit Function Case zvar Lookup = "XXXXXXXXXXXXXXXXXXXXXXX9XXXXXXX9" If Mid(Lookup, opcod + 1, 1) <> "X" And Val(Mid(Lookup, opcod + 1, 1)) > Ver Then HasBranch = True: Exit Function Case zEXT Lookup = "XXXXXX9XXXXXXXXXXXXXXXXX9XX9XXXX" If Mid(Lookup, opcod + 1, 1) <> "X" And Val(Mid(Lookup, opcod + 1, 1)) > Ver Then HasBranch = True: Exit Function End Select End Function Public Function RunInstruction(zinst As zInstruction) As Integer Dim opname As String Dim statedump As String Dim tmpstr As String Dim tmp(12) As Long Dim tmpobj As zObject Dim tmpobj2 As zObject Dim Operand(8) As Long Dim OpType(8) As OperandTypes If DebugOn Then For tmp(1) = 255 To 16 Step -1 If Globals(tmp(1)) <> 0 Then statedump = " G" & HexVal(tmp(1) - 16) & ":" & HexVal(Globals(tmp(1))) & statedump Next For tmp(1) = CurrentRoutine.LocalCount To 1 Step -1 statedump = " L" & HexVal(tmp(1) - 1) & ":" & HexVal(CurrentRoutine.Locals(tmp(1))) & statedump Next statedump = " SP:" & HexVal(Stack(StackPointer)) & statedump End If Select Case zinst.OpCodeType Case z1OP Operand(1) = zinst.Operand(1) OpType(1) = zinst.OperandType(1) Select Case zinst.OpCode Case zJZ opname = "JZ" tmp(1) = GetValue(OpType(1), Operand(1)) Branch tmp(1) = 0, zinst Case zGET_SIBLING opname = "GET_SIBLING" tmp(1) = GetValue(OpType(1), Operand(1), , True) Set tmpobj = GetObject(tmp(1)) SetValue zinst.Store, tmpobj.Sibling Branch tmpobj.Sibling <> 0, zinst Case zGET_CHILD opname = "GET_CHILD" tmp(1) = GetValue(OpType(1), Operand(1), , True) Set tmpobj = GetObject(tmp(1)) SetValue zinst.Store, tmpobj.Child Branch tmpobj.Child <> 0, zinst Case zGET_PARENT opname = "GET_PARENT" tmp(1) = GetValue(OpType(1), Operand(1), , True) Set tmpobj = GetObject(tmp(1)) SetValue zinst.Store, tmpobj.Parent PC = zinst.NextInstr Case zGET_PROP_LEN opname = "GET_PROP_LEN" tmp(1) = GetValue(OpType(1), Operand(1), , True) If tmp(1) = 0 Then SetValue zinst.Store, 0 Else tmp(2) = GetByte(Story(), tmp(1) - 1) Select Case Ver Case 1 To 3 SetValue zinst.Store, (tmp(2) \ 32) + 1 Case 4 To 9 If (tmp(2) And 128) = 128 Then tmp(2) = tmp(2) Mod 64 If tmp(2) = 0 Then tmp(2) = 64 SetValue zinst.Store, tmp(2) Else If (tmp(2) And 64) = 64 Then SetValue zinst.Store, 2 Else SetValue zinst.Store, 1 End If End If End Select End If PC = zinst.NextInstr Case zINC opname = "INC" tmp(1) = GetValue(2, Operand(1), True) SetValue Operand(1), tmp(1) + 1, True PC = zinst.NextInstr Case zDEC opname = "INC" tmp(1) = GetValue(2, Operand(1), True) SetValue Operand(1), tmp(1) - 1, True PC = zinst.NextInstr Case zPRINT_ADDR opname = "PRINT_ADDR" tmp(1) = GetValue(OpType(1), Operand(1), , True) OutPut PrintZString(Story(), tmp(1)) PC = zinst.NextInstr Case zCALL_1S tmp(1) = PackAddr(GetValue(OpType(1), Operand(1), , True), True) opname = "CALL_1S" PerformCall tmp(1), zinst.NextInstr, zinst.Store, 0, tmp() Case zREMOVE_OBJ opname = "REMOVE_OBJ" tmp(1) = GetValue(OpType(1), Operand(1), , True) PerformRemove tmp(1) PC = zinst.NextInstr Case zPRINT_OBJ opname = "PRINT_OBJ" tmp(1) = GetValue(OpType(1), Operand(1), , True) Set tmpobj = GetObject(tmp(1)) OutPut tmpobj.ShortName PC = zinst.NextInstr Case zRET opname = "RET" tmp(1) = GetValue(OpType(1), Operand(1)) PerformReturn tmp(1) Case zJUMP opname = "JUMP" tmp(1) = GetValue(OpType(1), Operand(1)) PC = zinst.NextInstr + tmp(1) - 2 Case zPRINT_PADDR opname = "PRINT_PADDR" tmp(1) = GetValue(OpType(1), Operand(1), , True) OutPut PrintZString(Story(), PackAddr(tmp(1), False)) PC = zinst.NextInstr Case zLOAD opname = "LOAD" tmp(1) = GetValue(2, Operand(1), True) SetValue zinst.Store, tmp(1), True PC = zinst.NextInstr Case zNOT If Ver < 5 Then opname = "NOT" tmp(1) = GetValue(OpType(1), Operand(1), , True) SetValue zinst.Store, Not tmp(1) PC = zinst.NextInstr Else tmp(1) = PackAddr(GetValue(OpType(1), Operand(1), , True), True) opname = "CALL_1N" PerformCall tmp(1), zinst.NextInstr, -1, 0, tmp() End If End Select Case z0OP Select Case zinst.OpCode Case zRTRUE opname = "RTRUE" PerformReturn 1 Case zRFALSE opname = "RFALSE" PerformReturn 0 Case zPRINTLIT opname = "PRINTLIT" OutPut zinst.Text PC = zinst.NextInstr Case zPRINT_RET opname = "PRINT_RET" OutPut zinst.Text OutPut vbCrLf PerformReturn 1 Case zNOP opname = "NOP" PC = zinst.NextInstr Case zSAVE opname = "SAVE" SaveState PC = zinst.NextInstr Case zRESTORE opname = "RESTORE" RestoreState Case zRESTART opname = "RESTART" Restart Case zRET_POPPED opname = "RET_POPPED" tmp(1) = GetValue(2, 0) PerformReturn tmp(1) Case zPOP opname = "POP" GetValue 2, 0 PC = zinst.NextInstr Case zCATCH opname = "CATCH" SetValue zinst.Store, RoutinePointer PC = zinst.NextInstr Case zQUIT opname = "QUIT" PrintInstr zinst, opname, statedump Exit Function Case zNEW_LINE opname = "NEW_LINE" OutPut vbCrLf PC = zinst.NextInstr Case zSHOW_STATUS opname = "SHOW_STATUS" ShowStatus PC = zinst.NextInstr Case zVERIFY opname = "VERIFY" Branch Verify, zinst Case zPIRACY opname = "PIRACY" Branch True, zinst End Select Case zEXT Select Case zinst.OpCode Case zLOG_SHIFT opname = "LOG_SHIFT" tmp(1) = GetValue(OpType(1), Operand(1)) tmp(2) = GetValue(OpType(2), Operand(2)) For tmp(3) = tmp(2) To -1 tmp(1) = tmp(1) \ 2 tmp(1) = tmp(1) And 32767 Next For tmp(3) = 1 To tmp(2) tmp(1) = tmp(1) * 2 Next SetValue zinst.Store, tmp(1) PC = zinst.NextInstr Case zART_SHIFT opname = "ART_SHIFT" tmp(1) = GetValue(OpType(1), Operand(1)) tmp(2) = GetValue(OpType(2), Operand(2)) For tmp(3) = tmp(2) To -1 tmp(1) = tmp(1) \ 2 Next For tmp(3) = 1 To tmp(2) tmp(1) = tmp(1) * 2 Next SetValue zinst.Store, tmp(1) PC = zinst.NextInstr Case zSAVE_UNDO opname = "SAVE_UNDO" SetValue zinst.Store, -1 PC = zinst.NextInstr Case Else If MsgBox("EXT opcodes not yet implemented! Continue?", vbCritical + vbYesNo) = vbYes Then PC = zinst.NextInstr Else Exit Function End If End Select Case z2OP For tmp(1) = 1 To zinst.OperandCount OpType(tmp(1)) = zinst.OperandType(tmp(1)) Operand(tmp(1)) = zinst.Operand(tmp(1)) Next Select Case zinst.OpCode Case zJE opname = "JE" tmp(1) = 0 For tmp(2) = 1 To zinst.OperandCount tmp(tmp(2) + 2) = GetValue(OpType(tmp(2)), Operand(tmp(2))) Next For tmp(2) = 2 To zinst.OperandCount tmp(1) = (tmp(1) Or (tmp(3) = tmp(tmp(2) + 2))) Next Branch CBool(tmp(1)), zinst Case zJL opname = "JL" tmp(1) = GetValue(OpType(1), Operand(1)) tmp(2) = GetValue(OpType(2), Operand(2)) Branch tmp(1) < tmp(2), zinst Case zJG opname = "JG" tmp(1) = GetValue(OpType(1), Operand(1)) tmp(2) = GetValue(OpType(2), Operand(2)) Branch tmp(1) > tmp(2), zinst Case zDEC_CHK opname = "DEC_CHK" tmp(1) = GetValue(2, Operand(1), True) tmp(2) = GetValue(OpType(2), Operand(2)) SetValue Operand(1), tmp(1) - 1, True Branch tmp(1) - 1 < tmp(2), zinst Case zINC_CHK opname = "INC_CHK" tmp(1) = GetValue(2, Operand(1), True) tmp(2) = GetValue(OpType(2), Operand(2)) SetValue Operand(1), tmp(1) + 1, True Branch tmp(1) + 1 > tmp(2), zinst Case zJIN opname = "JIN" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) Set tmpobj = GetObject(tmp(1)) Branch tmpobj.Parent = tmp(2), zinst Case zTEST opname = "TEST" tmp(1) = GetValue(OpType(1), Operand(1)) tmp(2) = GetValue(OpType(2), Operand(2)) Branch tmp(2) = (tmp(1) And tmp(2)), zinst Case zOR opname = "OR" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) SetValue zinst.Store, tmp(1) Or tmp(2) PC = zinst.NextInstr Case zAND opname = "AND" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) SetValue zinst.Store, tmp(1) And tmp(2) PC = zinst.NextInstr Case zTEST_ATTR opname = "TEST_ATTR" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) Set tmpobj = GetObject(tmp(1)) Branch tmpobj.GetAttribute(tmp(2)), zinst Case zSET_ATTR opname = "SET_ATTR" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) Set tmpobj = GetObject(tmp(1)) tmpobj.SetAttribute tmp(2) tmpobj.WriteObject Story() PC = zinst.NextInstr Case zCLEAR_ATTR opname = "CLEAR_ATTR" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) Set tmpobj = GetObject(tmp(1)) tmpobj.ClearAttribute tmp(2) tmpobj.WriteObject Story() PC = zinst.NextInstr Case zSTORE opname = "STORE" tmp(1) = GetValue(OpType(2), Operand(2), , True) SetValue Operand(1), tmp(1), True PC = zinst.NextInstr Case zINSERT_OBJ opname = "INSERT_OBJ" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) PerformInsert tmp(1), tmp(2) PC = zinst.NextInstr Case zLOADW opname = "LOADW" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) SetValue zinst.Store, GetWord(Story(), tmp(1) + 2 * tmp(2)) PC = zinst.NextInstr Case zLOADB opname = "LOADB" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) SetValue zinst.Store, Story(tmp(1) + tmp(2)) PC = zinst.NextInstr Case zGET_PROP opname = "GET_PROP" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) Set tmpobj = GetObject(tmp(1)) SetValue zinst.Store, tmpobj.Prop(tmp(2)) PC = zinst.NextInstr Case zGET_PROP_ADDR opname = "GET_PROP_ADDR" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) Set tmpobj = GetObject(tmp(1)) SetValue zinst.Store, tmpobj.PropAddr((tmp(2))) PC = zinst.NextInstr Case zGET_NEXT_PROP opname = "GET_NEXT_PROP" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) Set tmpobj = GetObject(tmp(1)) SetValue zinst.Store, tmpobj.NextProp(tmp(2)) PC = zinst.NextInstr Case zADD opname = "ADD" tmp(1) = GetValue(OpType(1), Operand(1)) tmp(2) = GetValue(OpType(2), Operand(2)) SetValue zinst.Store, tmp(1) + tmp(2) PC = zinst.NextInstr Case zSUB opname = "SUB" tmp(1) = GetValue(OpType(1), Operand(1)) tmp(2) = GetValue(OpType(2), Operand(2)) SetValue zinst.Store, tmp(1) - tmp(2) PC = zinst.NextInstr Case zMUL opname = "MUL" tmp(1) = GetValue(OpType(1), Operand(1)) tmp(2) = GetValue(OpType(2), Operand(2)) SetValue zinst.Store, tmp(1) * tmp(2) PC = zinst.NextInstr Case zDIV opname = "DIV" tmp(1) = GetValue(OpType(1), Operand(1)) tmp(2) = GetValue(OpType(2), Operand(2)) SetValue zinst.Store, tmp(1) \ tmp(2) PC = zinst.NextInstr Case zMOD opname = "MOD" tmp(1) = GetValue(OpType(1), Operand(1)) tmp(2) = GetValue(OpType(2), Operand(2)) SetValue zinst.Store, tmp(1) Mod tmp(2) PC = zinst.NextInstr Case zCALL_2S opname = "CALL_2S" tmp(2) = PackAddr(GetValue(OpType(1), Operand(1), , True), True) tmp(1) = GetValue(OpType(2), Operand(2)) PerformCall tmp(2), zinst.NextInstr, zinst.Store, 1, tmp() Case zCALL_2N opname = "CALL_2N" tmp(2) = PackAddr(GetValue(OpType(1), Operand(1), , True), True) tmp(1) = GetValue(OpType(2), Operand(2)) PerformCall tmp(2), zinst.NextInstr, -1, 1, tmp() Case zSET_COLOUR opname = "SET_COLOUR" tmp(1) = GetValue(OpType(1), Operand(1)) tmp(2) = GetValue(OpType(2), Operand(2)) scr.SetColor tmp(1), tmp(2) PC = zinst.NextInstr Case zTHROW opname = "THROW" MsgBox "Please Implement THROW!" PC = zinst.NextInstr End Select Case zvar For tmp(1) = 1 To zinst.OperandCount Operand(tmp(1)) = zinst.Operand(tmp(1)) OpType(tmp(1)) = zinst.OperandType(tmp(1)) Next Select Case zinst.OpCode Case zCALL_VS opname = "CALL_VS" tmp(zinst.OperandCount) = GetValue(OpType(1), Operand(1), , True) For tmp(zinst.OperandCount + 1) = 2 To zinst.OperandCount tmp(tmp(zinst.OperandCount + 1) - 1) = GetValue(OpType(tmp(zinst.OperandCount + 1)), Operand(tmp(zinst.OperandCount + 1))) Next PerformCall PackAddr(tmp(zinst.OperandCount)), zinst.NextInstr, zinst.Store, zinst.OperandCount - 1, tmp() Case zSTOREW opname = "STOREW" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) tmp(3) = GetValue(OpType(3), Operand(3)) SetWord Story(), tmp(1) + 2 * tmp(2), tmp(3) If tmp(1) + 2 * tmp(2) = 16 Then If (tmp(3) And 2) = 2 Then scr.SetTextStyle 8 Else scr.SetTextStyle scr.GetTextStyle And 7 End If End If PC = zinst.NextInstr Case zSTOREB opname = "STOREB" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) tmp(3) = GetValue(OpType(3), Operand(3)) SetByte Story(), tmp(1) + tmp(2), tmp(3) PC = zinst.NextInstr Case zPUT_PROP opname = "PUT_PROP" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) tmp(3) = GetValue(OpType(3), Operand(3)) Set tmpobj = GetObject(tmp(1)) tmpobj.Prop(tmp(2)) = tmp(3) tmpobj.WriteObject Story() PC = zinst.NextInstr Case zSREAD opname = "READ" 'DebugOn = True tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) If zinst.OperandCount > 2 Then tmp(3) = GetValue(OpType(3), Operand(3), , True) tmp(4) = GetValue(OpType(4), Operand(4), , True) PerformRead tmp(1), tmp(2), tmp(3), tmp(4) Else PerformRead tmp(1), tmp(2) End If If Ver > 4 Then SetValue zinst.Store, 13 PC = zinst.NextInstr Case zPRINT_CHAR opname = "PRINT_CHAR" tmp(1) = GetValue(OpType(1), Operand(1)) OutPut Chr(tmp(1)) PC = zinst.NextInstr Case zPRINT_NUM opname = "PRINT_NUM" tmp(1) = GetValue(OpType(1), Operand(1)) OutPut CStr(tmp(1)) PC = zinst.NextInstr Case zRANDOM opname = "RANDOM" tmp(1) = GetValue(OpType(1), Operand(1)) If tmp(1) < 0 Then Rnd tmp(1) Randomize tmp(1) SetValue zinst.Store, 0 ElseIf tmp(1) = 0 Then Randomize Timer SetValue zinst.Store, 0 Else SetValue zinst.Store, Int(Rnd * tmp(1)) + 1 End If PC = zinst.NextInstr Case zPUSH opname = "PUSH" tmp(1) = GetValue(OpType(1), Operand(1)) SetValue 0, tmp(1) PC = zinst.NextInstr Case zPULL opname = "PULL" If Ver = 6 Then SetValue zinst.Store, GetValue(2, 0) Debug.Print Else tmp(1) = GetValue(OpType(1), Operand(1)) SetValue tmp(1), GetValue(zvariable, 0) End If PC = zinst.NextInstr Case zSPLIT_WINDOW opname = "SPLIT_WINDOW" tmp(1) = GetValue(OpType(1), Operand(1)) scr.SplitWindow tmp(1) PC = zinst.NextInstr Case zSET_WINDOW opname = "SET_WINDOW" tmp(1) = GetValue(OpType(1), Operand(1)) scr.SetWindow tmp(1) PC = zinst.NextInstr Case zCALL_VS2 opname = "CALL_VS2" tmp(zinst.OperandCount) = GetValue(OpType(1), Operand(1), , True) For tmp(zinst.OperandCount + 1) = 2 To zinst.OperandCount tmp(tmp(zinst.OperandCount + 1) - 1) = GetValue(OpType(tmp(zinst.OperandCount + 1)), Operand(tmp(zinst.OperandCount + 1))) Next PerformCall PackAddr(tmp(zinst.OperandCount)), zinst.NextInstr, zinst.Store, zinst.OperandCount - 1, tmp() Case zERASE_WINDOW opname = "ERASE_WINDOW" tmp(1) = GetValue(OpType(1), Operand(1)) scr.EraseWindow tmp(1) PC = zinst.NextInstr Case zERASE_LINE opname = "ERASE_LINE" tmp(1) = GetValue(OpType(1), Operand(1)) scr.EraseLine tmp(1), Ver PC = zinst.NextInstr Case zSET_CURSOR opname = "SET_CURSOR" tmp(1) = GetValue(OpType(1), Operand(1)) tmp(2) = GetValue(OpType(2), Operand(2)) If Ver > 5 Then tmp(3) = GetValue(OpType(3), Operand(3)) scr.SetCursor tmp(1), tmp(2), Ver, tmp(3) Else scr.SetCursor tmp(1), tmp(2), Ver End If PC = zinst.NextInstr Case zGET_CURSOR opname = "GET_CURSOR" tmp(1) = GetValue(OpType(1), Operand(1)) scr.GetCursor tmp(2), tmp(3) SetWord Story(), tmp(1), tmp(2) SetWord Story(), tmp(1) + 2, tmp(3) PC = zinst.NextInstr Case zSET_TEXT_STYLE opname = "SET_TEXT_STYLE" tmp(1) = GetValue(OpType(1), Operand(1)) scr.SetTextStyle tmp(1) PC = zinst.NextInstr Case zBUFFER_MODE opname = "BUFFER_MODE" tmp(1) = GetValue(OpType(1), Operand(1)) scr.BufferMode tmp(1) PC = zinst.NextInstr Case zOUTPUT_STREAM opname = "OUTPUT_STREAM" tmp(1) = GetValue(OpType(1), Operand(1)) If zinst.OperandCount > 1 Then tmp(2) = GetValue(OpType(2), Operand(2), , True) End If If tmp(1) < 0 Then OutPutStream(-tmp(1)) = False If tmp(1) = -3 Then Output3CharCount(Output3Pointer) = 0 Output3Pointer = Output3Pointer - 1 End If Else OutPutStream(tmp(1)) = True If tmp(1) = 3 Then Output3Pointer = Output3Pointer + 1 Output3CharCount(Output3Pointer) = 0 Output3Tables(Output3Pointer) = tmp(2) End If End If PC = zinst.NextInstr Case zINPUT_STREAM opname = "INPUT_STREAM" MsgBox "Please Implement INPUT_STREAM" PC = zinst.NextInstr Case zSOUND_EFFECT opname = "SOUND_EFFECT" For tmp(1) = 1 To zinst.OperandCount tmp(1 + tmp(1)) = GetValue(OpType(tmp(1)), Operand(tmp(1))) Next Beep PC = zinst.NextInstr Case zREAD_CHAR opname = "READ_CHAR" tmp(1) = GetValue(OpType(1), Operand(1)) If zinst.OperandCount > 1 Then tmp(2) = GetValue(OpType(2), Operand(2)) If zinst.OperandCount > 2 Then tmp(3) = GetValue(OpType(3), Operand(3)) End If End If scr.LinesPrinted = 0 scr.UpdateDisplay ExpectingInput = True Do Until InputStream <> "" DoEvents Loop ExpectingInput = False 'DebugOn = True tmp(4) = Asc(Left(InputStream, 1)) InputStream = "" SetValue zinst.Store, tmp(4) PC = zinst.NextInstr Case zSCAN_TABLE opname = "SCAN_TABLE" tmp(1) = GetValue(zinst.OperandType(1), zinst.Operand(1), , True) tmp(2) = GetValue(zinst.OperandType(2), zinst.Operand(2), , True) tmp(3) = GetValue(zinst.OperandType(3), zinst.Operand(3)) tmp(4) = 0 For tmp(5) = 0 To tmp(3) - 1 If GetWord(Story(), tmp(2) + tmp(5) * 2, True) = tmp(1) Then tmp(4) = 1 SetValue zinst.Store, tmp(2) + tmp(5) * 2 Exit For End If Next If tmp(4) = 0 Then SetValue zinst.Store, 0 Branch (tmp(4) <> 0), zinst Case zNOT_VAR opname = "NOT" tmp(1) = GetValue(OpType(1), Operand(1), , True) SetValue zinst.Store, Not tmp(1) PC = zinst.NextInstr Case zCALL_VN opname = "CALL_VN" tmp(zinst.OperandCount) = GetValue(OpType(1), Operand(1), , True) For tmp(zinst.OperandCount + 1) = 2 To zinst.OperandCount tmp(tmp(zinst.OperandCount + 1) - 1) = GetValue(OpType(tmp(zinst.OperandCount + 1)), Operand(tmp(zinst.OperandCount + 1))) Next PerformCall PackAddr(tmp(zinst.OperandCount)), zinst.NextInstr, -1, zinst.OperandCount - 1, tmp() Case zCALL_VN2 opname = "CALL_VN2" tmp(zinst.OperandCount) = GetValue(OpType(1), Operand(1), , True) For tmp(zinst.OperandCount + 1) = 2 To zinst.OperandCount tmp(tmp(zinst.OperandCount + 1) - 1) = GetValue(OpType(tmp(zinst.OperandCount + 1)), Operand(tmp(zinst.OperandCount + 1))) Next PerformCall PackAddr(tmp(zinst.OperandCount)), zinst.NextInstr, -1, zinst.OperandCount - 1, tmp() Case zTOKENISE opname = "TOKENISE" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) StoryDic.Tokenise Story(), tmp(1), tmp(2) PC = zinst.NextInstr Case zENCODE_TEXT opname = "ENCODE_TEXT" MsgBox "Please Implement ENCODE_TEXT" PC = zinst.NextInstr Case zCOPY_TABLE opname = "COPY_TABLE" tmp(1) = GetValue(OpType(1), Operand(1), , True) tmp(2) = GetValue(OpType(2), Operand(2), , True) tmp(3) = GetValue(OpType(3), Operand(3)) If tmp(2) = 0 Then For tmp(4) = 1 To Abs(tmp(3)) SetByte Story(), tmp(1) + tmp(4), 0 Next Else If tmp(3) < 0 Then For tmp(4) = 1 To Abs(tmp(3)) SetByte Story(), tmp(2) + tmp(4) - 1, GetByte(Story(), tmp(1) + tmp(4) - 1) Next Else If tmp(1) > tmp(2) Then For tmp(4) = 1 To Abs(tmp(3)) SetByte Story(), tmp(2) + tmp(4) - 1, GetByte(Story(), tmp(1) + tmp(4) - 1) Next Else For tmp(4) = Abs(tmp(3)) To 1 Step -1 SetByte Story(), tmp(2) + tmp(4) - 1, GetByte(Story(), tmp(1) + tmp(4) - 1) Next End If End If End If PC = zinst.NextInstr Case zPRINT_TABLE opname = "PRINT_TABLE" MsgBox "Please Implement PRINT_TABLE" PC = zinst.NextInstr Case zCHECK_ARG_COUNT opname = "CHECK_ARG_COUNT" tmp(1) = GetValue(OpType(1), Operand(1)) Branch CurrentRoutine.ArgCount >= tmp(1), zinst Case Else opname = "UNKNOWN" MsgBox "Unimplemented Opcode" PC = zinst.NextInstr End Select End Select PrintInstr zinst, opname, statedump RunInstruction = 1 End Function Private Function GetValue(OperandType As OperandTypes, ByVal OperandValue As Long, Optional Indirect As Boolean, Optional Unsigned As Boolean) As Long If OperandType = zvariable Then Select Case OperandValue Case 0 GetValue = Stack(StackPointer) If Not Indirect Then If StackPointer <= CurrentRoutine.FramePointer Then MsgBox "Stack Underflow", vbCritical Else StackPointer = StackPointer - 1 End If Else Debug.Print ; End If Case 1 To 15 GetValue = CurrentRoutine.Locals(OperandValue) Case 16 To 255 GetValue = Globals(OperandValue) End Select Else GetValue = OperandValue End If GetValue = GetValue And 65535 If Not Unsigned And (GetValue And 32768) = 32768 Then GetValue = GetValue - 65536 End Function Private Function SetValue(ByVal VarNo As Byte, ByVal value As Long, Optional Indirect As Boolean) value = value And 65535 Select Case VarNo Case 0 If Not Indirect Then StackPointer = StackPointer + 1 End If Stack(StackPointer) = value Case 1 To 15 CurrentRoutine.Locals(VarNo) = value Case 16 To 255 Globals(VarNo) = value End Select End Function Private Function Verify() As Boolean Dim i As Long Dim checksum As Long Dim StoryLen As Long If Ver < 4 Then StoryLen = GetWord(Story(), 26, True) * 2 ElseIf Ver < 6 Then StoryLen = GetWord(Story(), 26, True) * 4 Else StoryLen = GetWord(Story(), 26, True) * 8 End If For i = 64 To StoryLen checksum = (checksum + Story(i)) Mod 65536 Next If checksum = GetWord(Story(), 28, True) Then Verify = True End Function Private Function SaveState() MsgBox "Please Implement zSAVE!" End Function Private Function RestoreState() MsgBox "Please Implement zRESTORE!" End Function Private Function Restart() Dim i As Integer alp(0) = "abcdefghijklmnopqrstuvwxyz" alp(1) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" alp(2) = "~^0123456789.,!?_#'" & Chr(34) & "/\-:()" scr.hdc = Me.Picture1.hdc scr.hWnd = Me.Picture1.hWnd Me.Picture1.ScaleMode = 3 scr.ScreenHeight = Me.Picture1.ScaleHeight - 5 scr.ScreenWidth = Me.Picture1.ScaleWidth - 5 Me.Picture1.ScaleMode = 1 scr.EraseWindow -1 StoryLoaded = LoadStory(Story(), OriginalStory) SetByte Story(), 33, scr.ScreenWidth \ scr.CharWidth SetByte Story(), 32, scr.ScreenHeight \ scr.CharHeight SetByte Story(), 39, scr.CharHeight SetByte Story(), 38, scr.CharWidth Select Case Ver Case 1 To 3 scr.SplitWindow 1 SetByte Story(), 1, (GetByte(Story(), 1) And 135) Or 96 Case 4 To 8 SetByte Story(), 1, 253 End Select scr.BufferMode 1 If Ver < 4 Then scr.SplitWindow 1 OutPutStream(1) = True OutPutStream(3) = False PC = GetWord(Story(), 6, True) Set Routines(RoutinePointer) = New zRoutine Set CurrentRoutine = Routines(RoutinePointer) StackPointer = 0 Stack(StackPointer) = 0 For i = 1 To 1024 Set ObjectCache(i) = New zObject Next End Function Private Function ShowStatus() Dim zobj As zObject Dim wdt As Long Dim stln As String Dim score As String scr.SplitWindow 1 scr.SetWindow 1 scr.SetTextStyle 1 wdt = (scr.ScreenWidth / scr.CharWidth) - 2 stln = Space(wdt) If Globals(16) < 1 Then Exit Function Set zobj = GetObject(Globals(16)) Mid(stln, 1, Len(zobj.ShortName)) = zobj.ShortName If (GetByte(Story(), 1) And 2) = 2 Then score = CStr(Globals(17)) & ":" & Format(CStr(Globals(18)), "00") Else score = CStr(Globals(17)) & "/" & CStr(Globals(18)) End If Mid(stln, wdt - Len(score), Len(score)) = score scr.OutPut stln scr.SetWindow 0 End Function Private Function GetObject(ObjNo As Long) As zObject Dim addr As Long Dim ReachedEnd As Boolean Dim Offset As Long Dim ObjectLen As Integer Dim proptablelen As Integer Dim AttribByteCount As Byte Dim i As Integer Dim PropLen As Integer Dim PropAddr As Long Dim Prop As Long Dim PropNo As Integer If ObjNo <= 1024 Then If ObjectCache(ObjNo).ObjNo = ObjNo Then Set GetObject = ObjectCache(ObjNo): Exit Function End If Select Case Ver Case 1 To 3 proptablelen = 62 ObjectLen = 9 AttribByteCount = 4 Case 4 To 8 proptablelen = 126 ObjectLen = 14 AttribByteCount = 6 End Select Set GetObject = New zObject ReDim PropertyDefaults(proptablelen) For i = 0 To proptablelen Step 2 GetObject.PropDefault((i / 2) + 1) = GetWord(Story(), GetWord(Story(), 10) + i) Next Offset = GetWord(Story, 10, True) + proptablelen + (ObjNo - 1) * ObjectLen GetObject.ObjNo = ObjNo GetObject.Ver = Ver GetObject.ObjTableAddr = Offset For i = 0 To AttribByteCount - 1 GetObject.AttribByte(i) = Story(Offset + i) Next If Ver < 4 Then GetObject.Parent = GetByte(Story(), Offset + i) GetObject.Sibling = GetByte(Story(), Offset + i + 1) GetObject.Child = GetByte(Story(), Offset + i + 2) GetObject.PropTableAddr = GetWord(Story, Offset + i + 3, True) Else GetObject.Parent = GetWord(Story(), Offset + i, True) GetObject.Sibling = GetWord(Story(), Offset + i + 2, True) GetObject.Child = GetWord(Story(), Offset + i + 4, True) GetObject.PropTableAddr = GetWord(Story(), Offset + i + 6, True) End If GetObject.ShortName = PrintZString(Story(), GetObject.PropTableAddr + 1) addr = GetObject.PropTableAddr + Story(GetObject.PropTableAddr) * 2 + 1 Do If Story(addr) = 0 Then Exit Do If Ver < 4 Then PropLen = (Story(addr) \ 32) + 1 PropNo = Story(addr) Mod 32 Else PropNo = Story(addr) Mod 64 If (Story(addr) And 128) = 128 Then addr = addr + 1 PropLen = Story(addr) Mod 64 If PropLen = 0 Then PropLen = 64 Else If (Story(addr) And 64) = 64 Then PropLen = 2 Else PropLen = 1 End If End If PropAddr = addr + 1 Select Case PropLen Case 1 Prop = Story(PropAddr) Case 2 Prop = GetWord(Story(), PropAddr) Case Else Prop = 0 End Select GetObject.SetProp PropNo, Prop, PropLen, PropAddr addr = PropLen + PropAddr Loop If ObjNo <= 1024 Then Set ObjectCache(ObjNo) = GetObject End Function Public Function Branch(expr As Boolean, zinst As zInstruction) Dim tmp1 As Long If expr Xor zinst.BranchCond Then PC = zinst.NextInstr Else If zinst.Branch < 2 Then tmp1 = zinst.Branch PerformReturn tmp1 Else PC = zinst.Branch End If End If End Function Public Function PrintInstr(zinst As zInstruction, opname As String, statedump As String) Dim i As Integer If Not DebugOn Then Exit Function Static lastroutine As Integer Dim OutStr As String OutStr = OutStr & HexVal(zinst.Address) & ": " OutStr = OutStr & opname & Space(16 - Len(opname)) For i = 1 To zinst.OperandCount If zinst.OperandType(i) = zvariable Then Select Case zinst.Operand(i) Case 0 OutStr = OutStr & "(SP)+" Case 1 To 15 OutStr = OutStr & "L" & HexVal(zinst.Operand(i) - 1) Case 16 To 255 OutStr = OutStr & "G" & HexVal(zinst.Operand(i) - 16) End Select Else OutStr = OutStr & "#" & HexVal(zinst.Operand(i)) & " " End If If i < zinst.OperandCount Then OutStr = OutStr & "," Next If zinst.Text <> "" Then OutStr = OutStr & Chr(34) & zinst.Text & Chr(34) If HasBranch(zinst.OpCodeType, zinst.OpCode) Then OutStr = OutStr & " [" & zinst.BranchCond & "] " & HexVal(zinst.Branch) End If If HasStore(zinst.OpCodeType, zinst.OpCode) Then OutStr = OutStr & " -> " Select Case zinst.Store Case 0 OutStr = OutStr & "-(SP)" Case 1 To 16 OutStr = OutStr & "L" & HexVal(zinst.Store - 1) Case 17 To 255 OutStr = OutStr & "G" & HexVal(zinst.Store - 16) End Select End If OutStr = OutStr & statedump OutStr = Space(2 * lastroutine) & OutStr & statedump 'Debug.Print OutStr ts.WriteLine OutStr lastroutine = RoutinePointer End Function Property Get Globals(ByVal Index As Byte) As Long Globals = GetWord(Story(), GetWord(Story(), 12, True) + (2 * (Index - 16))) End Property Property Let Globals(ByVal Index As Byte, value As Long) value = value And 65535 SetWord Story(), GetWord(Story(), 12, True) + (2 * (Index - 16)), value End Property Public Function PerformRead(TextOffset As Long, ParseOffset As Long, Optional Interval As Long, Optional Routine As Long, Optional IgnoreNonmatches As Boolean) Dim i As Integer Dim a As String Dim c As Integer Static lastcount As Integer If Ver < 4 Then ShowStatus scr.LinesPrinted = 0 scr.UpdateDisplay ExpectingInput = True Do Until InStr(1, InputStream, Chr(13)) > 0 If Len(InputStream) > lastcount Then OutPut Right(InputStream, 1) scr.UpdateDisplay scr.LinesPrinted = 0 End If lastcount = Len(InputStream) DoEvents Loop ExpectingInput = False a = Left(InputStream, InStr(1, InputStream, Chr(13)) - 1) InputStream = "" OutPut vbCrLf If Ver > 4 Then c = 1 Story(TextOffset + 1) = Len(a) Else c = 0 Story(TextOffset + i + 1 + Len(a)) = 0 End If For i = 1 To Len(a) Story(TextOffset + i + c) = Asc(Mid(a, i, 1)) Next StoryDic.Tokenise Story(), TextOffset, ParseOffset End Function Public Function PerformRemove(ByVal ObjNo As Long) Dim zobj As zObject Dim tmpobj As zObject Set zobj = GetObject(ObjNo) If zobj.Parent <> 0 Then Set tmpobj = GetObject(zobj.Parent) If tmpobj.Child = ObjNo Then tmpobj.Child = zobj.Sibling tmpobj.WriteObject Story() Else Set tmpobj = GetObject(tmpobj.Child) Do Until tmpobj.Sibling = ObjNo Or tmpobj.Sibling = 0 Set tmpobj = GetObject(tmpobj.Sibling) Loop tmpobj.Sibling = zobj.Sibling tmpobj.WriteObject Story() End If End If zobj.Parent = 0 zobj.Sibling = 0 zobj.WriteObject Story() End Function Public Function PerformInsert(ObjNo As Long, NewParent As Long) Dim zobj As zObject Dim tmpobj As zObject PerformRemove ObjNo Set zobj = GetObject(ObjNo) Set tmpobj = GetObject(NewParent) zobj.Parent = NewParent zobj.Sibling = tmpobj.Child tmpobj.Child = ObjNo zobj.WriteObject Story() tmpobj.WriteObject Story() End Function Public Function PerformCall(ByVal Routine As Long, ByVal ReturnAddress As Long, ByVal StoreVar As Long, ByVal ArgumentCount As Long, Arguments() As Long) Dim i As Integer If Routine = 0 Then If StoreVar >= 0 Then SetValue StoreVar, 0 PC = ReturnAddress Exit Function End If RoutinePointer = RoutinePointer + 1 Set Routines(RoutinePointer) = New zRoutine Set CurrentRoutine = Routines(RoutinePointer) CurrentRoutine.FramePointer = StackPointer CurrentRoutine.ReturnAddress = ReturnAddress CurrentRoutine.LocalCount = GetByte(Story(), Routine) CurrentRoutine.StoreVar = StoreVar CurrentRoutine.ArgCount = ArgumentCount PC = Routine + 1 If Ver < 5 Then For i = 1 To CurrentRoutine.LocalCount CurrentRoutine.Locals(i) = GetWord(Story(), PC) PC = PC + 2 Next End If For i = 1 To ArgumentCount CurrentRoutine.Locals(i) = Arguments(i) Next End Function Public Function PerformReturn(ByVal ReturnValue As Long) StackPointer = CurrentRoutine.FramePointer Set CurrentRoutine = Routines(RoutinePointer - 1) If Routines(RoutinePointer).StoreVar >= 0 Then SetValue Routines(RoutinePointer).StoreVar, ReturnValue PC = Routines(RoutinePointer).ReturnAddress Set Routines(RoutinePointer) = Nothing RoutinePointer = RoutinePointer - 1 End Function Private Function OutPut(OutStr As String) Dim i As Integer Dim LeftOver As String If OutPutStream(3) Then For i = 1 To Len(OutStr) SetWord Story, Output3Tables(Output3Pointer), Output3CharCount(Output3Pointer) + 1 SetByte Story, Output3Tables(Output3Pointer) + 2 + Output3CharCount(Output3Pointer), Asc(Mid(OutStr, i, 1)) Output3CharCount(Output3Pointer) = Output3CharCount(Output3Pointer) + 1 Next Else If OutPutStream(1) Then LeftOver = scr.OutPut(OutStr) Do Until LeftOver = "" scr.LinesPrinted = 0 scr.UpdateDisplay ExpectingInput = True Do Until Len(InputStream) > 0 DoEvents Loop InputStream = "" ExpectingInput = False LeftOver = scr.OutPut(LeftOver, True) Loop End If End If End Function Private Sub Command2_Click() Dim hFont As Long 'TextOut Me.Picture1.hdc, 30, 30, "Hello World!", 12 'SetGraphicsMode Me.Picture1.hdc, 2 hFont = CreateFont(20, 0, 0, 0, 0, 0, 0, 0, 162, 7, 0, 0, 80, "") SelectObject Me.Picture1.hdc, hFont TextOut Me.Picture1.hdc, 50, 50, "Decorative", 10 hFont = CreateFont(20, 0, 0, 0, 0, 0, 0, 0, 162, 7, 0, 0, 48, "") SelectObject Me.Picture1.hdc, hFont TextOut Me.Picture1.hdc, 70, 70, "Modern", 6 hFont = CreateFont(20, 0, 0, 0, 0, 0, 0, 0, 162, 7, 0, 0, 16, "") SelectObject Me.Picture1.hdc, hFont TextOut Me.Picture1.hdc, 90, 90, "Roman", 5 hFont = CreateFont(20, 0, 0, 0, 0, 0, 0, 0, 162, 7, 0, 0, 16, "") SelectObject Me.Picture1.hdc, hFont TextOut Me.Picture1.hdc, 110, 110, "Swiss", 5 Me.Picture1.Refresh End Sub Private Sub Form_KeyPress(KeyAscii As Integer) If Not ExpectingInput Then Exit Sub If KeyAscii = 8 Then If Len(InputStream) > 0 Then scr.DeleteChar Right(InputStream, 1) scr.LinesPrinted = 0 scr.UpdateDisplay InputStream = Mid(InputStream, 1, Len(InputStream) - 1) Else InputStream = Chr(8) End If Else InputStream = InputStream + Chr(KeyAscii) End If End Sub Private Sub Form_Unload(Cancel As Integer) End End Sub Private Function PackAddr(Address As Long, Optional AddrType As Long) As Long Select Case Ver Case 1 To 3 PackAddr = 2 * Address Case 4 To 5 PackAddr = 4 * Address Case 6 To 7 If AddrType Then PackAddr = 4 * Address + 8 * RoutineOffset Else PackAddr = 4 * Address + 8 * StringOffset End If Case 8 PackAddr = 8 * Address End Select End Function Private Function PerformEncode(ZSCIIBufferStart As Long, Length As Long, From As Long, BufferAddress As Long) Debug.Print ; End Function