Imports System.Math
Public Class Form1
  Dim Datas() As Single
  Dim Rnd As New System.Random
  Dim Vmin, Vmax As Double
  Dim StepNumber As Integer
  Dim ParticleNumber As Integer
  Dim ThresholdNumber As Integer
  Dim isOnePosition As Boolean
  Dim answers As New List(Of FnAndPos)
  Private Structure FnAndPos
    Dim F As Double
    Dim pos As Thresholds
    Public Function Clone() As FnAndPos
      Dim copy As New FnAndPos
      copy.F = F
      copy.pos = Me.pos.clone
      Return copy
    End Function
  End Structure
  Private Sub init()
    readDatas()
    ParticleNumber = Integer.Parse(TextBox2.Text.Trim)
    StepNumber = Integer.Parse(TextBox3.Text.Trim)
    ThresholdNumber = Integer.Parse(TextBox4.Text.Trim)
    isOnePosition = CheckBox1.Checked
    Vmax = Datas.Length * Rnd.Next(200, 1000) / 2000
    Vmin = -Vmax
  End Sub
  Sub readDatas()
    Dim dataList As New List(Of Single)
    For Each line As String In TextBox1.Lines
      Dim Temp As Single = 0
      If Single.TryParse(line.Trim, Temp) Then
        dataList.Add(Temp)
      End If
    Next
    Datas = dataList.ToArray
  End Sub

  Private Sub VAdjusting(ByRef nextV() As Thresholds)
    Dim i, j As Integer
    For i = 0 To nextV.Length - 1
      For j = 0 To nextV(i).Count - 1
        If nextV(i)(j) < Vmin Then nextV(i)(j) = Vmin
        If nextV(i)(j) > Vmax Then nextV(i)(j) = Vmax
      Next
    Next

  End Sub
  Private Sub XAdjusting(ByRef nextX() As Thresholds)
    Dim i, j As Integer
    For i = 0 To nextX.Length - 1
      For j = 0 To nextX(i).Count - 1
        If nextX(i)(j) <= 0 Then nextX(i)(j) = 1
        If nextX(i)(j) > Datas.Length - 1 Then nextX(i)(j) = Datas.Length - 1
      Next
    Next
  End Sub
  Private Function getNextV(ByVal currentV() As Thresholds, ByVal currentPBests() As FnAndPos, ByVal currentGBest As FnAndPos, ByVal currentX() As Thresholds) As Thresholds()
    Dim result(currentV.Length - 1) As Thresholds
    Dim i As Integer = 0
    Dim c1 As Double = 2, c2 As Double = 2 '¼ÓËٶȶ¼È¡2
    Dim r1 As Double = Rnd.NextDouble
    Dim r2 As Double = Rnd.NextDouble
    For i = 0 To currentV.Length - 1
      result(i) = currentV(i) + c1 * r1 * (currentPBests(i).pos - currentX(i)) + c2 * r2 * (currentGBest.pos - currentX(i))
    Next
    VAdjusting(result)
    Return result
  End Function
  Private Function getNextX(ByVal currentX() As Thresholds, ByVal NextV() As Thresholds) As Thresholds()
    Dim result(currentX.Length - 1) As Thresholds
    For i As Integer = 0 To currentX.Length - 1
      result(i) = currentX(i) + NextV(i)
    Next
    XAdjusting(result)
    Return result
  End Function
  Private Function getFnandPos(ByVal currentX() As Thresholds) As FnAndPos()
    Dim average As Single = 0
    Dim V2 As Double = 0, S2(currentX.Count - 1) As Double, B2(currentX.Count - 1) As Double
    Dim result(currentX.Count - 1) As FnAndPos
    Dim t, i As Integer 'tÊÇÖ¸Á£×ÓÊý£»iÊÇÖ¸ÃÅÏÞãÐÖµ¸öÊý
    For Each item As Single In Datas
      average += item
    Next
    average /= Datas.Length
    For Each item As Single In Datas
      V2 += (item - average) ^ 2
    Next
    For t = 0 To currentX.Count - 1
      With currentX(t)
        S2(t) += squareSum(0, .Item(0) - 1)
        For i = 0 To .Count - 2       'µ±ãÐÖµ´óÓÚ2ʱ£¬ÔËÐдËÏî¡£
          S2(t) += squareSum(.Item(i), .Item(i + 1) - 1)
        Next
        S2(t) += squareSum(.Item(.Count - 1), Datas.Length - 1)


        B2(t) = V2 - S2(t)
        result(t).F = B2(t) * (Datas.Length - .Count - 1) / (S2(t) * (.Count)) '×¢Ò⹫ʽ²é¿´
        result(t).pos = currentX(t)
      End With
    Next
    Return result
  End Function
  Private Function squareSum(ByVal startId As Integer, ByVal endId As Integer) As Double
    Dim average As Double = 0, sum As Double = 0
    If startId <= endId Then
      For i As Integer = startId To endId
        average += Datas(i)
      Next
      average /= Abs(endId - startId) + 1
      For i As Integer = startId To endId
        sum += (Datas(i) - average) ^ 2
      Next
    Else
      For i As Integer = startId To endId Step -1
        average += Datas(i)
      Next
      average /= Abs(endId - startId) + 1
      For i As Integer = startId To endId Step -1
        sum += (Datas(i) - average) ^ 2
      Next
    End If
    Return sum
  End Function
  Private Function pBest(ByVal oldPns() As FnAndPos, ByVal Xns() As FnAndPos) As FnAndPos()
    Dim i As Integer
    Dim result(oldPns.Length - 1) As FnAndPos
    For i = 0 To oldPns.Length - 1
      If Xns(i).F > oldPns(i).F Then
        result(i).F = Xns(i).F
        result(i).pos = Xns(i).pos
      Else
        result(i).F = oldPns(i).F
        result(i).pos = oldPns(i).pos
      End If
    Next
    Return result
  End Function
  Private Function gBest(ByVal gPbests() As FnAndPos) As FnAndPos
    Dim i As Integer, mmax As Double = Double.MinValue
    Dim result As FnAndPos = Nothing
    For i = 0 To gPbests.Length - 1
      If mmax < gPbests(i).F Then
        mmax = gPbests(i).F
        result.F = mmax
        result.pos = gPbests(i).pos
      End If
    Next
    Return result
  End Function

  Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
    Dim TBoxString As New System.Text.StringBuilder
    Dim answer As Boolean = False
    If TextBox1.Text = "" Then
      TextBox1.Text = "ûÓÐÊäÈëÊý¾Ý,ÇëÊý¾ÝÊý¾Ý"
      TextBox1.SelectAll()
      TextBox1.Focus()
      Exit Sub
    End If
    For Each line As String In TextBox1.Lines
      Dim Temp As Single = 0
      If Single.TryParse(line.Trim, Temp) Then
        If TBoxString.Length <> 0 Then
          TBoxString.Append(vbCrLf & line.Trim)
        Else
          TBoxString.Append(line.Trim)
        End If
      Else
        If Not answer Then
          If MessageBox.Show("´æÔÚÎÞЧÊý¾Ý»ò¿ÕÐУ¬ÊÇ·ñÌÞ³ý£¿", "Êý¾ÝÎÞЧ", MessageBoxButtons.YesNo, MessageBoxIcon.Question) = Windows.Forms.DialogResult.Yes Then
            answer = True
            Continue For
          Else
            Exit Sub
          End If
        End If
      End If
    Next
    TextBox1.Text = TBoxString.ToString
    TextBox1.Text.Trim()
    MessageBox.Show("¼ì²â³É¹¦!")
  End Sub

  Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
    init()
    Dim currentX(ParticleNumber - 1), nextX(ParticleNumber - 1) As Thresholds
    Dim currentV(ParticleNumber - 1), nextV(ParticleNumber - 1) As Thresholds
    Dim currentPbest(ParticleNumber - 1), nextPbest(ParticleNumber - 1) As FnAndPos
    Dim currentGbest, nextGbest As FnAndPos
    Dim i, j As Integer
    answers.Clear()
    TextBox5.Clear()
    If isOnePosition Then
      Dim X0 As New Thresholds
      For j = 0 To ThresholdNumber - 1
        X0.Add(Rnd.Next(0, Datas.Length - 2) + 1) ' ÉèÖÃÿ¸öÁ£×Ó³õʼλÖÃΪ£¨1£¬Datas.length-1)Ö®¼ä
      Next

      For i = 0 To ParticleNumber - 1
        currentV(i) = New Thresholds
        currentX(i) = New Thresholds
        For j = 0 To ThresholdNumber - 1
          currentV(i).Add((Rnd.NextDouble - 0.5) * Vmax) 'ËÙ¶È
          currentX(i).Add(X0(j))
        Next
      Next
    Else
      For i = 0 To ParticleNumber - 1
        currentV(i) = New Thresholds
        currentX(i) = New Thresholds
        For j = 0 To ThresholdNumber - 1
          currentV(i).Add((Rnd.NextDouble - 0.5) * Vmax) 'ËÙ¶È
          currentX(i).Add(Rnd.Next(0, Datas.Length - 2) + 1)
        Next
      Next
    End If
    currentPbest = getFnandPos(currentX)
    currentGbest = gBest(currentPbest)
    answers.Add(currentGbest)

    For i = 0 To StepNumber - 1
      nextV = getNextV(currentV, currentPbest, currentGbest, currentX)
      nextX = getNextX(currentX, nextV)
      nextPbest = pBest(currentPbest, getFnandPos(nextX))
      nextGbest = gBest(nextPbest)
      answers.Add(nextGbest)
      currentV = nextV.Clone
      currentX = nextX.Clone
      currentPbest = nextPbest.Clone
      currentGbest = nextGbest.Clone
    Next
    i = 0
    For Each item As FnAndPos In answers
      TextBox5.AppendText(String.Format("Step{0}({1}) F={2}{3}", i.ToString.PadRight(6), String.Join(",", item.pos.ToArray), item.F.ToString("F3"), vbCrLf))
      i += 1
    Next
  End Sub

  Private Sub TextBox1_KeyDown(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyEventArgs) Handles TextBox1.KeyDown
    If e.Control And e.KeyCode = Keys.A Then
      TextBox1.SelectAll()
    End If
  End Sub

  Structure Fpos
    Dim i As Integer
    Dim j As Integer
    Dim F As Double
  End Structure
  Private Sub Button3_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button3.Click
    readDatas()
    Dim i, j As Integer
    Dim s2 As Double = 0
    Dim B2 As Double = 0
    Dim F As Double = 0
    Dim average As Double = 0
    Dim V2 As Double = 0
    Dim DataLength As Integer = Datas.Length
    Dim mMax As Double = Double.MinValue
    Dim mFpos As Fpos
    Dim dataList As New List(Of Fpos)
    For Each item As Single In Datas
      average += item
    Next
    average /= Datas.Length
    For Each item As Single In Datas
      V2 += (item - average) ^ 2
    Next


    For i = 0 To DataLength - 3
      For j = i + 1 To DataLength - 2
        s2 = squareSum(0, i) + squareSum(i + 1, j) + squareSum(j + 1, DataLength - 1)
        B2 = V2 - s2
        F = B2 * (Datas.Length - 2 - 1) / (s2 * 2)
        If F > mMax Then
          mMax = F
          mFpos.i = i
          mFpos.j = j
          mFpos.F = F
          dataList.Add(mFpos)
        End If
      Next
    Next
    'i = 37
    'j = 40
    's2 = squareSum(0, i) + squareSum(i, j) + squareSum(j, DataLength - 1)
    'B2 = V2 - s2
    'F = B2 * (Datas.Length - 2 - 1) / (s2 * 2)
    'MsgBox(F)
    For Each item As Fpos In dataList
      TextBox5.AppendText(String.Format("({0},{1}) F={2}" & vbCrLf, item.i, item.j, item.F.ToString("F4")))
    Next
  End Sub
  Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
  End Sub
