Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Display Text Differences

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • PBWin Display Text Differences

    I was really happy with how this came out. I wanted to compare 2 strings and show, using normal markup/strikeout syntax, how the two differ. More accurately, the result shows what actions you have to take (line add/delete) to turn one string into another.

    It's similar to the technique used to make patches for binary files, and is based on LCS (longest common subsequence) theory - not my invention, just my modification of code to the PowerBASIC environment.

    I'm also working on another version to highlight minor differences within a line, rather than deal with complete lines only. I've seen programs, such as Beyond Compare, that do this and have wanted the capability in my programs.

    This solution is now incorporated into the snippet comparison and server synchronization features of gbSnippets.

    Code:
    'Compilable Example:
    #Compile Exe
    #Dim All
    #Include "Win32API.inc"
    #Include "RichEdit.inc"
    #Include "CommCtrl.inc"
    Global hDlg As Dword, hRichEdit As Dword, txt1$, txt2$, hFont as Dword
    %ID_RichEdit = 500
    %ID_RichEditR = 501
    %ID_RichEditL = 502
    %COST_ADD1 = 1
    %COST_ADD2 = 1
    %COST_REPL = 1
    
    %move_NoChange = 0
    %move_Replace = 1
    %move_Add1 = 2
    %move_Add2 = 3
    
    Function PBMain () As Long
       Local style&
       CreateSampleText txt2$, txt1$  'txt2 is the result of changing txt1$
    
       Font New "Courier new", 10, 1 To hFont
    
       style& = %WS_Child Or %WS_Visible Or %ES_MultiLine Or %WS_VScroll Or %ES_AutoHScroll _
       Or %WS_HScroll Or %ES_AutoVScroll Or %ES_WantReturn Or %ES_NoHideSel Or %WS_TabStop
       Dialog New Pixels, 0, "Test Code",300,300,1180,400, %WS_OverlappedWindow To hDlg
       Control Add Button, hDlg, 100,"Push", 30,10,140,20
       Control Add Label, hDlg, 110,"Actions needed to convert Left to Middle are shown on Right.  Black - same on both. Red - remove from left. Blue - new in Middle", 200,10,800,20
       LoadLibrary("riched32.dll") : InitCommonControls
       Control Add "RichEdit", hDlg, %ID_RichEditL, "",5,40,380,350, style&, %WS_Ex_ClientEdge
       Control Add "RichEdit", hDlg, %ID_RichEditR, "",390,40,380,350, style&, %WS_Ex_ClientEdge
       Control Add "RichEdit", hDlg, %ID_RichEdit, "",775,40,380,350, style&, %WS_Ex_ClientEdge
       Control Set Text hDlg, %ID_RichEditL, $CrLf + txt1$
       Control Set Text hDlg, %ID_RichEditR, $CrLf + txt2$
       Control Set Font hDlg, %ID_RichEdit, hFont
       Control Set Font hDlg, %ID_RichEditL, hFont
       Control Set Font hDlg, %ID_RichEditR, hFont
       Control Handle hDlg, %ID_RichEdit To hRichEdit
       Dialog Show Modal hDlg Call DlgProc
    End Function 
    
    CallBack Function DlgProc() As Long
       Select Case CB.Msg
          Case %WM_InitDialog
             EditDistanceLines
          Case %WM_Command
             If CB.Msg = %WM_Command AND CB.Ctl = 100 AND CB.Ctlmsg = %BN_Clicked Then
                EditDistanceLines
             End If
       End Select
    End Function
    
    Function EditDistanceLines() As Integer
       ' Costs for adding or replacing lines.
       Dim lines1() As String, lines2() As String
       Dim temp$, cf As CHARFORMAT, P as CharRange
       Dim len1 As Integer, len2 As Integer
       Dim distances() As Integer
       Dim moves() As Long   'MoveType
       Dim i1 As Integer, i2 As Integer
       Dim line1 As String, line2 As String
       Dim dist_repl As Integer
       Dim dist_add1 As Integer
       Dim dist_add2 As Integer
       Dim move_sequence() As Long
       Dim num_moves As Integer
       Dim i As Integer
    
       ' Split the strings into arrays of lines.
       ' We add a vbCrLf at the front so we get an
       ' extra blank string in array entry 0.
       Dim lines1 (1 to ParseCount(txt1,$CrLf))
       Dim lines2 (1 to ParseCount(txt2,$CrLf))
       Parse txt1$, lines1(), $CrLf    'Split(vbCrLf & txt1, vbCrLf)
       Parse txt2$, lines2(), $CrLf    'Split(vbCrLf & txt2, vbCrLf)
    
       ' Allocate space for the distances
       ' and moves arrays.
       len1 = UBound(lines1)
       len2 = UBound(lines2)
       ReDim distances(0 To len1, 0 To len2)
       ReDim moves(0 To len1, 0 To len2)
    
       ' Initialize the arrays.
       moves(0, 0) = %move_NoChange
       For i1 = 1 To len1
          distances(i1, 0) = distances(i1 - 1, 0) + %COST_ADD1
          moves(i1, 0) = %move_Add1
       Next i1
       For i2 = 1 To len2
          distances(0, i2) = distances(0, i2 - 1) + %COST_ADD2
          moves(0, i2) = %move_Add2
       Next i2
    
       ' Fill in the rest of the arrays.
       For i1 = 1 To len1
          line1 = lines1(i1)
          For i2 = 1 To len2
             line2 = lines2(i2)
    
             ' See how much it would cost to start
             ' from the (i1 - 1, i2 - 1) entry.
             If line1 = line2 Then
                dist_repl = distances(i1 - 1, i2 - 1)
             Else
                dist_repl = distances(i1 - 1, i2 - 1) + %COST_REPL
             End If
    
             ' See how much it would cost to start
             ' from the (i1 - 1, i2) and (i1, i2 - 1)
             ' entries.
             dist_add1 = distances(i1 - 1, i2) + %COST_ADD1
             dist_add2 = distances(i1, i2 - 1) + %COST_ADD2
    
             ' See which method is cheapest.
             If (dist_repl <= dist_add1) AND (dist_repl <= dist_add2) Then
                distances(i1, i2) = dist_repl
                If line1 = line2 Then
                   moves(i1, i2) = %move_NoChange
                Else
                   moves(i1, i2) = %move_Replace
                End If
             ElseIf (dist_add1 <= dist_repl) AND (dist_add1 <= dist_add2) Then
                distances(i1, i2) = dist_add1
                moves(i1, i2) = %move_Add1
             Else
                distances(i1, i2) = dist_add2
                moves(i1, i2) = %move_Add2
             End If
          Next i2
       Next i1
    
       ' Set the return edit distance value.
       EditDistanceLines = distances(len1, len2)
    
       ' Make a list of the moves we took
       ' (in reverse order).
       i1 = len1
       i2 = len2
       Do While (i1 > 0) Or (i2 > 0)
          ' Save the move.
          num_moves = num_moves + 1
          ReDim Preserve move_sequence(1 To num_moves)
          move_sequence(num_moves) = moves(i1, i2)
    
          ' Go to the previous position in the array.
          Select Case moves(i1, i2)
             Case %move_NoChange
                i1 = i1 - 1
                i2 = i2 - 1
             Case %move_Replace
                i1 = i1 - 1
                i2 = i2 - 1
             Case %move_Add1
                i1 = i1 - 1
             Case %move_Add2
                i2 = i2 - 1
          End Select
       Loop
    
       ' Use the moves to build the result string.
       i1 = 1
       i2 = 1
    
    
    '   LockWindowUpdate hRichEdit            'rchDifference.hWnd
       Control Set Text hDlg, %ID_RichEdit, ""   'rchDifference.Text = ""
       For i = num_moves To 1 Step -1
          Select Case move_sequence(i)
             Case %move_Add1
                AddToEndAndSelect $CrLf + lines1(i1)  
                SetRichTextColor %Red     'set format of selection + StrikeThru
                i1 = i1 + 1
             Case %move_Add2
                AddToEndAndSelect $CrLf + lines2(i2)
                SetRichTextColor %Blue     'set format of selection
                i2 = i2 + 1
             Case %move_Replace
                AddToEndAndSelect $CrLf + lines1(i1)
                SetRichTextColor %Red     'set format of selection + StrikeThru
    
                AddToEndAndSelect $CrLf + lines2(i2)
                SetRichTextColor %Blue     'set format of selection
                i1 = i1 + 1
                i2 = i2 + 1
             Case %move_NoChange
                AddToEndAndSelect $CrLf + lines2(i2)
                SetRichTextColor %Black     'set format of selection
                i1 = i1 + 1
                i2 = i2 + 1
          End Select
       Next i
    
       'unselect all
       P.cpmin = -1 : P.cpmax = 0
       SendMessage(hRichEdit, %EM_EXSetSel, 0, VarPTR(p))
    
    '   LockWindowUpdate 0
    End Function
    
    Function SetRichTextColor( ByVal NewColor As Long) As Long
       ' setRichTextColor sets the textcolor for selected text in a Richedit control.
       Local cf As CHARFORMAT
       cf.cbSize      = Len(cf)       'Length of structure
       cf.dwMask      = %CFM_COLOR Or %CFM_STRIKEOUT  'Set mask to colors only
       If NewColor = %Red Then cf.dwEffects   = %CFE_StrikeOut Else cf.dwEffects   = 0
       cf.crTextColor = NewColor      'Set the new color value
       SendMessage(hRichEdit, %EM_SETCHARFORMAT, %SCF_SELECTION, VarPTR(cf))
    End Function
    
    Function AddToEndAndSelect(ByVal buf$) As Long
       Local D As GetTextLengthEX, T As TextRange, iTextLength&, iResult&, P As CharRange, temp$
       'get length of all text
       D.flags = %GTL_Default
       iTextLength& = SendMessage(hRichEdit, %EM_GetTextLengthEX, VarPTR(D),0)
    
       'put cursor at end of control
       P.cpmin = iTextLength& : P.cpmax = P.cpmin
       SendMessage hRichEdit, %EM_EXSetSel, 0, VarPTR(P) To iResult&            'put cursor at end of control
    
       'put text at cursor
       SendMessage(hRichEdit, %EM_ReplaceSel, %True, StrPTR(buf$))   'only replace if selection exists.
       
       'select last line
       P.cpmin = iTextLength& + 2 : P.cpmax = P.cpmin + Len(buf$)
       SendMessage hRichEdit, %EM_EXSetSel, 0, VarPTR(P) To iResult&
    
    End Function 
    
    
    Sub CreateSampleText(a$, b$)
    a$ = "Private Function FileContents() As String" + $crlf
    a$ = a$ + "Dim fnum As Integer" + $crlf
    a$ = a$ + "Dim txt As String" + $crlf
    a$ = a$ + "" + $crlf
    a$ = a$ + "    On Error GoTo FileContentsError" + $crlf
    a$ = a$ + "" + $crlf
    a$ = a$ + "    fnum = FreeFile" + $crlf
    a$ = a$ + "    Open file_name For Input As fnum" + $crlf
    a$ = a$ + "    txt = Input$(Lof(fnum), #fnum)" + $crlf
    a$ = a$ + "    Close #fnum" + $crlf
    a$ = a$ + "    FileContents = txt" + $crlf
    a$ = a$ + "    " + $crlf
    a$ = a$ + "FileContentsError:" + $crlf
    b$ = "Private Function FileContents() As String" + $crlf
    b$ = b$ + "Dim txt As String" + $crlf
    b$ = b$ + "" + $crlf
    b$ = b$ + "    On Error GoTo FileContentsError" + $crlf
    b$ = b$ + "" + $crlf
    b$ = b$ + "    Open file_name For Input As 1" + $crlf
    b$ = b$ + "    txt = Input$(Lof(fnum), #1)" + $crlf
    b$ = b$ + "    Close #1" + $crlf
    b$ = b$ + "    FileContents = txt" + $crlf
    b$ = b$ + "    " + $crlf
    b$ = b$ + "FileContentsError:" + $crlf
    End Sub
    
    'gbs_00335
    Edited 27 Sept 2009 to remove lines of test code that could cause an error under some circumstances.
    Gary Beene
    Gary Beene
    Member
    Last edited by Gary Beene; 27 Sep 2009, 11:41 PM.
Working...
X