unit WorkF;
//*******************************************************
// Example program demonstrating work assignment using a
// network flow algorithm.
//*******************************************************
// Copyright (C) 1998 John Wiley & Sons, Inc.
// All rights reserved. See additional copyright
// information in Readme.txt.
//*******************************************************

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, StdCtrls;

const
    INFINITY = 32767;

type
    TNodeStatus = (nsNotInList, nsWasInList, nsNowInList);

    PSkill = ^TSkill;
    TSkill = record
        Name      : String[20];
        NextSkill : PSkill;
    end;

    PLink = ^TLink;
    PNode = ^TNode;
    TLink = record
        Node1    : PNode;
        Node2    : PNode;
        Capacity : Integer;
        Flow     : Integer;
        Residual : Integer;
        NextLink : PLink;   // Next link in the node's list of links.
    end;
    TNode = record
        Name     : String[20];
        TopLink  : PLink;       // Links out of this node.
        NextNode : PNode;       // Next node in list of all nodes.
        Status   : TNodeStatus; // Has it been in the tree?
        InLink   : PLink;       // The link into this node.
        TopSkill : PSkill;      // Linked list of skills.
    end;

    // Cell for candidate linked list.
    PCandidate = ^TCandidate;
    TCandidate = record
        Node          : PNode;
        NextCandidate : PCandidate;
    end;

  TWorkForm = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    mnuExit: TMenuItem;
    Help1: TMenuItem;
    mnuAbout: TMenuItem;
    EmployeeMemo: TMemo;
    JobMemo: TMemo;
    Label1: TLabel;
    Label2: TLabel;
    EmployeeLabel: TLabel;
    CmdAssign: TButton;
    Label4: TLabel;
    Label5: TLabel;
    JobsAssignedLabel: TLabel;
    JobLabel: TLabel;
    procedure mnuExitClick(Sender: TObject);
    procedure mnuAboutClick(Sender: TObject);
    procedure CmdAssignClick(Sender: TObject);
    function ReadInfo(lines : TStrings) : PNode;
    procedure BuildNetwork;
    procedure FindMaxFlows;
    procedure DisplayResult;
    procedure DestroyNetwork;
  private
    { Private declarations }
    TopEmpNode : PNode;
    TopJobNode : PNode;
    SourceNode : TNode;
    SinkNode   : TNode;
  public
    { Public declarations }
  end;

var
  WorkForm: TWorkForm;

implementation

{$R *.DFM}

procedure TWorkForm.mnuExitClick(Sender: TObject);
begin
    Close;
end;

procedure TWorkForm.mnuAboutClick(Sender: TObject);
const
    CRCR = #13#10#13#10;
begin


    MessageDlg(
        'Niniejszy program rozwiązuje zadanie przydziału pracy, wykorzystując algorytm obliczania ścieżek maksymalnych przepływów.' + CRCR +
        'Wprowadź w lewym okienku nazwiska pracowników wraz symbolicznymi oznaczeniami posiadanych przez nich kwalifikacji (oddzielonymi spacją). ' +
        'Wprowadź w prawym okienku symboliczne nazwy zadań do wykonania wraz z symbolicznymi oznaczeniami kwalifikacji niezbędnych do wykonania każdego z nich.' + CRCR +
        'Kliknięcie w przycisk "Przydziel" spowoduje dokonanie skojarzenia zadań z pracownikami o niezbędnych kwalifikacjach.'
        , mtInformation, [mbOK], 0);



end;

// Find the maximum work assignments.
procedure TWorkForm.CmdAssignClick(Sender: TObject);
begin
    // Create employee and job nodes.
    TopEmpNode := ReadInfo(EmployeeMemo.Lines);
    TopJobNode := ReadInfo(JobMemo.Lines);

    // Build the network.
    BuildNetwork;

    // Calculate the maximum flows.
    FindMaxFlows;

    // Show the results.
    DisplayResult;

    // Destroy the network.
    DestroyNetwork;
end;

// Build a linked list of nodes representing the data in
// the TStrings. Return the top of the list.
function TWorkForm.ReadInfo(lines : TStrings) : PNode;

    // Get a token delimited by delim from txt. Return
    // the token. Strip the token from the front of txt.
    function GetToken(var txt : String; delim : String) : String;
    var
        p : Integer;
    begin
        p := Pos(delim, txt);
        if (p = 0) then p := Length(txt) + 1;
        Result := Copy(txt, 1, p - 1);
        txt := Copy(txt, p + Length(delim), Length(txt));
    end;

var
    i              : Integer;
    top_node, node : PNode;
    skill          : PSkill;
    txt            : String;
