decalsamples.pas

C++中的STL真的让人爱不释手,如果你使用DELPHI,现在你也有了类似于STL的标准库,还不赶快下载啊!

    i : Integer;
begin
	a := DArray.Create;
  l := DList.Create;
	for i := 1 to 10 do
  	a.add([i]);
  for i := 4 to 7 do
  	l.add([i]);

  if includes(a,l) then
  	writeln('Inclusion');

  if includes(l,a) then
  	writeln('error');

  if includes(l,l) then
  	writeln('self include ok');

    
  FreeAll([a,l]);

end;

procedure SetOps2;
var a : DArray;
		l : DList;
    o : DArray;
    i : Integer;
begin
	a := DArray.Create;
  l := DList.Create;
	for i := 1 to 10 do
  	a.add([i]);
  for i := 4 to 7 do
  	l.add([i]);

  o := DArray.Create;
  setDifference(a,l,o.finish);
  PrintContainer(o);

  o.clear;

  setIntersection(a,l,o.finish);
  PrintContainer(o);

  FreeAll([a,l,o]);

end;

procedure SetOps3;
var a : DArray;
		l : DList;
    o : DArray;
    i : Integer;
begin
	a := DArray.Create;
  l := DList.Create;
	for i := 1 to 10 do
  	a.add([i]);
  for i := 20 to 27 do
  	l.add([i]);

  o := DArray.Create;
  setUnion(a,l,o.finish);
  PrintContainer(o);

  FreeAll([a,l,o]);

end;

procedure Comparing1;
var a,b : DArray;
		i : Integer;
begin

	a := DArray.Create;
  b := DArray.Create;

  for i := 1 to 15 do
  	begin
    	a.add([i]);
      b.add([i]);
    end;

  if equal(a,b) then
  	writeln('they''re equal');

  a.remove([5]);

  if equal(a,b) then
  	writeln('Error');

  FreeAll([a,b]);

end;


type
	TMorphing = class
  protected
  	FCount : Integer;
  public
  	function SimpleUnary(const obj : DObject) : DObject;
  end;

function TMorphing.SimpleUnary(const obj : DObject) : DObject;
begin
	result := Make([Format('closure %d - %d', [FCount, asInteger(obj)])]);
  Inc(FCount);
end;

function SimpleUnaryProc(ptr : Pointer; const obj : DObject) : DObject;
begin
	result := Make(['proc ' + IntToStr(asInteger(obj))]);
end;

{** Demonstrates how SDL function pointers can be used either as closures
or normal function pointers. }
procedure Morphing1;
var x : TMorphing;
		l : DList;
    a : DArray;
    s : DSet;
    i : Integer;
begin
	s := DSet.Create;

  x := TMorphing.Create;

  for i := 1 to 10 do
  	s.add([i]);

  l := DList.Create;
  a := DArray.Create;

  transformUnary(s, l, x.SimpleUnary);
  PrintContainer(l);

  transformUnary(s, a, MakeUnary(SimpleUnaryProc));
  PrintContainer(a);

  FreeAll([l,a,s,x]);
end;

procedure Rotate1;
var a : DArray;
		i : Integer;
begin
	a := DArray.Create;
  for i := 1 to 10 do
  	a.add([i]);

  PrintContainer(a);

  // rotate (shift) the entire array by 1 element
  rotate(a.start, advanceByF(a.start,1), a.finish);

  PrintContainer(a);

  a.free;
end;

procedure Rotate2;
var a : DArray;
		i : Integer;
begin
	a := DArray.Create;
  for i := 1 to 10 do
  	a.add([i]);

  PrintContainer(a);

  // shift the middle part of the array.  element 3 will go to position 5,
  // element 4 to position 6, and so on.
  rotate(advanceByF(a.start, 3), advanceByF(a.start, 5), advanceByF(a.start, 7));

  PrintContainer(a);

  a.free;
end;

{** Same as rotate2, but does the same operation on a list instead of an
array.  }
procedure Rotate3;
var a : DList;
		i : Integer;
