Pascal Programs from Algorithms 2nd edition
 
Copyright 1988. Addison-Wesley Publishing Company, Inc.
All Rights Reserved. 
 
 
--------------------------------
CHAPTER 1 Introduction   
 
 
--------------------------------
CHAPTER 2 Pascal
 
program euclid(input,output);
var x,y: integer;
function gcd(u,v: integer): integer;
  var t: integer;
  begin
  repeat
    if u<v then 
      begin t:=u; u:=v; v:=t end;
    u:=u-v
  until u=0;
  gcd:=v
  end;
begin
while not eof do
  begin
  readln(x,y);
  if (x>0) and (y>0) then writeln(x,y,gcd(x,y))
  end;
end.
 
--------------------------------
CHAPTER 3 Elementary Data Structures 
 
program primes(input,output); 
const N=1000;
var a: array[1..N] of boolean;
   i,j: integer; 
begin
a[1]:=false; for i:=2 to N do a[i]:=true;
for i:=2 to N div 2 do
  for j:=2 to N div i do a[i*j]:=false;
for i:=1 to N do
  if a[i] then write(i:4); 
end.
 
type link =^node;
    node = record key: integer; next: link end;
var head,z,t: link;
procedure listinitialize;
  begin
  new(head); new(z);
  head^.next:=z; z^.next:=z
  end;
procedure deletenext(t: link);
  begin	
  t^.next:=t^.next^.next;
  end;	
procedure insertafter(v: integer; t: link);
  var x: link;
  begin	
  new(x); 
  x^.key:=v; x^.next:=t^.next;
  t^.next:=x
  end;	
 
program josephus(input,output);
type link =^node;
     node = record key: integer; next: link end;
var i,N,M: integer; 
    t,x: link;
begin
read(N,M);
new(t); t^.key:=1; x:=t;
for i:=2 to N do
  begin new(t^.next); t:=t^.next; t^.key:=i end;
t^.next:=x;
while t<>t^.next do
  begin
  for i:=1 to M-1 do t:=t^.next;
  write(t^.next^.key);
  x:=t^.next;
  t^.next:=t^.next^.next;
  dispose(x);
  end;
writeln(t^.key);
end.
 
var key,next: array[0..N] of integer;
    x,head,z: integer;
procedure listinitialize;
  begin
  head:=0; z:=1; x:=1;
  next[head]:=z; next[z]:=z
  end;
procedure deletenext(t: integer);
  begin	
  next[t]:=next[next[t]]
  end;	
procedure insertafter(v: integer; t: integer);
  begin	
  x:=x+1;
  key[x]:=v; next[x]:=next[t];
  next[t]:=x
  end;	
 
push(5);
push(9); 
push(8);
push(pop+pop);
push(4); 
push(6);
push(pop*pop);
push(pop*pop);
push(7);
push(pop+pop);
push(pop*pop);
writeln(pop);
 
type link=^node;
    node= record key: integer; next: link end;
var head,z: link;
procedure stackinit;
  begin
  new(head); new(z);
  head^.next:=z; z^.next:=z
  end;
procedure push(v: integer);
  var t: link;
  begin 
  new(t); 
  t^.key:=v; t^.next:=head^.next; 
  head^.next:=t 
  end;
function pop: integer;
  var t: link;
  begin 
  t:=head^.next; 
  pop:=t^.key; 
  head^.next:=t^.next; 
  dispose(t) 
  end;
function stackempty: boolean;
  begin stackempty:=(head^.next=z) end;
 
stackinit; 
repeat
  repeat read(c) until c<>' ';
  if c =')' then write(chr(pop));
  if c ='+' then push(ord(c));
  if c ='*' then push(ord(c));
  while (c>='0') and (c<='9') do
    begin write(c); read(c) end;
  if c<>'(' then write (' ');
until eoln;
 
stackinit; 
repeat
  x:=0; 
  repeat read(c) until c<>' ';
  if c ='*' then x:=pop*pop;
  if c ='+' then x:=pop+pop;
  while (c>='0') and (c<='9') do
    begin x:=10*x+(ord(c)-ord('0')); read(c) end;
  push(x); 
until eoln;
writeln(pop);
 
  const maxP=100;
  var stack: array[0..maxP] of integer; 
      p: integer;
  procedure push(v: integer);
    begin stack[p]:=v; p:=p+1 end;
  function pop: integer;
    begin p:=p-1; pop:=stack[p] end;
  procedure stackinit;
    begin p:=0 end;
  function stackempty: boolean;
    begin stackempty:=(p<=0) end;
 
const max=100;
var queue: array[0..max] of integer; 
    head,tail: integer;
procedure put(v: integer);
  begin 
  queue[tail]:=v; tail:=tail+1;
  if tail>max then tail:=0
  end;
function get: integer;
  begin 
  get:=queue[head]; head:=head+1;
  if head>max then head:=0
  end;
procedure queueinitialize;
  begin head:=0; tail:=0 end;
function queueempty: boolean;
  begin queueempty:=(head=tail) end;
 
 
--------------------------------
CHAPTER 4 Trees   
 
type link=^node;
     node=record info: char; l,r: link end;
var x,z: link;
    c: char; 
 
begin
stackinit; 
new(z); z^.l:=z; z^.r:=z;
repeat
  repeat read(c) until c<>' ';
  new(x); x^.info:=c; 
  if (c='*') or (c='+') 
    then begin x^.r:=pop; x^.l:=pop end
    else begin x^.r:=z; x^.l:=z end;
  push(x)
until eoln;
 
procedure traverse(t: link);
  begin
  push(t);
  repeat
    t:=pop; 
    visit(t);
    if t<>z then push(t^.r); 
    if t<>z then push(t^.l); 
  until stackempty;
  end;
 
procedure traverse(t: link);
  begin
  put(t);
  repeat
    t:=get; 
    visit(t);
    if t<>z then put(t^.l); 
    if t<>z then put(t^.r); 
  until queueempty;
  end;
 
 
--------------------------------
CHAPTER 5 Recursion   
 
function factorial(N: integer): integer;
  begin
  if N=0 
    then factorial:=1 
    else factorial:=N*factorial(N-1);
  end;
 
function fibonacci(N: integer): integer;
  begin
  if N<=1 
    then fibonacci:=1 
    else fibonacci:=fibonacci(N-1)+fibonacci(N-2);
  end;
 
procedure fibonacci;
  const max=25;
  var i: integer;
      F: array[0..max] of integer;
  begin
  F[0]:=1; F[1]:=1;
  for i:=2 to max do F[i]:=F[i-1]+F[i-2]  
  end;
 
procedure rule(l,r,h: integer);
  var m: integer;
  begin
  if h>0 then
    begin
    m:=(l+r) div 2;
    mark(m,h);
    rule(l,m,h-1);
    rule(m,r,h-1)
    end
  end;
 
 
 
procedure rule(l,r,h: integer);
  var i,j: integer;
  begin
  j:=1;
  for i:=1 to h do
    begin
    for x:=0 to (l+r) div j do 
      mark(l+j+x*(j+j),i);
    j:=j+j;
    end;
  end;
 
procedure star(x,y,r: integer);
  begin
  if r>0 then
    begin
    star(x-r,y+r,r div 2);
    star(x+r,y+r,r div 2);
    star(x-r,y-r,r div 2);
    star(x+r,y-r,r div 2);
    box(x,y,r);
    end
  end;
 
procedure traverse(t: link);
  begin
  if t<>z then
    begin
    traverse(t^.l);
    visit(t);
    traverse(t^.r)
    end
  end;
 
procedure visit(t: link);
  begin x:=x+1; t^.x:=x; t^.y:=y end;
procedure traverse(t: link);
  begin
  y:=y+1;
  if t<>z then
    begin
    traverse(t^.l);
    visit(t);
    traverse(t^.r)
    end
  y:=y-1;
  end;
 
procedure traverse(t: link);
  begin
  if t<>z then
    begin
    visit(t);
    traverse(t^.l);
    traverse(t^.r)
    end
  end;
 
procedure traverse(t: link);
  label 0,1;
  begin
0: if t=z then goto 1;
  visit(t);
  traverse(t^.l);
  t:=t^.r; goto 0;
1: end;
 
procedure traverse(t: link);
  label 0,1,2,3;
  begin
0: if t=z then goto 1;
  visit(t);
  push(t); t:=t^.l; goto 0;
3: t:=t^.r; goto 0;
1: if stackempty then goto 2;
  t:=pop; goto 3;
2: end;
 
procedure traverse(t: link);
  label 0,2;
  begin
0: while t<>z do
    begin
    visit(t);
    push(t^.r); t:=t^.l
    end;
  if stackempty then goto 2;
  t:=pop; goto 0;
2: end;
 
