program QMsort;
 
(*_____________________________________________________*)
 
(*         Pawel Susicki      1988/89                  *)
(* Two sorting algorithms: quick-sort and merge-sort   *)
(* Warning :   int /m8000 qsort                        *)
(*       The maximal number of elements < 46           *)
(*_____________________________________________________*)
 
  unit NewPage : procedure;
  begin
    write( chr(27), "[2J")
  end NewPage;
 
  unit  SetCursor : procedure(row, column : integer);
    var c,d,e,f  : char,
        i,j : integer;
  begin
    i := row div 10;
    j := row mod 10;
    c := chr(48+i);
    d := chr(48+j);
    i := column div 10;
    j := column mod 10;
    e := chr(48+i);
    f := chr(48+j);
    write( chr(27), "[", c, d, ";", e, f, "H")
  end SetCursor;
 
  unit Initialization : procedure(output max , min : integer);
  begin
    call NewPage;
    call SetCursor(5,20);
    writeln("TWO  SORTING  ALGORITHMES");
    call SetCursor(7, 20);
    write("by Pawel Susicki 1988/1989");
    call SetCursor(12,10);
    write("This program presents the parralel realisation of the ");
    call SetCursor(13,10);
    write("Merge-sort and Quick-sort Algoriths.");
    call SetCursor(14,10);
    writeln("The Elements of the sequence are chosen randomly.");
    Call SetCursor(20,5);
    write("Number of elements : ");readln(max);
    write("    min for a process :");readln(min);
    write("    press CR to start"); readln;
  end Initialization;
 
(*------------------------------------------------------------------------*)
 
   unit ekran:IWGRAPH process(nr:integer,skip:integer);
 
   unit print:procedure(begin_line,index,val,kolor :integer);
      begin
      call color(kolor);
      call move(1+index*skip,begin_line);
      call draw(1+index*skip,begin_line-val);
      call color(0);
      call move(1+index*skip,begin_line-val-1);
      call draw(1+index*skip,begin_line-150);
      call move(index*skip,begin_line);
      call draw(index*skip,begin_line-150);
      call move(2+index*skip,begin_line);
      call draw(2+index*skip,begin_line-150);
   end print;
 
   unit lightprint:procedure(begin_line,index,val,kolor:integer);
   begin
      call color(kolor);
      for i := 0 to 2 do
          call move(i+index*skip,begin_line);
          call draw(i+index*skip,begin_line-val);
      od;
      call color(0);
      for i :=0 to 1 do
          call move(i+index*skip,begin_line-val-1);
          call draw(i+index*skip,begin_line-150);
      od;
   end lightprint;
 
 
   unit printchr:procedure(x,y:integer,s:string);
   var A : arrayof char,i : integer;
   begin
       A := unpack(s);
       call move(x,y);
       call color(14);
      for i := lower(A) to upper(A)
      do
       call HASCII(0);
       call hascii(ord(A(i)));
     od;
   end printchr;
 
   begin
   call gron(0);
   call cls;
   return;
   do
      accept print,lightprint,printchr;
   od;
end ekran;
 
(*-------------------------------------------------------------------*)
 
 
unit A: process(nr:integer,begin_line:integer,ile:integer,
                                      E:ekran,kolor:integer);
