Imports System.Collections.Generic
Imports BaseGA5.GeneticAlgorithm


Public Class QueenChromosome : Implements IChromosome

#Region "Local Variables"
    Private Shared _symbols() As String = {"A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P"}
    Private Const _Undefined As Integer = -1
    Private _NQ As Integer = 8
    Private _MaxCol As Integer = 8
    Private _MaxRow As Integer = 8
    Private _N As Integer
    Public _queens As List(Of Integer)
    Public _histogram As List(Of Integer)
    Private Shared _random As Random = New Random((DateTime.Now.Hour * 3600 + DateTime.Now.Minute * 60 + DateTime.Now.Second) * 1000 + DateTime.Now.Millisecond)
#End Region


    Public Sub New(ByVal maxCol As Integer, ByVal maxRow As Integer, ByVal NQ As Integer)
        If maxCol > 16 Then
            Throw New Exception(String.Format("Numebr of columns is out of range. Must be < 17"))
        End If
        _MaxCol = maxCol
        _MaxRow = maxRow
        _N = _MaxRow * _MaxCol
        _NQ = NQ
        _queens = CreateList(_NQ, _Undefined)
        _histogram = CreateList(_N, 0)
    End Sub

    Private Function CreateList(ByVal N As Integer, ByVal value As Integer)
        Dim o As New List(Of Integer)(N)
        While N > 0
            o.Add(value)
            N -= 1
        End While
        Return o
    End Function


    Public Sub RandomInit() Implements IChromosome.RandomInit
        Dim N As Integer = _NQ
        While N > 0
            Dim pos As Integer = _random.Next(0, _N)
            If Not _queens.Contains(pos) Then
                _queens(N - 1) = pos
                N -= 1
            End If
        End While
    End Sub


    Private Sub doCopy(ByVal dest As QueenChromosome, ByVal src As QueenChromosome)
        For j As Integer = 0 To _NQ - 1
            dest._queens(j) = src._queens(j)
        Next
    End Sub

    Public Sub Copy(ByVal dest As IChromosome) Implements IChromosome.Copy
        doCopy(dest, Me)
    End Sub

    Public Function ValidPosition(ByVal r As Integer, ByVal c As Integer) As Boolean
        Return (r >= 0 And r < _MaxRow) AndAlso (c >= 0 And c < _MaxCol)
    End Function

    Private Function ChangePosition(ByVal oldPos As Integer) As Integer
        Dim newPos As Integer = 0
        While True
            newPos = _random.Next(0, _N)
            If Not _queens.Contains(newPos) Then
                Return newPos
            End If
        End While
        Return _Undefined
    End Function


    Public Sub MutateAt(ByVal locus As Integer) Implements IChromosome.MutateAt
        _queens(locus) = ChangePosition(_queens(locus))
    End Sub

    Public Function ValidLocus(ByVal locus As Integer) As Boolean Implements IChromosome.ValidLocus
        Return locus >= 0 AndAlso locus < _NQ
    End Function

    Public Sub Validate()
        For j As Integer = 0 To _N - 1
            _histogram(j) = 0
        Next
        For Each pos As Integer In _queens
            If (pos < 0) Or (pos >= _N) Then
                Throw New Exception(String.Format("Invalid queen position {0}.", pos))
            End If
            If _histogram(pos) <> 0 Then
                Throw New Exception(String.Format("Duplicate queen position {0}.", pos))
            End If
        Next
    End Sub

    Private Sub doCrossOver(ByVal dad As QueenChromosome, ByVal mom As QueenChromosome, ByVal offspring1 As QueenChromosome, ByVal offspring2 As QueenChromosome)

        Dim qjoined As New List(Of Integer)

        For j As Integer = 0 To _NQ - 1
            If Not qjoined.Contains(dad._queens(j)) Then
                qjoined.Add(dad._queens(j))
            End If
            If Not qjoined.Contains(mom._queens(j)) Then
                qjoined.Add(mom._queens(j))
            End If
        Next


        Dim N As Integer = qjoined.Count
        If N < _NQ Or N > _NQ * 2 Then
            Throw New Exception(String.Format("Invalid number of queens ({0}) in joined list.", N))
        End If

        For j As Integer = 0 To _NQ - 1
            Dim pos As Integer = qjoined(j)
            offspring1._queens(j) = pos
            pos = qjoined(j + N - _NQ)
            offspring2._queens(j) = pos
        Next

    End Sub


    Public Sub CrossOver(ByVal mom As IChromosome, ByVal offspring1 As IChromosome, ByVal offspring2 As IChromosome) Implements IChromosome.CrossOver
        doCrossOver(Me, mom, offspring1, offspring2)
    End Sub


    Public Sub GetRowCol(ByVal pos As Integer, ByRef row As Integer, ByRef column As Integer)
        row = pos \ _MaxCol
        column = pos Mod _MaxCol
    End Sub

    Public Function GetPosition(ByVal r As Integer, ByVal c As Integer) As Integer
        Return r * _MaxCol + c
    End Function

    Public Function GetRow(ByVal pos As Integer) As Integer
        Return pos \ _MaxCol
    End Function

    Public Function GetCol(ByVal pos As Integer) As Integer
        Return pos Mod _MaxCol
    End Function

    Public Function GetSymbolic(ByVal pos As Integer) As String
        Return String.Format("{0}{1}", _symbols(pos Mod _MaxCol), (pos \ _MaxCol) + 1)
    End Function


    Public Function EvalFitness() As Double
        Dim sum As Double = 0
        For Each pos As Integer In _queens
            'Debug.WriteLine(String.Format("{0} --> {1};{2}", _queens(j), row, col))
            sum += OnSameColumn(pos)
            sum += OnSameRow(pos)
            sum += OnSameDiagonal(pos)
        Next
        'Debug.WriteLine(String.Format("Sum={0}", sum))
        Return sum
    End Function


    Private Function OnSameRow(ByVal pos As Integer) As Integer
        Dim sum As Integer = 0
        Dim row As Integer = GetRow(pos)
        For Each q As Integer In _queens
            sum += IIf((q \ _MaxCol) = row, 1, 0)
        Next
        Return sum - 1
    End Function

    Private Function OnSameColumn(ByVal pos As Integer) As Integer
        Dim sum As Integer = 0
        Dim col As Integer = GetCol(pos)
        For Each q As Integer In _queens
            sum += IIf((q Mod _MaxCol) = col, 1, 0)
        Next
        Return sum - 1
    End Function

    Private Function OnSameDiagonal(ByVal pos As Integer) As Integer
        Dim sum As Integer = 0
        Dim row As Integer = GetRow(pos)
        Dim col As Integer = GetCol(pos)

        For Each q As Integer In _queens
            sum += IIf(Math.Abs(GetRow(q) - row) = Math.Abs(GetCol(q) - col), 1, 0)
        Next
        Return sum - 1
    End Function

