program test;
(*_________________________________________________________*)
(*   For a given sequence of integers  A1, ...,An          *)
(*   find a subsequence   k1,k2,... ki  such that          *)
(*            SUM( 0<i<n+1 : Aki) = v                      *)
(*   (Take A(i) such that SUM(i:Ai)<250 and A(i)<100.)     *)
(*_________________________________________________________*)
 
const  left = 360 ,
      right = 600 ;
var   level : integer;
 
begin
   pref iiuwGRAPH block;
 
   unit dolej : procedure(kolor,ile:integer);
   var i,j:integer;
   begin
      call color(kolor);
      for i := Level-1 downto Level-ile
      do
         call move(left,i);
         call draw(right,i);
         for j :=1 to 300 do j:=j od;
      od;
      level := level-ile;
   end dolej;
 
   unit odlej : procedure(ile: integer);
   var i,j : integer;
   begin
             call color(0);
             for i := Level to Level+ile do
                   call move(left,i);
                   call draw(right,i);
                   for j := 1 to 300 do j:=j od;
              od;
              level := level+ile
   end odlej;
 
   unit sac_a_dos :  procedure(A:arrayof integer,v: integer);
   signal trouve;
   var i : integer;
      unit p : procedure(s,k : integer);
      var i : integer;
      begin
         call dolej(k,A(k));
         if s+ A(k)>v then
              call odlej(A(k));
              return
         fi;
         if s+A(k)=v then raise trouve fi;
         s := s+A(k);
         for i := k+1 to upper(A) do call p(s,i) od;
         call odlej(A(k));
 
         last_will : call MyWrite(k);
                     call affich(inXpos,inYpos,", ");
      end p;
      handlers
        when trouve : call affich(10,300,"press any key");
                      i := inchar;
        call affich(10,300,"RESULT::                   ");
        call move(80,300);
        terminate;
      end handlers;
 
   begin
        for i := lower(A) to upper(A) do call p(0,i) od;
        call affich(10,315,"There is no such sequence !!! ");
 
        last_will : call affich(10,325,"END of EXECUTION");
   end sac_a_dos;
 
   unit affich : procedure(x,y:integer,s:string);
   var TAB : arrayof char,i:integer;
   begin
      call color(14);
      TAB:= unpack(s);
      call move(x,y);
      for i := lower(TAB) to upper(TAB) do
            call HASCII(0);
            call HASCII(ord(TAB(i)));
      od;
   end affich;
 
   unit inchar : function : integer;
   var i  : integer;
   begin
      do
         i := inkey;
         if i<>0 then exit fi;
      od;
      result :=i;
   end inchar;
 
   unit MyRead :  function : integer;
   var   OrdN : integer;
   begin
      result := 0;
      do
         OrdN:=inchar;
         if OrdN=13 then exit fi;
         if (ordN<58 and ordN>47)
         then
               call hascii(0);
               call hascii(OrdN);
               result := result*10+ (OrdN - 48)
          else
               if ordN=8 then result := result div 10;
                  call move(inXpos-8,inYpos);call hascii(0);
               fi;
          fi;
      od;
   end MyRead;
 
   unit MyWrite : procedure( Number : integer );
   var   i, j, n : integer,
         Chiffres:arrayof integer;
   begin
       array Chiffres dim(1:10);
       n:=0;
       if Number=0 then n:=1; Chiffres(1):=0
       else
          while Number>0
          do
             n := n+1;
             i := Number div 10;
             Chiffres(n) := Number - i*10;
             Number := i;
          od;
          for i := n downto 1
          do
              call HASCII(0);
              call Hascii(Chiffres(i)+48);
          od;
       fi;
   end MyWrite;
 
   unit dzban : procedure(x,y,z,v:integer);
   var j : integer;
   begin
       call color(14);
       for j :=1 to 3 do
           call move(y+6+j,x);
           call draw(y+6+j,x-v);
           call move(z+j,x);
           call draw(z+j,x-v);
       od;
       for j :=y to z+10 do
              call move(j,x);
              call draw(j,x+10)
       od;
       for j :=1 to 3 do
           call move(y-5,x+10+j);
           call draw(z+15,x+10+j)
       od;
   end dzban;
 
   var         A : arrayof integer,
         v,i,j,n : integer;
