VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Begin VB.Form report_ed 
   Caption         =   "Report"
   ClientHeight    =   5250
   ClientLeft      =   60
   ClientTop       =   630
   ClientWidth     =   8430
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   5250
   ScaleWidth      =   8430
   Begin VB.TextBox Text1 
      Height          =   375
      Left            =   5880
      TabIndex        =   2
      Text            =   "Text1"
      Top             =   3120
      Width           =   615
      Visible         =   0   'False
   End
   Begin RichTextLib.RichTextBox rtbEd 
      Height          =   1575
      Left            =   0
      TabIndex        =   0
      Top             =   3600
      Width           =   8415
      _ExtentX        =   14843
      _ExtentY        =   2778
      _Version        =   393217
      Enabled         =   -1  'True
      ScrollBars      =   3
      TextRTF         =   $"report_ed.frx":0000
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Courier New"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin RichTextLib.RichTextBox rtbOutput 
      Height          =   3375
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   8415
      _ExtentX        =   14843
      _ExtentY        =   5953
      _Version        =   393217
      Enabled         =   -1  'True
      ScrollBars      =   2
      TextRTF         =   $"report_ed.frx":00E2
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Courier New"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin VB.Menu menu_help 
      Caption         =   "Help"
   End
End
Attribute VB_Name = "report_ed"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Base 1
Dim locals_name() As String
Dim locals_value() As Double
Dim locals_n As Integer
Dim last_if As Boolean


Sub eval_line(strLine0)
  Dim i As Long
  strline = LCase(strLine0)
  
  If Left(strline, 8) = "clear if" Then
    last_if = True
    Exit Sub
  End If
  
  If Left(strline, 6) = "loopif" Then
    Dim lstr0 As String
    'Dim lstr1 As String
    Dim lstrif As String
    Dim lstrdo As String
    lstr0 = Mid(strline, 8)
    pos_then = InStr(1, lstr0, "then")
    lstrif = Left(lstr0, pos_then - 1)
    lstrdo = Mid(lstr0, pos_then + 5)
    'rtbOutput.Visible = False
    For i = 1 To m_icount
      last_if = True
      Call eval_line("if " & Replace(lstrif, "(i)", "(" & CStr(i) & ")"))
      Call eval_line(Replace(lstrdo, "(i)", "(" & CStr(i) & ")"))
    Next
    'rtbOutput.Visible = True
    Exit Sub
  End If
  
  
  If Left(strline, 1) = "z" Then
    For i = 1 To Int(m_icount / 2)
      select_i(i) = 0
    Next
    Exit Sub
  End If
  If Left(strline, 1) = "q" Then
    For i = 1 To m_icount
      select_i(i) = 1
    Next
    Exit Sub
  End If
  
  pos_set = InStr(1, strLine0, "=")
  pos_if = InStr(1, strLine0, "if")
  If pos_if = 1 Then
    pos_set = 0
  End If
  
  If pos_set = 0 And pos_if = 0 Then
    strline2 = exp_expr(strline)
  ElseIf pos_set > 0 Then
    strline2 = exp_expr(Replace(Mid(strline, pos_set + 1), " ", ""))
  ElseIf pos_if = 1 Then
    strline2 = exp_expr(Replace(Mid(strline, pos_if + 3), " ", ""))
  End If
  
  ' Replace vector functions
  strline2 = eval_functions(strline2)
  
  
  Dim y As Double
  If pos_set = 0 Then
    If e_eval(strline2, y) Then
      If pos_if <> 1 Then
        'out last_if
        If last_if = True Then
          out strline & " = " & y
        End If
      Else
        Dim yres As String
        yres = y
        If y = "0" Then
          yres = "False"
          last_if = False
        End If
        If y = "-1" Then yres = "True"
        out strline & " = " & yres
      End If
    Else
      out "Error: " & strLine0
    End If
  Else
    If e_eval(strline2, y) Then
      Call store_local(Left(strline, pos_set - 1), y)
    End If
  End If
  
  If Left(strline, 6) = "print " Then
    strExpr = Mid(strline, 7)
  End If
    
