Saturday, 19 October 2019

VBA error 6219. One small step to the Christoffel symbol

I am trying to write a Word macro to expand the Christoffel symbol automatically. The expansion is simple:$$
\Gamma_{\mu\nu}^\sigma=\frac{1}{2}g^{\sigma\rho}\left(\partial_\mu g_{\nu\rho}+\partial_\nu g_{\rho\mu}-\partial_\rho g_{\mu\nu}\right)
$$One replaces the Christoffel symbol ##\Gamma_{\mu\nu}^\sigma## by a half times the inverse metric ##g^{\sigma\rho}## times the sum of slightly different index combinations of the partial derivative ##\partial_\mu## of the metric ##g_{\nu\rho}##. A new dummy index, ## \rho## in this case, is introduced (it is summed over) and the original indices ## \sigma,\mu,\nu## are placed carefully in the expansion. The Christoffel symbol occurs frequently in General Relativity and once I have done this a few times with different indices my eyes start to pop out, thus the motivation to write a macro to save said eyes.

The macro should be fairly straightforward. We want it to replace something like$$
A\Gamma_{\mu\nu}^\sigma X
$$by$$
A\frac{1}{2}g^{\sigma\rho}\left(\partial_\mu g_{\nu\rho}+\partial_\nu g_{\rho\mu}-\partial_\rho g_{\mu\nu}\right)X
$$An equation is an OMath object which consists of OMathFunction objects. So each of ## A,\Gamma_{\mu\nu}^\sigma,X## in the first equation is an  OMathFunction object. In theory it should be easy to replace the OMathFunction object ##\Gamma_{\mu\nu}^\sigma## by a bunch of new OMathFunction objects ##\frac{1}{2},g^{\sigma\rho},+\ etc##. Dream on!

When you want to add a new OMathFunction object, you need to call Add method of an OMathFunctions object. The OMathFunctions object is the list of OMathFunction objects in the equation. The second parameter of this Add method is the type of new OMathFunction to add. (This not well described in the documentation.) The list of types is here. So the fraction ##\frac{1}{2}## is an wdOMathFunctionFrac, the inverse metric which has superscripts ##g^{\sigma\rho}## is a wdOMathFunctionScrSup and ##+## is a wdOMathFunctionText. You can see all these in the debugger if you have a look at the OMathFunctions object. This Add method crashes with error 6219 if the type parameter is wdOMathFunctionText, so it is very difficult to get the ##+,-## signs into expansion. The only way I could discover was by using
Selection.TypeText ("+")
I could then insert ##g_{\mu\nu}+g^{\mu\nu}## at the selection point in an equation with this code:
Sub ExampleWriteExpression()
    'insertion point should be in equation. Metric + inverse metric inserted
    Dim Equation As OMath
    Dim MathTerm As OMathFunction

    If Selection.OMaths.Count <> 1 Then ExpanderFatalError ("Cursor must be in an equation.")
    Set Equation = Selection.OMaths(1)
    Set MathTerm = Equation.Functions.Add(Selection.Range, wdOMathFunctionScrSub)
    MathTerm.ScrSub.E.Range = "g"
    MathTerm.ScrSub.Sub.Range = ChrW(&H3BC) & ChrW(&H3BD)
    
    Selection.TypeText ("+")
    
'Set MathTerm = Equation.Functions.Add(Selection.Range, wdOMathFunctionText) still gets error

    Set MathTerm = Equation.Functions.Add(Selection.Range, wdOMathFunctionScrSup)
    MathTerm.ScrSup.E.Range = "g"
    MathTerm.ScrSup.Sup.Range = ChrW(&H3BC) & ChrW(&H3BD)
