unit MainForm; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, JvScrollBox, StdCtrls, JvCombobox, JvxCtrls, JvSpin, JvButton, OleServer, MSXML2_TLB, Math, ExtCtrls, JvPanel, JvWinDialogs, JvCheckBox, JvGIF, JvImage; type TShopForm = class(TForm) ItemsBox: TJvScrollBox; JvxLabel3: TJvxLabel; JvxLabel4: TJvxLabel; OutputPanel: TJvScrollBox; SetupBox: TGroupBox; ActionsBox: TGroupBox; JvxLabel1: TJvxLabel; JvxLabel2: TJvxLabel; JvxLabel5: TJvxLabel; MachinesBox: TJvxSpinEdit; JobsBox: TJvxSpinEdit; ChangeItems: TJvButton; SampleSize: TJvxSpinEdit; MakeGen0Button: TButton; ScoreSolutions: TButton; DrawBest: TJvButton; Mutate: TJvButton; NodeMutationRate: TJvxSpinEdit; JvxLabel6: TJvxLabel; Bevel1: TBevel; JvxLabel7: TJvxLabel; SubMutationRate: TJvxSpinEdit; JvxLabel8: TJvxLabel; GraftRate: TJvxSpinEdit; SaveCSV: TJvButton; DoXGens: TJvButton; GensToDo: TJvxSpinEdit; JvxLabel12: TJvxLabel; CloneRate: TJvxSpinEdit; LoadButton: TJvButton; OpenDialog: TJvOpenDialog2000; StoreGens: TJvCheckBox; ScaleValue: TJvxSpinEdit; JvxLabel9: TJvxLabel; JvImage1: TJvImage; JvImage2: TJvImage; NormValue: TJvxSpinEdit; JvxLabel10: TJvxLabel; TestFileButton: TJvButton; runtestsbutton: TJvButton; procedure ChangeItemsClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure MakeGen0ButtonClick(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure ScoreSolutionsClick(Sender: TObject); procedure DrawBestClick(Sender: TObject); procedure FormResize(Sender: TObject); procedure MutateClick(Sender: TObject); procedure MutationRateChange(Sender: TObject); procedure SaveCSVClick(Sender: TObject); procedure DoXGensClick(Sender: TObject); procedure GensToDoChange(Sender: TObject); procedure LoadButtonClick(Sender: TObject); procedure TestFileButtonClick(Sender: TObject); procedure runtestsbuttonClick(Sender: TObject); private { Private declarations } Solutions : TDOMDocument; Solution : IXMLDOMElement; AllGens : TDOMDocument; LastGen : IXMLDOMElement; GenNum : Integer; BestScores : Array of Single; AverageScores : Array of Single; tableInc : Integer; Scores : Array of Array[0..2] of Single; BestScoresGen : Array of Single; MinScore : Single; // the score for the best tree in the sample, where lower is better. BestTree : Integer; // the index of the tree with the lowest score. BestTreeJobs : Array of Array of Single; BestTreeMacs : Array of Array of Single; public { Public declarations } Items : Array of Array of Array[0..1] of TJvxSpinEdit; // first element of 2 element part is time, second element is order position JobLabels : Array of TJvxLabel; MachineLabels : Array of TJvxLabel; runNumber : Integer; procedure reverse(var arr : array of Integer); function createRandomTree(dir : string; var number : Array of Integer) : IXMLDOMElement; procedure getItems(root : IXMLDOMElement; var table : array of Integer; traversal : Integer); function deleteItems(root : IXMLDOMElement; var donorNodeList : array of Integer) : IXMLDOMElement; procedure sortJobs(var jobs : Array of single); function getNode(Element : IXMLDOMElement; var number : Integer) : IXMLDOMElement; function getNodeByNumber(root : IXMLDOMElement; number : Integer) : IXMLDOMElement; function canNodeBeDeleted(Element : IXMLDOMElement; number : Integer) : boolean; function isRelated(x, y : IXMLDOMElement) : Boolean; function isAncestor(x, y : IXMLDOMElement) : Boolean; function graft(tree, branch : IXMLDOMElement) : Boolean; end; var ShopForm: TShopForm; ticks_per_second : TLargeInteger; Filename : string; start_time, end_time : TLargeInteger; implementation {$R *.DFM} procedure TShopForm.ChangeItemsClick(Sender: TObject); var i, j : Integer; Item : TjvxSpinEdit; ItemLabel : TjvxLabel; OldItemsLength, OldItemsiLength : Integer; begin FormCreate(ChangeItems); for i := 0 to high(Items) do begin for j := 0 to high(Items[i]) do begin if (i >= MachinesBox.AsInteger) or (j >= JobsBox.AsInteger) then begin FreeAndNil(Items[i][j][0]); FreeAndNil(Items[i][j][1]); end; end; if i = 0 then begin OldItemsiLength := Length(Items[0]); end; end; OldItemsLength := Length(Items); setLength(Items, MachinesBox.AsInteger, JobsBox.AsInteger); for i := 0 to MachinesBox.AsInteger - 1 do begin for j := 0 to JobsBox.AsInteger - 1 do begin if (i >= OldItemsLength) or (j >= OldItemsiLength) then begin Items[i][j][0] := TJvxSpinEdit.Create(ItemsBox); with Items[i][j][0] do begin Width := 55; Decimal := 1; ValueType := vtFloat; MinValue := 0; Top := 30 + i * (Height + 5); Left := 80 + j * (Width + 60); Parent := ItemsBox; Value := trunc(Random(20)) + 1; end; Items[i][j][1] := TJvxSpinEdit.Create(ItemsBox); with Items[i][j][1] do begin Width := 45; Decimal := 0; ValueType := vtInteger; MinValue := 0; Top := 30 + i * (Height + 5); Left := Items[i][j][0].Left + Items[i][j][0].Width + 1; Parent := ItemsBox; Value := 0; end; end; end; end; end; procedure TShopForm.FormCreate(Sender: TObject); var Time : TLabel; i : Integer; begin ItemsBox.DoubleBuffered := True; Randomize; if Sender <> ChangeItems then Filename := ''; FreeAndNil(AllGens); AllGens := TDOMDocument.Create(Self); AllGens.DefaultInterface.documentElement := AllGens.DefaultInterface.createElement('generations'); AllGens.DefaultInterface.insertBefore(AllGens.DefaultInterface.createProcessingInstruction('xml', 'version="1.0" encoding="UTF-8"'), AllGens.DefaultInterface.documentElement); for i := 0 to 300 do begin Time := TLabel.Create(OutputPanel); with Time do begin Caption := IntToStr(i * 2); Left := (50 + i * 25) - Width div 2; Top := 10; Parent := OutputPanel; end; end; GenNum := 0; GensToDoChange(Self); end; procedure TShopForm.MakeGen0ButtonClick(Sender: TObject); var ItemArray : Array of Integer; h, i, j, k : Integer; Temp : Integer; Duplicate : Boolean; begin Randomize; FreeAndNil(AllGens); AllGens := TDOMDocument.Create(Self); AllGens.DefaultInterface.documentElement := AllGens.DefaultInterface.createElement('generations'); AllGens.DefaultInterface.insertBefore(AllGens.DefaultInterface.createProcessingInstruction('xml', 'version="1.0" encoding="UTF-8"'), AllGens.DefaultInterface.documentElement); FreeAndNil(Solutions); Solutions := TDOMDocument.Create(Self); Solutions.DefaultInterface.documentElement := Solutions.DefaultInterface.createElement('solutions'); Solutions.DefaultInterface.insertBefore(Solutions.DefaultInterface.createProcessingInstruction('xml', 'version="1.0" encoding="UTF-8"'), Solutions.DefaultInterface.documentElement); Setlength(ItemArray, MachinesBox.AsInteger * JobsBox.AsInteger); for j := 0 to SampleSize.AsInteger - 1 do begin for h := 0 to High(ItemArray) do ItemArray[h] := 0; for h := 0 to High(ItemArray) do begin repeat Duplicate := False; Temp := Round(Random(Length(ItemArray))); for i := 0 to h - 1 do begin if Temp = ItemArray[i] then begin Duplicate := True; break; end; end; until not Duplicate; ItemArray[h] := Temp; end; Solution := createRandomTree('top', ItemArray); Solutions.DefaultInterface.documentElement.appendChild(Solution); end; try Solutions.DefaultInterface.save('.\tree.xml'); except end; GenNum := 1; end; function TShopForm.getNodeByNumber(root : IXMLDOMElement; number : Integer) : IXMLDOMElement; var // gets the node with the given number i : Integer; begin Result := nil; if strToInt(root.attributes.getNamedItem('number').text) = number then begin Result := root; exit; end; for i := 0 to root.childNodes.length - 1 do begin Result := getNodeByNumber(IXMLDOMElement(root.childNodes[i]), number); if Result <> nil then exit; end; end; function TShopForm.createRandomTree(dir : string; var number : Array of Integer) : IXMLDOMElement; var numberCopy : array of Integer; list1, list2 : array of Integer; i : Integer; Att : IXMLDOMAttribute; begin Result := nil; if length(number) = 0 then exit; setLength(numberCopy, high(number)); setLength(list1, high(number)); setLength(list2, high(number)); for i := 0 to high(numberCopy) do begin numberCopy[i] := number[i + 1]; list1[i] := number[i + 1]; list2[i] := number[i + 1]; end; setlength(list1, ceil(length(numberCopy) / 2)); reverse(list2); setlength(list2, length(numberCopy) div 2); Result := Solutions.DefaultInterface.createElement('node'); Result.setAttribute('number', number[0]); Result.setAttribute('dir', dir); if length(list1) > 0 then begin Result.appendChild(createRandomTree('left', list1)); end else exit; if length(list2) > 0 then begin Result.appendChild(createRandomTree('right', list2)); end else exit; end; procedure TShopForm.reverse(var arr : array of Integer); var Temp : Integer; i : Integer; begin for i := 0 to (length(arr) div 2) - 1 do begin Temp := arr[i]; arr[i] := arr[high(arr) - i]; arr[high(arr) - i] := Temp; end; end; procedure TShopForm.FormDestroy(Sender: TObject); begin Solutions.free; end; procedure TShopForm.ScoreSolutionsClick(Sender: TObject); var h, i, j, k, p : Integer; TopElement : IXMLDOMElement; table : Array of Array of Integer; table1d : Array of Integer; MachineTimes : Array of Array[0..2] of Array of Single; // stores sorted start-end times for production on each machine. should always increase, so it should be automatically sorted JobTimes : Array of Array[0..2] of Array of Single; // stores sorted start-end times for production of each job. It is possible to insert items into gaps here TasksProcessed : Array of Integer; // how many tasks have been processed for each job // OutputTableFile : TFileStream; // OutputTable : String; MacNum : Integer; MacTime : Single; JobNum : Integer; JobTime : Single; OrderTime : Single; GapStart : Single; StartTime : Single; tableCopy1 : Array of Integer; tableCopy2 : Array of Integer; begin MinScore := -1; Setlength(BestScores, GenNum); Setlength(AverageScores, GenNum); BestScores[high(BestScores)] := -1; AverageScores[high(AverageScores)] := 0; setLength(table, MachinesBox.AsInteger, JobsBox.AsInteger); setLength(table1d, MachinesBox.AsInteger * JobsBox.AsInteger); setLength(MachineTimes, MachinesBox.AsInteger); setLength(JobTimes, JobsBox.AsInteger); // for each Job, for each traversal, JobTimes stores the start and end times for when the job has been machined setLength(Scores, SampleSize.AsInteger); setLength(BestScoresGen, SampleSize.AsInteger); // OutputTable := 'tables'; setLength(TasksProcessed, JobsBox.AsInteger); // keeps track of the highest task number processed so far for each Job for i := 0 to SampleSize.AsInteger - 1 do begin for p := 0 to high(scores[i]) do begin for j := 0 to high(MachineTimes) do setLength(MachineTimes[j][p], 0); for j := 0 to high(JobTimes) do setLength(JobTimes[j][p], 0); Scores[i][p] := -1; // initialised to -1 so that any time will be bigger; end; for p := 0 to high(Scores[i]) do begin TopElement := IXMLDOMElement(Solutions.DefaultInterface.documentElement.childNodes[i]); tableInc := 0; getItems(TopElement, table1d, p); setLength(tableCopy1, length(table1d)); for j := 0 to high(tableCopy1) do tableCopy1[j] := table1d[j]; // initialising the two copies of table1d. for j := 0 to high(TasksProcessed) do TasksProcessed[j] := -1; while length(tableCopy1) > 0 do begin setLength(TableCopy2, 0); for j := 0 to high(tableCopy1) do begin // find the machine number MacNum := tableCopy1[j] div JobsBox.AsInteger; // find the job number JobNum := tableCopy1[j] mod JobsBox.AsInteger; // only process the node if all previous tasks for the job have been done if Items[MacNum][JobNum][1].AsInteger = TasksProcessed[JobNum] + 1 then begin TasksProcessed[JobNum] := Items[MacNum][JobNum][1].AsInteger; // get earliest available time to maintain the ordering if TasksProcessed[JobNum] = 0 then OrderTime := 0 else begin OrderTime := JobTimes[JobNum][p][high(JobTimes[JobNum][p])]; end; // get earliest Available time for machine try MacTime := MachineTimes[MacNum][p][high(MachineTimes[MacNum][p])]; except MacTime := 0; end; // get first gap in job processing starting >= MacTime try k := 0; while k < length(JobTimes[JobNum][p]) do begin if k > 0 then begin if (JobTimes[JobNum][p][k] - JobTimes[JobNum][p][k - 1] >= Items[MacNum][JobNum][0].Value) then begin if JobTimes[JobNum][p][k - 1] >= MacTime then begin GapStart := JobTimes[JobNum][p][(k div 2) - 1]; break; end; end; end; k := k + 2; end; if k = length(JobTimes[JobNum][p]) then JobTime := JobTimes[JobNum][p][high(JobTimes[JobNum][p])] else JobTime := GapStart; except JobTime := 0; end; StartTime := Max(JobTime, MacTime); StartTime := Max(StartTime, OrderTime); // Allocate memory to store times and processes setlength(MachineTimes[MacNum][p], length(MachineTimes[MacNum][p]) + 3); setlength(JobTimes[JobNum][p], length(JobTimes[JobNum][p]) + 2); // store times MachineTimes[MacNum][p][high(MachineTimes[MacNum][p]) - 2] := MacNum * JobsBox.AsInteger + JobNum; MachineTimes[MacNum][p][high(MachineTimes[MacNum][p]) - 1] := StartTime; MachineTimes[MacNum][p][high(MachineTimes[MacNum][p])] := StartTime + Items[MacNum][JobNum][0].Value; JobTimes[JobNum][p][high(JobTimes[JobNum][p]) - 1] := StartTime; JobTimes[JobNum][p][high(JobTimes[JobNum][p])] := StartTime + Items[MacNum][JobNum][0].Value; // find the highest time in MachineTimes as the fitness of the current tree Scores[i][p] := Max(Scores[i][p], MachineTimes[MacNum][p][high(MachineTimes[MacNum][p])]); // sort and store job times sortJobs(JobTimes[JobNum][p]); end else begin // if this node cannot be processed yet, because previous tasks in the job haven't been done yet setLength(TableCopy2, length(TableCopy2) + 1); TableCopy2[high(tableCopy2)] := TableCopy1[j]; end; end; setLength(tableCopy1, length(tableCopy2)); for k := 0 to high(tableCopy2) do tableCopy1[k] := tableCopy2[k]; end; end; // now that times have been determined, do some output { OutputTable := OutputTable + ''#13#10; OutputTable := OutputTable + ''#13#10''#13#10''#13#10; for j := 1 to (2 * JobsBox.AsInteger) do begin if j mod 2 = 1 then OutputTable := OutputTable + ''#13#10 else OutputTable := OutputTable + ''#13#10; end; OutputTable := OutputTable + ''#13#10''#13#10; for j := 0 to MachinesBox.AsInteger - 1 do begin OutputTable := OutputTable + ''#13#10''#13#10; for k := 0 to (3 * JobsBox.AsInteger) - 1 do begin if k mod 3 <> 0 then OutputTable := OutputTable + ''#13#10; end; OutputTable := OutputTable + ''#13#10; end; OutputTable := OutputTable + '
 Start TimeEnd Time
Machine ' + IntToStr(j) + '' + FloatToStr(MachineTimes[j][k]) + '
'#13#10;} for k := 0 to SampleSize.AsInteger - 1 do begin BestScoresGen[k] := Scores[k][0]; for j := 1 to high(Scores[k]) do begin if Scores[k][j] < BestScoresGen[k] then BestScoresGen[k] := Scores[k][j]; end; end; AverageScores[GenNum - 1] := AverageScores[GenNum - 1] + BestScoresGen[i] / SampleSize.Value; if (MinScore > BestScoresGen[i]) or (MinScore < 0) then begin MinScore := BestScoresGen[i]; BestScores[GenNum - 1] := MinScore; BestTree := i; p := 0; // get traversal of best score for current tree for k := 1 to high(scores[i]) do begin if Scores[i][k] < Scores[i][p] then p := k; end; setLength(BestTreeJobs, Length(JobTimes)); setLength(BestTreeMacs, Length(MachineTimes)); for k := 0 to high(BestTreeJobs) do begin setlength(BestTreeJobs[k], Length(JobTimes[k][p])); for j := 0 to high(BestTreeJobs[k]) do begin BestTreeJobs[k][j] := JobTimes[k][p][j]; end; end; for k := 0 to high(BestTreeMacs) do begin setlength(BestTreeMacs[k], Length(MachineTimes[k][p])); for j := 0 to high(BestTreeMacs[k]) do begin BestTreeMacs[k][j] := MachineTimes[k][p][j]; end; end; end; end; { try OutputTableFile := TFileStream.Create('.\outputTable.html', fmCreate or fmOpenWrite); OutputTableFile.Write(PChar(OutputTable)^,Length(OutputTable)); except MessageDlg('Could not create the output file.'#13#10'Please check that there is enough disk space and that the disk is not write-protected.', mtError, [mbOK], 0); end; FreeAndNil(OutputTableFile); } end; procedure TShopForm.getItems(root : IXMLDOMElement; var table : array of Integer; traversal : Integer); var i : Integer; begin case traversal of 0: begin // prefix traversal table[tableInc] := StrToInt(root.attributes.getNamedItem('number').text); tableInc := tableInc + 1; for i := 0 to root.childNodes.length - 1 do getItems(IXMLDOMElement(root.childNodes[i]), table, traversal); end; 1: begin // infix traversal if root.childnodes.length >= 1 then begin if root.firstChild.attributes.getNamedItem('dir').text = 'left' then begin getItems(IXMLDOMElement(root.firstChild), table, traversal); end; end; table[tableInc] := StrToInt(root.attributes.getNamedItem('number').text); tableInc := tableInc + 1; if root.childnodes.length >= 1 then begin if root.lastChild.attributes.getNamedItem('dir').text = 'right' then begin getItems(IXMLDOMElement(root.lastChild), table, traversal); end; end; end; 2: begin // postfix traversal for i := 0 to root.childNodes.length - 1 do getItems(IXMLDOMElement(root.childNodes[i]), table, traversal); table[tableInc] := StrToInt(root.attributes.getNamedItem('number').text); tableInc := tableInc + 1; end; end; end; procedure TShopForm.sortJobs(var jobs : Array of single); var i : Integer; TempJobTime : Array[0..1] of Single; begin for i := 2 to high(jobs) do begin if jobs[i] < jobs[i - 1] then begin TempJobTime[0] := jobs[i]; TempJobTime[1] := jobs[i + 1]; jobs[i] := jobs[i - 2]; jobs[i + 1] := jobs[i - 1]; jobs[i - 2] := TempJobTime[0]; jobs[i - 1] := TempJobTime[1]; end; end; end; procedure TShopForm.DrawBestClick(Sender: TObject); var i, j : Integer; StartTime, EndTime : Single; Shape : TShape; ProcessNum : TLabel; begin for i := 0 to outputPanel.ControlCount - 1 do begin try TShape(OutputPanel.Controls[i]).brush.Bitmap := nil; // trying to cause an exception if it is not a shape OutputPanel.Controls[i].free; except end; try if TLabel(OutputPanel.Controls[i]).tag < 0 then begin // trying to cause an exception if it is not a process number label OutputPanel.Controls[i].free; end; except end; end; OutputPanel.Repaint; for i := 0 to high(BestTreeMacs) do begin Shape := TShape.Create(OutputPanel); with Shape do begin Visible := False; Height := 20; Width := Round(BestTreeMacs[i][high(BestTreeMacs[i])] * 12.5); Top := 50 + i * (Height + 5); Left := 50; Brush.Color := clGray; Parent := OutputPanel; Visible := True; end; for j := 1 to high(BestTreeMacs[i]) do begin if (j - 1) mod 3 = 1 then begin StartTime := BestTreeMacs[i][j - 1]; EndTime := BestTreeMacs[i][j]; // draw the box representing these start and end times for the machine i Shape := TShape.Create(OutputPanel); with Shape do begin Visible := False; Height := 20; Width := Round((EndTime - StartTime) * 12.5); Top := 50 + i * (Height + 5); Left := 50 + Round(StartTime * 12.5); Brush.Color := clRed; Parent := OutputPanel; Visible := True; end; ProcessNum := TLabel.Create(OutputPanel); with ProcessNum do begin Visible := False; Caption := FormatFloat('0', BestTreeMacs[i][j - 2]); Font.Color := clBlack; Color := clRed; Left := 50 + Round(StartTime * 12.5) + (Round((EndTime - StartTime) * 12.5) div 2) - Width div 2; Top := 50 + i * (Shape.Height + 5) + (Shape.Height - Height) div 2; Tag := -1; Parent := OutputPanel; Visible := True; end; end; end; end; end; procedure TShopForm.FormResize(Sender: TObject); begin ItemsBox.Height := (3 * Height) div 8; OutputPanel.Height := (3 * Height) div 8; // ActionsBox.Top := ClientHeight - ActionsBox.Height; // SetupBox.Top := ClientHeight - SetupBox.Height; end; procedure TShopForm.MutateClick(Sender: TObject); var i, j, k, r, ass : Integer; WorstScore, BestScore : Single; BestIndex, WorstIndex : Integer; Weights : Array of Single; lnSumOfScores : Double; SumNumerators : Double; numOfKids : Array of Integer; totalKids : Integer; Nodes : Array[0..1] of IXMLDOMElement; Parents : Array[0..1] of IXMLDOMElement; dirs : Array[0..1] of string; NodeNumbers : Array[0..1] of Integer; NodesClash : Boolean; CurrentTree : IXMLDOMElement; DonorTree, DonorNode : IXMLDOMElement; DonorNodeList : Array of Integer; RandomVal : Single; DonorFound : Boolean; BestCloned : Boolean; OneBestCloned : Boolean; begin // backup old tree LastGen := IXMLDOMElement(Solutions.DefaultInterface.documentElement.cloneNode(true)); if StoreGens.Checked then // there is the option of not storing all data as it can use hundreds of MB of memory AllGens.DefaultInterface.documentElement.appendChild(Solutions.DefaultInterface.documentElement.cloneNode(true)); // destroy old tree so new items can be written FreeAndNil(Solutions); Solutions := TDOMDocument.Create(Self); Solutions.DefaultInterface.documentElement := Solutions.DefaultInterface.createElement('solutions'); Solutions.DefaultInterface.insertBefore(Solutions.DefaultInterface.createProcessingInstruction('xml', 'version="1.0" encoding="UTF-8"'), Solutions.DefaultInterface.documentElement); // get top and bottom scores BestScore := -1; WorstScore := -1; for i := 0 to high(BestScoresGen) do begin if (BestScoresGen[i] < BestScore) or (BestScore < 0) then begin BestScore := BestScoresGen[i]; BestIndex := i; end; if (BestScoresGen[i] > WorstScore) or (WorstScore < 0) then begin WorstScore := BestScoresGen[i]; WorstIndex := i; end; end; // normalise scores as starting from 0 for i := 0 to high(Scores) do begin BestScoresGen[i] := BestScoresGen[i] + NormValue.Value - BestScore; end; WorstScore := WorstScore + NormValue.Value - BestScore; BestScore := NormValue.Value; // get weights: (1 - ln(score[i]) / ln(totalScore) / sum of numerators setLength(Weights, Length(BestScoresGen)); lnSumOfScores := 0; for i := 0 to high(BestScoresGen) do begin lnSumOfScores := lnSumOfScores + BestScoresGen[i]; end; lnSumOfScores := ln(lnSumOfScores); { for i := 0 to high(Scores) do begin // Version 2 weighting only Scores[i] := 1 + WorstScore - Scores[i]; end; } for i := 0 to high(BestScoresGen) do begin SumNumerators := SumNumerators + power(0.80 + ScaleValue.AsInteger * 0.02, BestScoresGen[i]); // Version 2 weighting // SumNumerators := SumNumerators + 1 - ln(Scores[i]) / lnSumOfScores; // Version 1 weighting end; for i := 0 to high(BestScoresGen) do begin Weights[i] := power(0.80 + ScaleValue.AsInteger * 0.02, BestScoresGen[i]) / SumNumerators; // Version 2 weighting // Weights[i] := (1 - ln(Scores[i]) / lnSumOfScores) / SumNumerators; // Version 1 weighting end; // determine how many of each tree will be mutated and passed to the next generation setLength(NumOfKids, Length(BestScoresGen)); totalKids := 0; for i := 0 to high(BestScoresGen) do begin NumOfKids[i] := Round(Weights[i] * SampleSize.AsInteger); totalKids := totalKids + NumOfKids[i]; end; while totalKids < SampleSize.AsInteger do begin Inc(NumOfKids[round(random(High(NumOfKids)))]); Inc(totalKids); end; while totalKids > SampleSize.AsInteger do begin if NumOfKids[WorstIndex] > 0 then NumOfKids[WorstIndex] := NumOfKids[WorstIndex] - 1 else begin RandomVal := BestIndex; while (RandomVal = BestIndex) or (NumOfKids[Round(RandomVal)] = 0) do RandomVal := Random(High(NumOfKids)); NumOfKids[Round(RandomVal)] := NumOfKids[Round(RandomVal)] - 1; end; totalKids := totalKids - 1; end; // mutate trees: for each tree: begin OneBestCloned := false; // one copy of the first tree that has the best makespan will be passed through for i := 0 to high(BestScoresGen) do begin if random < 0.5 then BestCloned := False // 50% chance of cloning a tree that has the best makespan else BestCloned := True; for j := 0 to NumOfKids[i] - 1 do begin CurrentTree := IXMLDOMElement(LastGen.ChildNodes[i].cloneNode(True)); if (BestScoresGen[i] = BestScore) and (not (BestCloned and OneBestCloned)) then begin// making sure that at least one tree that has BestCloned := true; // the best score is passed unchanged to the next generation. OneBestCloned := true; // It ensures that the best score for each generation does not get worse end else begin // choose node mutation or sub-tree mutation RandomVal := random; if RandomVal <= NodeMutationRate.Value then begin { try // example assertion code for ass := 0 to MachinesBox.AsInteger * JobsBox.AsInteger - 1 do assert(getNodeByNumber(currentTree, ass) <> nil, 'The node with number ' + IntToStr(ass) + ' is missing from currentTree in the NODE mutation section of mutateclick.'); except on E: EAssertionFailed do MessageDlg(E.Message, mtWarning, [mbOK], 0); end;} // if node mutation then begin // select nodes for k := 0 to 1 do begin nodeNumbers[k] := round(random(MachinesBox.AsInteger * JobsBox.AsInteger - 1)); while (k = 1) and (nodenumbers[k] = nodenumbers[k - 1]) do nodeNumbers[k] := round(random(MachinesBox.AsInteger * JobsBox.AsInteger - 1)); Nodes[k] := getNodeByNumber(CurrentTree, nodeNumbers[k]); end; // swap values Nodes[0].attributes.getNamedItem('number').text := IntToStr(nodeNumbers[1]); Nodes[1].attributes.getNamedItem('number').text := IntToStr(nodeNumbers[0]); end else if RandomVal <= NodeMutationRate.Value + SubMutationRate.Value then begin // if subtree mutation then begin // select nodes for k := 0 to 1 do begin nodeNumbers[k] := round(random(MachinesBox.AsInteger * JobsBox.AsInteger - 1)); while getNodeByNumber(currentTree, nodeNumbers[k]).attributes.getNamedItem('dir').text = 'top' do nodeNumbers[k] := round(random(MachinesBox.AsInteger * JobsBox.AsInteger - 1)); // preventing top node from being chosen if k = 1 then begin NodesClash := True; while NodesClash do begin NodesClash := False; // Choose a node Nodes[k] := getNodeByNumber(CurrentTree, nodeNumbers[k]); // if node and Nodes[0] are directly related then choose again if isRelated(Nodes[0], Nodes[1]) then begin NodesClash := True; nodeNumbers[k] := round(random(MachinesBox.AsInteger * JobsBox.AsInteger - 1)); while getNodeByNumber(currentTree, nodeNumbers[k]).attributes.getNamedItem('dir').text = 'top' do nodeNumbers[k] := round(random(MachinesBox.AsInteger * JobsBox.AsInteger - 1)); // preventing top node from being chosen end; end; end else Nodes[k] := getNodeByNumber(currentTree, nodeNumbers[k]); Parents[k] := IXMLDOMElement(Nodes[k].parentNode); // save left/right values dirs[k] := Nodes[k].attributes.getNamedItem('dir').text; end; // prune nodes for k := 0 to 1 do Parents[k].removeChild(Nodes[k]); // swap positions for k := 0 to 1 do begin // fix dir values if dirs[k] = 'left' then begin if Parents[k].childNodes.length = 0 then begin Nodes[abs(k - 1)].attributes.getNamedItem('dir').text := dirs[k]; Parents[k].appendChild(Nodes[abs(k - 1)].cloneNode(true)); end else begin Nodes[abs(k - 1)].attributes.getNamedItem('dir').text := dirs[k]; Parents[k].insertBefore(Nodes[abs(k - 1)].cloneNode(true), Parents[k].firstChild); end; end else begin Nodes[abs(k - 1)].attributes.getNamedItem('dir').text := dirs[k]; Parents[k].appendChild(Nodes[abs(k - 1)].cloneNode(true)); end; end; end else if RandomVal <= NodeMutationRate.Value + SubMutationRate.Value + GraftRate.Value then begin DonorFound := false; while not DonorFound do begin // get donor tree r := i; while r = i do r := Round(random(SampleSize.AsInteger - 1)); DonorTree := IXMLDOMElement(LastGen.childNodes[r].cloneNode(true)); // extract donor branch -> compile numbers into list r := round(random(MachinesBox.AsInteger * JobsBox.AsInteger - 1)); while getNodeByNumber(donorTree, r).attributes.getNamedItem('dir').text = 'top' do r := round(random(MachinesBox.AsInteger * JobsBox.AsInteger - 1)); // preventing top node from being chosen DonorNode := getNodeByNumber(DonorTree, r); TableInc := 0; setLength(DonorNodeList, MachinesBox.AsInteger * JobsBox.AsInteger); for r := 0 to high(DonorNodeList) do DonorNodeList[r] := -1; getItems(DonorNode, DonorNodeList, 0); for r := 0 to high(DonorNodeList) do if DonorNodeList[r] = -1 then break; setLength(DonorNodeList, r); // check that all nodes in donor branch can be safely removed from the recipient DonorFound := true; for r := 0 to High(DonorNodeList) do begin if not CanNodeBeDeleted(CurrentTree, DonorNodeList[r]) then begin DonorFound := false; break; end; end; end; // traverse recipient tree, removing each node that appears in the donor branch list and promoting random children to fill the parent node's role try CurrentTree := deleteItems(CurrentTree, DonorNodeList); except on E: Exception do MessageDlg(E.Message, mtWarning, [mbOK], 0); end; // graft donor tree at random point of recipient graft(CurrentTree, donorNode); end; end; // assign new tree to new sample Solutions.DefaultInterface.documentElement.appendChild(currentTree); end; end; GenNum := GenNum + 1; end; function TShopForm.getNode(Element : IXMLDOMElement; var number : Integer) : IXMLDOMElement; var i : Integer; begin Result := nil; if number = 0 then begin Result := Element; exit; end else begin for i := 0 to Element.childNodes.length - 1 do begin if Result = nil then begin number := number - 1; Result := getNode(IXMLDOMElement(Element.ChildNodes[i]), number); end else exit; end; end; end; function TShopForm.canNodeBeDeleted(Element : IXMLDOMElement; number : Integer) : boolean; var // checks to see if node with number attribute = number is a leaf or parent of a leaf i, j : Integer; begin Result := false; if (Element.attributes.getNamedItem('number').text = intToStr(number)) and (Element.childNodes.length = 0) then begin Result := true; exit; end; if Element.parentNode <> nil then begin if (Element.parentNode.attributes.getNamedItem('number').text = intToStr(number)) and (Element.childNodes.length < 2) then begin Result := true; exit; end else if Element.parentNode.attributes.getNamedItem('number').text = intToStr(number) then exit; end; for i := 0 to Element.childNodes.length - 1 do begin Result := canNodeBeDeleted(IXMLDOMElement(Element.childNodes[i]), number); if Result then exit; end; end; function TShopForm.isRelated(x, y : IXMLDOMElement) : Boolean; begin Result := isAncestor(x, y) or isAncestor(y, x); end; function TShopForm.isAncestor(x, y : IXMLDOMElement) : Boolean; begin if (not (x.attributes.getNamedItem('dir').text = 'top')) and (y.attributes.getNamedItem('dir').text = 'top') then Result := False else if (x.attributes.getNamedItem('number').text) = (y.attributes.getNamedItem('number').text) then Result := True else Result := isAncestor(x, IXMLDOMElement(y.parentNode)); end; procedure TShopForm.MutationRateChange(Sender: TObject); var relativeSizes : array[0..1] of single; begin // if SubMutationRate.Value + NodeMutationRate.Value + GraftRate.Value > 1 then begin { if (Sender = SubMutationRate) or (Sender = CloneRate) then begin RelativeSizes[0] := NodeMutationRate.Value / (GraftRate.Value + NodeMutationRate.Value); RelativeSizes[1] := GraftRate.Value / (GraftRate.Value + NodeMutationRate.Value); NodeMutationRate.OnChange := nil; GraftRate.OnChange := nil; NodeMutationRate.Value := ((1 - CloneRate.Value) - SubMutationRate.Value) * RelativeSizes[0]; GraftRate.Value := ((1 - CloneRate.Value) - SubMutationRate.Value) * RelativeSizes[1]; NodeMutationRate.OnChange := MutationRateChange; GraftRate.OnChange := MutationRateChange; end else if Sender = NodeMutationRate then begin RelativeSizes[0] := SubMutationRate.Value / (GraftRate.Value + SubMutationRate.Value); RelativeSizes[1] := GraftRate.Value / (GraftRate.Value + SubMutationRate.Value); SubMutationRate.OnChange := nil; GraftRate.OnChange := nil; SubMutationRate.Value := ((1 - CloneRate.Value) - NodeMutationRate.Value) * RelativeSizes[0]; GraftRate.Value := ((1 - CloneRate.Value) - NodeMutationRate.Value) * RelativeSizes[1]; SubMutationRate.OnChange := MutationRateChange; GraftRate.OnChange := MutationRateChange; end else begin RelativeSizes[0] := NodeMutationRate.Value / (SubMutationRate.Value + NodeMutationRate.Value); RelativeSizes[1] := SubMutationRate.Value / (SubMutationRate.Value + NodeMutationRate.Value); NodeMutationRate.OnChange := nil; SubMutationRate.OnChange := nil; NodeMutationRate.Value := ((1 - CloneRate.Value) - GraftRate.Value) * RelativeSizes[0]; SubMutationRate.Value := ((1 - CloneRate.Value) - GraftRate.Value) * RelativeSizes[1]; NodeMutationRate.OnChange := MutationRateChange; SubMutationRate.OnChange := MutationRateChange; end;} // end; end; function TShopForm.deleteItems(root : IXMLDOMElement; var donorNodeList : array of Integer) : IXMLDOMElement; var i, j : Integer; parent : IXMLDOMElement; children : array of IXMLDOMElement; childToPromote : Integer; rootdir : string; ChildrenLength : Integer; BufferElement : IXMLDOMElement; begin Result := IXMLDOMElement(root.cloneNode(false)); for i := 0 to high(donorNodeList) do begin if StrToInt(Result.attributes.getNamedItem('number').text) = donorNodeList[i] then begin rootdir := Result.attributes.getNamedItem('dir').text; // get the current node's children setlength(children, root.childNodes.length); for j := 0 to high(Children) do children[j] := IXMLDOMElement(root.childNodes[j].cloneNode(true)); // disconnect children from root node while root.hasChildNodes do root.removeChild(root.firstChild); // if there is at least one child, choose a child to be promoted ChildrenLength := Length(Children); if childrenlength = 1 then childToPromote := 0 else if childrenlength > 1 then begin // look at each child and promote the first child that has at most one child of its own for j := 0 to childrenlength - 1 do begin if children[j].childNodes.length <= 1 then begin childToPromote := j; break; end; end; end else childToPromote := -1; // assign the child to the root level in either the top, left or right position as appropriate if childToPromote >= 0 then begin Children[ChildToPromote].attributes.getNamedItem('dir').text := rootdir; Result := IXMLDOMElement(Children[ChildToPromote].cloneNode(true)); end else Result := nil; // if there is still one child left, add it to either the left or right position as appropriate if Childrenlength = 2 then begin if Result.childNodes.length = 1 then begin // if the node that was promoted already has one child if Result.firstChild.attributes.getNamedItem('dir').text = 'left' then begin // and if the child is on the left Result.appendChild(Children[abs(ChildToPromote - 1)].cloneNode(true)); // add the original root node's Result.lastChild.attributes.getNamedItem('dir').text := 'right'; // other child to the right end else begin // and if the child is on the right Result.insertBefore(Children[abs(ChildToPromote - 1)].cloneNode(true), Result.firstChild); // add the original root node's Result.firstChild.attributes.getNamedItem('dir').text := 'left'; // other child to the left end; end else // or if the node that was promoted had no children, then add the original root node's other child Result.appendChild(Children[abs(ChildToPromote - 1)].cloneNode(true)); // to whichever side it was already on end; // if the above code is executed, then call deleteItems(newRoot, table); exit; to avoid the code below if ChildToPromote >= 0 then Result := deleteItems(IXMLDOMElement(Result.cloneNode(true)), donorNodeList); exit; end; end; ChildrenLength := root.childNodes.length; i := 0; while i < childrenLength do begin BufferElement := deleteItems(IXMLDOMElement(root.childNodes[i].cloneNode(true)), donorNodeList); if BufferElement <> nil then Result.appendChild(BufferElement); i := i + 1; end; end; function TShopForm.graft(tree, branch : IXMLDOMElement) : boolean; var // grafting takes place at the first available position, thereby ensuring that trees take less space i : Integer; // than if they were allowed to branch out in any way begin Result := true; if tree.childNodes.length = 0 then tree.appendChild(branch.cloneNode(true)) else if tree.childnodes.length = 1 then begin if tree.firstChild.attributes.getNamedItem('dir').text = 'left' then begin tree.appendChild(branch.cloneNode(true)); tree.lastChild.attributes.getNamedItem('dir').text := 'right'; end else begin tree.insertBefore(branch.cloneNode(true), tree.firstChild); tree.firstChild.attributes.getNamedItem('dir').text := 'left'; end; end else begin Result := false; for i := 0 to tree.childnodes.length - 1 do begin Result := graft(IXMLDOMElement(tree.childnodes[i]), branch); if result then exit; end; end; end; procedure TShopForm.SaveCSVClick(Sender: TObject); var CSV : TFileStream; csvstring : String; i : Integer; begin // put in data here at some point csvstring := 'Sample Size,' + IntToStr(SampleSize.AsInteger) + ',Time taken (min),' + FormatFloat('0.000', ((end_time - start_time) / ticks_per_second) / 60) + #13#10'Generation,Best Score,Average Score'#13#10; for i := 0 to high(BestScores) do begin csvString := csvString + IntToStr(i) + ',' + FloatToStr(BestScores[i]) + ',' + FloatToStr(AverageScores[i]) + #13#10; end; try try if Filename = '' then CSV := TFileStream.Create('.\output.csv', fmCreate or fmOpenWrite) else CSV := TFileStream.Create(ChangeFileExt(Filename, '.nsg.' + formatfloat('0.00', NodeMutationRate.Value) + '-' + formatfloat('0.00', SubMutationRate.Value) + '-' + formatfloat('0.00', GraftRate.Value) + ' -- ' + IntToStr(runNumber) + '.csv' ), fmCreate or fmOpenWrite); except CSV := TFileStream.Create('c:\output.csv', fmCreate or fmOpenWrite); end; CSV.Write(PChar(csvstring)^,Length(csvstring)); except MessageDlg('Could not create the csv file.'#13#10'Please check that there is enough disk space and that the disk is not write-protected.', mtError, [mbOK], 0); end; FreeAndNil(CSV); end; procedure TShopForm.DoXGensClick(Sender: TObject); var i : Integer; begin try QueryPerformanceCounter(start_time); for i := 0 to GensToDo.AsInteger - 1 do begin if GenNum = 0 then MakeGen0ButtonClick(Self) else begin try MutateClick(Self); except MessageDlg('Error in MutateClick.', mtError, [mbOK], 0); end; end; try ScoreSolutionsClick(Self); except MessageDlg('Error in ScoreSolutionsClick.', mtError, [mbOK], 0); end; end; if (Sender <> TestFileButton) then DrawBestClick(Self); QueryPerformanceCounter(end_time); SaveCSVClick(Self); try if (Sender = DoXGens) and StoreGens.Checked then AllGens.DefaultInterface.save('.\allGens.xml'); except try if StoreGens.Checked then AllGens.DefaultInterface.save('c:\allGens.xml'); except MessageDlg('Could not create allGens.xml.'#13#10'Please check that there is enough disk space and that the disk is not write-protected.', mtError, [mbOK], 0); end; end; except end; end; procedure TShopForm.GensToDoChange(Sender: TObject); begin DoXGens.Caption := 'Do ' + IntToStr(GensToDo.AsInteger) + ' Gens'; end; procedure TShopForm.LoadButtonClick(Sender: TObject); var InFile : TFileStream; InString : TStringStream; ch : char; curNum : String; readingNum : Boolean; numsRead : Integer; s : String; begin openDialog.Execute; if OpenDialog.Filename = '' then exit; Filename := OpenDialog.Filename; try numsRead := 0; readingNum := False; InFile := TFileStream.Create(OpenDialog.Filename,fmOpenRead); InString := TStringStream.Create(s); InString.CopyFrom(Infile, 0); InFile.Free; InString.Position := 0; while not (InString.Position = Instring.Size) do begin InString.Read(ch, 1); try if StrToInt(string(ch)) > -1000 then begin if not readingNum then begin readingNum := true; curNum := ''; end; curNum := curNum + ch; end; except if readingNum then begin readingNum := false; if numsRead = 0 then JobsBox.Value := StrToInt(curNum) else if numsRead = 1 then begin MachinesBox.Value := StrToInt(curNum); ChangeItemsClick(Self); end else begin Items[((numsRead div 2) - 1) mod MachinesBox.AsInteger][((numsRead div 2) - 1) div MachinesBox.AsInteger][(numsRead + 1) mod 2].Value := StrToInt(curNum); end; numsRead := numsRead + 1; end; end; end; finally // Infile.Free; InString.Free; end; end; procedure TShopForm.TestFileButtonClick(Sender: TObject); begin SubMutationRate.MaxValue := 2; NodeMutationRate.MaxValue := 2; GraftRate.MaxValue := 2; // NodeMutationRate.Value := 0.0; while NodeMutationRate.Value <= 0.9 do begin SubMutationRate.Value := 0; while SubMutationRate.Value <= 1 - NodeMutationRate.Value do begin GraftRate.Value := 1 - (NodeMutationRate.Value + SubMutationRate.Value); DoXGensClick(TestFileButton); FormCreate(ChangeItems); SubMutationRate.Value := SubMutationRate.Value + 0.1; end; NodeMutationRate.Value := NodeMutationRate.Value + 0.05; end; SubMutationRate.MaxValue := 1; NodeMutationRate.MaxValue := 1; GraftRate.MaxValue := 1; end; procedure TShopForm.runtestsbuttonClick(Sender: TObject); var i, j : Integer; begin for j := 0 to 4 do begin runNumber := j; GenNum := 0; for i := 0 to 4 do begin ScaleValue.Value := 5 + i; NormValue.Value := 1 + 7 * i; DoXGensClick(TestFileButton) end; end; end; initialization // get ticks/sec QueryPerformanceFrequency(TLargeInteger(ticks_per_second)); end.