Visual Basic for Applications/Viterbi 模拟器 VBA 2
已经注意到一些人在不同的方式下计算格形度量。因此，此页面包含与VBA 中的 Viterbi 模拟器中相同的卷积编码函数。主要区别在于，该页面以 CLOSENESS 的形式显示其度量，而此页面则以 HAMMING 距离的形式显示。这两个代码的布局略有不同，但错误校正保持一致。.
此代码适用于 Excel。它模拟了数据通道卷积编码的行为，尽管出于必要性，它专注于简单的例子。提供了两个速率为 1/2 的系统；两者都包含三个阶段，一个用于生成多项式 (111,110)，另一个用于 (111,101)。该代码是为了提高对 Wikibooks 页面 一个基本的卷积编码示例 的理解而编写的，但对于没有其他软件的学生来说，它也可能具有基本的使用价值。该代码专注于由高斯噪声源引起的随机错误类型。在下面的下拉框中可以找到空白工作表。
|
对于每种配置，都提供了基本选项。这里没有包含用户窗体，作者更倾向于直接在顶层过程的代码中修改设置。分支度量使用 HAMMING 距离而不是 CLOSENESS。可以使用 CLOSENESS 的版本可以在 相邻页面 上找到。
- 用户模式设置允许应用各种输入和错误组合。
- 两个编码器都为每一位输入产生两位输出。消息输入（显示流m）可以由用户指定，手动或随机生成到任何给定长度。解码器输出消息与原始消息区分开来，表示为m*。
- 用户可以运行一次循环或多次循环。长时间循环平均通常很有用。一个消息框会汇总所有循环中的 BER（误码率）结果。用户可以将一个选定循环的度量和基本流输出到工作表中。
- 编码器输出被修改以包含错误。这模拟了传输通道中随机噪声的影响。用户可以设置特定位置的特定错误，或在整个范围内应用随机错误，以达到指定的误码率。请记住，错误位位置适用于编码器的输出，并且那里的位数将是消息输入的位的两倍。
- 显示流被标记。用户可以显示一个循环的度量和流。流是
- m 是输入编码器的原始消息。
- c 是来自编码器的编码输出，不含任何错误。
- r 是编码器输出的接收版本，包含应用的错误。
- m* 是解码器输出，恢复的消息。
以下代码以一个完整的模块形式提供。将代码复制到标准模块中。在顶层过程RunCoding中设置选项，然后运行该过程以获得错误校正结果的摘要。该过程将清除Sheet1，因此请确保其中没有其他重要工作。例如，假设要测试 7,5 配置在随机输入和随机错误（误码率为 0.01）下的性能。操作步骤如下
- 设置nCodePolyGen= 75 以选择 111,101 配置，
- nModeNumber = 8 用于具有随机错误的随机输入，
- nAutoCycles = 100 用于 100 个块的平均值，
- nLenAutoInput = 500 用于每个输入块使用 500 位，
- nNumCdrFlushBits = 3 用于在每个输入块的末尾添加刷新位，
- sngBER = 0.01 用于应用百分之一的错误，
- 其他选项可以忽略。
- 运行过程 RunCoding。第一个循环的输出将显示在 sheet one 上，并且当运行完成时，一个消息框将显示在解码器中更改的 BER 的摘要。在使用新参数运行之间，重新保存代码或按下编辑器的重置按钮。
修改日期：14/Aug/18；删除了列号限制。现在由用户负责。
代码功能日期：11/Aug/18。
修改日期：11/Aug/18；修正了累积错误和过程 ColourTheErrors()。
修改日期：10/Jan/18；修正了过程名称错误。
修改日期：03/Nov/17；将回溯路径边缘值流添加到工作表显示中。
修改日期：01/Nov/17；修正了编码错误。
修改日期：31/Oct/17；将回溯路径着色添加回来。
Option Explicit
Sub RunCoding() ' FOR HAMMING DISTANCE METHODS
' Run this procedure with chosen in-code settings to study the cross-decoder performance.
' THIS VERSION RUNS AND OUTPUTS METRICS BASED ON HAMMING DISTANCE AS OPPOSED TO CLOSENESS
' 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.
' 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
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 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 = "10110101001" ' 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 = 6 ' 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 = 7 ' 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 = AutoRandomInput(nLenAutoInput) & String(nNumCdrFlushBits, "0") ' auto random message
End Select
' CODER
' obtain a coded message from the input
Select Case nCodePolyGen
Case 76
ConvolutionalCoderT7B6 sMW, sCodedMessage
Case 75
ConvolutionalCoderT7B5 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 = AddFixedErrs(sChannelTx, vEM)
Case 2, 6 ' two error spacing, manual gap and start
sChannelRx = FixedSpacedErrors(sChannelTx, nFirst, nClearErrGap, 0)
Case 3, 7 ' two errors only, random gap and manual start
sChannelRx = TwoErrOnlyRndGap(sChannelTx, nFirst, 0)
Case 4, 8 ' auto random errors to manual BER setting
sChannelRx = InsertBERRnd(sChannelTx, sngBER, 0)
Case 9, 10 ' no errors at all
sChannelRx = sChannelTx
End Select
' DECODER
' using a Viterbi trellis algorithm
Select Case nCodePolyGen
Case 75
ConvolutionalDecodeD sChannelRx, sDecodedMessage, sEdges, bLucky, 75, vArr, vT
Case 76
ConvolutionalDecodeD sChannelRx, sDecodedMessage, sEdges, bLucky, 76, vArr, vT
Case Else
MsgBox "Chosen algorithm not found - 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
DigitsToSheetRow sMW, 1, 6, "m" ' message in
DigitsToSheetRow sChannelTx, 2, 7, "c" ' correctly coded message
DigitsToSheetRow sChannelRx, 2, 8, "r" ' coded message as received
DigitsToSheetRow sEdges, 2, 9, "r*" ' back path edge values
DigitsToSheetRow 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 = NumBitsDifferent(sMW, sDM, nLenStream) ' message errors single cycle
nDErr = NumBitsDifferent(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) ' mark input and output errors for block length and 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 ConvolutionalCoderT7B5(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 ConvolutionalCoderT7B6(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 FixedSpacedErrors(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 positon 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, 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
FixedSpacedErrors = sAccum
End Function
Function TwoErrOnlyRndGap(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
TwoErrOnlyRndGap = sAccum
End Function
Function AddFixedErrs(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
AddFixedErrs = sWork
End Function
Function InsertBERRnd(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
InsertBERRnd = sAccum
End Function
Sub ConvolutionalDecodeD(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 and displays use Hamming distance in this version.
' In branch estimates the highest 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 minimum 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, nNumLows 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) ' back path tint array
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
GeneralDataT7B5 nVert, sCurrState, sPrevStateU, sPrevStateL, sUSOut, sLSOut, sBitU, sBitL
ElseIf nConfiguration = 76 Then
GeneralDataT7B6 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 arbitrarily high. 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
FrontExceptions75D nTime, nVert, sLSOut, sUSOut, sPrevStateAccumL, sPrevStateAccumU
ElseIf nConfiguration = 76 Then
FrontExceptions76D nTime, nVert, sLSOut, sUSOut, sPrevStateAccumL, sPrevStateAccumU
Else
MsgBox "Configuration not defined"
End If
' Calculate incoming branch metrics and add their previous path metrics to each
sProposedAccumU = CStr(GetProposedAccum(sRcdBits, sUSOut, sPrevStateAccumU))
sProposedAccumL = CStr(GetProposedAccum(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 = "Keep": sDiscardedU = "Discard"
sNodeAccum = sProposedAccumL
ElseIf CLng(sProposedAccumU) < CLng(sProposedAccumL) Then
sDiscardedL = "Discard": sDiscardedU = "Keep"
sNodeAccum = sProposedAccumU
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 for the sheet display
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 descending
SortMetricsArr2D1Key vH, 1, 1, 1 ' and assoc recs are in same row
' Detect start point ambiguity for possible future use
' Count number of entries with same low value in column
nNumLows = 0
For r = 1 To 4 ' number rows in every column
If vH(1, 1) = vH(r, 1) Then nNumLows = nNumLows + 1
Next r
If nNumLows > 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 = GetStateFmRow(nStartR) ' common
' Use present state name to fetch the output bits
If nConfiguration = 75 Then
GetOutputBitsT7B5 sCurrState, bUpperPath, sEdgeBits, sInputBit
ElseIf nConfiguration = 76 Then
GetOutputBitsT7B6 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
GetPosOfSourceT7B5 nStartR, nStartC, bUpperPath, nSwapR, nSwapC
ElseIf nConfiguration = 76 Then
GetPosOfSourceT7B6 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 'message single bit stream
sOut2 = sAccumEdgeValues 'back path edge double bit stream
End Sub
Function FrontExceptions75D(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 distance only
If nT = 1 And nV = 1 Then
sLSO = "00": sUSO = "00": sPSAL = "20": sPSAU = "0"
ElseIf nT = 1 And nV = 3 Then
sLSO = "11": sUSO = "11": sPSAL = "20": sPSAU = "0"
ElseIf nT = 2 And nV = 1 Then
sLSO = "00": sUSO = "00": sPSAL = "20"
ElseIf nT = 2 And nV = 2 Then
sLSO = "10": sUSO = "10": sPSAL = "20"
ElseIf nT = 2 And nV = 3 Then
sLSO = "11": sUSO = "11": sPSAL = "20"
ElseIf nT = 2 And nV = 4 Then
sLSO = "01": sUSO = "01": sPSAL = "20"
End If
FrontExceptions75D = True
End Function
Function FrontExceptions76D(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 distance only
If nT = 1 And nV = 1 Then
sLSO = "00": sUSO = "00": sPSAL = "20": sPSAU = "0"
ElseIf nT = 1 And nV = 3 Then
sLSO = "11": sUSO = "11": sPSAL = "20": sPSAU = "0"
ElseIf nT = 2 And nV = 1 Then
sLSO = "00": sUSO = "00": sPSAL = "20" ' arbitrarily high
ElseIf nT = 2 And nV = 2 Then
sLSO = "11": sUSO = "11": sPSAL = "20"
ElseIf nT = 2 And nV = 3 Then
sLSO = "11": sUSO = "11": sPSAL = "20"
ElseIf nT = 2 And nV = 4 Then
sLSO = "00": sUSO = "00": sPSAL = "20"
End If
FrontExceptions76D = True
End Function
Function SortMetricsArr2D1Key(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
SortMetricsArr2D1Key = True
End Function
Function GeneralDataT7B5(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
GeneralDataT7B5 = True
End Function
Function GeneralDataT7B6(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
GeneralDataT7B6 = True
End Function
Function GetStateFmRow(nRow As Long) As String
' returns alpha name of state for parameter
' row position in trellis column
Select Case nRow
Case 1
GetStateFmRow = "a"
Case 2
GetStateFmRow = "b"
Case 3
GetStateFmRow = "c"
Case 4
GetStateFmRow = "d"
End Select
End Function
Function GetOutputBitsT7B6(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
GetOutputBitsT7B6 = True
End Function
Function GetOutputBitsT7B5(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
GetOutputBitsT7B5 = True
End Function
Function GetPosOfSourceT7B5(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
GetPosOfSourceT7B5 = True
End Function
Function GetPosOfSourceT7B6(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
GetPosOfSourceT7B6 = True
End Function
Function DigitsToSheetRow(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 AutoRandomInput(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
AutoRandomInput = sAccum
End Function
Function GetProposedAccum(ByVal sIn1 As String, ByVal sIn2 As String, ByVal sPrevAccum As String) As Long
' Compares two binary strings of equal length
' Returns the count of the bits in function name plus sPrevAccum that are different
' It is the Hamming distance between the two binary bit strings plus some accum metric
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:
If sPrevAccum = "" Then sPrevAccum = "0"
GetProposedAccum = m + CLng(sPrevAccum)
End Function
Function NumBitsDifferent(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 binary 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)
NumBitsDifferent = m
End Function
- 一个基本的卷积编码示例：详细介绍了错误校正配置的工作原理。描述了为此模拟器制作的主题材料。
- VBA 中的 Viterbi 模拟器：以 CLOSENESS 的形式显示度量，而不是像此页面一样以汉明距离的形式显示。