End Class
¡®%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
¡¯¹¹½¨ThresholdsÏòÁ¿Àà
¡®%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Public Class Thresholds
  Inherits List(Of Integer)
  Public Function clone() As Thresholds
    Dim a As New Thresholds   '¸´ÖÆÎÊÌâ
    a.InsertRange(0, Me)
    Return a
  End Function
  'Public Function Sort() As Thresholds
  '  Return MyBase.Sort
  'End Function
  Public Shared Operator +(ByVal A As Thresholds, ByVal B As Thresholds) As Thresholds
    Dim c As New Thresholds
    For i As Integer = 0 To A.Count - 1
      c.Add(A(i) + B(i))
    Next
    Return c
  End Operator
  Public Shared Operator -(ByVal A As Thresholds, ByVal B As Thresholds) As Thresholds
    Dim c As New Thresholds
    For i As Integer = 0 To A.Count - 1
      c.Add(A(i) - B(i))
    Next
    Return c
  End Operator
  Public Shared Operator *(ByVal A As Single, ByVal B As Thresholds) As Thresholds
    Dim c As New Thresholds
    For i As Integer = 0 To B.Count - 1
      c.Add(A * B(i))
    Next
    Return c
  End Operator
  Public Shared Operator *(ByVal A As Thresholds, ByVal B As Single) As Thresholds
    Dim c As New Thresholds
    For i As Integer = 0 To A.Count - 1
      c.Add(A(i) * B)
    Next
    Return c
  End Operator
End Class

13Â¥: Originally posted by cttsyauchina at 2014-06-17 22:07:37
VB.net±àµÄ£¬.net 2.0ÒÔÉ϶¼¿ÉÒÔ°¡...

2Â¥: Originally posted by yalefield at 2011-12-17 17:33:31:
д¸öC/C++ÓïÑÔ°æµÄ·¢ÉÏ»ØÀ´°É¡£