\ ------------------- Collection of FlashSort Codes ---------------- \ ----- Ada, ..., C, ..., FORTH, Fortran, ..., Pascal -------------- \ ------- Copyright (c) 1997-2000 Karl-Dietrich Neubert ----------- \ ---------------- email: Flacodes@neubert.net ------------------- \ ------------------------------------------------------------------ -------------------------------------------------------------------- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -------------------------------------------------------------------- --************************************* -- The FlashSort package version 3.0 ** --************************************* --*********************************************************** -- This package has been written in ADA by Jerome Delcourt ** -- email: sicander@club-internet.fr ** -- from the idea of Karl-Dietrich Neubert. ** -- ** -- This code has been verified with the ada compiler ** -- GNAT 3.12 for DOS. It should work with any Ada 83 ** -- or Ada 95 compiler. ** --*********************************************************** --*************************** --** PACKAGE SPECIFICATION ** --*************************** PACKAGE FlashSort IS ----------------------------------------------------------------------------- -- The procedure FlashSort_for_discrete_elements provides an adaptation of -- -- the FlashSort algorithm for any type of vector in which the type of -- -- elements is discrete (a variable of a discrete type can only have -- -- a limited number of possible value, as integers for example, in -- -- oppposition to float numbers). -- -- This procedure also works for any other kind of elements in the vector, -- -- provided that they belong to an enumerated type. -- ----------------------------------------------------------------------------- GENERIC TYPE Element IS (<>); TYPE Index IS (<>); TYPE Vector IS ARRAY(Index RANGE <>) OF Element; PROCEDURE FlashSort_for_discrete_elements(V : IN OUT Vector); ----------------------------------------------------------------------------- -- The procedure FlashSort_for_discrete_elements provides an adaptation of -- -- the FlashSort algorithm for any type of vector in which the type of -- -- elements is discrete (a variable of a discrete type can only have -- -- a limited number of possible value, as integers for example, in -- -- oppposition to float numbers). -- ----------------------------------------------------------------------------- GENERIC TYPE Element IS digits <>; TYPE Index IS (<>); TYPE Vector IS ARRAY(Index RANGE <>) OF Element; PROCEDURE FlashSort_for_float_number_elements(V : IN OUT Vector); ----------------------------------------------------------------------------- END FlashSort; --****************** --** PACKAGE BODY ** --****************** PACKAGE BODY FlashSort IS -- Depending on your compiler, you may have to change the following line. TYPE Greatest_Integer_Type IS NEW LONG_INTEGER; GENERIC TYPE Item IS PRIVATE; PROCEDURE Generic_Swap(x, y : IN OUT Item); PROCEDURE Generic_Swap(x, y : IN OUT Item) IS Temp : CONSTANT Item := x; BEGIN x := y; y := Temp; END Generic_Swap; FUNCTION Trunc(x : IN LONG_FLOAT) RETURN Greatest_Integer_Type IS Temp : CONSTANT Greatest_Integer_Type := Greatest_Integer_Type(x); BEGIN IF (x < LONG_FLOAT(Temp)) THEN RETURN Temp-1; ELSE RETURN Temp; END IF; END; --****************************************************************** --** PROCEDURE FlashSort_for_discrete_elements(V : IN OUT Vector) ** --****************************************************************** PROCEDURE FlashSort_for_discrete_elements(V : IN OUT Vector) IS PROCEDURE Swap IS NEW Generic_Swap(Element); NbClass : CONSTANT Greatest_Integer_Type := V'LENGTH / 10 + 1; -- NbClass represents the number of classes. K : Greatest_Integer_Type; NMove : Greatest_Integer_Type := 0; Hold, Flash : Element; J : Index := V'FIRST; IndexVMax : Index; -- Indice of the greatest coefficient in the vector IndexVMin : Index; -- Indice of the lowest coefficient in the vector. VMin : Element := Element'LAST; -- Lowest element in the vector VMax : Element := Element'FIRST; -- Greatest element in the vector L : ARRAY(1..NbClass) OF Greatest_Integer_Type := (OTHERS => 0); C1 : LONG_FLOAT; BEGIN ---------------------------------- ---------------------------------- -- FIRST STEP : CLASS FORMATION -- ---------------------------------- ---------------------------------- -- Calculate IndexVMax and VMin FOR I IN V'RANGE LOOP IF (VMax < V(I)) THEN IndexVMax := I; VMax := V(I); END IF; IF (V(I) < VMin) THEN IndexVMin := I; VMin := V(I); END IF; END LOOP; ------------------------------------------ -- If VMin = VMax, V is already sorted. -- ------------------------------------------ IF (VMin = VMax) THEN RETURN; END IF; ---------------------------------------------------- -- Calculate the number of elements of the vector -- -- in each class -- ---------------------------------------------------- -- Note : VMin /= VMax, so, in the following line, -- there can't be a division by zero. C1 := LONG_FLOAT(NbClass - 1) / LONG_FLOAT(Element'POS(VMax) - Element'POS(VMin)); FOR I IN V'RANGE LOOP K := 1 + Trunc(C1 * LONG_FLOAT(Element'POS(V(I)) - Element'POS(VMin))); L(K) := L(K) + 1; END LOOP; ---------------------------------------------------------- -- Cumulate the number of elements of each class, -- -- so now L(K) := L(K) + L(K-1). -- -- That means that the last class L(NbClass) is equal -- -- to the size of the vector : L(NbClass) = V'LENGTH. -- ---------------------------------------------------------- FOR I IN L'FIRST+1..L'LAST LOOP L(I) := L(I) + L(I-1); END LOOP; Swap(V(V'FIRST), V(IndexVMax)); ------------------------------- ------------------------------- -- SECOND STEP : PERMUTATION -- ------------------------------- ------------------------------- K := NbClass; WHILE (NMove < (V'LENGTH - 1)) LOOP WHILE (Index'POS(J) - Index'POS(V'FIRST) + 1 > L(K)) LOOP -- Note : L(L'LAST) = V'LENGTH, -- so this loop will allways end. J := Index'SUCC(J); K := 1 + Trunc(C1 * LONG_FLOAT(Element'POS(V(J)) - Element'POS(VMin))); END LOOP; Flash := V(J); WHILE (Index'POS(J) - Index'POS(V'FIRST) + 1 /= L(K) + 1) LOOP K := 1 + Trunc(C1 * LONG_FLOAT(Element'POS(Flash) - Element'POS(VMin))); Swap(Flash, V(Index'VAL(L(K) + Index'POS(V'FIRST) - 1))); L(K) := L(K) - 1; NMove := NMove + 1; END LOOP; END LOOP; ------------------------------------- ------------------------------------- -- THIRD STEP : STRAIGHT INSERTION -- ------------------------------------- ------------------------------------- FOR I IN REVERSE V'FIRST..Index'PRED(Index'PRED(V'LAST)) LOOP IF (V(Index'SUCC(I)) < V(I)) THEN Hold := V(I); J := I; WHILE (V(Index'SUCC(J)) < Hold) LOOP V(J) := V(Index'SUCC(J)); J := Index'SUCC(J); END LOOP; V(J) := Hold; END IF; END LOOP; END FlashSort_for_discrete_elements; --********************************************************************** --** PROCEDURE FlashSort_for_float_number_elements(V : IN OUT Vector) ** --********************************************************************** PROCEDURE FlashSort_for_float_number_elements(V : IN OUT Vector) IS PROCEDURE Swap IS NEW Generic_Swap(Element); NbClass : CONSTANT Greatest_Integer_Type := V'LENGTH / 10 + 1; -- NbClass represents the number of classes. K : Greatest_Integer_Type; NMove : Greatest_Integer_Type := 0; Hold, Flash : Element; J : Index := V'FIRST; IndexVMax : Index; -- Indice of the greatest coefficient in the vector IndexVMin : Index; -- Indice of the lowest coefficient in the vector. VMin : Element := Element'LARGE; -- Lowest element in the vector VMax : Element := -Element'LARGE; -- Greatest element in the vector L : ARRAY(1..NbClass) OF Greatest_Integer_Type := (OTHERS => 0); C1 : LONG_FLOAT; BEGIN ---------------------------------- ---------------------------------- -- FIRST STEP : CLASS FORMATION -- ---------------------------------- ---------------------------------- -- Calculate IndexVMax and VMin FOR I IN V'RANGE LOOP IF (VMax < V(I)) THEN IndexVMax := I; VMax := V(I); END IF; IF (V(I) < VMin) THEN IndexVMin := I; VMin := V(I); END IF; END LOOP; ------------------------------------------ -- If VMin = VMax, V is already sorted. -- ------------------------------------------ IF (VMin = VMax) THEN RETURN; END IF; ---------------------------------------------------- -- Calculate the number of elements of the vector -- -- in each class -- ---------------------------------------------------- -- Note : VMin /= VMax, so, in the following line, -- there can't be a division by zero. C1 := LONG_FLOAT(NbClass - 1) / LONG_FLOAT(VMax - VMin); FOR I IN V'RANGE LOOP K := 1 + Trunc(C1 * LONG_FLOAT(V(I) - VMin)); L(K) := L(K) + 1; END LOOP; ---------------------------------------------------------- -- Cumulate the number of elements of each class, -- -- so now L(K) := L(K) + L(K-1). -- -- That means that the last class L(NbClass) is equal -- -- to the size of the vector : L(NbClass) = V'LENGTH. -- ---------------------------------------------------------- FOR I IN L'FIRST+1..L'LAST LOOP L(I) := L(I) + L(I-1); END LOOP; Swap(V(V'FIRST), V(IndexVMax)); ------------------------------- ------------------------------- -- SECOND STEP : PERMUTATION -- ------------------------------- ------------------------------- K := NbClass; WHILE (NMove < (V'LENGTH - 1)) LOOP WHILE (Index'POS(J) - Index'POS(V'FIRST) + 1 > L(K)) LOOP -- Note : L(L'LAST) = V'LENGTH, -- so this loop will allways end. J := Index'SUCC(J); K := 1 + Trunc(C1 * LONG_FLOAT(V(J) - VMin)); END LOOP; Flash := V(J); WHILE (Index'POS(J) - Index'POS(V'FIRST) + 1 /= L(K) + 1) LOOP K := 1 + Trunc(C1 * LONG_FLOAT(Flash - VMin)); Swap(Flash, V(Index'VAL(L(K) + Index'POS(V'FIRST) - 1))); L(K) := L(K) - 1; NMove := NMove + 1; END LOOP; END LOOP; ------------------------------------- ------------------------------------- -- THIRD STEP : STRAIGHT INSERTION -- ------------------------------------- ------------------------------------- FOR I IN REVERSE V'FIRST..Index'PRED(Index'PRED(V'LAST)) LOOP IF (V(Index'SUCC(I)) < V(I)) THEN Hold := V(I); J := I; WHILE (V(Index'SUCC(J)) < Hold) LOOP V(J) := V(Index'SUCC(J)); J := Index'SUCC(J); END LOOP; V(J) := Hold; END IF; END LOOP; END FlashSort_for_float_number_elements; END FlashSort; --*************************************** --** TEST Nø1 OF THE FLASHSORT PACKAGE ** --*************************************** -- Here, the indexes of the vector and its elements are integers : -- it is one of the common situation. WITH TEXT_IO; USE TEXT_IO; WITH FlashSort; USE FlashSort; PROCEDURE Test1 IS TYPE Vector_of_integers IS ARRAY(INTEGER RANGE <>) OF LONG_INTEGER; PACKAGE Integer_IO IS NEW TEXT_IO.INTEGER_IO(INTEGER); USE Integer_IO; PACKAGE Long_Integer_IO IS NEW TEXT_IO.INTEGER_IO(LONG_INTEGER); USE Long_Integer_IO; Nb : INTEGER; ------------------------------------------------------------------------------ PROCEDURE My_FlashSort IS NEW FlashSort_for_discrete_elements(LONG_INTEGER, INTEGER, Vector_of_integers); ------------------------------------------------------------------------------ PROCEDURE Init_Nb(Nb : OUT INTEGER) IS BEGIN PUT("Number of elements in the vector : "); GET(Nb); END Init_Nb; ------------------------------------------------------------------------------ PROCEDURE Init_Vector(Vect : IN OUT Vector) IS BEGIN PUT_LINE("Initialisation of the vector : "); FOR I IN Vect'RANGE LOOP PUT("Element nø"); PUT(I+1, 0); PUT(" : "); GET(Vect(I)); END LOOP; END Init_Vector; ------------------------------------------------------------------------------ PROCEDURE Write_Vector(Msg : IN STRING; Vect : IN Vector) IS BEGIN PUT_LINE(Msg); FOR I IN Vect'RANGE LOOP PUT(Vect(I), 0); PUT(' '); END LOOP; NEW_LINE; END Write_Vector; ------------------------------------------------------------------------------ BEGIN Init_Nb(Nb); DECLARE Vecteur1, Vecteur2 : Vector(0..Nb-1); BEGIN Init_Vector(Vecteur1); Vecteur2 := Vecteur1; My_FlashSort(Vecteur2); Write_Vector("Your vector :", Vecteur1); Write_Vector("The sorted vector :", Vecteur2); END; END Test1; --*************************************** --** TEST Nø2 OF THE FLASHSORT PACKAGE ** --*************************************** -- Here, the indexes of the vector are integers, -- and the elements of the vector (entered in english on the keyboard) are -- some days of the week. WITH TEXT_IO; USE TEXT_IO; WITH FlashSort; USE FlashSort; PROCEDURE Test2 IS TYPE Day IS (Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday); TYPE Vector IS ARRAY(LONG_INTEGER RANGE <>) OF Day; PACKAGE Day_IO IS NEW TEXT_IO.ENUMERATION_IO(Day); USE Day_IO; PACKAGE Long_Integer_IO IS NEW TEXT_IO.INTEGER_IO(LONG_INTEGER); USE Long_Integer_IO; Nb : LONG_INTEGER; ------------------------------------------------------------------------------ PROCEDURE My_FlashSort IS NEW FlashSort_for_discrete_elements(Day, LONG_INTEGER, Vector); ------------------------------------------------------------------------------ PROCEDURE Init_Nb(Nb : OUT LONG_INTEGER) IS BEGIN PUT("Number of elements in the vector : "); GET(Nb); END Init_Nb; ------------------------------------------------------------------------------ PROCEDURE Init_Vector(Vect : IN OUT Vector) IS BEGIN PUT_LINE("Initialisation of the vector : "); FOR I IN Vect'RANGE LOOP PUT("Days nø"); PUT(I+1, 0); PUT(" : "); GET(Vect(I)); END LOOP; END Init_Vector; ------------------------------------------------------------------------------ PROCEDURE Write_Vector(Msg : IN STRING; Vect : IN Vector) IS BEGIN PUT_LINE(Msg); FOR I IN Vect'RANGE LOOP PUT(Vect(I)); PUT(' '); END LOOP; NEW_LINE; END Write_Vector; ------------------------------------------------------------------------------ BEGIN Init_Nb(Nb); DECLARE Vecteur1, Vecteur2 : Vector(0..Nb-1); BEGIN Init_Vector(Vecteur1); Vecteur2 := Vecteur1; My_FlashSort(Vecteur2); Write_Vector("Your vector :", Vecteur1); Write_Vector("The sorted vector :", Vecteur2); END; END Test2; --*************************************** --** TEST Nø3 OF THE FLASHSORT PACKAGE ** --*************************************** -- Here, the indexes of the vector are the days of the week, -- and the elements of the array are float numbers. WITH TEXT_IO; USE TEXT_IO; WITH FlashSort; USE FlashSort; PROCEDURE Test3 IS TYPE Day IS (Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday); TYPE Vector IS ARRAY(Day RANGE <>) OF FLOAT; PACKAGE Day_IO IS NEW TEXT_IO.ENUMERATION_IO(Day); USE Day_IO; PACKAGE Float_IO IS NEW TEXT_IO.FLOAT_IO(Num => FLOAT); USE Float_IO; Vecteur1, Vecteur2 : Vector(Monday..Sunday); ------------------------------------------------------------------------------ PROCEDURE My_FlashSort IS NEW FlashSort_for_float_number_elements(FLOAT, Day, Vector); ------------------------------------------------------------------------------ PROCEDURE Init_Vector(Vect : IN OUT Vector) IS BEGIN PUT_LINE("Initialisation of the vector : "); FOR I IN Vect'RANGE LOOP PUT(I); PUT(" : "); GET(Vect(I)); END LOOP; END Init_Vector; ------------------------------------------------------------------------------ PROCEDURE Write_Vector(Msg : IN STRING; Vect : IN Vector) IS BEGIN PUT_LINE(Msg); FOR I IN Vect'RANGE LOOP PUT(Vect(I)); PUT(' '); END LOOP; NEW_LINE; END Write_Vector; ------------------------------------------------------------------------------ BEGIN Init_Vector(Vecteur1); Vecteur2 := Vecteur1; My_FlashSort(Vecteur2); Write_Vector("Your vector :", Vecteur1); Write_Vector("The sorted vector :", Vecteur2); END Test3; -------------------------------------------------------------------- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -------------------------------------------------------------------- /***** FLASH.C ,FLOAT-, recursive subroutine version Translation of algorithm into C by Michael Sahota *****/ /* Subroutine Flash(a,n,m,ctr) - Sorts array a with n elements by use of the index vector l of dimension m (with m about 0.1 n). - The routine runs fastest with a uniform distribution of elements. - The vector l is declare dynamically using the calloc function. - The variable ctr counts the number of times that flashsort is called. - THRESHOLD is a very important constant. It is the minimum number of elements required in a subclass before recursion is used. */ #include #include ; #include ; const int THRESHOLD = 75; const CLASS_SIZE = 75; /* minimum value for m */ void flashsort(float a[],int n,int m,int *ctr) { /* declare variables */ int *l,nmin,nmax,i,j,k,nmove,nx,mx; float c1,c2,flash,hold; /* allocate space for the l vector */ l=(int*)calloc(m,sizeof(int)); /***** CLASS FORMATION ****/ nmin=nmax=0; for (i=0 ; i a[nmax]) nmax = i; if ( (a[nmax]==a[nmin]) && (ctr==0) ) { printf("All the numbers are identical, the list is sorted\n"); return; } c1=(m-1.0)/(a[nmax]-a[nmin]) ; c2=a[nmin]; l[0]=-1; /* since the base of the "a" (data) array is 0 */ for (k=1; k l[k] ) { j++; k=floor(c1*(a[j]-c2) ) ; } flash=a[ j ] ; while ( j <= l[k] ) { k=floor(c1*(flash-c2)); hold=a[ l[k] ]; a[ l[k] ] = flash; l[k]--; flash=hold; nmove++; } } /**** Choice of RECURSION or STRAIGHT INSERTION *****/ for (k=0;k<(m-1);k++) if ( (nx = l[k+1]-l[k]) > THRESHOLD ) /* then use recursion */ { flashsort(&a[l[k]+1],nx,CLASS_SIZE,ctr); (*ctr)++; } else /* use insertion sort */ for (i=l[k+1]-1; i > l[k] ; i--) if (a[i] > a[i+1]) { hold=a[i]; j=i; while (hold > a[j+1] ) a[j++]=a[j+1] ; a[j]=hold; } free(l); /* need to free the memory we grabbed for the l vector */ } -------------------------------------------------------------------- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -------------------------------------------------------------------- \ -------- Flash-Sort: sorting by in situ Permutation --------- \ ------------ A demo of the principal mechanism -------------- : ARRAY CREATE WSIZE * ALLOT DOES> SWAP WSIZE * + ; \ ------------------------- Flash-Sort ----------------------- VARIABLE M 1000 M ! \ 256 M ! M @ ARRAY L VARIABLE NA 100000 NA ! NA @ ARRAY A VARIABLE K VARIABLE N VARIABLE JJ VARIABLE NMOVE : KEY-VALUE ( addr --- KEY-VALUE) ( COLUMN @ + COLLATION-TABLE ) \ generalized version @ ; : CLASSIFY ( --- ) \ count elements of classes 0 L M @ WSIZE * 0 FILL N @ 0 DO 1 I A KEY-VALUE L +! LOOP ; : L-VECTOR ( --- ) \ accumulate counts -1 M @ 0 DO I L DUP >R @ + DUP R> ! LOOP DROP ; : FLASH-EXCHANGE ( @ KEY-VALUE --- @ KEY-VALUE ) \ save the value at position L(K) \ put the L(K) value in place K ! K @ L @ A DUP KEY-VALUE >R DUP @ >R ! R> R> ; : PERMUTE ( --- ) \ permute a cycle JJ @ A DUP @ SWAP KEY-VALUE DUP K ! BEGIN K @ L @ JJ @ >= WHILE FLASH-EXCHANGE -1 K @ L +! -1 NMOVE +! REPEAT DROP DROP ; : LEADER ( --- ) \ find a cycle leader at position JJ BEGIN 1 JJ +! JJ @ DUP A KEY-VALUE L @ <= UNTIL ; : FLASH-SORT ( --- ) CLASSIFY L-VECTOR N @ NMOVE ! 0 JJ ! \ first leader PERMUTE BEGIN NMOVE @ WHILE LEADER \ next leader PERMUTE REPEAT ; -------------------------------------------------------------------- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -------------------------------------------------------------------- SUBROUTINE FLASH1 (A. N. L. M) C SORTS ARRY A WITH N ELEMENTS BY USE OF INDEX VECTOR L C OF DIMENSION M WITH M ABOUT 0.1 N. C COPYRIGHT (C) K. - D. NEUBERT 1997 DIMENSION A(1),L(1) C ============================ CLASS FORMATION ===== ANMIN=A(1) NMAX=1 DO I=1,N IF( A(I).LT.ANMIN) ANMIN=A(I) IF( A(I).GT.A(NMAX)) NMAX=I END DO IF (ANMIN.EQ.A(NMAX)) RETURN C1=(M - 1) / (A(NMAX) - ANMIN) DO K=1,M L(K)=0 END DO DO I=1,N K=1 + INT(C1 * (A(I) - ANMIN)) L(K)=L(K) + 1 END DO DO K=2,M L(K)=L(K) + L(K - 1) END DO HOLD=A(NMAX) A(NMAX)=A(1) A(1)=HOLD C =============================== PERMUTATION ===== NMOVE=0 J=1 K=M DO WHILE (NMOVE.LT.N - 1) DO WHILE (J.GT.L(K)) J=J + 1 K=1 + INT(C1 * (A(J) - ANMIN)) END DO FLASH=A(J) DO WHILE (.NOT.(J.EQ.L(K) + 1)) K=1 + INT(C1 * (FLASH - ANMIN)) HOLD=A(L(K)) A(L(K))=FLASH FLASH=HOLD L(K)=L(K) - 1 NMOVE=NMOVE + 1 END DO END DO C ========================= STRAIGHT INSERTION ===== DO I=N-2,1,-1 IF (A(I + 1).LT.A(I)) THEN HOLD=A(I) J=I DO WHILE (A(J + 1).LT.HOLD) A(J)=A(J + 1) J=J + 1 END DO A(J)=HOLD ENDIF END DO C =========================== RETURN,END FLASH1 ===== RETURN END <----- End of the Algorithm in FORTRAN --------------> -------------------------------------------------------------------- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -------------------------------------------------------------------- <------------- The Algorithm in Pascal --------------> (* FLASH.Pas , Integer Version *) (* Translation of algorithm into Pascal by Nuala Lawless *) PROGRAM Flashsort(input,output); TYPE ARR=array[1..1000]of integer; VAR A,L:arr; num,nmin,nmax,cnum,i,HOLD:integer; c1,c2:integer; PROCEDURE Readin; VAR i,x:integer; BEGIN Writeln( ' This is the Integer Version of Flashsort '); Writeln( ' In this Pascal Program, for specific testing '); Writeln( ' you may input directly the numbers to be sorted. '); Writeln( ' Type in the number of numbers to be sorted - '); Readln(num); for i:= 1 to num do begin Writeln( ' Type in number ' ,i,' - '); Readln( x ); A[i]:=x; end; Writeln(' How many classes do you want - '); Readln(cnum); END; (*********************************************************************) PROCEDURE Class; VAR i,k:integer; BEGIN nmin:=1; nmax:=1; for i:= 1 to num do begin if A[i] < A[nmin] then nmin:=i; if A[i] > A[nmax] then nmax:=i; end; c1:=( cnum - 1 ) div ( A[nmax] - A[nmin]); c2:= c1 * A[nmin]; for k:= 1 to cnum do L[k]:=0; for i:= 1 to num do begin k:=1 + ( c1 * A[i] - c2 ); L[k]:=L[k]+1; end; for k:= 2 to cnum do L[k]:=L[k] + L[k-1]; HOLD := A[nmax]; A[nmax]:=a[1]; A[1]:=HOLD; END; (**********************************************************************) PROCEDURE Perm; VAR nmove,i,j,k,FLASH:integer; BEGIN NMOVE:=0; j:=1; k:=cnum; while nmove < ( num - 1 ) do begin while j > L[k] do begin j:=j + 1; k:=1 + ( c1 * A[j] - c2 ) end; FLASH:=A[j]; while j <> ( L[k] + 1 ) do begin k:= 1 + ( c1*FLASH - c2 ); HOLD:=A[L[k]]; A[L[k]]:=FLASH; L[k]:=L[k]-1; FLASH:=HOLD; nmove:=nmove+1; end; end; END; (*************************************************************) PROCEDURE Insert; VAR i,j:integer; BEGIN for i:= num-2 downto 1 do begin if A[i+1] < A[i] then begin HOLD:=A[i]; j:=i; while A[j+1] < HOLD do begin A[j]:=A[j+1]; j:=j+1; end; A[j]:=HOLD end; end; END; (*****************************************************************) PROCEDURE Writeout; VAR i:integer; BEGIN for i:= 1 to num do write('Array A ',a[i],' , '); END; (******************************************************************) BEGIN (**** main program ****) Readin; Class; Perm; Insert; Writeout; END. <------------------ End of Algorithm in Pascal ------------> -------------------------------------------------------------------- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -------------------------------------------------------------------- <-------------------- End of File ------------------------->