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

4楼: Originally posted by nwwolfchj at 2011-12-18 14:19:00:
这个算法作高维度非线性优化可行不？实现方便不？

2楼: Originally posted by yalefield at 2011-12-17 17:33:31:
写个C/C++语言版的发上回来吧。

10楼: Originally posted by 406huanglong at 2013-03-21 21:06:38
毕业论文需要用到PSO算法，请教楼主的程序是用什么语言编写的？在什么平台上能运行？谢谢！

11楼: Originally posted by phenols at 2013-03-23 13:27:06
代码和界面有点不对吧
界面中只有两个按钮，但是代码中有三个

13楼: Originally posted by cttsyauchina at 2014-06-17 22:07:37
VB.net编的，.net 2.0以上都可以啊...