Visual Basic for Applications/Viterbi Simulator in VBA

Summary This code is made for Excel. It simulates the behavior of a data channel's convolutional coding, though by necessity it concentrates on simple examples. Two rate 1/2 systems are provided; both with three stages, one for generator polynomial (111,110), and the other for (111,101). The code was written to improve understanding of the Wikibooks page A Basic Convolutional Coding Example, but might also be of elementary use for students without other software. The code concentrates on random errors of the type caused by Gaussian noise sources. Blank work sheets can be found in the drop-box below: 500px center Blank Work Sheets for (7,5) and (7,6) Configurations thumb|500px|center|Viterbi Trellis Worksheet for configuration (7,6)thumb|500px|center|Viterbi Trellis Worksheet for configuration (7,5) The Simulator thumb|350px|This simulator uses Closeness to calculate its metrics. For each of the two configurations, rudimentary options have been provided. No user form has been included here, the author preferring to modify the settings directly in the top procedure's code. The branch metrics make use of CLOSENESS as opposed to HAMMING DISTANCE. A version using HAMMING DISTANCE can be found on an adjacent page. User mode settings allow various combinations of inputs and errors to be applied. Both coders produce two bits of output for every one bit of input. The message input (display stream m) can be specified by the user, manually or generated randomly to any given length. The decoder output message is distinguished from the original as m*. The user can run one cycle or many. Long cycle averaging is often useful. A message box summarizes the BER (bit error rate) results across all cycles. The user can output the metrics and basic streams for one chosen cycle to the worksheet. The coder output is modified to include errors. This simulates the effect of random noise in a transmission channel. The user can set specific errors in exact positions or apply random errors throughout to a specified bit error rate. Recall that error bit positions apply to the output of the coder and that the number of bits there will be double that of the message input. The display streams are labeled. The user can display the metrics and streams for a cycle. The streams are: m is the original message input to the coder. c is the coded output from the coder without any errors. r is the received version of the coder output with the applied errors. m* is the decoder output, the recovered message. The VBA Code The code is provided below in one complete module. Copy the code into a standard module. Set options in the top procedure RunCoding, then run that procedure to obtain a summary of error correcting results. The process will clear Sheet1, so be sure that no other essential work is located there. As an example of setting the options, assume that the intention is to test the performance of the 7,5 configuration with both random inputs and random errors to BER 0.01. Proceed as follows: Set nCodePolyGen= 75 to select the 111,101 configuration, nModeNumber = 8 for random inputs with random errors, nAutoCycles = 100 for the average of 100 blocks, nLenAutoInput = 500 to use five hundred bits in each input block, nNumCdrFlushBits = 3 to add flushing bits at end of each input block, sngBER = 0.01 to apply one percent errors, Other options can be ignored for this task. Run the procedure RunCodingC. Output for the first cycle will be displayed on sheet one, and a summary for the changed BER across the decoder will appear on a message box when the run is complete.. Re-save the code or press the editor's reset button between runs with new parameters. The Module Modification 14/Aug/18; removed column numbers restriction. User responsibility now. Code Functional 11/Aug/18. Modification 11/Aug/18; corrected ColourTheErrors() procedure. Modification 23/Mar/18; removed subroutine Notes as redundant. Modification 03/Nov/17; added back path edge stream to sheet display. Modification 01/Nov/17; corrected coding errors. Modification 31/Oct/17; added back path coloring. Option Explicit Sub RunCodingC() ' FOR CLOSENESS METHODS ' Run this procedure with chosen in-code settings to study the cross-decoder performance. ' Runs a Viterbi convolutional coder-decoder simulation for two rate 1/2 algorithms. ' Coder 7,6: Rate 1/2, constraint=3, gen polynomials top=(111) and bottom=(110), Dfree=4. ' Coder 7,5: Rate 1/2, constraint=3, gen polynomials top=(111) and bottom=(101), Dfree=5. ' Decoders; Viterbi to match each coder. VBA is coded for CLOSENESS as opposed to Hamming DISTANCE. ' Message inputs can be specified exactly, or randomly with chosen length. ' Error insertion can be exact, or random to a specified BER. Various error pair options exist. ' User set number of cycles and output choice. Message box for an all-cycle summary. Notes: ' The 7,5 coding algorithm with the higher "free distance" = 5 is better than 7,6's with FD = 4. ' Configuration (7,6) handles single bit errors with error free gaps of at least six bits. ' Configuration (7,6) handles some errored pairs in a limited way for some input conditions. ' Configuration (7,5) handles single bit errors with error free gaps of at least five bits. ' Configuration (7,5) handles errored pairs also, with error free gaps of about 12 -15 bits between such pairs. ' Performance Compared: Random Inputs with Random Errors: For 1Mb total input: ' (7,6): BER 1E-3 in, 4E-6 out: BER 1E-2 in, 6E-4 out. ' (7,5): BER 1E-3 in, 1E-6 out: BER 1E-2 in, 3E-5 out. Assignments: Dim oSht As Worksheet, vArr As Variant, vEM As Variant, bLucky As Boolean, vDisp As Variant Dim sngBerDecIn As Single, sngBER As Single, sngBerMOut As Single, nModeNumber As Integer Dim LB1 As Long, UB1 As Long, x As Long, nClearErrGap As Long, nNumCdrFlushBits As Long Dim m As Long, nLenAutoInput As Long, nAutoCycles As Long, rd As Long, cd As Long Dim r As Long, nLenStream As Long, nMErr As Long, nTotMErr As Long, nTotDIErr As Long Dim nTotLenStream As Long, nDErr As Long, nLenIntoDec As Long, nCycleToDisplay As Long Dim nTotMBSent As Long, nTotEBMess As Long, nNumDEPC As Long, nFirst As Long, nCodePolyGen As Integer Dim sDecodedMessage As String, sDM As String, sChannelRx As String, sChannelTx As String, sEdges As String Dim sCodedMessage As String, sMessage As String, sMW As String, sFctr As String, vT As Variant On Error GoTo ErrorHandler UserSettings: ' Set sheet 1 for output as text ' worksheet will be cleared and overwritten between runs Set oSht = ThisWorkbook.Worksheets("Sheet1") ' format sheet cells With oSht.Columns .NumberFormat = "@" .Font.Size = 16 End With oSht.Cells(1, 1).Select ' ================================================================================================================ ' ===========================MODE NUMBER DESCRIPTIONS============================================================= ' MODE 1 ' manual coder input- type string into variable sMessage ' manual decoder input errors-typed into array variable list vEM ' MODE 2 ' manual coder input- type string into variable sMessage ' regular spacing of errors throughout, set gap between two errors ' in nClearErrGap and start position for first in nFirst ' MODE 3 ' manual coder input- type string into variable sMessage ' one pair of errors only, gap between two errors is random and start ' position for first is set with nFirst- adjusts to input length ' MODE 4 ' manual coder input- type string into variable sMessage ' auto decoder input errors- random errors with BER (bit error rate) ' set in sngBER ' MODE 5 ' auto coder input- random input- length set in variable nLenAutoInput ' manual decoder input errors-typed into array variable list vEM ' MODE 6 ' auto coder input- random input- length set in variable nLenAutoInput ' regular spacing of errors throughout, set gap between two errors in ' nClearErrGap and start position for first in nFirst ' MODE 7 ' auto coder input- random input- length set in variable nLenAutoInput ' one pair of errors only, gap between two errors is random and start ' position for first is set with nFirst- adjusts to input length ' MODE 8 ' auto coder input- random input- length set in variable nLenAutoInput ' auto decoder input errors- random errors with BER (bit error rate) ' set in sngBER ' MODE 9 ' manual coder input- type string into variable sMessage ' no errors at all - no need to touch error settings ' -goes round error insertion ' MODE 10 ' auto coder input- random input- length set in variable nLenAutoInput ' no errors at all - no need to touch error settings ' -goes round error insertion ' ================================================================================================================ ' ===========================SET WORKING MODE HERE================================================================ nCodePolyGen = 76 ' options so far are 76 for (2,1,3)(111,110) or 75 for (2,1,3)(111,101) nModeNumber = 1 ' see meanings above ' ================================================================================================================ ' ===========================COMMON PARAMETERS==================================================================== nAutoCycles = 1 ' set the number of cycles to run nCycleToDisplay = nAutoCycles ' choose the cycle number for the metrics sheet output ' ================================================================================================================ ' ===========================RANDOM INPUT BLOCK LENGTH============================================================ ' USER SET BIT LENGTH FOR INPUT TO CODER - THE MESSAGE INPUT nLenAutoInput = 20 ' there will be double this number at decoder input ' ================================================================================================================ ' ===========================MANUAL INPUT SETTINGS================================================================ sMessage = "10110" ' for the Wiki page example ' sMessage = "10000" ' gives impulse response 11 10 11 ...00 00 00 for 7,5 ' sMessage = "10000" ' gives impulse response 11 11 10 ...00 00 00 for 7,6 ' ================================================================================================================= ' ===========================SET BER, POSITIONS AND GAPS=========================================================== nClearErrGap = 5 ' modes 2,3,7,and 6 to set an error gap nNumCdrFlushBits = 2 ' modes 2,3,4,6,7,and 8 to apply message end flushing sngBER = 0.1 ' modes 4 and 8 to insert specified bit error rate at decoder input nFirst = 5 ' modes 2,3,6,and 7 to set the first error position at decoder input ' ================================================================================================================= ' ===========================MANUALLY SET ERROR PARAMETERS========================================================= ' MANUALLY SET ERROR POSITIONS - arrange list in increasing order. Applies at decoder input ' vEM = Array(21, 28, 35, 42, 49, 56, 62) 'for (7,6). Single errors with gaps of 6 error free bits ' vEM = Array(21, 27, 33, 39, 45, 52, 59) 'for (7,5). Single errors with gaps of 5 error free bits ' vEM = Array(21, 22, 36, 37, 52, 53, 68, 69) 'for (7,5). 4 double errors with gaps around 12 error free bits ' vEM = Array(20, 21) vEM = Array(3, 9) ' ================================================================================================================= ' ================================================================================================================= WORKING: ' CYCLE COUNT DISPLAY SPECIFIC OVERRIDES Select Case nModeNumber Case 1, 2, 9 nAutoCycles = 1 ' some modes need only single cycle nCycleToDisplay = 1 End Select Application.DisplayStatusBar = True ' RUN A SPECIFIED NUMBER OF CYCLES For r = 1 To nAutoCycles DoEvents ' interrupt to handle system requests Application.StatusBar = (r * 100) \ nAutoCycles & " Percent complete" ' CODE the message stream ' Decide how input is produced for each mode ' and add three zeros for FLUSHING Select Case nModeNumber Case 1, 2, 3, 4, 9 If Len(sMessage) < 2 Then MsgBox "Manual input string sMessage is too short - closing": Exit Sub sMW = sMessage & String(nNumCdrFlushBits, "0") ' manually typed message into an array list Case 5, 6, 7, 8, 10 If nLenAutoInput < 2 Then MsgBox "Short string length specified -closing": Exit Sub sMW = AutoRandomInputC(nLenAutoInput) & String(nNumCdrFlushBits, "0") ' auto random message End Select ' CODER ' obtain a coded message from the input Select Case nCodePolyGen Case 76 ConvolutionalCoderT7B6C sMW, sCodedMessage Case 75 ConvolutionalCoderT7B5C sMW, sCodedMessage Case Else MsgBox "Chosen algorithm not found - closing" Exit Sub End Select sChannelTx = sCodedMessage ' check that manual error selection will fit the stream ' auto errors have own checks Select Case nModeNumber Case 1, 5 LB1 = LBound(vEM, 1): UB1 = UBound(vEM, 1) ' check whether positions are possible For x = LB1 To UB1 If vEM(x) > (2 * Len(sMW)) Then MsgBox "Manually selected bit positions don't fit the stream." & vbCrLf & _ "Increase input length or change the bit positions." & vbCrLf & _ "Closing." Exit Sub End If Next x End Select ' ERRORS ' ADD ERRORS to sChannelTX to simulate channel noise ' Decide how errors are inserted for each mode Select Case nModeNumber Case 1, 5 ' manual error assignment sChannelRx = AddFixedErrsC(sChannelTx, vEM) Case 2, 6 ' two error spacing, manual gap and start sChannelRx = FixedSpacedErrorsC(sChannelTx, nFirst, nClearErrGap, 0) Case 3, 7 ' two errors only, random gap and manual start sChannelRx = TwoErrOnlyRndGapC(sChannelTx, nFirst, 0) Case 4, 8 ' auto random errors to manual BER setting sChannelRx = InsertBERRndC(sChannelTx, sngBER, 0) Case 9, 10 ' no errors at all sChannelRx = sChannelTx End Select ' DECODER ' DECODE the errored bit stream - proc uses Viterbi algorithm Select Case nCodePolyGen Case 76 ConvolutionalDecodeC sChannelRx, sDecodedMessage, sEdges, bLucky, 76, vArr, vT Case 75 ConvolutionalDecodeC sChannelRx, sDecodedMessage, sEdges, bLucky, 75, vArr, vT Case Else MsgBox "Configuration not defined - 75 or 76 only - closing" Exit Sub End Select sDM = sDecodedMessage ' SELECTIVE DISPLAY FOR SHEET - display for any ONE cycle If Application.ScreenUpdating = True Then Application.ScreenUpdating = False If r = nCycleToDisplay And nCycleToDisplay <> 0 Then oSht.Activate oSht.Cells.ClearContents 'remove text oSht.Cells.Interior.Pattern = xlNone 'remove color fill ' chosen run metrics to sheet For rd = LBound(vArr, 2) To UBound(vArr, 2) For cd = LBound(vArr, 1) To UBound(vArr, 1) oSht.Cells(rd, cd + 1) = CStr(vArr(cd, rd)) Next cd Next rd With oSht ' block in unused nodes and add notes .Cells(1, 1) = "0" .Cells(2, 1) = "*" .Cells(3, 1) = "*" .Cells(4, 1) = "*" .Cells(2, 2) = "*" .Cells(4, 2) = "*" .Cells(12, 1) = "Notes:": .Cells(12, 2) = "Currently using (" & nCodePolyGen & ") configuration." .Cells(13, 1) = "m:" .Cells(14, 1) = "c:" .Cells(15, 1) = "r:" .Cells(16, 1) = "r*:" .Cells(17, 1) = "m*:" .Cells(13, 2) = "The original message stream:" .Cells(14, 2) = "The coded output stream:" .Cells(15, 2) = "The coded output with any channel errors in magenta:" .Cells(16, 2) = "The back path edge values:" .Cells(17, 2) = "The recovered message with any remaining errors in red:" .Cells(18, 2) = "The decoder back path is shown in yellow:" End With oSht.Range(Cells(13, 2), Cells(18, 2)).Font.Italic = True DigitsToSheetRowC sMW, 1, 6, "m" ' message in DigitsToSheetRowC sChannelTx, 2, 7, "c" ' correctly coded message DigitsToSheetRowC sChannelRx, 2, 8, "r" ' coded message as received DigitsToSheetRowC sEdges, 2, 9, "r*" ' back path edge values DigitsToSheetRowC sDecodedMessage, 1, 10, "m*" ' message out ' tint the back path cells For cd = LBound(vT, 1) To UBound(vT, 1) ' MsgBox vT(cd, 1) & " " & vT(cd, 2) oSht.Cells(vT(cd, 1), vT(cd, 2) + 1).Interior.Color = RGB(249, 216, 43) ' yellow-orange Next cd End If ' IN-LOOP DATA COLLECTION ' ACCUMULATE DATA across all cycles nMErr = NumBitsDifferentC(sMW, sDM, nLenStream) ' message errors single cycle nDErr = NumBitsDifferentC(sChannelRx, sChannelTx, nLenIntoDec) ' num decoder input errors single cycle nTotLenStream = nTotLenStream + nLenStream ' accum num message bits all cycles nTotMErr = nTotMErr + nMErr ' accum num message error bits all cycles nTotDIErr = nTotDIErr + nDErr ' accum num decoder input errors all cycles ' reset cycle error counters nDErr = 0: nDErr = 0 Next r ' end of main cycle counter Transfers: ' HIGHLIGHT ERRORS ON WORKSHEET - message bit errors red, changes to back path magenta ColourTheErrors Len(sMW) 'colours length of input block plus flushing ' PREPARE ALL-CYCLE SUMMARY nTotMBSent = nTotLenStream ' accum num message bits all cycles nTotEBMess = nTotMErr ' accum num message err bits all cycles nNumDEPC = nTotDIErr / nAutoCycles ' num input errors added decoder input each cycle sngBerDecIn = Round(nTotDIErr / (nTotMBSent * 2), 10) ' channel BER decoder input all cycles sngBerMOut = Round(nTotEBMess / nTotMBSent, 10) ' message BER decoder output all cycles If sngBerMOut = 0 Then sFctr = "Perfect" Else sFctr = Round(sngBerDecIn / sngBerMOut, 1) ' BER improvement across decoder End If ' OUTPUT SUMMARY MsgBox "Total of all message bits sent : " & nTotMBSent & vbCrLf & _ "Total errored bits in all received messages : " & nTotEBMess & vbCrLf & _ "Number channel errors per cycle : " & nNumDEPC & " in block lengths of : " & nLenIntoDec & vbCrLf & _ "BER applied over all decoder input : " & sngBerDecIn & " : " & sngBerDecIn * 100 & "%" & vbCrLf & _ "BER for all messages out of decoder : " & sngBerMOut & " : " & sngBerMOut * 100 & "%" & vbCrLf & _ "Improvement factor across decoder : " & sFctr ' RESETS If Application.ScreenUpdating = False Then Application.ScreenUpdating = True Application.StatusBar = "" Exit Sub ErrorHandler: If Err.Number <> 0 Then Select Case Err.Number Case 13 ' early exit for certain settings mistakes Err.Clear Exit Sub Case Else MsgBox "Error number: " & Err.Number & vbNewLine & _ "Error source: " & Err.Source & vbNewLine & _ "Description: " & Err.Description & vbNewLine Err.Clear Exit Sub End Select End If End Sub Function ConvolutionalCoderT7B5C(ByVal sInBitWord As String, sOut As String) ' rate 1/2 coder; one bit in leads to two bits out ' 3 register equivalent, constraint 3 ' generator polynomials are top = (1,1,1) and bottom = (1,0,1) ' taken for output first top then bottom Dim x0 As Long, x1 As Long, x2 As Long Dim sOut7 As String, sOut5 As String Dim n As Long, sOutBitWord As String If sInBitWord = "" Or Len(sInBitWord) < 5 Then MsgBox "Longer input required for ConvolutionalCoder - closing" Exit Function End If ' itialise all registers with zeros x0 = 0: x1 = 0: x2 = 0 ' run the single input bits through the shift register For n = 1 To Len(sInBitWord) ' this includes any flushing bits DoEvents ' shift in one bit x2 = x1 ' second contents into third position x1 = x0 ' first contents into second position x0 = CLng(Mid(sInBitWord, n, 1)) ' new bit into first ' combine register outputs sOut7 = x0 Xor x1 Xor x2 ' top adder output sOut5 = x0 Xor x2 ' bottom adder output ' combine and accumulate two adder results sOutBitWord = sOutBitWord & sOut7 & sOut5 sOut = sOutBitWord Next n End Function Function ConvolutionalCoderT7B6C(ByVal sInBitWord As String, sOut As String) ' rate 1/2 coder; one bit in leads to two bits out ' 3 register equivalent, constraint 3 ' generator polynomials are top = (1,1,1) and bottom = (1,1,0) ' taken for output first top then bottom Dim x0 As Long, x1 As Long, x2 As Long Dim sOut7 As String, sOut6 As String Dim n As Long, sOutBitWord As String If sInBitWord = "" Or Len(sInBitWord) < 5 Then MsgBox "Longer input required for ConvolutionalCoder - closing" Exit Function End If ' itialise all registers with zeros x0 = 0: x1 = 0: x2 = 0 ' run the single input bits through the shift register For n = 1 To Len(sInBitWord) ' this includes any flushing bits DoEvents ' shift in one bit x2 = x1 ' second contents into third position x1 = x0 ' first contents into second position x0 = CLng(Mid(sInBitWord, n, 1)) ' new bit into first ' combine register outputs sOut7 = x0 Xor x1 Xor x2 ' top adder output sOut6 = x0 Xor x1 ' bottom adder output ' combine and accumulate two adder results sOutBitWord = sOutBitWord & sOut7 & sOut6 sOut = sOutBitWord Next n End Function Function FixedSpacedErrorsC(ByVal sIn As String, ByVal nStart As Long, ByVal nErrFreeSpace As Long, _ nTail As Long, Optional nErrCount As Long) As String ' returns parameter input string in function name with errors added ' at fixed intervals, set by nERRFreeSpace, the error free space between errors, ' and sequence starts with position nStart. Total number of errors placed is found in option parameter nErrCount ' nTail is the number of end bits to keep clear of errors. Dim n As Long, nLen As Long, nWLen As Long, sAccum As String, c As Long, sSamp As String, nModBit As Long ' check for an empty input string If sIn = "" Then MsgBox "Empty string input in FixedSpacedErrors - closing" Exit Function End If ' get length of input less tail piece nWLen = Len(sIn) - nTail ' check length of input sufficient for parameters If nWLen - nStart < nErrFreeSpace + 1 Then MsgBox "Input too short in FixedSpacedErrors - increase length -closing" Exit Function End If ' accum the part before the start error sAccum = Mid$(sIn, 1, nStart - 1) ' modify the bit in start position and accum result sSamp = Mid$(sIn, nStart, 1) nModBit = CLng(sSamp) Xor 1 sAccum = sAccum & CStr(nModBit) nErrCount = 1 ' count one error added ' insert fixed interval errors thereafter For n = nStart + 1 To nWLen sSamp = Mid$(sIn, n, 1) c = c + 1 If c = nErrFreeSpace + 1 And n <= nWLen Then ' do the stuff c = 0 nModBit = CLng(sSamp Xor 1) sAccum = sAccum & CStr(nModBit) nErrCount = nErrCount + 1 Else sAccum = sAccum & sSamp End If Next n FixedSpacedErrorsC = sAccum End Function Function TwoErrOnlyRndGapC(ByVal sIn As String, ByVal nStart As Long, ByVal nTail As Long) As String ' returns input string in function name with only 2 added errors, the first at parameter position and ' the second after a random gap. ' nTail is the number of end bits to keep clear of errors. Dim nReqNumErr As Long, nSample As Long, r As Long, c As Long Dim vA() As Long, nRange As Long, nCount As Long, sAccum As String ' find length free of tail bits nRange = Len(sIn) - nTail ' check that sIn is long enough If nRange < nStart + 1 Then MsgBox "sIn too short for start point in TwoErrOnlyRndGap - closing" Exit Function End If ' set number of errors needed nReqNumErr = 2 ' one start and one random ' dimension an array to hold the work ReDim vA(1 To Len(sIn), 1 To 3) ' load array col 1 with the input bits ' and mark the start bit for error For r = LBound(vA, 1) To UBound(vA, 1) vA(r, 1) = CLng(Mid$(sIn, r, 1)) If r = nStart Then ' mark start bit with flag vA(r, 2) = 1 End If Next r ' mark intended positions until right number of ' non-overlapping errors is clear Do Until nCount = nReqNumErr nCount = 0 ' since first err in place DoEvents ' get a sample of row numbers in the working range nSample = Int((nRange - (nStart + 1) + 1) * Rnd + (nStart + 1)) ' error flag added to col 2 of intended row vA(nSample, 2) = 1 ' 1 denotes intention ' run through array col 1 For c = LBound(vA, 1) To UBound(vA, 1) ' count all intention markers so far If vA(c, 2) = 1 Then nCount = nCount + 1 End If Next c Loop ' when num errors is right modify the ones flagged For r = LBound(vA, 1) To UBound(vA, 1) sAccum = sAccum & CStr(vA(r, 1) Xor vA(r, 2)) Next r TwoErrOnlyRndGapC = sAccum End Function Function AddFixedErrsC(ByVal sIn As String, vA As Variant) As String ' returns string in function name with errors added in fixed positions. ' positions are set by one dimensional list in vA array Dim c As Long, nPosition As Long, UB1 As Long, LB1 As Long Dim sSamp As String, sWork As String, sSamp2 As String, sAccum As String LB1 = LBound(vA, 1): UB1 = UBound(vA, 1) sWork = sIn For nPosition = LB1 To UB1 ' 0 to 2 eg For c = 1 To Len(sWork) sSamp = Mid$(sWork, c, 1) If c = vA(nPosition) Then sSamp2 = (1 Xor CLng(sSamp)) sAccum = sAccum & sSamp2 Else sAccum = sAccum & sSamp End If Next c sWork = sAccum sAccum = "" Next nPosition AddFixedErrsC = sWork End Function Function InsertBERRndC(ByVal sIn As String, ByVal BER As Single, ByVal nTail As Long) As String ' returns input string of bits with added random errors in function name ' number of errors depends on length of sIn and BER parameter ' Set nTail to zero to apply errors to flushing bits too Dim nReqNumErr As Long, nSample As Long, r As Long, c As Long Dim vA() As Long, nRange As Long, nCount As Long, sAccum As String ' find length free of nTail eg, remove flushing nRange = Len(sIn) - nTail ' find number of errors that are needed nReqNumErr = CLng(BER * nRange) ' Clng rounds fractions If nReqNumErr < 1 Then MsgBox "Requested error rate produces less than one error in InsertBERRnd" & vbCrLf & _ "Increase stream length, or reduce BER, or both - closing" Exit Function End If ' dimension an array to hold the work ReDim vA(1 To Len(sIn), 1 To 3) ' load array col 1 with the input bits For r = LBound(vA, 1) To UBound(vA, 1) vA(r, 1) = CLng(Mid$(sIn, r, 1)) Next r ' mark intended positions until right number of ' non-overlapping errors is clear Do Until nCount = nReqNumErr nCount = 0 DoEvents ' get a sample of row numbers in the working range nSample = Int((nRange - 1 + 1) * Rnd + 1) ' error flag added to col 2 of intended row vA(nSample, 2) = 1 ' 1 denotes intention ' run through array col 1 For c = LBound(vA, 1) To UBound(vA, 1) ' count all intention markers so far If vA(c, 2) = 1 Then nCount = nCount + 1 End If Next c Loop ' when num errors is right modify the ones flagged For r = LBound(vA, 1) To UBound(vA, 1) sAccum = sAccum & CStr(vA(r, 1) Xor vA(r, 2)) Next r InsertBERRndC = sAccum End Function Sub ConvolutionalDecodeC(ByVal sIn As String, sOut As String, sOut2 As String, bAmbiguous As Boolean, _ nConfiguration As Long, vRet As Variant, vTint As Variant) ' works with rate 1/2 coder; one bit in leads to two bits out ' 3 register equivalent, constraint 3, generator polynomials are top = (1,1,1) and bottom = (1,1,0) for 7,6 ' and (1,1,1) and (1,0,1) for 7,5, selected by parameter nConfiguration= 75 or 76. ' NOTES: All calculations of metrics use maximum closeness as opposed to Hamming distance. ' In branch estimates the lowest total is always discarded. ' If branch metrics are equal, discard the bottom of the two incoming branches. ' Working for metrics assumes position at node with two incoming branches. ' Back track starts at last column's metric maximum then follows survivor paths ' back to state "a" time zero. Dim aV() As String, vH As Variant, sWIn As String, sPrevStateAccumL As String, sPrevStateAccumU As String Dim nStartR As Long, nStartC As Long, sEdgeBits As String, sInputBit As String Dim r As Long, c As Long, nSwapR As Long, nSwapC As Long Dim nVert As Long, nTime As Long, bUpperPath As Boolean, vW As Variant Dim sAccumEdgeValues As String, sAccumImpliesBits As String Dim sCurrState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, sLSOut As String Dim sBitU As String, sBitL As String, sRcdBits As String, nNumTrans As Long Dim sProposedAccumU As String, sProposedAccumL As String, sDiscardedU As String, sDiscardedL As String Dim sNodeAccum As String, sBackStateU As String, sBackStateL As String, nNumHighs As Long ' check that number received is even sWIn = sIn If Len(sWIn) Mod 2 = 0 Then nNumTrans = Len(sWIn) / 2 Else MsgBox "Odd bit pairing at input decoder -closing" Exit Sub End If ' dimension arrays Erase aV() ReDim aV(0 To nNumTrans, 1 To 4, 1 To 3) ' x transitions, y states, z node data ReDim vH(1 To 4, 1 To 3) ' r states, c node data ReDim vW(0 To nNumTrans, 1 To 4) ' r transitions, c states ReDim vTint(0 To nNumTrans, 1 To 2) aV(0, 1, 3) = "0" ' set metric for zero node ' CYCLE LOOP For nTime = 1 To nNumTrans For nVert = 1 To 4 DoEvents ' Get incoming branch data for current node If nConfiguration = 75 Then GeneralDataT7B5C nVert, sCurrState, sPrevStateU, sPrevStateL, sUSOut, sLSOut, sBitU, sBitL ElseIf nConfiguration = 76 Then GeneralDataT7B6C nVert, sCurrState, sPrevStateU, sPrevStateL, sUSOut, sLSOut, sBitU, sBitL End If ' Get the received bits for the incoming transition sRcdBits = Mid$(sWIn, (nTime * 2) - 1, 2) ' get the current node's previous states' metrics If sCurrState = "a" And sPrevStateU = "a" Then sPrevStateAccumU = aV(nTime - 1, 1, 3) If sCurrState = "a" And sPrevStateL = "b" Then sPrevStateAccumL = aV(nTime - 1, 2, 3) If sCurrState = "b" And sPrevStateU = "c" Then sPrevStateAccumU = aV(nTime - 1, 3, 3) If sCurrState = "b" And sPrevStateL = "d" Then sPrevStateAccumL = aV(nTime - 1, 4, 3) If sCurrState = "c" And sPrevStateU = "a" Then sPrevStateAccumU = aV(nTime - 1, 1, 3) If sCurrState = "c" And sPrevStateL = "b" Then sPrevStateAccumL = aV(nTime - 1, 2, 3) If sCurrState = "d" And sPrevStateU = "c" Then sPrevStateAccumU = aV(nTime - 1, 3, 3) If sCurrState = "d" And sPrevStateL = "d" Then sPrevStateAccumL = aV(nTime - 1, 4, 3) ' NOTE ON EXCEPTIONS ' Exceptions for transitions 0, 1 and 2. Some redundant, or fewer than two incoming branches. ' Nodes with single incoming branches; mark blind branches same edge value as existing edge, ' and mark their previous metrics as zeros. Because policy for choosing equal metrics is always ' to discard the bottom one, exceptions can then be handled in same loop. ' Zero column is handled entirely by settings for transition 1. ' Apply exceptions settings If nConfiguration = 75 Then FrontExceptions75C nTime, nVert, sLSOut, sUSOut, sPrevStateAccumL, sPrevStateAccumU ElseIf nConfiguration = 76 Then FrontExceptions76C nTime, nVert, sLSOut, sUSOut, sPrevStateAccumL, sPrevStateAccumU End If ' Calculate incoming branch metrics and add their previous path metrics to each sProposedAccumU = GetProposedAccumC(sRcdBits, sUSOut, sPrevStateAccumU) sProposedAccumL = GetProposedAccumC(sRcdBits, sLSOut, sPrevStateAccumL) ' Decide between the two proposed metrics for the current node ' Accept the higher value branch metric and discard the other ' If same in value, choose the top branch and discard the bottom. If CLng(sProposedAccumU) > CLng(sProposedAccumL) Then sDiscardedL = "Discard": sDiscardedU = "Keep" sNodeAccum = sProposedAccumU ElseIf CLng(sProposedAccumU) < CLng(sProposedAccumL) Then sDiscardedL = "Keep": sDiscardedU = "Discard" sNodeAccum = sProposedAccumL ElseIf CLng(sProposedAccumU) = CLng(sProposedAccumL) Then sDiscardedL = "Discard": sDiscardedU = "Keep" sNodeAccum = sProposedAccumU End If ' Update the node array with the discard data aV(nTime, nVert, 1) = sDiscardedU ' whether or not upper incoming discarded aV(nTime, nVert, 2) = sDiscardedL ' whether or not lower incoming discarded ' Update the node array with the value of path metric for the current node aV(nTime, nVert, 3) = sNodeAccum ' update work array with metric ' Update return work array with node metric value vW(nTime, nVert) = CLng(sNodeAccum) ' update return display array with metric Next nVert Next nTime ' Transfer last column metric values to a work array c = nNumTrans ' the last column number For r = 1 To 4 ' number of rows in every column vH(r, 1) = CLng(aV(c, r, 3)) ' metrics vH(r, 2) = CLng(c) ' column where metric found in main array vH(r, 3) = CLng(r) ' row where metric found in main array Next r ' Sort the last column values to place highest metric at top SortMetricsArr2D1KeyC vH, 0, 1, 1 ' and assoc recs are in same row ' Detect start point ambiguity for possible future use ' Count number of entries with same high value in column nNumHighs = 0 For r = 1 To 4 ' number rows in every column If vH(1, 1) = vH(r, 1) Then nNumHighs = nNumHighs + 1 Next r If nNumHighs > 1 Then bAmbiguous = True ' Note the row and column numbers for the back path start point nStartR = CLng(vH(1, 3)) ' retrieve row number nStartC = CLng(vH(1, 2)) ' retrieve col number ' add coordinates to vTint vTint(nStartC, 1) = nStartR vTint(nStartC, 2) = nStartC ' BACK PATH ' Navigate the back path and extract its data Do Until nStartC <= 0 DoEvents ' allow system requests ' Find survivor path into this node ' if upperpath is open... If aV(nStartC, nStartR, 1) = "Keep" Then bUpperPath = True Else bUpperPath = False ' if lower path is open... If aV(nStartC, nStartR, 2) = "Keep" Then bUpperPath = False Else bUpperPath = True ' Get present state sCurrState = GetStateFmRowC(nStartR) ' Use present state name to fetch the output bits If nConfiguration = 75 Then GetOutputBitsT7B5C sCurrState, bUpperPath, sEdgeBits, sInputBit ElseIf nConfiguration = 76 Then GetOutputBitsT7B6C sCurrState, bUpperPath, sEdgeBits, sInputBit Else MsgBox "Configuration not defined" End If ' Accumulate output and input values for hop sAccumEdgeValues = sEdgeBits & sAccumEdgeValues ' edge values -not used sAccumImpliesBits = sInputBit & sAccumImpliesBits ' decoded message -used ' Get array coordinates for next node in back path If nConfiguration = 75 Then GetPosOfSourceT7B5C nStartR, nStartC, bUpperPath, nSwapR, nSwapC ElseIf nConfiguration = 76 Then GetPosOfSourceT7B6C nStartR, nStartC, bUpperPath, nSwapR, nSwapC Else MsgBox "Configuration not defined" End If ' Update the new position coordinates for the next hop nStartR = nSwapR nStartC = nSwapC ' add coordinates to vTint vTint(nStartC, 1) = nStartR vTint(nStartC, 2) = nStartC Loop Transfers: ReDim vRet(LBound(vW, 1) To UBound(vW, 1), LBound(vW, 2) To UBound(vW, 2)) vRet = vW sOut = sAccumImpliesBits 'single bit message from back path sOut2 = sAccumEdgeValues 'double bit back path edge outputs End Sub Function GetStateFmRowC(nRow As Long) As String ' returns alpha name of state for parameter ' row position in trellis column Select Case nRow Case 1 GetStateFmRowC = "a" Case 2 GetStateFmRowC = "b" Case 3 GetStateFmRowC = "c" Case 4 GetStateFmRowC = "d" End Select End Function Function FrontExceptions75C(ByVal nT As Long, ByVal nV As Long, _ sLSO As String, sUSO As String, sPSAL As String, sPSAU As String) As Boolean ' applies the exceptions for configuration 7,5 - applies to closeness only If nT = 1 And nV = 1 Then sLSO = "00": sUSO = "00": sPSAL = "0": sPSAU = "0" ElseIf nT = 1 And nV = 3 Then sLSO = "11": sUSO = "11": sPSAL = "0": sPSAU = "0" ElseIf nT = 2 And nV = 1 Then sLSO = "00": sUSO = "00": sPSAL = "0" ElseIf nT = 2 And nV = 2 Then sLSO = "10": sUSO = "10": sPSAL = "0" ElseIf nT = 2 And nV = 3 Then sLSO = "11": sUSO = "11": sPSAL = "0" ElseIf nT = 2 And nV = 4 Then sLSO = "01": sUSO = "01": sPSAL = "0" End If FrontExceptions75C = True End Function Function FrontExceptions76C(ByVal nT As Long, ByVal nV As Long, _ sLSO As String, sUSO As String, sPSAL As String, sPSAU As String) As Boolean ' applies the exceptions for configuration 7,5 -applies to closeness only If nT = 1 And nV = 1 Then sLSO = "00": sUSO = "00": sPSAL = "0": sPSAU = "0" ElseIf nT = 1 And nV = 3 Then sLSO = "11": sUSO = "11": sPSAL = "0": sPSAU = "0" ElseIf nT = 2 And nV = 1 Then sLSO = "00": sUSO = "00": sPSAL = "0" ' arbitrarily high ElseIf nT = 2 And nV = 2 Then sLSO = "11": sUSO = "11": sPSAL = "0" ElseIf nT = 2 And nV = 3 Then sLSO = "11": sUSO = "11": sPSAL = "0" ElseIf nT = 2 And nV = 4 Then sLSO = "00": sUSO = "00": sPSAL = "0" End If FrontExceptions76C = True End Function Function SortMetricsArr2D1KeyC(ByRef vA As Variant, _ Optional ByVal bIsAscending As Boolean = True, _ Optional ByVal bIsRowSort As Boolean = True, _ Optional ByVal SortIndex As Long = -1, _ Optional ByRef vRet As Variant) As Boolean ' -------------------------------------------------------------------------------- ' Procedure : Sort2DArr ' Purpose : Bubblesorts a 2D array on 1 key, up or down, on any column or row. ' Options include in-place, with the source changed, or ' returned in vRet, with the source array intact. ' Optional parameters default to: ROW SORT in place, ASCENDING, ' using COLUMN ONE as the key. ' -------------------------------------------------------------------------------- Dim condition1 As Boolean, vR As Variant Dim i As Long, j As Long, y As Long, t As Variant Dim loR As Long, hiR As Long, loC As Long, hiC As Long Dim bWasMissing As Boolean ' find bounds of vA data input array loR = LBound(vA, 1): hiR = UBound(vA, 1) loC = LBound(vA, 2): hiC = UBound(vA, 2) ' find whether optional vR was initially missing bWasMissing = IsMissing(vRet) ' If Not bWasMissing Then Set vRet = Nothing ' check input range of SortIndex If bIsRowSort And (SortIndex < loC Or SortIndex > hiC) Then MsgBox "SortIndex out of bounds in Sort2DArr; closing now" Exit Function Else: End If If Not bIsRowSort And (SortIndex < loR Or SortIndex > hiR) Then MsgBox "SortIndex out of bounds in Sort2DArr; closing now" Exit Function Else: End If ' pass to a work variable vR = vA ' steer input options If bIsRowSort Then GoTo ROWSORT Else GoTo COLSORT ROWSORT: For i = loR To hiR - 1 For j = loR To hiR - 1 If bIsAscending Then condition1 = vR(j, SortIndex) > vR(j + 1, SortIndex) Else condition1 = vR(j, SortIndex) < vR(j + 1, SortIndex) End If If condition1 Then For y = loC To hiC t = vR(j, y) vR(j, y) = vR(j + 1, y) vR(j + 1, y) = t Next y End If Next Next GoTo Transfers COLSORT: For i = loC To hiC - 1 For j = loC To hiC - 1 If bIsAscending Then condition1 = vR(SortIndex, j) > vR(SortIndex, j + 1) Else condition1 = vR(SortIndex, j) < vR(SortIndex, j + 1) End If If condition1 Then For y = loR To hiR t = vR(y, j) vR(y, j) = vR(y, j + 1) vR(y, j + 1) = t Next y End If Next Next GoTo Transfers Transfers: ' decide whether to return in vA or vRet If Not bWasMissing Then ' vRet was the intended return array ' so return vRet leaving vA intact vRet = vR Else: ' vRet is not intended return array ' so reload vA with vR vA = vR End If ' set return function value SortMetricsArr2D1KeyC = True End Function Function GeneralDataT7B5C(nVert As Long, sCState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, _ sLSOut As String, sBitU As String, sBitL As String) As Boolean ' takes as input nVert as position in trellis column and returns various data for that state Select Case nVert Case 1 sCState = "a": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "00": sLSOut = "11": sBitU = "0": sBitL = "0" Case 2 sCState = "b": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "10": sLSOut = "01": sBitU = "0": sBitL = "0" Case 3 sCState = "c": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "11": sLSOut = "00": sBitU = "1": sBitL = "1" Case 4 sCState = "d": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "01": sLSOut = "10": sBitU = "1": sBitL = "1" Case Else End Select GeneralDataT7B5C = True End Function Function GeneralDataT7B6C(nVert As Long, sCState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, _ sLSOut As String, sBitU As String, sBitL As String) As Boolean ' takes as input nVert as position in trellis column and returns various data for that state Select Case nVert Case 1 sCState = "a": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "00": sLSOut = "10": sBitU = "0": sBitL = "0" Case 2 sCState = "b": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "11": sLSOut = "01": sBitU = "0": sBitL = "0" Case 3 sCState = "c": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "11": sLSOut = "01": sBitU = "1": sBitL = "1" Case 4 sCState = "d": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "00": sLSOut = "10": sBitU = "1": sBitL = "1" Case Else End Select GeneralDataT7B6C = True End Function Function GetProposedAccumC(sRcd As String, sOut As String, sPrevStateAccum As String) As String ' returns one branch metric in function based on previous state metric, input, and edge value. Dim nBit As Long, n As Long, m As Long, nTemp As Long If sRcd = "" Then sRcd = "00" For n = 1 To 2 nBit = CLng(Mid$(sOut, n, 1)) Xor CLng(Mid$(sRcd, n, 1)) m = m + nBit Next n If sPrevStateAccum = "" Then sPrevStateAccum = "0" nTemp = Abs(m - 2) + CLng(sPrevStateAccum) GetProposedAccumC = CStr(nTemp) End Function Function GetOutputBitsT7B5C(sState As String, bUpper As Boolean, _ sEdgeBits As String, sInputBit As String) As Boolean ' returns edge value and input given the alpha state name ' and choice of top or bottom branch. ' Applies to incoming branches joining at the node. Select Case sState Case "a" If bUpper = True Then sEdgeBits = "00" sInputBit = "0" Else sEdgeBits = "11" sInputBit = "0" End If Case "b" If bUpper = True Then sEdgeBits = "10" sInputBit = "0" Else sEdgeBits = "01" sInputBit = "0" End If Case "c" If bUpper = True Then sEdgeBits = "11" sInputBit = "1" Else sEdgeBits = "00" sInputBit = "1" End If Case "d" If bUpper = True Then sEdgeBits = "01" sInputBit = "1" Else sEdgeBits = "10" sInputBit = "1" End If End Select GetOutputBitsT7B5C = True End Function Function GetPosOfSourceT7B5C(nNodeR As Long, nNodeC As Long, bUpper As Boolean, _ nEdgeSourceR As Long, nEdgeSourceC As Long) As Boolean ' returns the array column and row for an incoming branch, ' given its position in trellis column and choice of top or bottom branch. Dim sNodesState As String ' convert to string state names Select Case nNodeR Case 1 sNodesState = "a" Case 2 sNodesState = "b" Case 3 sNodesState = "c" Case 4 sNodesState = "d" End Select ' for c=0 only If nNodeC = 0 Then MsgBox "No source beyond zero column" Exit Function End If ' For c>0 only Select Case sNodesState Case "a" If bUpper = True Then nEdgeSourceR = 1 nEdgeSourceC = nNodeC - 1 Else nEdgeSourceR = 2 nEdgeSourceC = nNodeC - 1 End If Case "b" If bUpper = True Then nEdgeSourceR = 3 nEdgeSourceC = nNodeC - 1 Else nEdgeSourceR = 4 nEdgeSourceC = nNodeC - 1 End If Case "c" If bUpper = True Then nEdgeSourceR = 1 nEdgeSourceC = nNodeC - 1 Else nEdgeSourceR = 2 nEdgeSourceC = nNodeC - 1 End If Case "d" If bUpper = True Then nEdgeSourceR = 3 nEdgeSourceC = nNodeC - 1 Else nEdgeSourceR = 4 nEdgeSourceC = nNodeC - 1 End If End Select GetPosOfSourceT7B5C = True End Function Function DigitsToSheetRowC(ByVal sIn As String, ByVal nNumGrp As Long, _ ByVal nRow As Long, Optional ByVal sRLabel As String = "*") ' takes string of digits and an option code and distributes bits to worksheet rows Dim n As Long, c As Long, sSamp As String Dim oSht As Worksheet Set oSht = ThisWorkbook.Worksheets("Sheet1") oSht.Activate If Len(sIn) Mod nNumGrp <> 0 Then MsgBox "Missing bits for grouping in DigitsToSheetRow - closing" Exit Function End If c = 0 ' 101 010 101 010 For n = 1 To (Len(sIn) - nNumGrp + 1) Step nNumGrp DoEvents sSamp = Mid$(sIn, n, nNumGrp) c = c + 1 oSht.Cells(nRow, c + 1) = sSamp If c >= 16384 Then Exit For Next n oSht.Cells(nRow, 1) = sRLabel End Function Sub ColourTheErrors(ByVal nLen As Long) ' colors specific data to show errors ' changes to decoder pairs in magenta ' changes between input and output message in red ' marks individual received bit errors in bold yellow ' marking is limited to 256 columns to accommodate Excel 2003 Dim oSht As Worksheet, c As Long, nRow As Long Set oSht = ThisWorkbook.Worksheets("Sheet1") oSht.Activate With oSht.Cells .Font.Color = RGB(0, 0, 0) .Font.Bold = False End With 'clear colours in rows below first four to preserve backpath For nRow = 5 To 20 oSht.Rows(nRow).Cells.Interior.Pattern = xlNone Next nRow For c = 2 To nLen + 1 'this is specified length of the string for display 'Note that Excel versions have different max columns 'Up to user to get it right eg: max 256 for Excel 2003 'block with error colouring 'message errors are in red If oSht.Cells(10, c) <> oSht.Cells(6, c) Then oSht.Cells(10, c).Interior.Color = vbRed 'received channel errors magenta If oSht.Cells(7, c) <> oSht.Cells(8, c) Then oSht.Cells(8, c).Interior.Color = vbMagenta 'individual errored character colouring in yellow within magenta block If Left(oSht.Cells(8, c).Value, 1) <> Left(oSht.Cells(7, c).Value, 1) Then With oSht.Cells(8, c).Characters(1, 1).Font .Color = -16711681 .Bold = True End With End If If Right(oSht.Cells(8, c).Value, 1) <> Right(oSht.Cells(7, c).Value, 1) Then With oSht.Cells(8, c).Characters(2, 1).Font .Color = -16711681 .Bold = True End With End If Next c End Sub Function GetOutputBitsT7B6C(sState As String, bUpper As Boolean, _ sEdgeBits As String, sInputBit As String) As Boolean ' returns edge value and input given the alpha state name ' and choice of top or bottom branch. ' Applies to incoming branches joining at the node. Select Case sState Case "a" If bUpper = True Then sEdgeBits = "00" sInputBit = "0" Else sEdgeBits = "10" sInputBit = "0" End If Case "b" If bUpper = True Then sEdgeBits = "11" sInputBit = "0" Else sEdgeBits = "01" sInputBit = "0" End If Case "c" If bUpper = True Then sEdgeBits = "11" sInputBit = "1" Else sEdgeBits = "01" sInputBit = "1" End If Case "d" If bUpper = True Then sEdgeBits = "00" sInputBit = "1" Else sEdgeBits = "10" sInputBit = "1" End If End Select GetOutputBitsT7B6C = True End Function Function GetPosOfSourceT7B6C(nNodeR As Long, nNodeC As Long, bUpper As Boolean, _ nEdgeSourceR As Long, nEdgeSourceC As Long) As Boolean ' returns the array column and row for an incoming branch, ' given its position in trellis column and choice of top or bottom branch. Dim sNodesState As String ' convert to string state names Select Case nNodeR Case 1 sNodesState = "a" Case 2 sNodesState = "b" Case 3 sNodesState = "c" Case 4 sNodesState = "d" End Select ' for c=0 only If nNodeC = 0 Then MsgBox "No source beyond zero column" Exit Function End If ' For c>0 only Select Case sNodesState Case "a" If bUpper = True Then nEdgeSourceR = 1 nEdgeSourceC = nNodeC - 1 Else nEdgeSourceR = 2 nEdgeSourceC = nNodeC - 1 End If Case "b" If bUpper = True Then nEdgeSourceR = 3 nEdgeSourceC = nNodeC - 1 Else nEdgeSourceR = 4 nEdgeSourceC = nNodeC - 1 End If Case "c" If bUpper = True Then nEdgeSourceR = 1 nEdgeSourceC = nNodeC - 1 Else nEdgeSourceR = 2 nEdgeSourceC = nNodeC - 1 End If Case "d" If bUpper = True Then nEdgeSourceR = 3 nEdgeSourceC = nNodeC - 1 Else nEdgeSourceR = 4 nEdgeSourceC = nNodeC - 1 End If End Select GetPosOfSourceT7B6C = True End Function Function AutoRandomInputC(ByVal nLength As Long) As String ' makes a pseudo random string of parameter nLength Dim n As Long, sSamp As String, sAccum As String ' Int((upperbound - lowerbound + 1) * Rnd + lowerbound) Randomize Timer For n = 1 To (nLength) sSamp = CStr(Int((1 - 0 + 1) * Rnd + 0)) sAccum = sAccum & sSamp Next n AutoRandomInputC = sAccum End Function Function NumBitsDifferentC(ByVal sIn1 As String, ByVal sIn2 As String, Optional nLength As Long) As Long ' compares two binary strings of equal length ' and returns the count of the bits in function name that are different ' It is the Hamming distance between the two bit strings Dim nErr As Long, n As Long, m As Long ' check that streams are same length for comparison If Len(sIn1) <> Len(sIn2) Then MsgBox "Stream lengths do not match in StrDifference - closing" Exit Function End If ' 0 and 0 = 0 ' 0 and 1 = 1 ' 1 and 0 = 1 ' 1 and 1 = 0 For n = 1 To Len(sIn1) nErr = Abs(CLng(Mid$(sIn1, n, 1)) - CLng(Mid$(sIn2, n, 1))) m = m + nErr Next n Transfers: nLength = Len(sIn1) NumBitsDifferentC = m End Function See Also A Basic Convolutional Coding Example Viterbi Simulator in VBA 2 External Links