begin
	a := DList.Create;
  for i := 1 to 10 do
  	a.add([i]);

  PrintContainer(a);

  // shift the middle part of the array.  element 3 will go to position 5,
  // element 4 to position 6, and so on.
  rotate(advanceByF(a.start, 3), advanceByF(a.start, 5), advanceByF(a.start, 7));

  PrintContainer(a);

  a.free;
end;

procedure Equal1;
var l : DList;
		a : DArray;
		i : Integer;
begin
	l := DList.Create;
  a := DArray.Create;
  for i := 1 to 10 do
  	begin
	  	l.add([i]);
      a.add([i]);
    end;

  // They should be equal at this point.
  if equal(a,l) then
  	writeln('They''re equal!');

  // Now they're not equal!
  a.remove([5]);

  if equal(a,l) then
  	writeln('Error');

  FreeAll([a,l]);

end;

procedure Mismatch1;
var l : DList;
		a : DArray;
		i : Integer;
    pair : DIteratorPair;
begin
	l := DList.Create;
  a := DArray.Create;
  for i := 1 to 10 do
  	begin
	  	l.add([i]);
      a.add([i]);
    end;

  // Since they have the same values, no mismatch should be detected
  pair := mismatch(a,l);
  if atEnd(pair.first) and atEnd(pair.second) then
  	writeln('Correct');

  // Now they're not equal!
  a.remove([5]);

  // Now we should detect a mismatch.
  pair := mismatch(a,l);
  if (not atEnd(pair.first)) or (not atEnd(pair.second)) then
  	begin
    	writeln('Mismatch detected.');
    end;

  FreeAll([a,l]);

end;

procedure DTStringList1;
var s : TStringList;
		dt : DTStrings;
begin
	s := TStringList.Create;
	dt := DTStrings.Create(s);

  s.Add('hello');
  s.Add('there');
  s.Add('in');
  s.Add('string');
  s.Add('land');
  s.Add('hello');

  PrintContainer(dt);

  writeln('There are ', count(dt, ['hello']), ' hellos.');

	dt.remove(['hello']);

  PrintContainer(dt);

  FreeAll([dt,s]);

end;

procedure BSearch1;
var a : DArray;
		i : Integer;
    iter : DIterator;
begin
	a := DArray.Create;
  i := 1;
  while i < 20 do
  	begin
	  	a.add([i]);
      Inc(i,2);
    end;

  iter := binarySearch(a, [1]);
  iter := binarySearch(a, [15]);
  iter := binarySearch(a, [7]);
  iter := binarySearch(a, [2]);
  iter := binarySearch(a, [14]);

  a.free;
end;

procedure Big1;
var i : Integer;
		a : DArray;
		ms, st : DeCALDWORD;
begin
	a := DArray.Create;

  ms := GetTickCount;

  a.ensureCapacity(500000);
	for i := 1 to 500000 do
  	a.add([i]);

  a.free;

  st := GetTickCount;
  ms := st - ms;
  writeln('Numerics done: ',ms);

	a := DArray.Create;

  a.ensureCapacity(500000);
	for i := 1 to 500000 do
  	a.add([IntToStr(i)]);

  a.free;

  ms := GetTickCount - st;
  writeln('Strings done: ', ms);

end;

procedure Big2;
var i : Integer;
		m : DMap;
		st, ms : DeCALDWORD;
begin
	m := DMap.Create;

  m.ensureCapacity(500000);

  ms := GetTickCount;

  for i := 1 to 500000 do
  	m.putPair([i, IntToStr(i)]);

  st := GetTickCount;
  ms := st - ms;
  writeln('add: ', ms);

  st := GetTickCount;

  m.free;

	ms := GetTickCount - st;

  writeln('free: ', ms);

end;

procedure Big3;
var i : Integer;
    a : DArray;
		ms : DeCALDWORD;
    sl : TStringList;