End Class

Imports System.Collections.Generic
Imports BaseGA5.GeneticAlgorithm


Public Class QueenGA : Inherits BaseGeneticAlgorithm(Of QueenChromosome)

    Private _crossoverP As Double = Double.NaN
    Private _mutateP As Double = Double.NaN
    Private _maxiter As Integer = 100
    Private _sideSize As Integer = 8
    Private _NQ As Integer = 8

    Public Event BestObject(ByVal sender As Object, ByVal obj As QueenChromosome)


    Public Sub New(ByVal SideSize As Integer, ByVal NQ As Integer, ByVal maxiter As Integer, ByVal crossoverP As Double, ByVal mutateP As Double)
        _sideSize = SideSize
        _NQ = NQ
        _maxiter = maxiter
        _crossoverP = crossoverP
        _mutateP = mutateP
    End Sub

    Public Function PickBestObject(ByVal population As IEnumerable(Of QueenChromosome)) As QueenChromosome
        Dim maxf As Double = Double.MinValue
        Dim o As QueenChromosome = Nothing
        For Each obj As QueenChromosome In population
            Dim value As Double = GetFitness(obj)
            If value > maxf Then
                maxf = value
                o = obj
            End If
        Next
        Return o
    End Function

    Protected Overrides Function CanStop(ByVal iteration As Integer, ByVal population As System.Collections.Generic.List(Of QueenChromosome)) As Boolean
        Debug.WriteLine(String.Format("Iteration={0}", iteration))
        Dim o As QueenChromosome = PickBestObject(population)
        If o IsNot Nothing Then
            Dim ftn As Integer = o.EvalFitness()
            Debug.WriteLine(String.Format("Sum={0}", ftn))
            RaiseEvent BestObject(Me, o)
            Return (iteration >= _maxiter) Or (ftn = 0)
        End If
        Return True
    End Function

    Public Overrides Function CreateChromosome() As QueenChromosome
        Return New QueenChromosome(_sideSize, _sideSize, _NQ)
    End Function

    Public Overrides Function EvalFitness(ByVal obj As QueenChromosome) As Double
        Return obj.EvalFitness()
    End Function

    Protected Overrides Function PerformCrossover() As Boolean
        Return _random.NextDouble <= _crossoverP
    End Function

    Protected Overrides Function PerformMutate() As Boolean
        Return _random.NextDouble() <= _mutateP
    End Function

End Class