End Sub

''' Functions operating on Sesim's individual and household vectors
Function eval_functions(strExpr) Dim strF As String Dim strVartype As String strF = strExpr posfunc = InStr(1, strF, "sum(") Do While posfunc > 0 posvpar = InStr(posfunc, strF, "(") poshpar = InStr(posvpar, strF, ")") func_var = Mid(strF, posvpar + 1, poshpar - posvpar - 1) strVartype = var_type(func_var) If strVartype = "i" Or strVartype = "h" Then vsum = 0 Call prepare_temp(func_var) If strVartype = "i" Then vcount = m_icount If strVartype = "h" Then vcount = m_hcount For i = 1 To vcount vsum = vsum + temp(i) Next strF = Replace(strF, Mid(strF, posfunc, poshpar - posfunc + 1), CStr(vsum)) End If posfunc = InStr(poshpar, strF, "sum(") Loop posfunc = InStr(1, strF, "mean(") Do While posfunc > 0 posvpar = InStr(posfunc, strF, "(") poshpar = InStr(posvpar, strF, ")") func_var = Mid(strF, posvpar + 1, poshpar - posvpar - 1) strVartype = var_type(func_var) If strVartype = "i" Or strVartype = "h" Then vsum = 0 Call prepare_temp(func_var) If strVartype = "i" Then vcount = m_icount If strVartype = "h" Then vcount = m_icount For i = 1 To vcount vsum = vsum + temp(i) Next strF = Replace(strF, Mid(strF, posfunc, poshpar - posfunc + 1), CStr(vsum / vcount)) End If posfunc = InStr(poshpar, strF, "mean(") Loop eval_functions = strF End Function
Function exp_expr(strExpr) Dim res1 As String Dim ggr As Integer res1 = x_exp_expr(strExpr) res2 = "" Do Until res1 = res2 ggr = ggr + 1 res2 = res1 res1 = x_exp_expr(res2) If ggr > 10 Then Exit Do Loop '' Check for functions 'If InStr(1, res1, "sum(") > 0 Then ' 'End If exp_expr = res1 End Function
Function x_exp_expr(strExpr) Dim str1 As String str1 = strExpr str2 = Replace(str1, "+", "@") str2 = Replace(str2, "-", "@") str2 = Replace(str2, "*", "@") str2 = Replace(str2, "/", "@") str2 = Replace(str2, "(", "@") str2 = Replace(str2, ")", "@") str2 = Replace(str2, "<", "@") str2 = Replace(str2, ">", "@") str2 = Replace(str2, "=", "@") 'str2 = Replace(str2, "[", "@") 'str2 = Replace(str2, "]", "@") parts = Split(str2, "@") '''out str2 If IsArray(parts) Then For i = 0 To UBound(parts) If Len(parts(i)) > 0 Then strVartype = var_type(parts(i)) If strVartype = "l" Then str1 = ReplaceWord(str1, CStr(parts(i)), get_local(parts(i))) End If If strVartype = "m" Then str1 = ReplaceWord(str1, CStr(parts(i)), CStr(get_macro_value(parts(i)))) End If If strVartype = "i" Or strVartype = "h" Then ' next part must be index If i < UBound(parts) Then If IsNumeric(parts(i + 1)) Then indexnr = CLng(parts(i + 1)) str1 = ReplaceWord(str1, CStr(parts(i) & "(" & CStr(indexnr) & ")"), CStr(get_value(parts(i), indexnr))) End If End If End If 'out var_type(parts(i)) & " " & parts(i) End If Next End If x_exp_expr = str1 End Function
Function var_type(strConst) var_type = "u" If IsNumeric(strConst) Then var_type = "n" Exit Function ElseIf is_local(strConst) Then var_type = "l" Exit Function ElseIf Left(strConst, 2) = "m_" Then For Each cv In mvar_coll If strConst = cv Then var_type = "m" Exit Function End If Next ElseIf Left(strConst, 2) = "i_" Then For Each cv In var_coll If strConst = cv Then var_type = "i" Exit Function End If Next ElseIf Left(strConst, 2) = "h_" Then For Each cv In var_coll If strConst = cv Then var_type = "h" Exit Function End If Next End If End Function
Private Sub Form_Load() Call readdata last_if = True End Sub
Private Sub Form_Resize() hojd = Me.Height bredd = Me.Width rtbOutput.Top = 10 rtbOutput.Height = 0.6 * hojd rtbOutput.Width = bredd - 20 rtbEd.Top = 20 + rtbOutput.Height rtbEd.Height = maxi(0, hojd - rtbOutput.Height - 500) rtbEd.Width = bredd - 20 End Sub
Private Sub rtbed_KeyDown(KeyCode As Integer, Shift As Integer) 'MsgBox KeyCode If KeyCode = vbKeyF8 Then A = getline() End If End Sub
Function getline() 'MsgBox rtbEd.SelStart pos = rtbEd.SelStart + 1 'out (pos) ' out (rtbOutput.SelStart) 'Exit Function slut = InStr(pos, rtbEd.text, vbCrLf) - 1 If slut <= 0 Then slut = Len(rtbEd.text) If slut = 0 Then Exit Function 'out ("slut " & slut) Start = InStrRev(rtbEd.text, vbCrLf, slut) If Start = 0 Then Start = 1 Else Start = Start + 2 End If 'out ("start " & start) txt = Mid$(rtbEd.text, Start, slut - Start + 1) 'out txt Call eval_line(txt) End Function
Sub out(txt) 'rtbOutput.text = rtbOutput.text & vbCrLf & ">" & txt & "<" rtbOutput.text = rtbOutput.text & vbCrLf & txt 'rtbOutput.SetFocus rtbOutput.SelStart = Len(rtbOutput.text) 'rtbEd.SetFocus End Sub
Private Sub Text1_Change() Dim strLines last_if = True strLines = Split(rtbEd.text, vbCrLf) If IsArray(strLines) Then For i = 0 To UBound(strLines) If strLines(i) <> "" Then 'out "[" & strLines(i) & "]" Call eval_line(strLines(i)) End If Next End If 'Call getline End Sub
Private Sub readdata() If Dir(sesimpath & "\parameterdata\rtbed.txt") <> "" Then fnum = FreeFile Open sesimpath & "\parameterdata\rtbed.txt" For Input As fnum rtbEd.text = Input(LOF(fnum), #fnum) Close fnum End If End Sub
Private Sub store_local(strName, dblValue) Dim i As Integer For i = 1 To locals_n If locals_name(i) = strName Then locals_value(i) = dblValue Exit Sub End If Next locals_n = locals_n + 1 ReDim Preserve locals_name(locals_n) ReDim Preserve locals_value(locals_n) locals_name(locals_n) = strName locals_value(locals_n) = dblValue End Sub
Private Function is_local(strName) As Boolean Dim i As Integer For i = 1 To locals_n If locals_name(i) = strName Then is_local = True Exit Function End If Next is_local = False End Function
Private Function get_local(strName) As Double Dim i As Integer For i = 1 To locals_n If locals_name(i) = strName Then get_local = locals_value(i) Exit Function End If Next End Function
Private Sub Form_Unload(Cancel As Integer) coll_view.Remove Me.Tag fnum = FreeFile Open sesimpath & "\parameterdata\rtbed.txt" For Output As fnum Print #fnum, rtbEd.text Close fnum End Sub
Private Sub menu_help_Click() out "Help:" out "Statement without '=' or 'if' -> print" out " example: i_age(1)" out "Statement with 'if' -> logical expression" out "Statement with '=' -> set variable" out " example: test=1" out "F8, evaluate current row" out "F5, evaluate all rows" End Sub