Visual Basic 4 Unleashed/Visual_Basic_4_Unleashed_SAMS_Publishing_1995.iso/source/chap36/minimize.bas

BASIC Source File | 1995-09-19 | 14.4 KB | 452 lines

Attribute VB_Name = "basMinimize"
'=====================================================================
'MINIMIZE.BAS by Frank Font 1995
'
'This VB 4 file contains functions and definitions that carry out a
'branch and bound minimization algorithm for the MakeTeam program.
'
'*********************************************************************
'NOTE: These program procedures are for entertainment purposes ONLY.
'=====================================================================
Option Explicit

Private AssignmentCost() As Integer  'Set in the init routine.
Private minsTable() As Integer       'Set in the init routine.
Private candidateMap()               'Map candidate records from 0 to max.
Private jobtitleMap()                'Map job records from 0 to max.
'---------------------------------------------------------------------
'Add all the children of node pointer (np) to the heap.
'---------------------------------------------------------------------
Private Function Expand(np As Long) As Integer
  Dim i As Integer
  ReDim LocalAssignmentCost(EmpsInPool + 1) As Integer  'Array of employees on team.
  Dim se As Long                                        'Pointer to a node.

  'Store for later use.
  se = np

  'Initialize "all" nodes as available for this job.
  For i = 1 To EmpsInPool
    If gExactSkills And AssignmentCost(memPool(np).job, i - 1) = 0 Then
      'Mark as unavailable.
      LocalAssignmentCost(i) = 0
    Else
      'Mark it as available.
      LocalAssignmentCost(i) = 1
    End If
  Next i

  'Travel back the chain to ignore members in further chain building.
  While memPool(se).Parent >= 0
    LocalAssignmentCost(memPool(se).emp) = 0
    se = memPool(se).Parent
  Wend

  For i = 1 To EmpsInPool
    If LocalAssignmentCost(i) > 0 Then

      'Zero assignment cost indicates no assignment is possible.
      se = Mem_alloc()
      memPool(se).job = memPool(np).job + 1
      memPool(se).emp = i
      memPool(se).Parent = np
      memPool(se).cost = TotalCostGuess(se)
      AddHeap se

    End If
    DoEvents
  Next i

  Expand = -1  'Okay.
End Function



'---------------------------------------------------------------------
'Calculate cost of candidate (emp) filling jobtitle (job).
'This is where the program checks the skills of the emp against
'the needs of a job.  If the emp has every skill defined by the
'job, the cost returned is a function of the emp's skill ratings.
'If one or more required skills is missing the value returned
'depends as follows:
'  Return 0 if gExactSkills = TRUE because the emp is not exact match.
' ...OR...
'  Return COST with MAX_Bad factored in if gExactSkills = FALSE
'A value of ZERO is interpretted elsewhere in the program
'to mean that the emp should not be considered for
'the job.
'
'Ratings are mapped as follows: (11 - data)
'Input    System
'-----    ------
'1  becomes 10      Worst
'.
'.
'5  becomes 6       Adequate
'.
'.
'10 becomes 1       Best
'Smaller numbers are better in this implementation of the branch and
'bound algorithm.  However, 0 is treated as a flag within the program
'to mean that there should be no consideration given to that emp
'doing that job.  This is determined by the program when it checks
'the gExactSkills flag and should never be forced by setting the
'database value to 11 so that the mapping produces 0.
'
'Note: Maximum rating in the database is 10 due to inversion method.
'---------------------------------------------------------------------
Private Function CalcCost(job As Integer, emp As Integer) As Integer
  Dim MyTable As Recordset, SQL$
  Dim SkillSet As Recordset
  Dim CostTotal As Integer

  CostTotal = 0

  'Get the skill set for the given title key.
  SQL$ = "Select SkillKey FROM tblSkillJob WHERE JobtitleKey = " + _
         Str$(jobtitleMap(job))
  Set SkillSet = gMainDB.OpenRecordset(SQL$, dbOpenDynaset)
'  SkillSet.MoveFirst
  Do Until SkillSet.EOF  ' Begin loop.

    'Lookup the skill rating for the given skill key.
    SQL$ = "Select Rating from tblCandidateSkill where ((SkillKey=" + _
           Str$(SkillSet!SkillKey) + ")) AND ((CandidateKey=" + _
           Str$(candidateMap(emp)) + "))"
    Set MyTable = gMainDB.OpenRecordset(SQL$, dbOpenDynaset)
    If MyTable.RecordCount = 0 Then
      'This candidate does not have this skill.
      If gExactSkills Then
        'When exact is on, even missing one skill means ineligability.
        MyTable.Close       ' Close table.
        SkillSet.Close
        CalcCost = 0
        Exit Function
      Else
        'Consider for the job but handicap very heavily.
        CostTotal = CostTotal + MAX_Bad
      End If
    Else
      'We have the skill -- invert the rating so we have 1 to 10.
      CostTotal = CostTotal + 11 - MyTable!Rating
    End If
    MyTable.Close       ' Close table.
    SkillSet.MoveNext   ' Locate next record.
  Loop  ' End of loop.

  SkillSet.Close

  CalcCost = CostTotal