(* This process is used to keep the given sequence of elements *)
(* and to do all necessary manipulations on it.                *)
 
   var tab:arrayof integer;
 
   unit take:function(i:integer):integer;
      begin
      result:=tab(i);
   end take;
 
   unit put_tab:procedure(i,val:integer);
      begin
      tab(i):=val;
      call E.print(begin_line,i,val,kolor);
   end put_tab;
 
   unit light:procedure(i:integer);
      begin
      call E.lightprint(begin_line,i,tab(i),kolor);
   end light;
 
   unit normal:procedure(i:integer);
      begin
      call E.print(begin_line,i,tab(i),kolor);
   end normal;
 
   unit swap:procedure(i,j:integer);
   var aux:integer;
   begin
      aux:=tab(i);
      tab(i):=tab(j);
      tab(j):=aux;
      call E.print(begin_line,i,tab(i),kolor);
      call E.print(begin_line,j,tab(j),kolor);
   end swap;
 
   unit comp:function(i,j:integer):integer;
      begin
      if tab(i)<tab(j)
        then result:=-1;
        else
         if tab(i)>tab(j)
           then result:=1;
           else result:=0;
         fi;
      fi;
   end comp;
 
   unit printchr:procedure(x,y:integer,s:string);
   begin
         call E.printchr(x,begin_line-y,s);
   end printchr;
 
   handlers
      when ACCERROR:call E.printchr(325,325,"ACCERROR");
                    call E.groff;call endrun;
      when CONERROR:call E.printchr(325,325,"CONERROR");
                    call E.groff;call endrun;
      when LOGERROR:call E.printchr(325,325,"LOGERROR");
                    call E.groff;call endrun;
      when MEMERROR:call E.printchr(325,325,"MEMERROR");
                    call E.groff;call endrun;
      when NUMERROR:call E.printchr(325,325,"NUMERROR");
                    call E.groff;call endrun;
      when TYPERROR:call E.printchr(325,325,"TYPERROR");
                    call E.groff;call endrun;
      when SYSERROR:call E.printchr(325,325,"SYSERROR");
                    call E.groff;call endrun;
   end handlers;
 
   begin
        array tab dim(1:ile);
        return;
        do
           accept take,put_tab,swap,comp,light,normal,printchr;
        od;
    end A;
 
(*----------------------------------------------------------------*)
unit sync:process(nr:integer);
(*This process is used uniquely for the sake of synchronization*)
   unit slock:procedure;
      begin
      accept sunlock;
   end slock;
 
   unit sunlock:procedure;
      begin
   end sunlock;
 
   begin
   return;
   do
      accept slock;
   od;
end sync;
 
(*--------------------------------------------------------------------*)
 
unit BS:process(nr:integer,from,until:integer,T:A,father:P);
(* Bubbel-sort algorithm. Both main-processes PMS and PQS use *)
(* this algorithm in the case the longeur of the table is<min *)
 
   var left:integer, l:boolean;
   begin
   return;
   do
      l:=true;
      left:=from;
      do
         call T.normal(left);
         if T.comp(left,left+1)>0 then
            call T.swap(left,left+1);
            l:=false;
         fi;
         if left=from then call T.light(left); fi;
         left:=left+1;
         if left >= until then exit; fi;
         call T.normal(left);(*bylo reverse*)
      od;
      call T.normal(from);
      if l then exit; fi;
   od;
   call father.sync;
end BS;
(*---------------------------------------------------------------*)
 
unit P: process(nr, from,until,min:integer, T:A, father:P,
                                        b:boolean,S:sync);
(* Process- prefix for both Quick and Merge sort *)
   var kolega:P, bubble:BS, left,right:integer;
 
   unit sync:procedure;
   end sync;
 
handlers
   when ACCERROR:call T.E.GROFF;writeln("ACCERROR");call endrun;
   when CONERROR:call T.E.GROFF;writeln("CONERROR");call endrun;
   when LOGERROR:call T.E.GROFF;writeln("LOGERROR");call endrun;
   when MEMERROR:call T.E.GROFF;writeln("MEMERROR");call endrun;
   when NUMERROR:call T.E.GROFF;writeln("NUMERROR");call endrun;
   when TYPERROR:call T.E.GROFF;writeln("TYPERROR");call endrun;
   when SYSERROR:call T.E.GROFF;writeln("SYSERROR");call endrun;
end handlers;
 
end P;
 