End Sub
There was quite a bit of difficulty in getting the selection in the right place and I kept getting things like$$
\frac{1}{2}g^{\sigma\rho}\left(\partial_\mu g_{\nu\rho}\partial_\nu g_{\rho\mu}\partial_\rho g_{\mu\nu}\right)+-
$$It is necessary align the selection range with the equation range and this is not the simple matter of subtraction that you might expect! It now works  properly and replaces multiple Christoffel symbols in an equation correctly. Click Read more below if you would like a look or copy. Covariant derivatives, Riemann tensors, using, metric and coordinates coming soon!

jpl on msofficeforums corrected me and showed me how to avoid using the Selection which is a bodge. I further refined his technique. It is now very beautiful.😅
'Macros to expand Christoffel symbols and more in MS equations in Office 365 (2019)
'By George Keeling and on my blog at www.general-relativity.net under Tools
'https://www.general-relativity.net/search/label/Tools
'Feel free to use, copy, modify and give away but not for commerce. Please credit me and the website.

'Bugs
'1) does not work with on non-italic indices
Option Explicit
Const gCapGamma = 915               'hex 393
Const gPartialDerivative = 8706     'hex 2202
Const gNabla = 8711
Const gMagic1 = -10187

Dim gIndexesUsed(1 To 51) As Integer  'Count of usage of each index alpha at 1, omega at 25, a at 26, z at 51
Dim gGreekUsed As Boolean


Sub ExpandSymbols()
'Expand all various symbols in an equation
    Dim Equation As OMath
    Dim MathTerm As OMathFunction, GammaTerm As OMathScrSubSup
    Call ZapIndexesUsed
    If Selection.OMaths.Count <> 1 Then
        ExpanderFatalError ("Cursor must be in an equation.")
    End If
    Set Equation = Selection.OMaths(1)
    Call FindIndexesUsed(Equation)
    Call ExpandEquation(Equation)
End Sub

Sub ExpandEquation(ByVal Equation As OMath)
    Dim MathTerm As OMathFunction, CovariantDerivativeTerm As OMathFunction
    Dim InnerEquation As OMath
    Dim iInnerEq As Integer

    Set CovariantDerivativeTerm = Nothing
   
    For Each MathTerm In Equation.Functions
        If CovariantDerivativeTerm Is Nothing Then
            If (MathTerm.Type = wdOMathFunctionScrSubSup) Then
                If Len(MathTerm.Range.Text) >= 2 Then
                If (AscW(Mid(MathTerm.Range.Text, 2, 1)) = gCapGamma) Then 'Have Christoffel symbol.
                    Call ExpandChristoffel(Equation.Functions, MathTerm)
                End If
                End If
            ElseIf MathTerm.Type = wdOMathFunctionScrSub Then
                If Len(MathTerm.Range.Text) >= 2 Then
                If (AscW(Mid(MathTerm.Range.Text, 2, 1)) = gNabla) Then 'Nabla: Covariant derivative
                    Set CovariantDerivativeTerm = MathTerm
                    'and continue to the next term which is what we must operate on
                End If
                End If
            ElseIf MathTerm.Type = wdOMathFunctionDelim Then   'delimiter - brackets, need to recurse
                For iInnerEq = 1 To MathTerm.Delim.E.Count
                    Set InnerEquation = MathTerm.Delim.E.Item(iInnerEq)
                    Call ExpandEquation(InnerEquation)
                Next
            End If
        Else
            Call ExpandCovariantDerivative(Equation.Functions, CovariantDerivativeTerm, MathTerm)
            Set CovariantDerivativeTerm = Nothing
        End If
    Next
End Sub