End Function

'---------------------------------------------------------------------
'Main branch and bound routine looks for lowest cost team.
'Returns cost of team.  If no team is found, cost is -1.
'---------------------------------------------------------------------
Public Function BB() As Double
  Dim RootNode As Long
  Dim res As Integer
  Dim tmp$

  'Do some initializations and show information.
  MapCandidates
  MapJobtitles
  InitAssignmentTable
  res = InitMinsTable()
  If Not res Then
    Beep
    tmp$ = SQLResultStr(gMainDB, "Name", "tblJobtitle", "JobtitleKey=" + _
           Str$(jobtitleMap(res)))
    Screen.MousePointer = 0
    MsgBox "Cannot continue.  No one is qualified to be '" + _
           tmp$ + "' in this project.  Add or modify candidates" + _
           " or do not require Exact Skill matching.", 48, gProgramTitle
    BB = -1
    Exit Function
  End If

  'Create the root node.
  RootNode = Mem_alloc
  memPool(RootNode).emp = 0
  memPool(RootNode).job = 0
  memPool(RootNode).cost = 0
  memPool(RootNode).Parent = -1

  While True
    If AnswerNode(RootNode) Then
      BB = PrintSolution(RootNode)
      Exit Function
    Else
      res = Expand(RootNode)
      If EmptyHeap Then
        'There are no more combinations to try.
        Screen.MousePointer = 0
        MsgBox "No teams using the specified criteria and candidate list can be made.", 64, gProgramTitle
        BB = -1
        Exit Function
      Else
        'Get the smallest cost node of the tries so far.
        RootNode = DeleteMin()
      End If
    End If
    DoEvents
    If gCancelMessage > 0 Then
      Beep
      gCancelMessage = -1
      MsgBox "Cancel Detected!", 16, gProgramTitle
      BB = -1
      Exit Function
    End If
  Wend
End Function


'---------------------------------------------------------------------
'Pass in node pointer (np) of node to check.  A node is an answer
'node if its job attribute indicates it is for the last job in the
'project.
'---------------------------------------------------------------------
Private Function AnswerNode(np As Long) As Boolean
  Dim result As Boolean
  If memPool(np).job = JobsInProject Then
    result = True
  Else
    result = False
  End If
  AnswerNode = result
End Function



'---------------------------------------------------------------------
'Map the jobtitles records to job numbers of array.
'This enables mapping of titles to the job assignment matrix.
'---------------------------------------------------------------------
Private Sub MapJobtitles()
  Dim i As Integer
  ReDim jobtitleMap(JobsInProject)
  Dim MyDB As DATABASE, MyTable As Recordset, SQL As String

  SQL$ = "Select JobtitleKey FROM tblJobProject WHERE ProjectKey = " + _
         frmMain.cboProjectTeam.BoundText

  i = 0
  Set MyTable = gMainDB.OpenRecordset(SQL$, dbOpenDynaset)
  MyTable.MoveFirst
  Do Until MyTable.EOF  ' Begin loop.

    jobtitleMap(i) = MyTable!JobtitleKey
    MyTable.MoveNext  ' Locate next record.
    i = i + 1

  Loop  ' End of loop.

  MyTable.Close ' Close table.
End Sub

'---------------------------------------------------------------------
'Map the candidate primary keys to employee numbers of array for.
'---------------------------------------------------------------------
Private Sub MapCandidates()

  Dim i As Integer
  ReDim candidateMap(EmpsInPool)

  Dim MyDB As DATABASE, MyTable As Recordset, SQL As String
  SQL$ = "Select CandidateKey FROM tblCandidate WHERE Available = -1"

  ' Open recordset.
  i = 0
  Set MyTable = gMainDB.OpenRecordset(SQL$, dbOpenDynaset)
  MyTable.MoveFirst
  Do Until MyTable.EOF  ' Begin loop.

    candidateMap(i) = MyTable!CandidateKey
    MyTable.MoveNext  ' Locate next record.
    i = i + 1

  Loop  ' End of loop.

  MyTable.Close ' Close table.
End Sub


'---------------------------------------------------------------------
'Print the solution to the database from node pointed to by np.  Also
'returns the absolute cost of the solution.
'---------------------------------------------------------------------
Private Function PrintSolution(np As Long) As Double
  Dim i As Integer
  Dim SQL$
  Dim totalcost As Double

  totalcost = memPool(np).cost
  While memPool(np).Parent >= 0
    SQL$ = "INSERT INTO tblCandidateProject(" + _
           "CandidateKey, ProjectKey, JobtitleKey) " + _
           "VALUES (" + Str$(candidateMap(memPool(np).emp - 1)) + _
           "," + frmMain.cboProjectTeam.BoundText + _
           "," + Str$(jobtitleMap(memPool(np).job - 1)) + ");"
    gMainDB.Execute SQL, dbFailOnError
    np = memPool(np).Parent
  Wend

  'Return the cost of this team.
  PrintSolution = totalcost