procedure traverse(t: link);
  begin
  push(t);
  repeat
    t:=pop; 
    while t<>z do
      begin
      visit(t);
      push(t^.r); 
      t:=t^.l
      end;
  until stackempty;
  end;
 
procedure traverse(t: link);
  begin
  push(t);
  repeat
    t:=pop; 
    if t<>z then
      begin
      visit(t);
      push(t^.r); 
      push(t^.l); 
      end;
  until stackempty;
  end;
 
procedure traverse(t: link);
  begin
  push(t);
  repeat
    t:=pop; 
    visit(t);
    if t^.r<>z then push(t^.r); 
    if t^.l<>z then push(t^.l); 
  until stackempty;
  end;
 
 
--------------------------------
CHAPTER 6 Analysis of Algorithms 
 
 
--------------------------------
CHAPTER 7 Implementation of Algorithms 
 
 
--------------------------------
CHAPTER 8 Elementary Sorting Methods 
 
program threesort(input,output);
const maxN=100;
var a: array[1..maxN] of integer;
    N,i: integer;
procedure sort3;
  var t: integer;
  begin
  if a[1]>a[2] then
    begin t:=a[1]; a[1]:=a[2]; a[2]:=t end;
  if a[1]>a[3] then
    begin t:=a[1]; a[1]:=a[3]; a[3]:=t end;
  if a[2]>a[3] then
    begin t:=a[2]; a[2]:=a[3]; a[3]:=t end;
  end;
begin
readln(N);
for i:=1 to N do read(a[i]);
if N=3 then sort3;
for i:=1 to N do write(a[i]);
writeln
end.
 
procedure selection;
  var i,j,min,t: integer;
  begin
  for i:=1 to N-1 do
    begin
    min:=i;
    for j:=i+1 to N do
      if a[j]<a[min] then min:=j;
    t:=a[min]; a[min]:=a[i]; a[i]:=t
    end;
  end;
 
procedure insertion;
  var i,j,v: integer;
  begin
  for i:=2 to N do
    begin
    v:=a[i]; j:=i;
    while a[j-1]>v do
      begin a[j]:=a[j-1]; j:=j-1 end;
    a[j]:=v
    end
  end;
 
procedure bubble;
  var i,j,t: integer;
  begin
  for i:=N downto 1 do
    for j:=2 to i do
      if a[j-1]>a[j] then
        begin t:=a[j-1]; a[j-1]:=a[j]; a[j]:=t end
  end;
 
procedure insertion;
  var i,j,v: integer;
  begin
  for i:=1 to N do p[i]:=i;
  for i:=2 to N do
    begin
    v:=p[i]; j:=i;
    while a[p[j-1]]>a[v] do
      begin p[j]:=p[j-1]; j:=j-1 end;
    p[j]:=v
    end
  end;
 
procedure insitu;
  var i,j,k,t: integer;
  begin
  for i:=1 to N do
    if p[i]<>i then
      begin
      t:=a[i]; k:=i;
      repeat
        j:=k; a[j]:=a[p[j]]; 
        k:=p[j]; p[j]:=j; 
      until k=i;
      a[j]:=t
      end;
  end;
 