Sub ExpandChristoffel(Functions As OMathFunctions, MathTerm As OMathFunction)
    'Expand Christoffel symbol
    'Functions are the functions of the original equation, which we add to
    'Mathterm is the Christoffel symbol term
    Dim UpIndex As Integer, LeftIndex As Integer, RightIndex As Integer, DummyIndex As Integer
    Dim NewMathTerm As OMathFunction
    Dim BracketFunctions As OMathFunctions, BracketTerm As OMathFunction    'just like paramters of this function
    Dim InsertionPoint As Range
   
    UpIndex = ToUnicode(Mid(MathTerm.ScrSubSup.Sup.Range.Text, 2, 1))
    LeftIndex = ToUnicode(Mid(MathTerm.ScrSubSup.Sub.Range.Text, 2, 1))
    RightIndex = ToUnicode(Mid(MathTerm.ScrSubSup.Sub.Range.Text, 4, 1))
    DummyIndex = GetNewDummyIndex()
   
    MathTerm.Range.Text = ""    'removes Christoffel symbol
    Set InsertionPoint = MathTerm.Range

    '1/2
    Set NewMathTerm = InsertFunction(Functions, InsertionPoint, wdOMathFunctionFrac)
    NewMathTerm.Frac.Num.Range.Text = "1"
    NewMathTerm.Frac.Den.Range.Text = "2"
    NewMathTerm.Frac.Type = wdOMathFracBar
   
    'inverse metric
    Set NewMathTerm = InsertFunction(Functions, InsertionPoint, wdOMathFunctionScrSup)
    NewMathTerm.ScrSup.E.Range = "g"
    NewMathTerm.ScrSup.Sup.Range = ChrW(UpIndex) & ChrW(DummyIndex)
   
    'brackets (defaults to round brackets)
    Set NewMathTerm = InsertFunction(Functions, InsertionPoint, wdOMathFunctionDelim)
    Set BracketFunctions = NewMathTerm.Delim.E(1).Functions
    Set BracketTerm = BracketFunctions(1)
   
    InsertionPoint.Start = InsertionPoint.Start - 1       'get into the bracket
    InsertionPoint.Collapse (wdCollapseStart)
   
    'first + term
    Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
    NewMathTerm.ScrSub.E.Range = ChrW(gPartialDerivative)
    NewMathTerm.ScrSub.Sub.Range = ChrW(LeftIndex)
    Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
    NewMathTerm.ScrSub.E.Range = "g"
    NewMathTerm.ScrSub.Sub.Range = ChrW(DummyIndex) & ChrW(RightIndex)
   
    'second + term
    Set InsertionPoint = BracketTerm.Range
    Call InsertText(InsertionPoint, "+")
    Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
    NewMathTerm.ScrSub.E.Range = ChrW(gPartialDerivative)
    NewMathTerm.ScrSub.Sub.Range = ChrW(RightIndex)
    Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
    NewMathTerm.ScrSub.E.Range = "g"
    NewMathTerm.ScrSub.Sub.Range = ChrW(LeftIndex) & ChrW(DummyIndex)
   
    'third - term
    Call InsertText(InsertionPoint, "-")
    Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
    NewMathTerm.ScrSub.E.Range = ChrW(gPartialDerivative)
    NewMathTerm.ScrSub.Sub.Range = ChrW(DummyIndex)
    Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
    NewMathTerm.ScrSub.E.Range = "g"
    NewMathTerm.ScrSub.Sub.Range = ChrW(LeftIndex) & ChrW(RightIndex)

End Sub