unit PMS:P process;
(* Algorithm MERGE-SORT. *)
   var ll,rr:integer;
   var tab:arrayof integer;
   var l,r:boolean;
 
   begin
   return;
   call T.light(from);
   left:=from+(until-from)div 2;
   right:=left+1;
   l:=false;
   r:=true;
   if left > from
     then
      l:=true;
      if right-from+1 > min
        then
         kolega:=new PMS(0,from,left,min,T,this PMS,false,S);
         resume(kolega);
        else
         bubble:=new BS(0,from,left,T,this PMS);
         resume(bubble);
      fi;
   fi;
   if until > right
     then
      r:=true;
      if until-right+1 > min
        then
         kolega:=new PMS(0,right,until,min,T,this PMS,false,S);
         resume(kolega);
        else
         bubble:=new BS(0,right,until,T,this PMS);
         resume(bubble);
      fi;
   fi;
   if l then accept sync; fi;
   if r then accept sync; fi;
   array tab dim(from:until);
   left:=from;
   ll:=from;
   rr:=right;
   do
      if left>=rr
       then
         tab(ll):=T.take(right);
         right:=right+1;
       else
         if right>until
          then
            tab(ll):=T.take(left);
            left:=left+1;
          else
            if T.comp(left,right)<0
             then
               tab(ll):=T.take(left);
               left:=left+1;
             else
               tab(ll):=T.take(right);
               right:=right+1;
            fi;
         fi;
      fi;
      ll:=ll+1;
      if ll>until then exit; fi;
   od;
   left:=from;
   do
      call T.put_tab(left,tab(left));
      left:=left+1;
      if left>until then exit; fi;
   od;
   if not b
    then call father.sync;
    else
      call T.printchr(50,60,"MERGE - SORT" );
      call S.sunlock;
   fi;
end PMS;
 
unit PQS:P process;
 
   var counter:integer;
 
   unit shuffle:procedure;
      begin
      call T.light(from);
      left:=from+1;
      right:=until;
      do
         while T.comp(from,left) >=0 do
            call T.normal(left);
            left:=left+1;
            if left < right then call T.normal(left); fi;
            if left > right then exit; fi;
         od;
         while T.comp(from,right)<=0 do
            call T.normal(right);
            right:=right-1;
            if left < right then call T.normal(right); fi;
            if left > right then exit; fi;
         od;
         if left<right then
            call T.swap(left,right);
            call T.normal(left);
            call T.normal(right);
         fi;
         if left >= right then exit; fi;
      od;
      call T.swap(from,right);
   end shuffle;
 
   unit gen:procedure(from,until:integer; inout c:integer);
      begin
      if from < until
       then
         c:=c+1;
         if until-right > min
           then
            kolega:=new PQS(0,from,until,min,T,this PQS,false,S);
            resume(kolega);
           else
            bubble:=new BS(0,from,until,T,this PQS);
            resume(bubble);
         fi;
      fi;
   end gen;
 
   begin
   counter:=0;
   return;
   call shuffle;
   while imax(right-from,until-right) > min+1 do
      if until-right < right-from
       then
         call gen(right+1,until,counter);
         until:=right-1;
       else
         call gen(from,right-1,counter);
         from:=right+1;
      fi;
      call shuffle;
   od;
   call gen(right+1,until,counter);
   call gen(from,right-1,counter);
   while counter > 0 do
      accept sync;
      counter:=counter-1;
   od;
   if not b
    then call father.sync;
    else
      call T.printchr(50,60,"QUICK - SORT");
      call S.sunlock;
   fi;
end PQS;
(*--------------------------------------------------------------------*)
 
 
var   E:ekran,T0,T1:A, S:sync, P1:PMS, P2:PQS,
      i,x,max,min:integer;
 
begin
    call Initialization(max,min);
 
    E:=new ekran(0,600/max);
    resume(E);
    (* the processes TO and T1 are used to operate on the given sequence*)
    T0:=new A(0,160,max,E,10);
    T1:=new A(0,320,max,E,11);
    resume(T0);
    resume(T1);
 
    i:=1;
    while i <= max do
          x := random*150;
          call T0.put_tab(i,x);
          call T1.put_tab(i,x);
          i:=i+1;
    od;
 
     S:=new sync(0);
     resume(S);
 
     P1:=new PMS(0,1,max,min,T0,none,true,S);
     P2:=new PQS(0,1,max,min,T1,none,true,S);
     resume(P1);
     resume(P2);
     call S.slock;(* main wait for all other processes *)
     call S.slock;
 
     call E.printchr(450,325,"press CR"); readln;
     call E.groff;
     call endrun;
end qsort.