close
文章出處
1 unit unit2; 2 3 interface 4 5 // 冒泡排序 6 procedure BubbleSort(var abc: array of Integer); 7 8 // 搖動排序 9 procedure ShakerSort(var abc: array of Integer); 10 11 // 梳子排序 12 procedure CombSort(var abc: array of Integer); 13 14 // 選擇排序 15 procedure SelectionSort(var abc: array of Integer); 16 17 // 標準插入排序 18 procedure InsertionSortStd(var abc: array of Integer); 19 20 // 優化的插入排序 21 procedure InsertionSort(var abc: array of Integer); 22 23 // 希爾排序 24 procedure ShellSort(var abc: array of Integer); 25 26 // 標準歸并排序 27 procedure MergeSortStd(var abc: array of Integer); 28 29 // 優化的歸并排序 30 procedure MergeSort(var abc: array of Integer); 31 32 // 標準快速排序 33 procedure QuickSortStd(var abc: array of Integer); 34 35 // 無遞歸的快速排序 36 procedure QuickSortNoRecurse(var abc: array of Integer); 37 38 // 隨機的快速排序 39 procedure QuickSortRandom(var abc: array of Integer); 40 41 // 中間值的快速排序 42 procedure QuickSortMedian(var abc: array of Integer); 43 44 // 優化的插入快速排序 45 procedure QuickSort(var abc: array of Integer); 46 47 // 堆排序 48 procedure HeapSort(var abc: array of Integer); 49 50 implementation 51 52 // 冒泡排序 53 procedure BubbleSort(var abc: array of Integer); 54 var 55 i, j: Integer; 56 Temp: Integer; 57 Done: boolean; 58 begin 59 for i := 0 to High(abc) do 60 begin 61 Done := true; 62 for j := High(abc) + 1 downto 0 do 63 if abc[j] < abc[j - 1] then 64 begin 65 Temp := abc[j]; 66 abc[j] := abc[j - 1]; 67 abc[j - 1] := Temp; 68 Done := false; 69 end; 70 if Done then 71 Exit; 72 end; 73 end; 74 75 // 梳子排序 76 procedure CombSort(var abc: array of Integer); 77 var 78 i, j: Integer; 79 Temp: Integer; 80 Done: boolean; 81 Gap: Integer; 82 begin 83 Gap := High(abc); 84 repeat 85 Done := true; 86 Gap := (longint(Gap) * 10) div 13; 87 if (Gap < 1) then 88 Gap := 1 89 else if (Gap = 9) or (Gap = 10) then 90 Gap := 11; 91 for i := 0 to (High(abc) - Gap) do 92 begin 93 j := i + Gap; 94 if abc[j] < abc[i] then 95 begin 96 Temp := abc[j]; 97 abc[j] := abc[i]; 98 abc[i] := Temp; 99 Done := false; 100 end; 101 end; 102 until Done and (Gap = 1); 103 end; 104 105 // 標準插入排序 106 procedure InsertionSortStd(var abc: array of Integer); 107 var 108 i, j: Integer; 109 Temp: Integer; 110 begin 111 for i := 0 to High(abc) do 112 begin 113 Temp := abc[i]; 114 j := i; 115 while (j > 0) and (Temp < abc[j - 1]) do 116 begin 117 abc[j] := abc[j - 1]; 118 dec(j); 119 end; 120 abc[j] := Temp; 121 end; 122 end; 123 124 // 優化的插入排序 125 procedure InsertionSort(var abc: array of Integer); 126 var 127 i, j: Integer; 128 IndexOfMin: Integer; 129 Temp: Integer; 130 begin 131 IndexOfMin := 0; 132 for i := 0 to High(abc) do 133 if abc[i] < abc[IndexOfMin] then 134 IndexOfMin := i; 135 if (0 <> IndexOfMin) then 136 begin 137 Temp := abc[0]; 138 abc[0] := abc[IndexOfMin]; 139 abc[IndexOfMin] := Temp; 140 end; 141 for i := 0 + 2 to High(abc) do 142 begin 143 Temp := abc[i]; 144 j := i; 145 while Temp < abc[j - 1] do 146 begin 147 abc[j] := abc[j - 1]; 148 dec(j); 149 end; 150 abc[j] := Temp; 151 end; 152 end; 153 154 // 選擇排序 155 procedure SelectionSort(var abc: array of Integer); 156 var 157 i, j: Integer; 158 IndexOfMin: Integer; 159 Temp: Integer; 160 begin 161 for i := 0 to High(abc) do 162 begin 163 IndexOfMin := i; 164 for j := i to High(abc) + 1 do 165 if abc[j] < abc[IndexOfMin] then 166 IndexOfMin := j; 167 Temp := abc[i]; 168 abc[i] := abc[IndexOfMin]; 169 abc[IndexOfMin] := Temp; 170 end; 171 end; 172 173 // 搖動排序 174 procedure ShakerSort(var abc: array of Integer); 175 var 176 i: Integer; 177 Temp: Integer; 178 iMin, iMax: Integer; 179 begin 180 iMin := 0; 181 iMax := High(abc) - Low(abc) + 1; 182 183 while (iMin < iMax) do 184 begin 185 for i := iMax downto 0 do 186 if abc[i] < abc[i - 1] then 187 begin 188 Temp := abc[i]; 189 abc[i] := abc[i - 1]; 190 abc[i - 1] := Temp; 191 end; 192 inc(iMin); 193 for i := 0 to iMax do 194 if abc[i] < abc[i - 1] then 195 begin 196 Temp := abc[i]; 197 abc[i] := abc[i - 1]; 198 abc[i - 1] := Temp; 199 end; 200 dec(iMax); 201 end; 202 end; 203 204 // 希爾排序 205 procedure ShellSort(var abc: array of Integer); 206 var 207 i, j: Integer; 208 h: Integer; 209 Temp: Integer; 210 Ninth: Integer; 211 begin 212 h := 1; 213 Ninth := High(abc) div 9; 214 while (h <= Ninth) do 215 h := (h * 3) + 1; 216 while (h > 0) do 217 begin 218 for i := h to High(abc) do 219 begin 220 Temp := abc[i]; 221 j := i; 222 while (j >= (0 + h)) and (Temp < abc[j - h]) do 223 begin 224 abc[j] := abc[j - h]; 225 dec(j, h); 226 end; 227 abc[j] := Temp; 228 end; 229 h := h div 3; 230 end; 231 end; 232 233 // 標準歸并排序 234 procedure MergeSortStd(var abc: array of Integer); 235 procedure MSS(var abc: array of Integer; aFirst: Integer; aLast: Integer; aTempList: array of Integer); 236 var 237 Mid: Integer; 238 i, j: Integer; 239 ToInx: Integer; 240 FirstCount: Integer; 241 begin 242 Mid := (aFirst + aLast) div 2; 243 if (aFirst < Mid) then 244 MSS(abc, aFirst, Mid, aTempList); 245 if (succ(Mid) < aLast) then 246 MSS(abc, succ(Mid), aLast, aTempList); 247 FirstCount := succ(Mid - aFirst); 248 Move(abc[aFirst], aTempList[0], FirstCount * sizeof(pointer)); 249 i := 0; 250 j := succ(Mid); 251 ToInx := aFirst; 252 while (i < FirstCount) and (j <= aLast) do 253 begin 254 if (aTempList[i] <= abc[j]) then 255 begin 256 abc[ToInx] := aTempList[i]; 257 inc(i); 258 end 259 else 260 begin 261 abc[ToInx] := abc[j]; 262 inc(j); 263 end; 264 inc(ToInx); 265 end; 266 if (i < FirstCount) then 267 Move(aTempList[i], abc[ToInx], (FirstCount - i) * sizeof(pointer)); 268 end; 269 270 var 271 TempList: array of Integer; 272 begin 273 if (0 < High(abc)) then 274 begin 275 SetLength(TempList, High(abc) div 2); 276 MSS(abc, 0, High(abc), TempList); 277 end; 278 end; 279 280 // 優化的歸并排序 281 procedure MergeSort(var abc: array of Integer); 282 const 283 MSCutOff = 15; 284 285 procedure MSInsertionSort(var abc: array of Integer; aFirst: Integer; aLast: Integer); 286 var 287 i, j: Integer; 288 IndexOfMin: Integer; 289 Temp: Integer; 290 begin 291 IndexOfMin := aFirst; 292 for i := succ(aFirst) to aLast do 293 if abc[i] < abc[IndexOfMin] then 294 IndexOfMin := i; 295 if (aFirst <> IndexOfMin) then 296 begin 297 Temp := abc[aFirst]; 298 abc[aFirst] := abc[IndexOfMin]; 299 abc[IndexOfMin] := Temp; 300 end; 301 for i := aFirst + 2 to aLast do 302 begin 303 Temp := abc[i]; 304 j := i; 305 while Temp < abc[j - 1] do 306 begin 307 abc[j] := abc[j - 1]; 308 dec(j); 309 end; 310 abc[j] := Temp; 311 end; 312 end; 313 314 procedure MS(var abc: array of Integer; aFirst: Integer; aLast: Integer; aTempList: array of Integer); 315 var 316 Mid: Integer; 317 i, j: Integer; 318 ToInx: Integer; 319 FirstCount: Integer; 320 begin 321 Mid := (aFirst + aLast) div 2; 322 if (aFirst < Mid) then 323 if (Mid - aFirst) <= MSCutOff then 324 MSInsertionSort(abc, aFirst, Mid) 325 else 326 MS(abc, aFirst, Mid, aTempList); 327 if (succ(Mid) < aLast) then 328 if (aLast - succ(Mid)) <= MSCutOff then 329 MSInsertionSort(abc, succ(Mid), aLast) 330 else 331 MS(abc, succ(Mid), aLast, aTempList); 332 FirstCount := succ(Mid - aFirst); 333 Move(abc[aFirst], aTempList[0], FirstCount * sizeof(pointer)); 334 i := 0; 335 j := succ(Mid); 336 ToInx := aFirst; 337 while (i < FirstCount) and (j <= aLast) do 338 begin 339 if (aTempList[i] <= abc[j]) then 340 begin 341 abc[ToInx] := aTempList[i]; 342 inc(i); 343 end 344 else 345 begin 346 abc[ToInx] := abc[j]; 347 inc(j); 348 end; 349 inc(ToInx); 350 end; 351 if (i < FirstCount) then 352 Move(aTempList[i], abc[ToInx], (FirstCount - i) * sizeof(pointer)); 353 end; 354 355 var 356 TempList: array of Integer; 357 begin 358 if (0 < High(abc)) then 359 begin 360 SetLength(TempList, High(abc) div 2); 361 MS(abc, 0, High(abc), TempList); 362 end; 363 end; 364 365 // 標準快速排序 366 procedure QuickSortStd(var abc: array of Integer); 367 procedure QSS(var abc: array of Integer; aFirst: Integer; aLast: Integer); 368 var 369 L, R: Integer; 370 Pivot: Integer; 371 Temp: Integer; 372 begin 373 while (aFirst < aLast) do 374 begin 375 Pivot := abc[(aFirst + aLast) div 2]; 376 L := pred(aFirst); 377 R := succ(aLast); 378 while true do 379 begin 380 repeat 381 dec(R); 382 until (abc[R] <= Pivot); 383 384 repeat 385 inc(L); 386 until (abc[L] >= Pivot); 387 388 if (L >= R) then 389 Break; 390 391 Temp := abc[L]; 392 abc[L] := abc[R]; 393 abc[R] := Temp; 394 end; 395 if (aFirst < R) then 396 QSS(abc, aFirst, R); 397 aFirst := succ(R); 398 end; 399 end; 400 401 begin 402 QSS(abc, 0, High(abc)); 403 end; 404 405 // 無遞歸的快速排序 406 procedure QuickSortNoRecurse(var abc: array of Integer); 407 procedure QSNR(var abc: array of Integer; aFirst: Integer; aLast: Integer); 408 var 409 L, R: Integer; 410 Pivot: Integer; 411 Temp: Integer; 412 Stack: array [0 .. 63] of Integer; { allows for 2 billion items } 413 SP: Integer; 414 begin 415 Stack[0] := aFirst; 416 Stack[1] := aLast; 417 SP := 2; 418 while (SP <> 0) do 419 begin 420 dec(SP, 2); 421 aFirst := Stack[SP]; 422 aLast := Stack[SP + 1]; 423 while (aFirst < aLast) do 424 begin 425 Pivot := abc[(aFirst + aLast) div 2]; 426 L := pred(aFirst); 427 R := succ(aLast); 428 while true do 429 begin 430 repeat 431 dec(R); 432 until (abc[R] <= Pivot); 433 repeat 434 inc(L); 435 until (abc[L] >= Pivot); 436 if (L >= R) then 437 Break; 438 Temp := abc[L]; 439 abc[L] := abc[R]; 440 abc[R] := Temp; 441 end; 442 if (R - aFirst) < (aLast - R) then 443 begin 444 Stack[SP] := succ(R); 445 Stack[SP + 1] := aLast; 446 inc(SP, 2); 447 aLast := R; 448 end 449 else 450 begin 451 Stack[SP] := aFirst; 452 Stack[SP + 1] := R; 453 inc(SP, 2); 454 aFirst := succ(R); 455 end; 456 end; 457 end; 458 end; 459 460 begin 461 QSNR(abc, 0, High(abc)); 462 end; 463 464 // 隨機的快速排序 465 procedure QuickSortRandom(var abc: array of Integer); 466 procedure QSR(var abc: array of Integer; aFirst: Integer; aLast: Integer); 467 var 468 L, R: Integer; 469 Pivot: Integer; 470 Temp: Integer; 471 begin 472 while (aFirst < aLast) do 473 begin 474 R := aFirst + Random(aLast - aFirst + 1); 475 L := (aFirst + aLast) div 2; 476 Pivot := abc[R]; 477 abc[R] := abc[L]; 478 abc[L] := Pivot; 479 L := pred(aFirst); 480 R := succ(aLast); 481 while true do 482 begin 483 repeat 484 dec(R); 485 until (abc[R] <= Pivot); 486 repeat 487 inc(L); 488 until (abc[L] >= Pivot); 489 if (L >= R) then 490 Break; 491 Temp := abc[L]; 492 abc[L] := abc[R]; 493 abc[R] := Temp; 494 end; 495 if (aFirst < R) then 496 QSR(abc, aFirst, R); 497 aFirst := succ(R); 498 end; 499 end; 500 501 begin 502 QSR(abc, 0, High(abc)); 503 end; 504 505 // 中間值的快速排序 506 procedure QuickSortMedian(var abc: array of Integer); 507 procedure QSM(var abc: array of Integer; aFirst: Integer; aLast: Integer); 508 var 509 L, R: Integer; 510 Pivot: Integer; 511 Temp: Integer; 512 begin 513 while (aFirst < aLast) do 514 begin 515 if (aLast - aFirst) >= 2 then 516 begin 517 R := (aFirst + aLast) div 2; 518 if (abc[aFirst] > abc[R]) then 519 begin 520 Temp := abc[aFirst]; 521 abc[aFirst] := abc[R]; 522 abc[R] := Temp; 523 end; 524 if (abc[aFirst] > abc[aLast]) then 525 begin 526 Temp := abc[aFirst]; 527 abc[aFirst] := abc[aLast]; 528 abc[aLast] := Temp; 529 end; 530 if (abc[R] > abc[aLast]) then 531 begin 532 Temp := abc[R]; 533 abc[R] := abc[aLast]; 534 abc[aLast] := Temp; 535 end; 536 Pivot := abc[R]; 537 end 538 else 539 Pivot := abc[aFirst]; 540 L := pred(aFirst); 541 R := succ(aLast); 542 while true do 543 begin 544 repeat 545 dec(R); 546 until (abc[R] <= Pivot); 547 repeat 548 inc(L); 549 until (abc[L] >= Pivot); 550 if (L >= R) then 551 Break; 552 Temp := abc[L]; 553 abc[L] := abc[R]; 554 abc[R] := Temp; 555 end; 556 if (aFirst < R) then 557 QSM(abc, aFirst, R); 558 aFirst := succ(R); 559 end; 560 end; 561 562 begin 563 QSM(abc, 0, High(abc)); 564 end; 565 566 // 優化插入的快速排序 567 procedure QuickSort(var abc: array of Integer); 568 const 569 QSCutOff = 15; 570 571 procedure QSInsertionSort(var abc: array of Integer; aFirst: Integer; aLast: Integer); 572 var 573 i, j: Integer; 574 IndexOfMin: Integer; 575 Temp: Integer; 576 begin 577 IndexOfMin := aFirst; 578 j := aFirst + QSCutOff; { !!.01 } 579 if (j > aLast) then 580 j := aLast; 581 for i := succ(aFirst) to j do 582 if abc[i] < abc[IndexOfMin] then 583 IndexOfMin := i; 584 if (aFirst <> IndexOfMin) then 585 begin 586 Temp := abc[aFirst]; 587 abc[aFirst] := abc[IndexOfMin]; 588 abc[IndexOfMin] := Temp; 589 end; 590 { now sort via fast insertion method } 591 for i := aFirst + 2 to aLast do 592 begin 593 Temp := abc[i]; 594 j := i; 595 while Temp < abc[j - 1] do 596 begin 597 abc[j] := abc[j - 1]; 598 dec(j); 599 end; 600 abc[j] := Temp; 601 end; 602 end; 603 604 procedure QS(var abc: array of Integer; aFirst: Integer; aLast: Integer); 605 var 606 L, R: Integer; 607 Pivot: Integer; 608 Temp: Integer; 609 Stack: array [0 .. 63] of Integer; { allows for 2 billion items } 610 SP: Integer; 611 begin 612 Stack[0] := aFirst; 613 Stack[1] := aLast; 614 SP := 2; 615 616 while (SP <> 0) do 617 begin 618 dec(SP, 2); 619 aFirst := Stack[SP]; 620 aLast := Stack[SP + 1]; 621 622 while ((aLast - aFirst) > QSCutOff) do 623 begin 624 R := (aFirst + aLast) div 2; 625 if (abc[aFirst] > abc[R]) then 626 begin 627 Temp := abc[aFirst]; 628 abc[aFirst] := abc[R]; 629 abc[R] := Temp; 630 end; 631 if (abc[aFirst] > abc[aLast]) then 632 begin 633 Temp := abc[aFirst]; 634 abc[aFirst] := abc[aLast]; 635 abc[aLast] := Temp; 636 end; 637 if (abc[R] > abc[aLast]) then 638 begin 639 Temp := abc[R]; 640 abc[R] := abc[aLast]; 641 abc[aLast] := Temp; 642 end; 643 Pivot := abc[R]; 644 645 L := aFirst; 646 R := aLast; 647 while true do 648 begin 649 repeat 650 dec(R); 651 until (abc[R] <= Pivot); 652 repeat 653 inc(L); 654 until (abc[L] >= Pivot); 655 if (L >= R) then 656 Break; 657 Temp := abc[L]; 658 abc[L] := abc[R]; 659 abc[R] := Temp; 660 end; 661 662 if (R - aFirst) < (aLast - R) then 663 begin 664 Stack[SP] := succ(R); 665 Stack[SP + 1] := aLast; 666 inc(SP, 2); 667 aLast := R; 668 end 669 else 670 begin 671 Stack[SP] := aFirst; 672 Stack[SP + 1] := R; 673 inc(SP, 2); 674 aFirst := succ(R); 675 end; 676 end; 677 end; 678 end; 679 680 begin 681 QS(abc, 0, High(abc)); 682 QSInsertionSort(abc, 0, High(abc)); 683 end; 684 685 // 堆排序 686 procedure HeapSort(var abc: array of Integer); 687 procedure HSTrickleDown(var abc: array of Integer; root, count: Integer); 688 var 689 KKK: Integer; 690 begin 691 abc[0] := abc[root]; 692 KKK := 2 * root; 693 while KKK <= count do 694 begin 695 if (KKK < count) and (abc[KKK] < abc[KKK + 1]) then 696 inc(KKK); 697 if abc[0] < abc[KKK] then 698 begin 699 abc[root] := abc[KKK]; 700 root := KKK; 701 KKK := 2 * root; 702 end 703 else 704 KKK := count + 1; 705 end; 706 abc[root] := abc[0]; 707 end; 708 709 var 710 Inx: Integer; 711 ItemCount: Integer; 712 tmp: Integer; 713 begin 714 ItemCount := High(abc) - Low(abc) + 1; 715 for Inx := ItemCount div 2 downto 1 do 716 begin 717 HSTrickleDown(abc, Inx, ItemCount); 718 end; 719 720 for Inx := ItemCount downto 2 do 721 begin 722 tmp := abc[1]; 723 abc[1] := abc[Inx]; 724 abc[Inx] := tmp; 725 HSTrickleDown(abc, 1, Inx - 1); 726 end; 727 end; 728 729 end.
 |
不含病毒。www.avast.com |
全站熱搜
留言列表