End Function


'---------------------------------------------------------------------
'A DEBUG ROUTINE
'Print the Minumum Table contents.
'---------------------------------------------------------------------
Private Sub PrintMinsTable()
  Dim E As Integer
  Dim j As Integer
  Dim line As String

  Debug.Print "*** Min table ***"
  For j = 0 To JobsInProject - 1
    line = ""
    For E = 0 To EmpsInPool - 1
      line = line + ", " + Str$(minsTable(j, E))
    Next E
    Debug.Print line + " : " + Str$(minsTable(j, E))
  Next j

End Sub


'---------------------------------------------------------------------
'A DEBUG ROUTINE
'Print the Assignment Table contents.
'---------------------------------------------------------------------
Private Sub PrintAssignmentTable()
  Dim E As Integer
  Dim j As Integer
  Dim line As String

  Debug.Print "*** Assignment table ***"
  For j = 0 To JobsInProject - 1
    line = ""
    For E = 0 To EmpsInPool - 1
      line = line + ", " + Str$(AssignmentCost(j, E))
    Next E
    Debug.Print line
  Next j

End Sub

'---------------------------------------------------------------------
'Initialize the table used to compute the estimated costs.
'Returns -1 if okay.  On error, returns number of job that triggered it.
'Note: Assingment cost of 0 means employee cannot do that job so that
'      assignment cost is not considered in the row minimum calculation.
'Special Note: Sort this table with higher costs first and you will get
'      better performance by inducing smarter pathing early on.
'---------------------------------------------------------------------
Private Function InitMinsTable() As Integer

  Dim E As Integer
  Dim j As Integer
  Dim et As Integer
  Dim rowmin As Double
  Dim realmin As Double

  ReDim minsTable(JobsInProject, EmpsInPool + 1)

  For j = JobsInProject - 1 To 0 Step -1
    realmin = MAX_Double
    For E = 0 To EmpsInPool - 1
      rowmin = MAX_Double
      For et = 0 To EmpsInPool - 1
        'Zero is not considered a cost -- it is a flag.
        If AssignmentCost(j, et) <= rowmin And AssignmentCost(j, et) > 0 Then
          realmin = AssignmentCost(j, et)
          If et <> E Then
            rowmin = realmin
          End If
        End If
      Next et
      'Set minimum value at right of row.
      minsTable(j, E) = rowmin
    Next E
    'Set value at right of row.
    minsTable(j, E) = realmin
    If realmin = MAX_Double Then   'Was the value changed?
      'Fail because no one can do job j.
      InitMinsTable = j
      Exit Function
    End If
  Next j

  'Signal that everything is okay so far.
  InitMinsTable = -1
End Function



'---------------------------------------------------------------------
'Estimate the total cost from this node down.  (Educated guess.)
'The only requirement for this function is that it return a value
'that is NEVER higher than the actual cost of going down the path
'that starts with node np.  (Otherwise the algorithm might ignore  a
'good combination becuase it looks too expensive.)
'---------------------------------------------------------------------
Private Function TotalCostGuess(np As Long) As Double
  Dim hc As Double
  If memPool(memPool(np).Parent).cost > 0 Then
    hc = ((memPool(memPool(np).Parent).cost) - _
         minsTable(memPool(np).job - 1, EmpsInPool) + _
         AssignmentCost(memPool(np).job - 1, memPool(np).emp - 1))
  Else
    hc = AssignmentCost(memPool(np).job - 1, memPool(np).emp - 1) + _
         FutureCostTerm(np)
  End If

  TotalCostGuess = hc
End Function


'---------------------------------------------------------------------
'Returns the estimated future cost from this node on.  Cost is sum of
'row minimums excluding the current column.
'---------------------------------------------------------------------
Private Function FutureCostTerm(np As Long) As Double
  Dim ft As Double
  Dim j As Integer

  ft = 0
  For j = memPool(np).job To JobsInProject - 1
    ft = ft + minsTable(j, memPool(np).emp - 1)
  Next j

  FutureCostTerm = ft
End Function


'---------------------------------------------------------------------
'Initialize the assignement table by filling in cost of an employee
'for each job in the project.  Higher value means less capable except
'for zero, which means impossible job for the candidate.
'---------------------------------------------------------------------
Private Sub InitAssignmentTable()
  'Assignment format = AssignmentCost(job, emp)

  Dim job As Integer
  Dim emp As Integer

  ReDim AssignmentCost(JobsInProject, EmpsInPool)

  For job = 0 To JobsInProject
    For emp = 0 To EmpsInPool
      AssignmentCost(job, emp) = CalcCost(job, emp)
    Next emp
  Next job

End Sub