begin
    top_node := nil;
    for i := 0 to lines.Count - 1 do
    begin
        txt := Trim(Lines[i]);
        if (txt = '') then continue;

        // Create a node for this item.
        GetMem(node, SizeOf(TNode));
        node^.NextNode := top_node;
        top_node := node;

        // Get the node's name.
        node^.Name := GetToken(txt, ' ');
        txt := Trim(txt);
        node^.TopLink := nil;
        node^.Status := nsNotInList;
        node^.InLink := nil;

        // Get the node's skills.
        node^.TopSkill := nil;
        while (txt <> '') do
        begin
            GetMem(skill, SizeOf(TSkill));
            skill^.NextSkill := node^.TopSkill;
            node^.TopSkill := skill;
            skill^.Name := GetToken(txt, ' ');
            txt := Trim(txt);
        end;
    end; // End reading the lines.

    Result := top_node;
end;

// Build the work flow network.
procedure TWorkForm.BuildNetwork;
    // Return True if this employee can work this job.
    function CanDo(emp_node, job_node : PNode) : Boolean;
    var
        emp_skill, job_skill : PSkill;
    begin
        Result := False;
        job_skill := job_node^.TopSkill;
        while (job_skill <> nil) do
        begin
            // Check the the employee has this skill.
            emp_skill := emp_node^.TopSkill;
            while (emp_skill <> nil) do
            begin
                if (emp_skill^.Name = job_skill^.Name) then
                    break;
                emp_skill := emp_skill^.NextSkill;
            end;
            // If (emp_skill = nil) then the employee
            // does not have job_skill.
            if (emp_skill = nil) then exit;

            // Check the next skill.
            job_skill := job_skill^.NextSkill;
        end;
        Result := True;
    end;

    // Create links between the two nodes.
    procedure CreateLink(n1, n2 : PNode);
    var
        link : PLink;
    begin
        // Create the link.
        GetMem(link, SizeOf(TLink));
        link^.Node1 := n1;
        link^.Node2 := n2;
        link^.Capacity := 1;
        link^.Flow := 0;
        link^.Residual := 1;
        link^.NextLink := n1^.TopLink;
        n1^.TopLink := link;

        // Create the reverse link.
        GetMem(link, SizeOf(TLink));
        link^.Node1 := n2;
        link^.Node2 := n1;
        link^.Capacity := 0;
        link^.Flow := 0;
        link^.Residual := 0;
        link^.NextLink := n2^.TopLink;
        n2^.TopLink := link;
    end;

var
    emp_node, job_node : PNode;
begin
    // Create links from the source to the employees.
    emp_node := TopEmpNode;
    while (emp_node <> nil) do
    begin
        CreateLink(@SourceNode, emp_node);
        emp_node := emp_node^.NextNode;
    end;

    // Create links from the jobs to the Sink.
    job_node := TopJobNode;
    while (job_node <> nil) do
    begin
        CreateLink(job_node, @SinkNode);
        job_node := job_node^.NextNode;
    end;

    // Create links between employees and jobs.
    emp_node := TopEmpNode;
    while (emp_node <> nil) do
    begin
        job_node := TopJobNode;
        while (job_node <> nil) do
        begin
            if (CanDo(emp_node, job_node)) then
                CreateLink(emp_node, job_node);
            job_node := job_node^.NextNode;
        end;
        emp_node := emp_node^.NextNode;
    end;
end;

// Find the maximal flows.
procedure TWorkForm.FindMaxFlows;
    // Convert residuals into flows.
    procedure SetFlows(top_node : PNode);
    var
        node : PNode;
        link : PLink;
    begin
        node := top_node;
        while (node <> nil) do
        begin
            link := node^.TopLink;
            while (link <> nil) do
            begin
                if (link^.Capacity > link^.Residual) then
                    link^.Flow := link^.Capacity - link^.Residual
                else
                    // Negative to indicate backwards flow.
                    link^.Flow := link^.Residual - link^.Capacity;
                link := link^.NextLink;
            end;
            node := node^.NextNode;
        end;
    end;

var
    top_candidate, candidate : PCandidate;
    node, to_node            : PNode;
    link, rev_link           : PLink;
    min_residual             : Integer;