begin
    call GRON(0);
    call aFFich(150,15,"KNAPSACK PROBLEM");
    call affich(10,40,"Given a sequence  A[1],...,A[n] of integers");
    call affich(10,55,"find a subsequence i1,...,ij of the indices ");
    call affich(10,70,"such that A[i1] +...+ A[ij] = v ");
    call affich(10,110,"n = ");
    n := MyRead;
    call affich(10,130,"Elements of A :: ");
    array A dim (1:n);
    call move(10,145);
    for i := 1 to n do
          call color(i);
          A(i):= MyRead;
          call affich(inXpos,inYpos,", ")
    od;
    call affich(10,165,"v = ");
    v := MyRead;
    level := 300;
    call dzban( level,350,600,v);
 
    call sac_a_dos(A,v);
    v := inchar;
    call GROFF;
  end;
 
end test;
 
 
 
 
 
 
program test;
(*_________________________________________________________*)
(*   Donnee un sequence des nombres entier a1, ... an  .   *)
(*   Trouver un sequence k1,k2,... ki  tel que             *)
(*            SOMME( 0<i<n+1 : aki) = v                    *)
(*   (wersja bez rysowania)                                *)
(*_________________________________________________________*)
 
  unit sac_a_dos : procedure(A:arrayof integer,v: integer);
  signal trouve;
  var i : integer;
      unit p : procedure(s,k : integer);
      var i : integer;
      begin
         if s+ A(k)>v then return fi;
         if s+A(k)=v then raise trouve fi;
         s := s+A(k);
         for i := k+1 to upper(A) do call p(s,i) od;
         last_will : writeln(k);
      end p;
      handlers
        when trouve : writeln("RESULTAT :: ");
        terminate;
      end handlers;
 
begin
   for i := lower(A) to upper(A) do call p(0,i) od;
   writeln("il n'y a pas sequence i1,..ik tel que le somme est v ");
 
   last_will : writeln("Fin du sequence");
end sac_a_dos;
 
var A: arrayof integer, v,i,n : integer;
 
begin
    write(" n= ");
    readln(n);
    array A dim (1:n);
    for i := 1 to n do  read(A(i)) od;
    write("v = ");
    readln(v);
    call sac_a_dos(A,v);
    writeln("et fin d'execution.");
 
end test;
 
Dla danych 1 2 3 4 5 6 7 8 9 10, v=12
Wynik : sequence : 6 3 2 1 ( w takiej wlasnie kolejnosci !)
        Fin de sequence
et fin d'execution.
 
   (*  jezeli uzyje wind zamiast terminate to nawet gdy znajde rozwiazanie   *)
   (*  instrukcja for jest w tej procedurze kontynuowana az do konca, a potem *)
   (*  wydrukuje sie  " il n'ya pas sequence ...."                            *)
   (*  czyli wind "zwija" obiekty az do tego w ktorym jest odpowiedni handler *)
   (*  ale nie usuwa tego ostatniego (w przeciwienstwie do terminate)         *)
    (* ten tekst jest drukowany w obu przypadkach i wind i terminate *)
 
 
 
program TTT;
signal f(inout x,y : integer),g;
unit ppass : procedure( inout x,y : integer);
     begin
         raise f(x,y);
         call ppass(x,y);
end ppass;
var x,y,z,s : integer;
 
handlers
   when g : s := s+s;
            wind
end handlers;
begin
     block;
         handlers
              when f : if y=0 then raise g fi;
                        s := s+x;
                        y := y-1;
                        return;
         end handlers;
     begin
          readln(x,y);
          z := y;
          call ppass(x,z);
          write("to sie nie wydrukuje , bo wind zwija ten obiert bloku!");
     end;
      writeln("s= :" ,s);
end TT