Chip 1999 March/Chip_1999-03_cd.bin/zkuste/delphi/INFO/DI9806RS.ZIP/DecideF.pas

Pascal/Delphi Source File | 1998-02-05 | 13KB | 451 lines

unit DecideF;

interface

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

type
  TDecideForm = class(TForm)
    Label1: TLabel;
    CmdRandomize: TButton;
    NumChoicesText: TEdit;
    CostLabel1: TLabel;
    ProfitLabel1: TLabel;
    CostLabel2: TLabel;
    ProfitLabel11: TLabel;
    CostLabel21: TLabel;
    ProfitLabel21: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    TotalCostLabel: TStaticText;
    TotalProfitLabel: TStaticText;
    CmdSearch: TButton;
    Label4: TLabel;
    Label5: TLabel;
    AlgorithmOption: TRadioGroup;
    Label6: TLabel;
    MinCostText: TEdit;
    MaxCostText: TEdit;
    Label7: TLabel;
    Label8: TLabel;
    MinProfitText: TEdit;
    MaxProfitText: TEdit;
    Label9: TLabel;
    Label10: TLabel;
    NodesVisitedLabel: TStaticText;
    Label11: TLabel;
    MaxAvailableText: TEdit;
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    mnuExit: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure CmdRandomizeClick(Sender: TObject);
    procedure CmdSearchClick(Sender: TObject);

    procedure BranchAndBound(test_item : Integer);
    procedure SearchExhaustively(test_item : Integer);
    procedure HillClimbing;
    procedure SearchRandomly;
    procedure ShowResults;
    procedure ResetSolution;
    procedure DisableSearch(Sender: TObject);
    procedure mnuExitClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  DecideForm: TDecideForm;

implementation

{$R *.DFM}

const
    MAX_CHOICES = 40;
var
    CostLabel   : array [1..MAX_CHOICES] of TStaticText;
    ProfitLabel : array [1..MAX_CHOICES] of TStaticText;

    NumChoices, CostAvailable : Integer;
    TestProfit, TestCost, BestProfit, UnusedProfit : Integer;
    Cost, Profit     : array [1..MAX_CHOICES] of Integer;
    TestUse, BestUse : array [1..MAX_CHOICES] of Boolean;
    NodesVisited     : Integer;

procedure TDecideForm.FormCreate(Sender: TObject);
const
    GAP = 3;
var
    cost_left, profit_left : Integer;
    top, wid, hgt, diff    : Integer;
    i                      : Integer;
begin
    // Initialize the random number generator.
    Randomize;

    // Create cost, profit, and use controls.
    hgt := 17;
    wid := CostLabel1.Width;
    cost_left := CostLabel1.Left;
    profit_left := ProfitLabel1.Left;
    top := CostLabel1.Top + CostLabel1.Height + GAP;
    diff := CostLabel2.Left - CostLabel1.Left;

    for i := 1 to MAX_CHOICES do
    begin
        CostLabel[i] := TStaticText.Create(Self);
        CostLabel[i].Parent := Self;
        CostLabel[i].SetBounds(cost_left, top, wid, hgt);
        CostLabel[i].AutoSize := False;
        CostLabel[i].BorderStyle := sbsSunken;

        ProfitLabel[i] := TStaticText.Create(Self);
        ProfitLabel[i].Parent := Self;
        ProfitLabel[i].SetBounds(profit_left, top, wid, hgt);
        ProfitLabel[i].AutoSize := False;
        ProfitLabel[i].BorderStyle := sbsSunken;

        if (i Mod 10 = 0) then
        begin
            cost_left := cost_left + diff;
            profit_left := profit_left + diff;
            top := CostLabel1.Top + CostLabel1.Height + GAP;
        end else
            top := top + hgt + GAP;
    end; // End creating controls.
end;

procedure TDecideForm.CmdRandomizeClick(Sender: TObject);
var
    i, min_cost, CostAvailable, min_profit, max_profit : Integer;