Sub ExpandCovariantDerivative(Functions As OMathFunctions, CdTerm As OMathFunction, MathTerm As OMathFunction)
    'Expand Covariant Derivative
    'Functions are the functions of the original equation, which we add to
    'CdTerm is the covariant derivative operator
    'Mathterm is the term after the covariant derivative term, the operand, a tensor with up or down indices or both
    'We do not (yet) do an operand in brackets or deal with metric compatibility
   
    'first to all up indices, then all down indices
    Dim UpIndexes(1 To 51) As Integer
    Dim DownIndexes(1 To 51) As Integer
    Dim UpIndexString As String, DownIndexString As String, Tensor As String, DummyIndex As Integer, CdIndex As Integer
    Dim NewMathTerm As OMathFunction
   
    If MathTerm.Type = wdOMathFunctionScrSub Then
        DownIndexString = MathTerm.ScrSub.Sub.Range.Text
        Tensor = ToUnicode(Mid(MathTerm.ScrSub.E.Range.Text, 2, 1))
    ElseIf MathTerm.Type = wdOMathFunctionScrSup Then
        UpIndexString = MathTerm.ScrSup.Sup.Range.Text
        Tensor = ToUnicode(Mid(MathTerm.ScrSup.E.Range.Text, 2, 1))
    ElseIf MathTerm.Type = wdOMathFunctionScrSubSup Then
        DownIndexString = MathTerm.ScrSubSup.Sub.Range.Text
        UpIndexString = MathTerm.ScrSubSup.Sup.Range.Text
        Tensor = ToUnicode(Mid(MathTerm.ScrSubSup.E.Range.Text, 2, 1))
    Else
        Exit Sub        'cannot recognise operand ***************************************
    End If
   
    DummyIndex = GetNewDummyIndex()
    CdIndex = ToUnicode(Mid(CdTerm.ScrSub.Sub.Range.Text, 2, 1))
   
    CdTerm.ScrSub.E.Range.Text = ChrW(gPartialDerivative)    'change nabla to partial derivative

    'Now add + term for each up index and - term for each down index
    Selection.TypeText ("+" & Tensor)
   
End Sub

Sub ZapIndexesUsed()
    'values preserved in gIndexesUsed from one call to another ...
    Dim iIU As Integer
    For iIU = 1 To UBound(gIndexesUsed)
        gIndexesUsed(iIU) = 0
    Next
    gGreekUsed = False
End Sub

Sub FindIndexesUsed(ByVal Equation As OMath)
'Find all tensor indexes used in equation, so that we do not use them as dummy variables.
'only search for lower case italic roman and greek!
    Dim MathTerm As OMathFunction
    Dim InnerEquation As OMath
    Dim iInnerEq As Integer

    For Each MathTerm In Equation.Functions
        If MathTerm.Type = wdOMathFunctionScrSubSup Then   'super and sub script
            Call CheckIndexes(MathTerm.ScrSubSup.Sub.Range.Text)
            Call CheckIndexes(MathTerm.ScrSubSup.Sup.Range.Text)
        End If
        If MathTerm.Type = wdOMathFunctionScrSup Then   'super script
            Call CheckIndexes(MathTerm.ScrSup.Sup.Range.Text)
        End If
        If MathTerm.Type = wdOMathFunctionScrSub Then   'super script
            Call CheckIndexes(MathTerm.ScrSub.Sub.Range.Text)
        End If
        If MathTerm.Type = wdOMathFunctionDelim Then   'delimiter - brackets, need to recurse
            For iInnerEq = 1 To MathTerm.Delim.E.Count
                Set InnerEquation = MathTerm.Delim.E.Item(iInnerEq)
                Call FindIndexesUsed(InnerEquation)
            Next
        End If
    Next
End Sub

Sub CheckIndexes(IndexText As String)
    'Check all the indexes in a string which may contain spaces.
    Dim iText As Integer, UniCode As Integer
    For iText = 1 To Len(IndexText)
        UniCode = 0
        UniCode = ToUnicode(Mid(IndexText, iText, 1))
        If UniCode = &H3D5 Then
            UniCode = &H3C6         'alternate phi, same as phi
        End If
        'Now have correct Unicode char in UniCode which we will use to index into gIndexesUsed
        If (UniCode > 0) Then
            If (UniCode > 0) And (UniCode < &H7B) Then
                'It's roman
                UniCode = UniCode - &H60 + 25
            Else
                UniCode = UniCode - &H3B0
                gGreekUsed = True
            End If
            gIndexesUsed(UniCode) = gIndexesUsed(UniCode) + 1
        End If
    Next
End Sub