begin
	a := DArray.Create;

	i := 0;
  while i < 500000 do
  	begin
	  	a.add([i, i+1, i+2, i+3, i+4]);
      Inc(i,5);
    end;

  ms := GetTickCount;

	randomShuffle(a);

	writeln('Shuffle: ', GetTickCount - ms);

  ms := GetTickCount;

  sort(a);

	writeln('Sort: ', GetTickCount - ms);

  a.free;

  writeln('Now doing strings...');

	a := DArray.Create;

  ms := GetTickCount;
	i := 0;
  while i < 500000 do
  	begin
	  	a.add([IntToStr(i)]);
      Inc(i);
    end;
	writeln('Adding: ', GetTickCount - ms);

  ms := GetTickCount;

	randomShuffle(a);

  writeln('Shuffle: ', GetTickCount - ms);

  ms := GetTickCount;

  sort(a);

  writeln('Sort: ', GetTickCount - ms);

  ms := GetTickCount;

	randomShuffle(a);

  writeln('Shuffle: ', GetTickCount - ms);

  ms := GetTickCount;

  stablesort(a);

  writeln('StableSort: ', GetTickCount - ms);

  randomShuffle(a);

  // to make the timing comparison fair, we need to do it this way.
  // we don't predeclare a capacity for sl, because we don't do it
  // for SDL.  SDL doesn't require foreknowledge of this to perform well.
  // TStringList's performance does increase (~30%) if you declare
  // capacity early and large.
	sl := TStringList.Create;
  ms := GetTickCount;
	for i := 0 to 499999 do
  	sl.add(InttoStr(i));
  writeln('Adding to string list: ', GetTickCount - ms);

  // now we're going to add the shuffled strings.
  sl.clear;
	for i := 0 to 499999 do
  	sl.add(a.atAsString(i));

  ms := GetTickCount;
	sl.Sort;
	writeln('sorting string list: ', GetTickCount - ms);
	sl.free;

  a.free;

end;

procedure Big4;
var ms, i, x, dels : DeCALDWORD;
		iter : DIterator;
    s : DSet;
begin
	s := DSet.Create;
  dels := 0;
  ms := GetTickCount;
  for i := 1 to 500000 do
  	begin
    	if Random(2) = 0 then
      	begin
        	s.add([Random(500000)]);
        end
      else
      	begin
        	x := Random(500000);
        	iter := s.locate([x]);
          if not atEnd(iter) then
          	begin
							s.remove([x]);
              Inc(dels);
            end;
        end;
    end;

  writeln('Processed ', dels, ' in ', GetTickCount - ms);

  s.free;
end;

procedure StressHashSet;
var m : DHashSet;
		i : Integer;
		ms : DeCALDWORD;
    iter : DIterator;
begin
	m := DHashset.Create;

  ms := GetTickCount;

	for i := 1 to 10000 do
   	m.add([i]);

	writeln('Add time is: ', GetTickCount - ms);

  ms := GetTickCount;
  i := 1;
  while i < 10000 do
  	begin
		  m.remove([i]);
      Inc(i, 2);
    end;
	writeln('Remove time is: ', GetTickCount - ms);

  // Verify correct contents.
  iter := m.start;
  while not AtEnd(iter) do
  	begin
			if getInteger(iter) mod 2 <> 0 then
      	writeln('Error');
      advance(iter);
    end;


  m.free;
end;

function Gen1(ptr : Pointer) : DObject;
begin
	result := Make([TTest.Create]);
end;

procedure Generate1;
var list : DList;
begin
	list := DList.Create;
  Generate(list, 10, MakeGenerator(Gen1));
  ObjFree(list);
  list.free;
end;

function Inj1(ptr : Pointer; const obj1, obj2 : DObject) : DObject;
begin
	result := Make([asInteger(obj1) + TTest(asObject(obj2)).FCount]);
end;

procedure Inject1;
var arr : DArray;
begin
	arr := DArray.Create;
  Generate(arr, 10, makeGenerator(Gen1));
  writeln('Sum is ', decal.toInteger(Inject(arr, [0], MakeBinary(Inj1))));
  ObjFree(arr);
  arr.free;