begin
    NumChoices := StrToInt(NumChoicesText.Text);
    min_cost := StrToInt(MinCostText.Text);
    CostAvailable := StrToInt(MaxCostText.Text);
    min_profit := StrToInt(MinProfitText.Text);
    max_profit := StrToInt(MaxProfitText.Text);

    for i := 1 to NumChoices do
    begin
        Cost[i] := Trunc(Random(CostAvailable - min_cost + 1)) + min_cost;
        CostLabel[i].Caption := Format('%d', [Cost[i]]);
        Profit[i] := Trunc(Random(20)) + 5;
        Profit[i] := Trunc(Random(max_profit - min_profit + 1)) + min_profit;
        ProfitLabel[i].Caption := Format('%d', [Profit[i]]);
    end;

    for i := NumChoices + 1 to MAX_CHOICES do
    begin
        CostLabel[i].Caption := '';
        ProfitLabel[i].Caption := '';
    end;

    // Reset the best solution colors.
    ResetSolution;

    CmdSearch.Enabled := True;
end;

procedure TDecideForm.CmdSearchClick(Sender: TObject);
begin
    Screen.Cursor := crHourglass;

    // Start with no solution.
    ResetSolution;

    // Perform the search.
    case AlgorithmOption.ItemIndex of
        0 : SearchExhaustively(1);
        1 : BranchAndBound(1);
        2 : HillClimbing;
        3 : SearchRandomly;
    end;

    // Display the results.
    ShowResults;

    Screen.Cursor := crDefault;
end;

// Perform a branch and bound search assuming items
// 1 through (test_item - 1) are fixed.
procedure TDecideForm.BranchAndBound(test_item : Integer);
var
    i : Integer;
begin
    NodesVisited := NodesVisited + 1;

    // If we've reached a leaf node, we know
    // this solution is an improvement.
    if (test_item > NumChoices) then
    begin
        for i := 1 to NumChoices do
            BestUse[i] := TestUse[i];
        BestProfit := TestProfit;
        Exit;
    end;

    // Try to add test_item to the test solution.
    if ((TestCost + Cost[test_item] <= CostAvailable) and
        (TestProfit + UnusedProfit > BestProfit)) then
    begin
        // Add it.
        TestUse[test_item] := True;
        TestCost := TestCost + Cost[test_item];
        TestProfit := TestProfit + Profit[test_item];
        UnusedProfit := UnusedProfit - Profit[test_item];

        // Recursively test this solution.
        BranchAndBound(test_item + 1);

        // Take the item back out of the solution.
        TestUse[test_item] := False;
        TestCost := TestCost - Cost[test_item];
        TestProfit := TestProfit - Profit[test_item];
        UnusedProfit := UnusedProfit + Profit[test_item];
    end;

    // Try a solution without test_item.
    if (TestProfit + UnusedProfit - Profit[test_item]
            > BestProfit) then
    begin
        UnusedProfit := UnusedProfit - Profit[test_item];
        BranchAndBound(test_item + 1);
        UnusedProfit := UnusedProfit + Profit[test_item];
    end;
end;

// Perform an exhaustive search assuming items
// 1 through (test_item - 1) are fixed.
procedure TDecideForm.SearchExhaustively(test_item : Integer);
var
    i : Integer;
begin
    NodesVisited := NodesVisited + 1;

    // If we have assigned every item, see if we have
    // found an improved solution.
    if (test_item > NumChoices) Then
    begin
        if ((TestCost <= CostAvailable) and
            (TestProfit > BestProfit)) then
        begin
            // Save the improved solution.
            for i := 1 to NumChoices do
                BestUse[i] := TestUse[i];
            BestProfit := TestProfit;
        end;
        Exit;
    end;

    // Add test_item to the test solution.
    TestUse[test_item] := True;
    TestCost := TestCost + Cost[test_item];
    TestProfit := TestProfit + Profit[test_item];

    // Recursively see what we can find.
    SearchExhaustively(test_item + 1);

    // Take test_item back out of the test solution.
    TestUse[test_item] := False;
    TestCost := TestCost - Cost[test_item];
    TestProfit := TestProfit - Profit[test_item];

    // Recursively see what solution we can find
    // without test_item in the solution.
    SearchExhaustively(test_item + 1);
end;

// Find a solution using a hill climbing heuristic.
procedure TDecideForm.HillClimbing;
var
    unspent, best_i, best_profit, i : Integer;
begin
    unspent := CostAvailable;

    // Repeatedly look for an item to add to the solution.
    while (True) do
    begin
        // Find the item with largest profit that fits
        // in the solution.
        best_profit := -1;
        best_i := -1;
        for i := 1 to NumChoices do
        begin
            // This is not really nodes visited, but it's
            // something we can use for comparison.
            NodesVisited := NodesVisited + 1;

            // If the item has not yet been used, and if
            // we have the funds to afford it, and if it
            // gives better profit, take it.
            if ((not BestUse[i]) and
                (Cost[i] <= unspent) and
                (Profit[i] > best_profit)) Then
            begin
                best_i := i;
                best_profit := Profit[i];
            end;
        end;

        // If best_i < 0, no more items will fit
        // in the solution so we're done.
        if (best_i < 0) then Exit;

        // Add the item found to the solution.
        BestUse[best_i] := True;
        BestProfit := BestProfit + best_profit;
        unspent := unspent - Cost[best_i];
    end;