procedure shellsort;
  label 0;
  var i,j,h,v: integer;
  begin
  h:=1; repeat h:=3*h+1 until h>N;
  repeat
    h:=h div 3;
    for i:=h+1 to N do
    begin
      v:=a[i]; j:=i;
      while a[j-h]>v do
        begin
        a[j]:=a[j-h]; j:=j-h;
        if j<=h then goto 0
        end;
   0: a[j]:=v
    end
  until h=1;
  end;
 
  for j:=0 to M-1 do count[j]:=0;
  for i:=1 to N do
    count[a[i]]:=count[a[i]]+1;
  for j:=1 to M-1 do
    count[j]:=count[j-1]+count[j];
  for i:=N downto 1 do
    begin
    b[count[a[i]]]:=a[i];
    count[a[i]]:=count[a[i]]-1
    end;
  for i:=1 to N do a[i]:=b[i];
{ 
 
--------------------------------
CHAPTER 9 Quicksort   
 
procedure quicksort(l,r: integer);
  var i: integer;
  begin
  if r>l then
    begin
    i:=partition(l,r);
    quicksort(l,i-1);
    quicksort(i+1,r)
    end
  end;
 
procedure quicksort(l,r: integer);
  var v,t,i,j: integer;
  begin
  if r>l then
    begin
    v:=a[r]; i:=l-1; j:=r;
    repeat
      repeat i:=i+1 until a[i]>=v;
      repeat j:=j-1 until a[j]<=v;
      t:=a[i]; a[i]:=a[j]; a[j]:=t;
    until j<=i;
    a[j]:=a[i]; a[i]:=a[r]; a[r]:=t;
    quicksort(l,i-1);
    quicksort(i+1,r)
    end
  end;
 
procedure quicksort;
  var t,i,l,r: integer;
  begin
  l:=1; r:=N; stackinit; 
  push(l); push(r);
  repeat
    if r>l then
      begin
      i:=partition(l,r);
      if (i-l)>(r-i)
        then begin push(l); push(i-1); l:=i+1 end
        else begin push(i+1); push(r); r:=i-1 end;
      end
    else
      begin r:=pop; l:=pop end;
  until stackempty;
  end;
 
procedure select(l,r,k: integer);
  var i;
  begin
  if r>l then
    begin
    i:=partition(l,r);
    if i>l+k-1 then select(l,i-1,k);
    if i<l+k-1 then select(i+1,r,k-i);
    end
  end;
 
procedure select(k: integer);
  var v,t,i,j,l,r: integer;
  begin
  l:=1; r:=N;
  while r>l do
    begin
    v:=a[r]; i:=l-1; j:=r;
    repeat
      repeat i:=i+1 until a[i]>=v;
      repeat j:=j-1 until a[j]<=v;
      t:=a[i]; a[i]:=a[j]; a[j]:=t;
    until j<=i;
    a[j]:=a[i]; a[i]:=a[r]; a[r]:=t;
    if i>=k then r:=i-1;
    if i<=k then l:=i+1;
    end;
  end;
 
 
--------------------------------
CHAPTER 10 Radix Sorting  
 
procedure radixexchange(l,r,b: integer);
  var t,i,j: integer;
  begin
  if (r>l) and (b>=0) then
    begin
    i:=l; j:=r;
    repeat
      while (bits(a[i],b,1)=0) and (i<j) do i:=i+1;
      while (bits(a[j],b,1)=1) and (i<j) do j:=j-1;
      t:=a[i]; a[i]:=a[j]; a[j]:=t;
    until j=i;
    if bits(a[r],b,1)=0 then j:=j+1;
    radixexchange(l,j-1,b-1);
    radixexchange(j,r,b-1);
    end
  end;
 
procedure straightradix;
  var i,j,pass: integer;
      count: array[0..M] of integer;
  begin
  for pass:=0 to (w div m)-1 do
    begin
    for j:=0 to M-1 do count[j]:=0;
    for i:=1 to N do
      count[bits(a[i],pass*m,m)]:=count[bits(a[i],pass*m,m)]+1;
    for j:=1 to M-1 do
      count[j]:=count[j-1]+count[j];
    for i:=N downto 1 do
      begin
      b[count[bits(a[i],pass*m,m)]]:=a[i];
      count[bits(a[i],pass*m,m)]:=count[bits(a[i],pass*m,m)]-1;
      end;
    for i:=1 to N do a[i]:=b[i];
    end;
  end;
 
 
--------------------------------
CHAPTER 11 Priority Queues  
 
procedure insert(v: integer);
  begin
  N:=N+1; a[N]:=v;
  end;
function remove: integer;
  var j,max: integer;
  begin
  max:=1;
  for j:=2 to N do
    if a[j]>a[max] then max:=j;
  remove:=a[max];
  a[max]:=a[N]; N:=N-1;
  end;
 
procedure upheap(k: integer);
  var v: integer;
  begin
  v:=a[k]; a[0]:=maxint;
  while a[k div 2]<=v do
    begin a[k]:=a[k div 2]; k:=k div 2 end;
  a[k]:=v
  end;
procedure insert(v: integer);
  begin
  N:=N+1; a[N]:=v;
  upheap(N)
  end;
 
  procedure downheap(k: integer);
    label 0;
    var i,j,v: integer;
    begin
    v:=a[k];
    while k<=N div 2 do
      begin
      j:=k+k;
      if j<N then if a[j]<a[j+1] then j:=j+1;
      if v>=a[j] then goto 0;
      a[k]:=a[j]; k:=j;
      end;
  0: a[k]:=v
    end;
 
function remove: integer;
  begin
  remove:=a[1];
  a[1]:=a[N]; N:=N-1;
  downheap(1);
  end;
 
function replace(v: integer):integer;
  begin
  a[0]:=v;
  downheap(0);
  replace:=a[0];
  end;
 
  N:=0;
  for k:=1 to M do insert(a[k]);
  for k:=M downto 1 do a[k]:=remove;
 
procedure heapsort;
  var k,t: integer;
  begin
  N:=M;
  for k:=M div 2 downto 1 do downheap(k);
  repeat
    t:=a[1]; a[1]:=a[N]; a[N]:=t;
    N:=N-1; downheap(1)
  until N<=1;
  end;
 
procedure pqconstruct;
  var k: integer;
  begin
  N:=M;
  for k:=1 to N do
    begin p[k]:=k; q[k]:=k end;
  for k:=M div 2 downto 1 do pqdownheap(k);
  end;
 
  procedure pqdownheap(k: integer);
    label 0;
    var j,v: integer;
    begin
    v:=p[k];
    while k<= N div 2 do
      begin
      j:=k+k;
      if j<N then if a[p[j]]<a[p[j+1]] then j:=j+1;
      if a[v]>=a[p[j]] then goto 0;
      p[k]:=p[j]; q[p[j]]:=k; k:=j;
      end;
  0: p[k]:=v; q[v]:=k
  end;
 
 
--------------------------------
CHAPTER 12 Mergesort   
 
i:=1; j:=1;
a[M+1]:=maxint; b[N+1]:=maxint;
for k:=1 to M+N do
  if a[i]<b[j]
    then begin c[k]:=a[i]; i:=i+1 end
    else begin c[k]:=b[j]; j:=j+1 end;
 
type link=^node;
     node= record key: integer; next: link end;
var t,z: link;
    N: integer;
 
function merge(a,b: link): link;
  var c: link;
  begin
  c:=z;
  repeat
    if a^.key<=b^.key 
      then begin c^.next:=a; c:=a; a:=a^.next end
      else begin c^.next:=b; c:=b; b:=b^.next end
  until c^.key=maxint;
  merge:=z^.next; z^.next:=z;
  end;
 
procedure mergesort(l,r: integer);
  var i,j,k,m: integer;
  begin
  if r-l>0 then
    begin
    m:=(r+l) div 2;
    mergesort(l,m); mergesort(m+1,r);
    for i:=m downto l do b[i]:=a[i]; 
    for j:=m+1 to r do b[r+m+1-j]:=a[j];
    for k:=l to r do
      if b[i]<b[j] 
        then begin a[k]:=b[i]; i:=i+1 end
        else begin a[k]:=b[j]; j:=j-1 end;
    end;
  end;
 
function mergesort(c: link): link;
  var a,b: link;
  begin
  if c^.next=z then mergesort:=c else
    begin
    a:=c; b:=c^.next; b:=b^.next; b:=b^.next;
    while b<>z do begin c:=c^.next; b:=b^.next; b:=b^.next end;
    b:=c^.next; c^.next:=z;
    mergesort:=merge(mergesort(a),mergesort(b));
    end;
  end;
 
function mergesort(c: link): link;
  var a,b,head,todo,t: link;
      i,N: integer;
  begin
  N:=1; new(head); head^.next:=c;
  repeat
    todo:=head^.next; c:=head;
    repeat
      t:=todo;
      a:=t; for i:=1 to N-1 do t:=t^.next;
      b:=t^.next; t^.next:=z;
      t:=b; for i:=1 to N-1 do t:=t^.next;
      todo:=t^.next; t^.next:=z;
      c^.next:=merge(a,b);
      for i:=1 to N+N do c:=c^.next
    until todo=z;
    N:=N+N;
  until a=head^.next;
  mergesort:=head^.next
  end;
 
 
--------------------------------
CHAPTER 13 External Sorting  
 
 
--------------------------------
CHAPTER 14 Elementary Searching Methods 
 
type node= record key,info: integer end;
var a: array[0..maxN] of node;
   N: integer;
procedure initialize;
  begin N:=0 end;
function seqsearch(v: integer; x: integer): integer;
  begin
  a[N+1].key:=v;
  if x<=N then
    repeat x:=x+1 until v=a[x].key;
  seqsearch:=x
  end;
function seqinsert(v: integer): integer;
  begin
  N:=N+1; a[N].key:=v;
  seqinsert:=N;
  end;
 
type link=^node;
     node= record key,info: integer; next: link end;
var head,t,z: link;
    i: integer;
procedure initialize;
  begin
  new(z); z^.next:=z;
  new(head); head^.next:=z;
  end;
function listsearch(v: integer; t: link): link;
  begin
  z^.key:=v;
  repeat t:=t^.next until v<=t^.key;
  if v=t^.key 
    then listsearch:=t
    else listsearch:=z
  end;
 
function listinsert(v: integer; t: link): link;
  var x: link;
  begin
  z^.key:=v;
  while t^.next^.key<v do t:=t^.next;
  new(x); x^.next:=t^.next; t^.next:=x;
  x^.key:=v;
  listinsert:=x;
  end;
 
function binarysearch(v: integer): integer;
  var x,l,r: integer;
  begin
  l:=1; r:=N;
  repeat
    x:=(l+r) div 2;
    if v<a[x].key then r:=x-1 else l:=x+1
  until (v=a[x].key) or (l>r);
  if v=a[x].key 
    then binarysearch:=x
    else binarysearch:=N+1
  end;
 
type link=^node;
     node=record key,info: integer; l,r: link end;
var t,head,z: link;
function treesearch(v: integer; x: link): link;
  begin
  z^.key:=v;
  repeat
    if v<x^.key then x:=x^.l else x:=x^.r
  until v=x^.key;
  treesearch:=x
  end;
 
procedure treeinitialize;
  begin
  new(z); z^.l:=z; z^.r:=z;
  new(head); head^.key:=0; head^.r:=z;
  end;
 
function treeinsert(v: integer; x:link): link;
  var p: link;
  begin
  repeat
    p:=x;
    if v<x^.key then x:=x^.l else x:=x^.r
  until x=z;
  new(x); x^.key:=v; x^.l:=z; x^.r:=z;
  if v<p^.key then p^.l:=x else p^.r:=x;
  treeinsert:=x
  end;
 
procedure treeprint(x: link);
  begin
  if x<>z then
    begin
    treeprint(x^.l);
    printnode(x);
    treeprint(x^.r)
    end
  end;
 
procedure treedelete(t,x: link);
  var p,c: link;
  begin
  repeat
    p:=x;
    if t^.key<x^.key then x:=x^.l else x:=x^.r
  until x=t;
  if t^.r=z then x:=x^.l
  else if t^.r^.l=z then
    begin x:=x^.r; x^.l:=t^.l end
  else
    begin
    c:=x^.r; while c^.l^.l<>z do c:=c^.l;
    x:=c^.l; c^.l:=x^.r;
    x^.l:=t^.l; x^.r:=t^.r
    end;
  if t^.key<p^.key then p^.l:=x else p^.r:=x;
  end;
 
 
--------------------------------
CHAPTER 15 Balanced Trees  
 
function rbtreeinsert(v: integer; x:link): link;
  var gg,g,p: link;
  begin
  p:=x; g:=x;
  repeat
    gg:=g; g:=p; p:=x;
    if v<x^.key then x:=x^.l else x:=x^.r;
    if x^.l^.red and x^.r^.red then x:=split(v,gg,g,p,x);
  until x=z;
  new(x); x^.key:=v; x^.l:=z; x^.r:=z;
  if v<p^.key then p^.l:=x else p^.r:=x;
  rbtreeinsert:=x;
  x:=split(v,gg,g,p,x);
  end;
 
function rotate(v: integer; y: link): link;
  var c,gc: link;
  begin
  if v<y^.key then c:=y^.l else c:=y^.r;
  if v<c^.key
    then begin gc:=c^.l; c^.l:=gc^.r; gc^.r:=c end
    else begin gc:=c^.r; c^.r:=gc^.l; gc^.l:=c end;
  if v<y^.key then y^.l:=gc else y^.r:=gc;
  rotate:=gc
  end;
 
function split(v: integer; gg,g,p,x: link): link;
  begin
  x^.red:=true; x^.l^.red:=false; x^.r^.red:=false;
  if p^.red then
    begin
    g^.red:=true;
    if (v<g^.key)<>(v<p^.key) then p:=rotate(v,g);
    x:=rotate(v,gg);
    x^.red:=false
    end;
  head^.r^.red:=false;
  split:=x
  end;
 
type link=^node;
     node= record key,info: integer; l,r: link; red: boolean end;
var head,z: link;
 
procedure rbtreeinitialize;
  begin
  new(z); z^.l:=z; z^.r:=z; z^.red:=false;
  new(head); head^.key:=0; head^.r:=z;
  end;
 
 
--------------------------------
CHAPTER 16 Hashing   
 
  h:=key[1];
  for j:=2 to keysize do 
    begin
    h:=((h*32)+key[j]) mod M;
    end;
 
type link=^node;
     node=record key,info: integer; next: link end;
var heads: array[0..M] of link;
    t,z: link;
procedure initialize;
  var i: integer;
  begin
  new(z); z^.next:=z;
  for i:=0 to M-1 do
    begin new(heads[i]); heads[i]^.next:=z end;
  end;
 
procedure hashinitialize;
  var i: integer;
  begin
  for i:=0 to M do a[i].key:=maxint;
  end;
function hashinsert(v: integer): integer;
  var x: integer;
  begin
  x:=h(v);
  while a[x].key<>maxint do x:=(x+1) mod M;
  a[x].key:=v;
  hashinsert:=x;
  end;
 
 
--------------------------------
CHAPTER 17 Radix Searching  
 
function digitalsearch(v: integer; x: link): link;
  var b: integer;
  begin
  z^.key:=v; b:=maxb;
  repeat
    if bits(v,b,1)=0 then x:=x^.l else x:=x^.r;
    b:=b-1;
  until v=x^.key;
  digitalsearch:=x
  end;
 
function digitalinsert(v: integer; x: link): link;
  var p: link; b: integer;
  begin
  b:=maxb;
  repeat
    p:=x;
    if bits(v,b,1)=0 then x:=x^.l else x:=x^.r;
    b:=b-1;
  until x=z;
  new(x); x^.key:=v; x^.l:=z; x^.r:=z;
  if bits(v,b+1,1)=0 then p^.l:=x else p^.r:=x;
  digitalinsert:=x
  end;
 
type link=^node;
     node= record key,info,b: integer; l,r: link end;
var head,z: link;
 
function patriciasearch(v: integer; x: link): link;
  var p: link;
  begin
  repeat
    p:=x;
    if bits(v,x^.b,1)=0 then x:=x^.l else x:=x^.r;
  until p^.b<=x^.b;
  patriciasearch:=x
  end;
 
function patriciainsert(v: integer; x: link): link;
  label 0;
  var t,p: link; i: integer;
  begin
  t:=patriciasearch(v,x);
  if v=t^.key then goto 0;
  i:=maxb;
  while bits(v,i,1)=bits(t^.key,i,1) do i:=i-1;
  repeat
    p:=x;
    if bits(v,x^.b,1)=0 then x:=x^.l else x:=x^.r;
  until (x^.b<=i) or (p^.b<=x^.b);
  new(t); t^.key:=v; t^.b:=i;
  if bits(v,t^.b,1)=0
    then begin t^.l:=t; t^.r:=x end
    else begin t^.r:=t; t^.l:=x end;
  if bits(v,p^.b,1)=0 then p^.l:=t else p^.r:=t;
0: patriciainsert:=t
  end;
 
 
--------------------------------
CHAPTER 18 External Searching  
 
 
--------------------------------
CHAPTER 19 String Searching  
 
function brutesearch: integer;
  var i,j: integer;
  begin
  i:=1; j:=1;
  repeat
    if a[i]=p[j]
      then begin i:=i+1; j:=j+1 end
      else begin i:=i-j+2; j:=1 end;
  until (j>M) or (i>N);
  if j>M then brutesearch:=i-M else brutesearch:=i
  end;
 
function kmpsearch: integer;
  var i,j: integer;
  begin
  i:=1; j:=1; initnext;
  repeat
    if (j=0) or (a[i]=p[j])
      then begin i:=i+1; j:=j+1 end
      else begin j:=next[j] end;
  until (j>M) or (i>N);
  if j>M then kmpsearch:=i-M else kmpsearch:=i;
  end;
 
procedure initnext;
  var i,j: integer;
  begin
  i:=1; j:=0; next[1]:=0;
  repeat
    if (j=0) or (p[i]=p[j])
      then begin i:=i+1; j:=j+1; next[i]:=j end
      else begin j:=next[j] end;
  until i>=M;
  end;
 
  i:=0;
0: i:=i+1;
1: if a[i]<>'1' then goto 0; i:=i+1;
2: if a[i]<>'0' then goto 1; i:=i+1;
3: if a[i]<>'1' then goto 1; i:=i+1;
4: if a[i]<>'0' then goto 2; i:=i+1;
5: if a[i]<>'0' then goto 3; i:=i+1;
6: if a[i]<>'1' then goto 1; i:=i+1;
7: if a[i]<>'1' then goto 2; i:=i+1;
8: if a[i]<>'1' then goto 2; i:=i+1;
  search:=i-8;
 
if p[j]<>p[i] then next[i]:=j else next[i]:=next[j];
 
function mischarsearch: integer;
  var i,j: integer;
  begin
  i:=M; j:=M; initskip;
  repeat
    if a[i]=p[j]
      then begin i:=i-1; j:=j-1 end
      else
        begin
        if M-j+1>skip[index(a[i])]
          then i:=i+M-j+1
          else i:=i+skip[index(a[i])];
        j:=M;
        end;
  until (j<1) or (i>N);
  mischarsearch:=i+1
  end;
 
function rksearch: integer;
  const q=33554393; d=32;
  var h1,h2,dM,i: integer;
  begin
  dM:=1; for i:=1 to M-1 do dM:=(d*dM) mod q;
  h1:=0; for i:=1 to M do h1:=(h1*d+index(p[i])) mod q;
  h2:=0; for i:=1 to M do h2:=(h2*d+index(a[i])) mod q;
  i:=1;
  while (h1<>h2) and (i<=N-M) do
    begin
    h2:=(h2+d*q-index(a[i])*dM) mod q;
    h2:=(h2*d+index(a[i+M])) mod q;
    i:=i+1;
    end;
  rksearch:=i;
  end;
 
 
--------------------------------
CHAPTER 20 Pattern Matching  
 
function match(j: integer): integer;
  const scan=-1;
  var state,n1,n2: integer;
  begin
  dequeinit; put(scan);
  match:=j-1; state:=next1[0];
  repeat
    if state=scan then
      begin j:=j+1; put(scan) end
    else if ch[state]=a[j] then
      put(next1[state])
    else if ch[state]=' ' then
      begin
      n1:=next1[state]; n2:=next2[state];
      push(n1); if n1<>n2 then push(n2)
      end;
    state:=pop;
  until (j>N) or (state=0) or (dequeempty);
  if state=0 then match:=j-1;
  end;
 
 
--------------------------------
CHAPTER 21 Parsing   
 
procedure expression;
  begin
  term;
  if p[j]='+' then
    begin j:=j+1; expression end
  end;
 
procedure term;
  begin
  factor;
  if (p[j]='(') or letter(p[j]) then term
  end;
 
procedure factor;
  begin
  if p[j]='(' then
    begin
    j:=j+1;
    expression;
    if p[j]=')' then j:=j+1 else error
    end
  else if letter(p[j]) then j:=j+1 else error;
  if p[j]='*' then j:=j+1
  end;
 
 
procedure badexpression;
  begin
  if letter(p[j]) then j:=j+1 else
    begin
    badexpression;
    if p[j]<>'+' then error else
      begin j:=j+1; term end
    end
  end;
 
function expression: integer;
  var t1,t2: integer;
  begin
  t1:=term; expression:=t1;
  if p[j]='+' then
    begin
    j:=j+1; state:=state+1;
    t2:=state; expression:=t2; state:=state+1;
    setstate(t2,' ',expression,t1);
    setstate(t2-1,' ',state,state);
    end;
  end;
 
function term;
  var t: integer;
  begin
  term:=factor;
  if (p[j]='(') or letter(p[j]) then t:=term
  end;
 
function factor;
  var t1,t2: integer;
  begin
  t1:=state;
  if p[j]='(' then
    begin
    j:=j+1; t2:=expression;
    if p[j]=')' then j:=j+1 else error
    end
  else if letter(p[j]) then
    begin
    setstate(state,p[j],state+1,state+1);
    t2:=state; j:=j+1; state:=state+1
    end
  else error;
  if p[j]<>'*' then factor:=t2 else
    begin
    setstate(state,' ',state+1,t2);
    factor:=state; next1[t1-1]:=state;
    j:=j+1; state:=state+1;
    end;
  end;
 
procedure matchall;
  begin
  j:=1; state:=1;
  next1[0]:=expression; 
  setstate(state,' ',0,0);
  for i:=1 to N-1 do
     if match(i)>=i then writeln(i);
  end;
 
 
--------------------------------
CHAPTER 22 File Compression  
 
for i:=0 to 26 do count[i]:=0;
for i:=1 to M do
  count[index(a[i])]:=count[index(a[i])]+1;
 
N:=0;
for i:=0 to 26 do
  if count[i]<>0 then
    begin N:=N+1; heap[N]:=i end;
for k:=N downto 1 do pqdownheap(k);
 
repeat
  t:=heap[1]; heap[1]:=heap[N]; N:=N-1;
  pqdownheap(1);
  count[26+N]:=count[heap[1]]+count[t];
  dad[t]:=26+N; dad[heap[1]]:=-26-N;
  heap[1]:=26+N; pqdownheap(1);
until N=1;
dad[26+N]:=0;
 
for k:=0 to 26 do
  if count[k]=0 then
    begin code[k]:=0; len[k]:=0 end
  else
    begin
    i:=0; j:=1; t:=dad[k]; x:=0;
    repeat
      if t<0 then begin x:=x+j; t:=-t end;
      t:=dad[t]; j:=j+j; i:=i+1
    until t=0;
    code[k]:=x; len[k]:=i;
    end;
 
for j:=1 to M do
  for i:=len[index(a[j])] downto 1 do
    write(bits(code[index(a[j])],i-1,1):1);
 
 
--------------------------------
CHAPTER 23 Cryptology   
 
 
--------------------------------
CHAPTER 24 Elementary Geometric Methods 
 
type point = record x,y: integer end;
    line = record p1,p2: point end;
var polygon: array[0..Nmax] of point;
 
function ccw(p0,p1,p2: point): integer;
  var dx1,dx2,dy1,dy2: integer;
  begin
  dx1:=p1.x-p0.x; dy1:=p1.y-p0.y;
  dx2:=p2.x-p0.x; dy2:=p2.y-p0.y;
  if dx1*dy2>dy1*dx2 then ccw:=1;
  if dx1*dy2<dy1*dx2 then ccw:=-1;
  if dx1*dy2=dy1*dx2 then 
    begin
    if (dx1*dx2<0) or (dy1*dy2<0) then ccw:=-1 else
    if (dx1*dx1+dy1*dy1)>=(dx2*dx2+dy2*dy2) then ccw:=0 else ccw:=1;
    end;
  end;
 
function intersect(l1,l2: line): boolean;
  begin
  intersect:=((ccw(l1.p1,l1.p2,l2.p1)*ccw(l1.p1,l1.p2,l2.p2))<=0)
         and ((ccw(l2.p1,l2.p2,l1.p1)*ccw(l2.p1,l2.p2,l1.p2))<=0);
  end;
 
function theta(p1,p2: point): real;
  var dx,dy,ax,ay: integer;
      t: real;
  begin
  dx:=p2.x-p1.x; ax:=abs(dx);
  dy:=p2.y-p1.y; ay:=abs(dy);
  if (dx=0) and (dy=0) then t:=0
		       else t:=dy/(ax+ay);
  if dx<0 then t:= 2-t
	  else if dy<0 then t:=4+t;
  theta:=t*90.0;
  end;
 
function inside(t: point): boolean;
  var count,i,j: integer;
      lt,lp: line;
  begin
  count:=0; j:=0;
  p[0]:=p[N]; p[N+1]:=p[1];
  lt.p1:=t; lt.p2:=t; lt.p2.x:=maxint;
  for i:=1 to N do
    begin
    lp.p1:=p[i]; lp.p2:=p[i];
    if not intersect(lp,lt) then
      begin
      lp.p2:=p[j]; j:=i;
      if intersect(lp,lt) then count:=count+1;
      end;
    end;
  inside:=((count mod 2)=1);
  end;
 
 
--------------------------------
CHAPTER 25 Finding the Convex Hull
 
function wrap: integer;
  var i,min,M: integer;
      minangle,v: real;
      t: point;
  begin
  min:=1;
  for i:=2 to N do
    if p[i].y<p[min].y then min:=i;
  M:=0; p[N+1]:=p[min]; minangle:=0.0;
  repeat
    M:=M+1; t:=p[M]; p[M]:=p[min]; p[min]:=t;
    min:=N+1; v:=minangle; minangle:=360.0;
    for i:=M+1 to N+1 do
      if theta(p[M],p[i])>v then
        if theta(p[M],p[i])<minangle then
          begin min:=i; minangle:=theta(p[M],p[min]) end;
  until min=N+1;
  wrap:=M;
  end;
 
function grahamscan: integer;
  var i,j,min,M: integer;
      l: line; t: point;
  begin
  min:=1;
  for i:=2 to N do
    if p[i].y<p[min].y then min:=i;
  for i:=1 to N do
    if (p[i].y=p[min].y) and (p[i].x>p[min].x) then min:=i;
  t:=p[1]; p[1]:=p[min]; p[min]:=t;
  shellsort;
  p[0]:=p[N];
  M:=3;
  for i:=4 to N do
    begin
    while ccw(p[M],p[M-1],p[i])>=0 do M:=M-1;
    M:=M+1;
    t:=p[M]; p[M]:=p[i]; p[i]:=t;
    end;
  grahamscan:=M;
  end;
 
 
--------------------------------
CHAPTER 26 Range Searching  
 
type interval = record x1,x2: integer end;
 
procedure treerange(t: link; int: interval);
  var tx1,tx2: boolean;
  begin
  if t<>z then
    begin
    tx1:=t^.key>=int.x1;
    tx2:=t^.key<=int.x2;
    if tx1 then treerange(t^.l,int);
    if tx1 and tx2
      then {t^.key is within the range}
    if tx2 then treerange(t^.r,int);
    end
  end;
 
const maxG=20;
type link=^node;
     node=record p: point; next: link end;
var grid: array[0..maxG,0..maxG] of link;
    size: integer;
    z: link;
procedure preprocess;
  procedure insert(p: point);
    var t: link;
    begin
    new(t); t^.p:=p;
    t^.next:=grid[p.x div size,p.y div size];
    grid[p.x div size,p.y div size]:=t;
    end;
  begin
  new(z);
  size:=1; while size*size<max*max/N do size:=size+size;
  for i:=0 to maxG do
    for j:=0 to maxG do grid[i,j]:=z;
  for i:=0 to N do insert(p[i]);
  end;
 
procedure gridrange(rect: rectangle);
  var t: link;
      i,j: integer;
  begin
  for i:=(rect.x1 div size) to (rect.x2 div size) do
    for j:=(rect.y1 div size) to (rect.y2 div size) do
      begin
      t:=grid[i,j];
      while t<>z do
        begin
        if insiderect(t^.p, rect) 
          then {point t^.p is within the range}
          t:=t^.next
        end
      end
  end;
 
type link=^node;
     node=record p: point; l,r: link end;
var  t,head,z: link;
procedure treeinsert(p: point; t: link);
  var f: link;
      d,td: boolean;
  begin
  d:=true;
  repeat
    if d then td:=p.x<t^.p.x
      else td:=p.y<t^.p.y;
    f:=t;
    if td then t:=t^.l else t:=t^.r;
    d:= not d;
  until t=z;
  new(t); t^.p:=p; t^.l:=z; t^.r:=z;
  if td then f^.l:=t else f^.r:=t;
  end;
 
procedure preprocess;
  function initialize: link;
    var t: link;
    begin
    p[0].x:=0; p[0].y:=0; p[0].info:=0;
    new(t); t^.p:=p[0]; t^.r:=z;
    initialize:=t
    end;
  begin
  new(z); head:=initialize;
  for i:=1 to N do treeinsert(p[i],head);
  end;
 
procedure range(t: link; rect: rectangle; d: boolean);
  var t1,t2,tx1,tx2,ty1,ty2: boolean;
  begin
  if t<>z then
    begin
    tx1:=rect.x1<t^.p.x; tx2:=t^.p.x<=rect.x2;
    ty1:=rect.y1<t^.p.y; ty2:=t^.p.y<=rect.y2;
    if d then begin t1:=tx1; t2:=tx2 end
       else begin t1:=ty1; t2:=ty2 end;
    if t1 then range(t^.l,rect, not d);
    if insiderect(t^.p, rect) 
      then {point t^.p is within the range}
    if t2 then range(t^.r,rect, not d);
    end
  end;
 
 
--------------------------------
CHAPTER 27 Geometric Intersection  
 
procedure buildytree;
  var x1,y1,x2,y2: integer;
  begin
  hy:=bstinitialize; N:=0;
  repeat
  N:=N+1;
    read(x1,y1,x2,y2); if eoln then readln;
    lines[N].p1.x:=x1; lines[N].p1.y:=y1;
    lines[N].p2.x:=x2; lines[N].p2.y:=y2;
    bstinsert(N,y1,hy);
    if y2<>y1 then bstinsert(N,y2,hy);
  until eof;
end;
 
procedure scan(next: link);
  var t,x1,x2,y1,y2: integer;
      int: interval;
  begin
  if next<>z then
    begin
    scan(next^.l);
    x1:=lines[next^.info].p1.x; y1:=lines[next^.info].p1.y;
    x2:=lines[next^.info].p2.x; y2:=lines[next^.info].p2.y;
    if x2<x1 then begin t:=x2; x2:=x1; x1:=t end;
    if y2<y1 then begin t:=y2; y2:=y1; y1:=t end;
    if next^.key=y1 then bstinsert(next^.info,x1,hx);
    if next^.key=y2 then
      begin
      bstdelete(next^.info,x1,hx);
      int.x1:=x1; int.x2:=x2;
      bstrange(hx^.r,int);
      end;
    scan(next^.r)
    end
  end;
 
 
--------------------------------
CHAPTER 28 Closest-Point Problems  
 
function merge(a,b: link): link;
  var c: link; comp: boolean;
  begin
  c:=z;
  repeat
    if pass=1 
      then comp:=a^.p.x<b^.p.x 
      else comp:=a^.p.y<b^.p.y;
    if comp 
      then begin c^.next:=a; c:=a; a:=a^.next end
      else begin c^.next:=b; c:=b; b:=b^.next end
  until c=z;
  merge:=z^.next; z^.next:=z;
  end;
 
procedure check(p1,p2: point);
  var dist: real;
  begin
  if (p1.y<>z^.p.y) and (p2.y<>z^.p.y) then
    begin
    dist:=sqrt((p1.x-p2.x)*(p1.x-p2.x)+(p1.y-p2.y)*(p1.y-p2.y));
    if dist<min then
      begin min:=dist; cp1:=p1; cp2:=p2 end;
    end;
  end;
 
function sort(c: link; N: integer): link;
  var a,b: link; i: integer;
      middle: real;
      p1,p2,p3,p4: point;
  begin
  if c^.next=z then sort:=c else
    begin
    a:=c;
    for i:= 2 to N div 2 do c:=c^.next;
    b:=c^.next; c^.next:=z;
    if pass=2 then middle:=b^.p.x;
    c:=merge(sort(a,N div 2),sort(b,N-(N div 2)));
    sort:=c;
    if pass=2 then
      begin
      a:=c; p1:=z^.p; p2:=z^.p; p3:=z^.p; p4:=z^.p;
      repeat
        if abs(a^.p.x-middle)<min then
          begin
          check(a^.p,p1);
          check(a^.p,p2);
          check(a^.p,p3);
          check(a^.p,p4);
          p1:=p2; p2:=p3; p3:=p4; p4:=a^.p
          end;
        a:=a^.next
      until a=z
      end
    end;
  end;
 
new(z); z^.next:=z;
z^.p.x:=maxint; z^.p.y:=maxint;
new(h); h^.next:=readlist;
min:=maxint;
pass:=1; h^.next:=sort(h^.next,N);
pass:=2; h^.next:=sort(h^.next,N);
 
 
--------------------------------
CHAPTER 29 Elementary Graph Algorithms 
 
program adjmatrix(input,output);
const maxV=50;
var j,x,y,V,E: integer;
    a: array[1..maxV,1..maxV] of boolean;
begin
readln(V,E);
for x:=1 to V do
  for y:=1 to V do a[x,y]:=false;
for x:=1 to V do a[x,x]:=true;
for j:=1 to E do
  begin
  readln(v1,v2);
  x:=index(v1); y:=index(v2);
  a[x,y]:=true; a[y,x]:=true
  end;
end.
 
program adjlist(input,output);
const maxV=1000;
type link=^node;
     node=record v: integer; next: link end;
var j,x,y,V,E: integer;
    t,z: link;
    adj: array[1..maxV] of link;
begin
readln(V,E);
new(z); z^.next:=z;
for j:=1 to V do adj[j]:=z;
for j:=1 to E do
  begin
  readln(v1,v2);
  x:=index(v1); y:=index(v2);
  new(t); t^.v:=x; t^.next:=adj[y]; adj[y]:=t;
  new(t); t^.v:=y; t^.next:=adj[x]; adj[x]:=t;
  end;
end.
 
procedure listdfs;
  var id,k: integer;
      val: array[1..maxV] of integer;
  procedure visit(k: integer);
    var t: link;
    begin
    id:=id+1; val[k]:=id;
    t:=adj[k];
    while t<>z do
      begin
      if val[t^.v]=0 then visit(t^.v);
      t:=t^.next
      end
    end;
  begin
  id:=0;
  for k:=1 to V do val[k]:=0;
  for k:=1 to V do
    if val[k]=0 then visit(k)
  end;
 
procedure visit(k: integer);
  var t: integer;
  begin
  id:=id+1; val[k]:=id;
  for t:=1 to V do
    if a[k,t] then
      if val[t]=0 then visit(t);
  end;
 
procedure listdfs;
  var id,k: integer;
      val: array[1..maxV] of integer;
  procedure visit(k: integer);
    var t: link;
    begin
    push(k);
    repeat
      k:=pop;
      id:=id+1; val[k]:=id;
      t:=adj[k];
      while t<>z do
        begin
        if val[t^.v]=0 then 
          begin push(t^.v); val[t^.v]:=-1 end;
        t:=t^.next
        end
    until stackempty
    end;
  begin
  id:=0; stackinit;
  for k:=1 to V do val[k]:=0;
  for k:=1 to V do
    if val[k]=0 then visit(k)
  end;
 
procedure listbfs;
  var id,k: integer;
      val: array[1..maxV] of integer;
  procedure visit(k: integer);
    var t: link;
    begin
    put(k);
    repeat
      k:=get;
      id:=id+1; val[k]:=id;
      t:=adj[k];
      while t<>z do
        begin
        if val[t^.v]=0 then 
          begin put(t^.v); val[t^.v]:=-1 end;
        t:=t^.next
        end
    until queueempty
    end;
  begin
  id:=0; queueinitialize;
  for k:=1 to V do val[k]:=0;
  for k:=1 to V do
    if val[k]=0 then visit(k)
  end;
 
 
--------------------------------
CHAPTER 30 Connectivity   
 
function visit(k: integer): integer;
  var t: link;
      m,min: integer;
  begin
  id:=id+1; val[k]:=id; min:=id;
  t:=adj[k];
  while t<>z do
    begin
    if val[t^.v]=0 then
      begin
      m:=visit(t^.v);
      if m<min then min:=m;
      if m>=val[k] then write(name(k));
      end
    else if val[t^.v]<min then min:=val[t^.v];
    t:=t^.next
    end
  visit:=min;
  end;
 
function find(x,y: integer; union: boolean): boolean;
  var i,j: integer;
  begin
  i:=x; while dad[i]>0 do i:=dad[i];
  j:=y; while dad[j]>0 do j:=dad[j];
  if union and (i<>j) then dad[j]:=i;
  find:=(i<>j)
  end;
 
function find(x,y: integer; union: boolean): boolean;
  var i,j,t: integer;
  begin
  i:=x; while dad[i]>0 do i:=dad[i];
  j:=y; while dad[j]>0 do j:=dad[j];
  while dad[x]>0 do
    begin t:=x; x:=dad[x]; dad[t]:=i end;
  while dad[y]>0 do
    begin t:=y; y:=dad[y]; dad[t]:=j end;
  if union and (i<>j) then
    if dad[j]<dad[i]
      then begin dad[j]:=dad[j]+dad[i]-1; dad[i]:=j end
      else begin dad[i]:=dad[i]+dad[j]-1; dad[j]:=i end;
  find:=(i<>j)
  end;
 
 
--------------------------------
CHAPTER 31 Weighted Graphs  
 
procedure listpfs;
  var id,k: integer;
      val: array[1..maxV] of integer;
  procedure visit(k: integer);
    var t: link;
    begin
    if pqupdate(k,unseen) then dad[k]:=0;
    repeat
      id:=id+1; 
      k:=pqremove; val[k]:=-val[k];
      if val[k]=unseen then val[k]:=0;
      t:=adj[k];
      while t<>z do
        begin
        if val[t^.v]<0 then 
          if pqupdate(t^.v,priority) then 
            begin val[t^.v]:=-(priority); dad[t^.v]:=k end;
        t:=t^.next
        end
    until pqempty
    end;
  begin
  id:=0; pqinitialize;
  for k:=1 to V do val[k]:=-unseen;
  for k:=1 to V do
    if val[k]=-unseen then visit(k)
  end;
 
program kruskal(input,output);
const maxV=50; maxE=2500;
type edge=record v1,v2,w: integer end;
var i,j,m,x,y,V,E: integer;
    edges: array[0..maxE] of edge;
 
begin
readln(V,E);
for j:=1 to E do
  begin
  readln(c,d,edges[j].w);
  edges[j].v1:=index(c);
  edges[j].v2:=index(d);
  end;
findinit; pqconstruct; i:=0;
repeat
  m:=pqremove; x:=edges[m].v1; y:=edges[m].v2;
  if find(x,y,true) then
    begin
    edgefound(x,y);
    i:=i+1
    end
until pqempty or (i=V-1);
end.
 
procedure matrixpfs;
  var k,min,t: integer;
  begin
  for k:=1 to V do
    begin val[k]:=-unseen; dad[k]:=0 end;
  val[0]:=-(unseen+1);
  min:=1;
  repeat
    k:=min; val[k]:=-val[k]; min:=0;
    if val[k]=unseen then val[k]:=0;
    for t:=1 to V do
      if val[t]<0 then
        begin
        if (a[k,t]<>0) and (val[t]<-(priority) then
          begin val[t]:=-(priority); dad[t]:=k end;
        if val[t]>val[min] then min:=t;
        end
    until min=0;
  end;
 
 
--------------------------------
CHAPTER 32 Directed Graphs  
 
  for k:=1 to V do
    begin
    id:=0;
    for j:=1 to V do val[j]:=0;
    visit(k);
    writeln
    end;
 
for y:=1 to V do
  for x:=1 to V do
    if a[x,y] then
      for j:=1 to V do
        if a[y,j] then a[x,j]:=true;
 
for y:=1 to V do
  for x:=1 to V do
    if a[x,y]>0 then
      for j:=1 to V do
        if a[y,j]>0 then
          if (a[x,j]=0) or (a[x,y]+a[y,j]<a[x,j])
            then a[x,j]:=a[x,y]+a[y,j];
 
function visit(k: integer): integer;
  var t: link;
      m,min: integer;
  begin
  id:=id+1; val[k]:=id; min:=id;
  stack[p]:=k; p:=p+1;
  t:=adj[k];
  while t<>z do
    begin
    if val[t^.v]=0
      then m:=visit(t^.v)
      else m:=val[t^.v];
    if m<min then min:=m;
    t:=t^.next
    end;
  if min=val[k] then
    begin
    repeat
      p:=p-1; write(name(stack[p]));
      val[stack[p]]:=V+1
    until stack[p]=k;
    writeln
    end;
  visit:=min;
  end;
 
 
--------------------------------
CHAPTER 33 Network Flow  
 
  if size[k,t]>0 
    then priority:=size[k,t]-flow[k,t]
    else priority:=-flow[k,t];
  if priority>val[k] then priority:=val[k];
 
repeat
  matrixpfs(1,V);
  y:=V; x:=dad[V];
  while x<>0 do
    begin
    flow[x,y]:=flow[x,y]+val[V];
    flow[y,x]:=-flow[x,y];
    y:=x; x:=dad[y]
    end
until val[V]=1-maxint
 
 
--------------------------------
CHAPTER 34 Matching   
 
for m:=1 to N do
  begin
  s:=m;
  repeat
    next[s]:=next[s]+1; w:=prefer[s,next[s]];
    if rank[w,s]<rank[w,fiancee[w]] then
      begin t:=fiancee[w]; fiancee[w]:=s; s:=t end;
  until s=0;
  end;
 
 
--------------------------------
CHAPTER 35 Random Numbers  
 
a[0]:=seed;
for i:=1 to N do
  a[i]:=(a[i-1]*b+1) mod m;
 
program random(input,output);
const m=100000000; m1=10000; b=31415821;
var i,a,N: integer;
function mult(p,q: integer): integer;
  var p1,p0,q1,q0: integer;
  begin
  p1:=p div m1; p0:=p mod m1;
  q1:=q div m1; q0:=q mod m1;
  mult:=(((p0*q1+p1*q0) mod m1)*m1+p0*q0) mod m;
  end;
function random: integer;
  begin
  a:=(mult(a,b)+1) mod m;
  random:=a;
  end;
begin
read(N,a);
for i:=1 to N do writeln(random)
end.
 
function randombad(r: integer): integer;
  begin
  a:=(mult(b,a)+1) mod m;
  randombad:=a mod r;
  end;
 
function randomint(r: integer): integer;
  begin
  a:=(mult(a,b)+1) mod m;
  randomint:=((a div m1)*r) div m1
  end;
 
procedure randinit(s: integer);
  begin
  a[0]:=s; j:=0;
  repeat j:=j+1; a[j]:=(mult(b,a[j-1])+1) mod m until j=54;
  end;
function randomint(r: integer): integer;
  begin
  j:=(j+1) mod 55;
  a[j]:=(a[(j+23) mod 55]+a[(j+54) mod 55]) mod m;
  randomint:=((a[j] div m1)*r) div m1
  end;
 
function chisquare(N,r,s: integer): real;
  var i,t: integer;
      f: array[0..rmax] of integer;
  begin
  randinit(s);
  for i:=0 to rmax do f[i]:=0;
  for i:=1 to N do
    begin
    t:=randomint(r);
    f[t]:=f[t]+1;
    end;
  t:=0; for i:=0 to r-1 do t:=t+f[i]*f[i];
  chisquare:=((r*t/N) - N);
  end;
 
 
--------------------------------
CHAPTER 36 Arithmetic   
 
for i:=0 to N-1 do r[i]:=p[i]+q[i];
 
for i:=0 to 2*(N-1) do r[i]:=0;
for i:=0 to N-1 do
  for j:=0 to N-1 do
    r[i+j]:=r[i+j]+p[i]*q[j];
 
function add(p,q: link): link;
  var t: link;
  begin
  t:=z;
  repeat
    new(t^.next); t:=t^.next;
    t^.c:=p^.c+q^.c;
    p:=p^.next; q:=q^.next
  until (p=z) and (q=z);
  t^.next:=z; add:=z^.next
  end;
 
type link = ^node;
     node = record c: real; j: integer; next: link end;
 
function listadd(t: link; c: real; j: integer): link;
  begin
  new(t^.next); t:=t^.next;
  t^.c:=c; t^.j:=j;
  listadd:=t;
  end;
 
function add(p,q: link): link;
  begin
  t:=z; z^.j:=N+1;
  repeat
    if (p^.j=q^.j) and (p^.c+q^.c<>0.0) then
      begin
      t:=listadd(t,p^.c+q^.c,p^.j);
      p:=p^.next; q:=q^.next
      end
    else if p^.j<q^.j then
      begin t:=listadd(t,p^.c,p^.j); p:=p^.next end
    else if q^.j<p^.j then
      begin t:=listadd(t,q^.c,q^.j); q:=q^.next end;
  until (p=z) and (q=z);
  t^.next:=z; add:=z^.next
  end;
 
y:=p[N];
for i:=N-1 downto 0 do y:=x*y+p[i];
 
function mult(p,q: array[0..N-1] of real;
                N: integer) : array [0..2*N-2] of real;
var pl,ql,ph,qh,t1,t2: array [0..(N  div 2)-1] of real;
    rl,rm,rh: array[0..N-1] of real;
    i,N2: integer;
begin
if N=1 then mult[0]:=p[0]*q[0]
else
  begin
  N2:=N div 2;
  for i:=0 to N2-1 do
    begin pl[i]:=p[i]; ql[i]:=q[i] end;
  for i:=N2 to N-1 do
    begin ph[i-N2]:=p[i]; qh[i-N2]:=q[i] end;
  for i:=0 to N2-1 do t1[i]:=pl[i]+ph[i];
  for i:=0 to N2-1 do t2[i]:=ql[i]+qh[i];
  rm:=mult(t1,t2,N2);
  rl:=mult(pl,ql,N2);
  rh:=mult(ph,qh,N2);
  for i:=0 to N-2 do mult[i]:=rl[i]
  mult[N-1]:=0;
  for i:=0 to N-2 do mult[N+i]:=rh[i]
  for i:=0 to N-2 do
    mult[N2+i]:=mult[N2+i]+rm[i]-(rl[i]+rh[i]);
  end;
end.
 
  for i:=0 to N-1 do
    for j:=0 to N-1 do
      begin
      t:=0.0;
      for k:=0 to N-1 do t:=t+p[i,k]*q[k,j];
      r[i,j]:=t
      end;
 
 
--------------------------------
CHAPTER 37 Gaussian Elimination  
 
for i:=1 to N do
  for j:=i+1 to N do
    for k:=N+1 downto i do
      a[j,k]:=a[j,k]-a[i,k]*a[j,i]/a[i,i];
 
procedure eliminate;
  var i,j,k,max: integer;
      t: real;
  begin
  for i:=1 to N do
    begin
    max:=i;
    for j:=i+1 to N do
      if abs(a[j,i])>abs(a[max,i]) then max:=j;
    for k:=i to N+1 do
      begin t:=a[i,k]; a[i,k]:=a[max,k]; a[max,k]:=t end;
    for j:=i+1 to N do
      for k:=N+1 downto i do
        a[j,k]:=a[j,k]-a[i,k]*a[j,i]/a[i,i];
    end
  end;
 
procedure substitute;
  var j,k: integer;
      t: real;
  begin
  for j:=N downto 1 do
    begin
    t:=0.0;
    for k:=j+1 to N do t:=t+a[j,k]*x[k];
    x[j]:=(a[j,N+1]-t)/a[j,j]
    end
  end;
 
for i:=1 to N-1 do
  begin
  a[i+1,N+1]:=a[i+1,N+1]-a[i,N+1]*a[i+1,i]/a[i,i];
  a[i+1,i+1]:=a[i+1,i+1]-a[i,i+1]*a[i+1,i]/a[i,i]
  end;
for j:=N downto 1 do
  x[j]:=(a[j,N+1]-a[j,j+1]*x[j+1])/a[j,j];
 
 
--------------------------------
CHAPTER 38 Curve Fitting  
 
procedure makespline;
  var i: integer;
  begin
  readln(N);
  for i:=1 to N do readln(x[i],y[i]);
  for i:=2 to N-1 do d[i]:=2*(x[i+1]-x[i-1]);
  for i:=1 to N-1 do u[i]:=x[i+1]-x[i];
  for i:=2 to N-1 do
    w[i]:=6.0*((y[i+1]-y[i])/u[i]-(y[i]-y[i-1])/u[i-1]);
  p[1]:=0.0; p[N]:=0.0;
  for i:=2 to N-2 do
    begin
    w[i+1]:=w[i+1]-w[i]*u[i]/d[i];
    d[i+1]:=d[i+1]-u[i]*u[i]/d[i]
    end;
  for i:=N-1 downto 2 do
    p[i]:=(w[i]-u[i]*p[i+1])/d[i];
  end;
 
function eval(v: real): real;
  var t: real; i: integer;
  function f(x: real): real;
    begin f:=x*x*x-x end;
  begin
  i:=0; repeat i:=i+1 until v<=x[i+1];
  t:=(v-x[i])/u[i];
  eval:=t*y[i+1]+(1-t)*y[i]
      +u[i]*u[i]*(f(t)*p[i+1]+f(1-t)*p[i])/6.0
  end;
 
for i:=1 to M do
  for j:=1 to M+1 do
    begin
    t:= 0.0;
    for k:=1 to N do t:=t+f[i,k]*f[j,k];
    a[i,j]:=t;
    end;
 
 
--------------------------------
CHAPTER 39 Integration   
 
for i:=N downto 1 do p[i]:=p[i-1]/i; p[0]:=0;
 
function intrect(a,b: real; N: integer): real;
  var i: integer; w,r: real;
  begin
  r:=0; w:=(b-a)/N;
  for i:=1 to N do r:=r+w*f(a-w/2+i*w);
  intrect :=r;
  end;
 
function inttrap(a,b: real; N: integer): real;
  var i: integer; w,t: real;
  begin
  t:=0; w:=(b-a)/N;
  for i:=1 to N do t:=t+w*(f(a+(i-1)*w)+f(a+i*w))/2;
  inttrap:=t;
  end;
 
function intsimp(a,b: real; N: integer): real;
  var i: integer; w,s: real;
  begin
  s:=0; w:=(b-a)/N;
  for i:=1 to N do
    s:=s+w*(f(a+(i-1)*w)+4*f(a-w/2+i*w)+f(a+i*w))/6;
  intsimp:=s;
  end;
 
function adapt(a,b: real): real;
  begin
  if abs(intsimp(a,b,10)-intsimp(a,b,5))<tolerance
    then adapt:=intsimp(a,b,10)
    else adapt:=adapt(a,(a+b)/2) + adapt((a+b)/2,b);
  end;
 
 
--------------------------------
CHAPTER 40 Parallel Algorithms  
 
 
--------------------------------
CHAPTER 41 The Fast Fourier Transform
 
eval(p,outN,0);
eval(q,outN,0);
for i:=0 to outN do r[i]:=p[i]*q[i];
eval(r,outN,0);
for i:=1 to N do
  begin t:=r[i]; r[i]:=r[outN+1-i]; r[outN+1-i]:=t end;
for i:=0 to outN do r[i]:=r[i]/(outN+1);
 
procedure eval(var p: poly; N,k: integer);	
  var i,j: integer;
  begin
  if N=1 then
    begin
    t:=p[k]; p1:=p[k+1];
    p[k]:=t+p1; p[k+1]:=t-p1
    end
  else
    begin
    for i:=0 to N div 2 do
      begin
      j:=k+2*i;
      t[i]:=p[j]; t[i+1+N div 2]:=p[j+1]
      end;
    for i:=0 to N do p[k+i]:=t[i];
    eval(p,N div 2,k);
    eval(p,N div 2,k+1+N div 2);
    j:=(outN+1) div (N+1);
    for i:=0 to N div 2 do
      begin
      t:=w[i*j]*p[k+(N div 2)+1+i];
      t[i]:=p[k+i]+t; t[i+(N div 2)+1]:=p[k+i]-t
      end;
    for i:=0 to N do p[k+i]:=t[i]
    end
  end;
 
 
--------------------------------
CHAPTER 42 Dynamic Programming  
 
for j:=1 to N do
  begin
  for i:=1 to M do
    if i-size[j]>=0 then
      if cost[i]<(cost[i-size[j]]+val[j]) then
        begin
        cost[i]:=cost[i-size[j]]+val[j];
        best[i]:=j
        end;
  end;
 
for i:=1 to N do
  for j:=i+1 to N do cost[i,j]:=maxint;
for i:=1 to N do cost[i,i]:=0;
for j:=1 to N-1 do
  for i:=1 to N-j do
    for k:=i+1 to i+j do
      begin
      t:=cost[i,k-1]+cost[k,i+j]+r[i]*r[k]*r[i+j+1];
      if t<cost[i,i+j] then
        begin cost[i,i+j]:=t; best[i,i+j]:=k end;
      end;
 
procedure order(i,j: integer);
  begin
  if i=j then write(name(i)) else
    begin
    write('(');
    order(i,best[i,j]-1); order(best[i,j],j);
    write(')')
    end
  end;
 
for i:=1 to N do
  for j:=i+1 to N+1 do cost[i,j]:=maxint;
for i:=1 to N do cost[i,i]:=f[i];
for i:=1 to N+1 do cost[i,i-1]:=0;
for j:=1 to N-1 do
  for i:=1 to N-j do
    begin
    for k:=i to i+j do
      begin
      t:=cost[i,k-1]+cost[k+1,i+j];
      if t<cost[i,i+j] then
        begin cost[i,i+j]:=t; best[i,i+j]:=k end;
      end;
    t:=0; for k:=i to i+j do t:=t+f[k];
    cost[i,i+j]:=cost[i,i+j]+t;
    end;
 
 
--------------------------------
CHAPTER 43 Linear Programming  
 
procedure pivot(p,q: integer);
  var j,k: integer;
  begin
  for j:=0 to N do
    for k:=M+1 downto 1 do
      if (j<>p) and (k<>q) then
        a[j,k]:=a[j,k]-a[p,k]*a[j,q]/a[p,q];
  for j:=0 to N do if j<>p then a[j,q]:=0;
  for k:=1 to M+1 do if k<>q then a[p,k]:=a[p,k]/a[p,q];
  a[p,q]:=1
  end;
 
repeat
  q:=0; repeat q:=q+1 until (q=M+1) or (a[0,q]<0);
  p:=0; repeat p:=p+1 until (p=N+1) or (a[p,q]>0);
  for i:=p+1 to N do
    if a[i,q]>0 then
      if (a[i,M+1]/a[i,q])<(a[p,M+1]/a[p,q]) then p:=i;
  if (q<M+1) and (p<N+1) then pivot(p,q)
until (q=M+1) or (p=N+1);
 
 
--------------------------------
CHAPTER 44 Exhaustive Search  
 
procedure visit(k: integer);
  var t: integer;
  begin
  id:=id+1; val[k]:=id;
  for t:=1 to V do
    if a[k,t] then
      if val[t]=0 then visit(t);
  id:=id-1; val[k]:=0
  end;
 
procedure visit(k: integer);
  var t: integer;
  begin
  id:=id+1; val[k]:=id;
  if id=V then writeperm;
  for t:=1 to V do
    if val[t]=0 then visit(t);
  id:=id-1; val[k]:=0
  end;
 
 
--------------------------------
CHAPTER 45 NP-Complete Problems