Function ToUnicode(Char As String) As Integer
    'convert one charachter string from equation into unicode. 0 if unknown.
    'Charachter is lower case roman or greek italic.
    '********** Need to add uppercase!!
    'includes alternate theta, upsilon, phi
    Dim CharCode As Integer
    CharCode = AscW(Char)
    If (CharCode >= -8452) And (CharCode <= -8423) Then
        ToUnicode = 9397 + CharCode       'Unicode greek
    ElseIf CharCode = 8462 Then
        ToUnicode = &H68                'roman h is special. Planck at work!
    ElseIf (CharCode >= -9138) And (CharCode <= -9113) Then
        ToUnicode = 9235 + CharCode       'Unicode roman
    Else
        ToUnicode = 0
    End If
End Function

Function GetNewDummyIndex() As Integer
    'get new dummy index.  greek if any greek in list, otherwise roman. Start with mu,nu,rho, sigma,tau,lambda, kappa
    Dim iIU As Integer
    If gGreekUsed Then
        If gIndexesUsed(12) = 0 Then
            gIndexesUsed(12) = 1
            GetNewDummyIndex = &H3BC
            Exit Function
        End If
        If gIndexesUsed(13) = 0 Then
            gIndexesUsed(13) = 1
            GetNewDummyIndex = &H3BD
            Exit Function
        End If
        If gIndexesUsed(17) = 0 Then
            gIndexesUsed(17) = 1
            GetNewDummyIndex = &H3C1
            Exit Function
        End If
        If gIndexesUsed(19) = 0 Then
            gIndexesUsed(19) = 1
            GetNewDummyIndex = &H3C3
            Exit Function
        End If
        If gIndexesUsed(20) = 0 Then
            gIndexesUsed(20) = 1
            GetNewDummyIndex = &H3C4
            Exit Function
        End If
        If gIndexesUsed(11) = 0 Then
            gIndexesUsed(11) = 1
            GetNewDummyIndex = &H3BB
            Exit Function
        End If
        If gIndexesUsed(10) = 0 Then
            gIndexesUsed(10) = 1
            GetNewDummyIndex = &H3BA
            Exit Function
        End If
        'No obvious spare ones found. Start at alpha and at z (oops, in worst case could be roman)
        For iIU = 1 To UBound(gIndexesUsed)
            If gIndexesUsed(iIU) = 0 Then
                gIndexesUsed(iIU) = 1
                If iIU <= 25 Then
                    GetNewDummyIndex = iIU + &H3B0      'greek
                Else
                     GetNewDummyIndex = iIU + &H60      'bad luck roman
                End If
                Exit Function
            End If
        Next
    Else
        'roman just do a to z then alpha to omega
        For iIU = 26 To 51
            If gIndexesUsed(iIU) = 0 Then
                gIndexesUsed(iIU) = 1
                GetNewDummyIndex = iIU + &H60 - 25
                Exit Function
            End If
        Next
        For iIU = 1 To 25
            If gIndexesUsed(iIU) = 0 Then
                gIndexesUsed(iIU) = 1
                GetNewDummyIndex = iIU + &H3B0
                Exit Function
            End If
        Next
    End If
    'very bad luck, no indices left
    GetNewDummyIndex = &H2605  'black star
End Function

Function InsertFunction(Functions As OMathFunctions, InsertionPoint As Range, FuncType As WdOMathFunctionType) As OMathFunction
    'Add a function in Functions at InsertionPoint and move InsertionPoint to after the function, ready for next
    Dim NewFunction As OMathFunction
    Set NewFunction = Functions.Add(InsertionPoint, FuncType)
    Set InsertionPoint = NewFunction.Range
    InsertionPoint.Collapse (wdCollapseEnd)
    Set InsertFunction = NewFunction
End Function

Sub InsertText(InsertionPoint As Range, MyText As String)
    'Inserts MyText at InsertionPoint and returns moves InsertionPoint to after that text
    'so this is very similar to
    'Equation.Functions.Add(InsertionPoint, wdOMathFunctionNormalText) .... which does not work!!
    'many thankss to jpl for this. https://www.msofficeforums.com/word-vba/31587-vba-omath-object.html
    InsertionPoint.Text = MyText
    InsertionPoint.Collapse (wdCollapseEnd)