begin
    // Repeat until we can find no more augmenting paths.
    repeat
        // Find an augmenting path in the residual network.
        // Reset the nodes' NodeStatus and InLink values.
        node := TopEmpNode;
        while (node <> nil) do
        begin
            node^.Status := nsNotInList;
            node^.InLink := nil;
            node := node^.NextNode;
        end;
        node := TopJobNode;
        while (node <> nil) do
        begin
            node^.Status := nsNotInList;
            node^.InLink := nil;
            node := node^.NextNode;
        end;
        SourceNode.Status := nsNotInList;
        SourceNode.InLink := nil;
        SinkNode.Status := nsNotInList;
        SinkNode.InLink := nil;

        // Put the source on the candidate list.
        SourceNode.Status := nsNowInList;
        GetMem(top_candidate, SizeOf(TCandidate));
        top_candidate^.Node := @SourceNode;
        top_candidate^.NextCandidate := nil;

        // Repeat until the candidate list is empty.
        while (top_candidate <> nil) do
        begin
            // Remove the top candidate from the list.
            node := top_candidate^.Node;
            node^.Status := nsWasInList;
            candidate := top_candidate^.NextCandidate;
            FreeMem(top_candidate);
            top_candidate := candidate;

            // Examine the links out of this node.
            link := node^.TopLink;
            while (link <> nil) do
            begin
                // See if the residual > 0 and this node
                // has never been on the list.
                to_node := link^.Node2;
                if ((link^.Residual > 0) and
                    (to_node^.Status = nsNotInList)) then
                begin
                    // Add it to the list.
                    to_node^.Status := nsNowInList;
                    to_node^.InLink := link;
                    GetMem(candidate, SizeOf(TCandidate));
                    candidate^.Node := to_node;
                    candidate^.NextCandidate := top_candidate;
                    top_candidate := candidate;
                end;
                link := link^.NextLink;
            end; // End examining links out of the node.

            // Stop if the sink has been labeled.
            if (SinkNode.InLink <> nil) then break;
        end; // End while (top_candidate <> nil) do ...

        // Stop if we found no augmenting path.
        if (SinkNode.InLink = nil) then break;

        // Trace the augmenting path from SinkNode back to
        // SourceNode to find the smallest residual.
        min_residual := INFINITY;
        to_node := @SinkNode;
        while (to_node <> @SourceNode) do
        begin
            link := to_node^.InLink;
            if (link^.Residual < min_residual) then
                min_residual := link^.Residual;
            to_node := link^.Node1;
        end;

        // Update the residuals using the augmenting path.
        to_node := @SinkNode;
        while (to_node <> @SourceNode) do
        begin
            link := to_node^.InLink;
            link^.Residual := link^.Residual - min_residual;

            // Find and update the reverse link.
            node := link^.Node1;
            rev_link := to_node^.TopLink;
            while (rev_link <> nil) do
            begin
                if (rev_link^.Node2 = node) then break;
                rev_link := rev_link^.NextLink;
            end;
            if (rev_link <> nil) then
                rev_link^.Residual :=
                    rev_link^.Residual + min_residual;

            // Update the next link in the augmenting path.
            to_node := link^.Node1;
        end;

        // Free any items remaining in the candidate list.
        while (top_candidate <> nil) do
        begin
            candidate := top_candidate^.NextCandidate;
            FreeMem(top_candidate);
            top_candidate := candidate;
        end;
    until (False); // End infinite loop looking for augmenting paths
    // The loop ends when there are no more augmenting paths.

    // Calculate the flows from the residuals.
    SetFlows(TopEmpNode);
    SetFlows(TopJobNode);
end;

// Display the results.
procedure TWorkForm.DisplayResult;
const
    CR = #13#10;
var
    emp_txt, job_txt : String;
    node             : PNode;
    link             : PLink;
    total_flow       : Integer;
begin
    total_flow := 0;
    emp_txt := '';
    job_txt := '';

    // For each employee, see what link is used, if any.
    node := TopEmpNode;
    while (node <> nil) do
    begin
        link := node^.TopLink;
        while (link <> nil) do
        begin
            if (link.Flow > 0) then
            begin
                emp_txt := emp_txt + node^.Name + CR;
                job_txt := job_txt + link^.Node2^.Name + CR;
                total_flow := total_flow + 1;
                break;
            end;
            link := link^.NextLink;
        end;
        node := node^.NextNode;
    end;

    EmployeeLabel.Caption := emp_txt;
    JobLabel.Caption := job_txt;
    JobsAssignedLabel.Caption := IntToStr(total_flow);
end;

// Free the network memory.
procedure TWorkForm.DestroyNetwork;
    // Free this node's links.
    procedure FreeNodeLinks(node : PNode);
    var
        link, next_link : PLink;
    begin
        link := node^.TopLink;
        while (link <> nil) do
        begin
            next_link := link^.NextLink;
            FreeMem(link);
            link := next_link;
        end;
        node^.TopLink := nil;
    end;

    // Free this node's skills.
    procedure FreeNodeSkills(node : PNode);
    var
        skill, next_skill : PSkill;
    begin
        skill := node^.TopSkill;
        while (skill <> nil) do
        begin
            next_skill := skill^.NextSkill;
            FreeMem(skill);
            skill := next_skill;
        end;
        node^.TopSkill := nil;
    end;

    // Free all the nodes in this list and their links.
    procedure FreeNodeList(var top_node : PNode);
    var
        next_node : PNode;
    begin
        while (top_node <> nil) do
        begin
            FreeNodeLinks(top_node);
            FreeNodeSkills(top_node);
            next_node := top_node^.NextNode;
            FreeMem(top_node);
            top_node := next_node;
        end;
    end;

begin
    FreeNodeLinks(@SourceNode);
    FreeNodeLinks(@SinkNode);

    FreeNodeList(TopEmpNode);
    FreeNodeList(TopJobNode);
end;

end.