end;

// Find a solution using a randomized heuristic.
procedure TDecideForm.SearchRandomly;
const
    NUM_TRIALS = 1000;
var
    trial, unspent, num_items, num, i : Integer;
begin
    // Attempt NUM_TRAILS * NumChoices trials.
    for trial := 1 to NUM_TRIALS * NumChoices do
    begin
        unspent := CostAvailable;

        // Add randomly selected items to the solution
        // until no more will fit.
        while (True) do
        begin
            // See how many items can fit in the solution.
            num_items := 0;
            for i := 1 to NumChoices do
                if ((not TestUse[i]) and
                    (Cost[i] <= unspent)) then
                        num_items := num_items + 1;

            // This is not really nodes visited, but it's
            // something we can use for comparison. We add
            // NumChoices since we examine all NumChoices
            // nodes.
            NodesVisited := NodesVisited + NumChoices;

            // See if no more fit.
            if (num_items < 1) then Break;

            // Pick an item randomly.
            num := Trunc(Random(num_items)) + 1;

            // Find the item.
            for i := 1 to NumChoices do
                if ((not TestUse[i]) and
                    (Cost[i] <= unspent)) then
                begin
                    num := num - 1;
                    if (num < 1) then Break;
                end;

            // Select it.
            TestUse[i] := True;
            unspent := unspent - Cost[i];
            TestProfit := TestProfit + Profit[i];
        end;

        // We have finished creating the random solution.
        // See if it an improvement.
        if (TestProfit > BestProfit) then
        begin
            for i := 1 to NumChoices do
            begin
                for i := 1 to NumChoices do
                    BestUse[i] := TestUse[i];
                BestProfit := TestProfit;
            end;
        end; // End saving improved solution.

        // Reset the test solution for the next trial.
        TestProfit := 0;
        TestCost := 0;
        for i := 1 to NumChoices do
            TestUse[i] := False;
    end; // End of this trial.
end;

procedure TDecideForm.ShowResults;
var
    i, best_cost : Integer;
begin
    // Mark the items in the best solution.
    for i := 1 to NumChoices do
    begin
        if (BestUse[i]) then
        begin
            CostLabel[i].Font.Color := clWhite;
            CostLabel[i].Color := clBlack;
            ProfitLabel[i].Font.Color := clWhite;
            ProfitLabel[i].Color := clBlack;
        end;
    end;

    // Calculate the best solution's cost.
    best_cost := 0;
    for i := 1 to NumChoices do
        if (BestUse[i]) then best_cost := best_cost + Cost[i];

    // Show the total cost and profit.
    TotalCostLabel.Caption := Format('%d', [best_cost]);
    TotalProfitLabel.Caption := Format('%d', [BestProfit]);
    NodesVisitedLabel.Caption := Format('%d', [NodesVisited]);
end;

procedure TDecideForm.ResetSolution;
var
    i : Integer;
begin
    // Blank the result strings.
    TotalCostLabel.Caption := '';
    TotalProfitLabel.Caption := '';
    NodesVisitedLabel.Caption := '';
    Application.ProcessMessages;

    // Reset algorithm variables.
    TestProfit := 0;
    TestCost := 0;
    BestProfit := 0;
    NodesVisited := 0;

    // See how much money is available.
    CostAvailable := StrToInt(MaxAvailableText.Text);

    // See how much profit is possible.
    UnusedProfit := 0;
    for i := 1 to NumChoices do
    begin
        UnusedProfit := UnusedProfit + Profit[i];
        BestUse[i] := False;
    end;

    for i := 1 to MAX_CHOICES do
    begin
        CostLabel[i].Font.Color := clBlack;
        CostLabel[i].Color := clBtnFace;
        ProfitLabel[i].Font.Color := clBlack;
        ProfitLabel[i].Color := clBtnFace;
    end;
end;

procedure TDecideForm.DisableSearch(Sender: TObject);
begin
    CmdSearch.Enabled := False;
end;

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

end.