end;

function Inj2(ptr : Pointer; const obj1, obj2 : DObject) : DObject;
var s : String;
begin
	s := asString(obj1);
  if Length(s) > 0 then
  	result := Make([s + ';' + TTest(asObject(obj2)).FName])
  else
  	result := Make([TTest(asObject(obj2)).FName]);
end;

procedure Inject2;
var arr : DArray;
	  bigString : String;
begin
	// Create a comma-delimited set of names.
	arr := DArray.Create;
  Generate(arr, 10, makeGenerator(gen1));
	bigString := decal.toString(Inject(arr, [''], MakeBinary(Inj2)));
  writeln('Here are the comma delimited names:');
  writeln(bigString);
  ObjFree(arr);
  arr.free;
end;

type
	ATest = procedure;

procedure FrameTest(proc : ATest; const name : String);
begin
	writeln('-----------------------------------------------------------');
  writeln('Test: ', name);
  proc;
  writeln;
end;

procedure DoExamples;
begin
	RegisterDeCALPrinter(TTest, TestPrinter);

  RandomGo;


//
// No leaks for these examples:
//


	FrameTest(AddExample1,        'AddExample1');
  FrameTest(AddExample2,        'AddExample2');
  FrameTest(AddExample3,        'AddExample3');
  FrameTest(AddExample4,        'AddExample4');
  FrameTest(AddExample5,        'AddExample5');
  FrameTest(AddExample6,        'AddExample6');
  FrameTest(AddExample7,        'AddExample7');
  FrameTest(AddExample8,        'AddExample8');
  FrameTest(AddExample9,        'AddExample9');

  FrameTest(Comparator1,        'Comparator1');
	FrameTest(Comparator2,        'Comparator2');
  FrameTest(Comparator3,        'Comparator3');

  FrameTest(Set1,               'Set1');
  FrameTest(Set2,               'Set2');
  FrameTest(Set3,               'Set3');

  FrameTest(Map1,               'Map1');
  FrameTest(Map2,               'Map2');
  FrameTest(Map3,               'Map3');
  FrameTest(Map4,               'Map4');
  FrameTest(Map5,               'Map5');
  FrameTest(Map6,               'Map6');
  FrameTest(Map7,               'Map7');

  FrameTest(Sorting1,           'Sorting1');
  FrameTest(Sorting2,           'Sorting2');
  FrameTest(Sorting3,           'Sorting3');

  FrameTest(Replace1,           'Replace1');
  FrameTest(Replace2,           'Replace2');

  FrameTest(Transform1,         'Transform1');
  FrameTest(Transform2,         'Transform2');

  FrameTest(Shuffling1,         'Shuffling1');

  FrameTest(Morphing1,          'Morphing1');

  FrameTest(SetOps1,            'SetOps1');
  FrameTest(SetOps2,            'SetOps2');
  FrameTest(SetOps3,            'SetOps3');

  FrameTest(Rotate1,            'Rotate1');
  FrameTest(Rotate2,            'Rotate2');
  FrameTest(Rotate3,            'Rotate3');

  FrameTest(Equal1,             'Equal1');

  FrameTest(Mismatch1,          'Mismatch1');

  FrameTest(DTStringList1,      'DTStringList1');

  FrameTest(StressHashSet,      'StressHashSet');
  FrameTest(Inject1,            'Inject1');
  FrameTest(Inject2,            'Inject2');
  FrameTest(Generate1,          'Generate1');
  FrameTest(Comparing1,         'Comparing1');
  FrameTest(Bsearch1,           'Bsearch1');

//
// These examples have leaks:
//

//
// These examples are untested:
//

{

  FrameTest(Big1,               'Big1');
  FrameTest(Big2,               'Big2');
  FrameTest(Big3,               'Big3');
  FrameTest(Big4,               'Big4');

  }


  Writeln('Testing is complete');

end;

end.