End Sub

Sub ExpanderFatalError(Message As String)
    Call MsgBox(Message, vbOKOnly, "Expander says")
    End
End Sub

'******************************** test functions below here
Sub junk()
End Sub

Sub ExampleWriteSymbols()
    'Insert capital gamma, partial derivative, nabla
    Call Selection.InsertSymbol(gCapGamma, , True)
    Call Selection.InsertSymbol(gPartialDerivative, , True)
    Call Selection.InsertSymbol(gNabla, , True)
End Sub

Sub ExampleWriteAlphabet()
    'insertion point should be in equation. alphabet written one charachter before end.
    Dim LetterCode As Integer, Letter0 As Integer
   
    Dim Equation As OMath
    Dim MathTerm As OMathFunction, GammaTerm As OMathScrSubSup
    Dim MyRange As Range
   
   
    Letter0 = &H61 ' Start letter = 391 ALPHA, 3B1 alpha, 41 A, 61 a
   
    If Selection.OMaths.Count <> 1 Then
        ExpanderFatalError ("Cursor must be in an equation.")
    End If
    Set Equation = Selection.OMaths(1)
    Set MyRange = Equation.Range
    MyRange.Collapse (wdCollapseEnd)
    Call MyRange.MoveEnd(wdCharacter, -1)
    MyRange.Text = ""
    For LetterCode = Letter0 To Letter0 + 20
        MyRange.Text = MyRange.Text & ChrW(LetterCode)
    Next
    'Set MathTerm = Equation.Functions.Add(MyRange, wdOMathFunctionNormalText)
End Sub

Sub ExampleWriteExpression()
    'insertion point should be in equation. Metric + inverse metric inserted
    Dim Equation As OMath
    Dim MathTerm As OMathFunction
    Dim InsertionPoint As Range

    If Selection.OMaths.Count <> 1 Then ExpanderFatalError ("Cursor must be in an equation.")
    Set Equation = Selection.OMaths(1)
    Set InsertionPoint = Selection.Range
   
    Set MathTerm = InsertFunction(Equation.Functions, InsertionPoint, wdOMathFunctionScrSub)
    MathTerm.ScrSub.E.Range = "g"
    MathTerm.ScrSub.Sub.Range = ChrW(&H3BC) & ChrW(&H3BD)
   
    Call InsertText(InsertionPoint, "+")

    Set MathTerm = InsertFunction(Equation.Functions, InsertionPoint, wdOMathFunctionScrSup)
    MathTerm.ScrSup.E.Range = "g"
    MathTerm.ScrSup.Sup.Range = ChrW(&H3BC) & ChrW(&H3BD)
End Sub

Sub ExampleReadSymbols()
    Dim Equation As OMath
    Dim MathTerm As OMathFunction
    Dim Symbol(1 To 6) As Integer
   
    If Selection.OMaths.Count <> 1 Then
        ExpanderFatalError ("Cursor must be in equation.")
    End If
    Set Equation = Selection.OMaths(1)
   
    For Each MathTerm In Equation.Functions
        Symbol(1) = AscW(Mid(MathTerm.Range.Text, 1, 1))
        Symbol(2) = AscW(Mid(MathTerm.Range.Text, 2, 1))
        Symbol(3) = AscW(Mid(MathTerm.Range.Text, 3, 1))
        Symbol(4) = AscW(Mid(MathTerm.Range.Text, 4, 1))
        Symbol(5) = AscW(Mid(MathTerm.Range.Text, 5, 1))
        Symbol(6) = AscW(Mid(MathTerm.Range.Text, 6, 1))
    Next
End Sub 'break here to check results

No comments:

Post a comment