type
  PRBTNode = ^RBTNode;
  RBTNode =  record
    up    : PRBTNode;
    left  : PRBTNode;
    right : PRBTNode;
    key   : typ_danych;
    …
  end;

struct RBTNode
{
  RBTNode *up, *left, *right;
  typ_danych key;
  …
};

Type RBTNode
  up As RBTNode Ptr
  left As RBTNode Ptr
  right As RBTNode Ptr
  key As typ_danych
  …
End Type

// Zbiory zaimplementowane w drzewach czerwono-czarnych
// Data   : 9.07.2014
// (C)2014 mgr Jerzy Wałaszek
//-----------------------------------------------------

program sets;

// Definicja węzła drzewa czerwono-czarnego

type
  PRBTNode = ^RBTNode;
  RBTNode  = record
    up    : PRBTNode;
    left  : PRBTNode;
    right : PRBTNode;
    key   : integer;
    color : char;
  end;

// Zmienne globalne

var
  S : RBTNode = (up:@S;left:@S;right:@S;key:0;color:'B'); // Węzeł strażnika

// Procedury obsługi drzew czerwono-czarnych

// Wykonuje rotację w lewo względem A
//-----------------------------------
procedure rot_L (var root : PRBTNode; A : PRBTNode);
var
  B, p : PRBTNode;
begin
  B := A^.right;
  if B <> @S then
  begin
    p := A^.up;
    A^.right := B^.left;
    if A^.right <> @S then A^.right^.up := A;

    B^.left := A;
    B^.up := p;
    A^.up := B;

    if p <> @S then
    begin
      if p^.left = A then p^.left := B else p^.right := B;
    end
    else root := B;
  end;
end;

// Wykonuje rotację w prawo względem A
//------------------------------------
procedure rot_R (var root : PRBTNode; A : PRBTNode);
var
  B, p : PRBTNode;
begin
  B := A^.left;
  if B <> @S then
  begin
    p := A^.up;
    A^.left := B^.right;
    if A^.left <> @S then A^.left^.up := A;

    B^.right := A;
    B^.up := p;
    A^.up := B;

    if p <> @S then
    begin
      if p^.left = A then p^.left := B else p^.right := B;
    end
    else root := B;
  end;
end;

// Wstawia do drzewa węzeł o kluczu k
//-----------------------------------
procedure insertRBT (var root : PRBTNode; k : integer);
var
  X, Y : PRBTNode;
begin
  new (X);               // Tworzymy nowy węzeł
  X^.left  := @S;          // Inicjujemy pola
  X^.right := @S;
  X^.up    := root;
  X^.key   := k;
  if X^.up = @S then root := X // X staje się korzeniem
  else
  while true do            // Szukamy liścia do zastąpienia przez X
  begin
    if k < X^.up^.key then
    begin
      if X^.up^.left = @S then
      begin
        X^.up^.left := X;  // X zastępuje lewy liść
        break;
      end;
      X^.up := X^.up^.left;
    end
    else
    begin
      if X^.up^.right = @S then
      begin
        X^.up^.right := X; // X zastępuje prawy liść
        break;
      end;
      X^.up := X^.up^.right;
    end;
  end;
  X^.color := 'R';         // Węzeł kolorujemy na czerwono
  while(X <> root) and (X^.up^.color = 'R') do
  begin
    if X^.up = X^.up^.up^.left then
    begin
      Y := X^.up^.up^.right; // Y -> wujek X

      if Y^.color = 'R' then // Przypadek 1
      begin
        X^.up^.color := 'B';
        Y^.color := 'B';
        X^.up^.up^.color := 'R';
        X := X^.up^.up;
        continue;
      end;

      if X = X^.up^.right then // Przypadek 2
      begin
        X := X^.up;
        rot_L (root, X);
      end;

      X^.up^.color := 'B'; // Przypadek 3
      X^.up^.up^.color := 'R';
      rot_R (root, X^.up^.up);
      break;
    end
    else
    begin                  // Przypadki lustrzane
      Y := X^.up^.up^.left;

      if Y^.color = 'R' then // Przypadek 1
      begin
        X^.up^.color := 'B';
        Y^.color := 'B';
        X^.up^.up^.color := 'R';
        X := X^.up^.up;
        continue;
      end;

      if X = X^.up^.left then // Przypadek 2
      begin
        X := X^.up;
        rot_R (root, X);
      end;

      X^.up^.color := 'B'; // Przypadek 3
      X^.up^.up^.color := 'R';
      rot_L (root, X^.up^.up);
      break;
    end;
  end;
  root^.color := 'B';
end;

// Wyszukuje najmniejszy węzeł w poddrzewie
// o korzeniu p
//-----------------------------------------
function  minRBT (p : PRBTNode) : PRBTNode;
begin
  if p <> @S then
    while p^.left <> @S do
      p := p^.left;
  minRBT := p;
end;

// Zwraca następnik p
//-------------------
function succRBT (p : PRBTNode) : PRBTNode;
var
  r : PRBTNode;
begin
  succRBT := @S;
  if p <> @S then
  begin
    if p^.right <> @S then succRBT := minRBT (p^.right)
    else
    begin
      r := p^.up;
      while(r <> @S) and (p = r^.right) do
      begin
        p := r;
        r := r^.up;
      end;
      succRBT := r;
    end;
  end;
end;

// Usuwa z drzewa węzeł X
//-----------------------
procedure removeRBT (var root : PRBTNode; X : PRBTNode);
var
  W, Y, Z : PRBTNode;
begin
  if(X^.left = @S) or (X^.right = @S) then Y := X
  else Y := succRBT (X);

  if Y^.left <> @S then Z := Y^.left
  else Z := Y^.right;

  Z^.up := Y^.up;

  if Y^.up = @S then root := Z
  else if Y = Y^.up^.left then Y^.up^.left  := Z
  else                         Y^.up^.right := Z;

  if Y <> X then X^.key := Y^.key;

  if Y^.color = 'B' then   // Naprawa struktury drzewa czerwono-czarnego
    while(Z <> root) and (Z^.color = 'B') do
      if Z = Z^.up^.left then
      begin

        W := Z^.up^.right;

        if W^.color = 'R' then
        begin              // Przypadek 1
          W^.color := 'B';
          Z^.up^.color := 'R';
          rot_L (root, Z^.up);
          W := Z^.up^.right;
        end;

        if(W^.left^.color = 'B') and (W^.right^.color = 'B') then
        begin              // Przypadek 2
          W^.color := 'R';
          Z := Z^.up;
          continue;
        end;

        if W^.right^.color = 'B' then
        begin              // Przypadek 3
          W^.left^.color := 'B';
          W^.color := 'R';
          rot_R (root, W);
          W := Z^.up^.right;
        end;

        W^.color := Z^.up^.color; // Przypadek 4
        Z^.up^.color := 'B';
        W^.right^.color := 'B';
        rot_L (root, Z^.up);
        Z := root;         // To spowoduje zakończenie pętli
      end
      else
      begin                // Przypadki lustrzane
        W := Z^.up^.left;

        if W^.color = 'R' then
        begin              // Przypadek 1
          W^.color := 'B';
          Z^.up^.color := 'R';
          rot_R (root, Z^.up);
          W := Z^.up^.left;
        end;

        if(W^.left^.color = 'B') and (W^.right^.color = 'B') then
        begin              // Przypadek 2
          W^.color := 'R';
          Z := Z^.up;
          continue;
        end;

        if W^.left^.color = 'B' then
        begin              // Przypadek 3
          W^.right^.color := 'B';
          W^.color := 'R';
          rot_L (root, W);
          W := Z^.up^.left;
        end;

        W^.color := Z^.up^.color;  // Przypadek 4
        Z^.up^.color := 'B';
        W^.left^.color := 'B';
        rot_R (root, Z^.up);
        Z := root;         // To spowoduje zakończenie pętli
      end;

  Z^.color := 'B';
  dispose (Y);
end;

// Procedury obsługi zbioru

// Szuka w drzewie węzła o danej wartości klucza x. Jeśli węzeł zostanie
// znaleziony, to zwraca jego adres. Inaczej zwraca wskazanie puste.
//----------------------------------------------------------------------
function s_isin (A:PRBTNode; x : integer) : PRBTNode;
begin
  while A <> @S do
  begin
    if A^.key = x then Exit (A); // Węzeł znaleziony
    if x < A^.key then A := A^.left
    else A := A^.right;
  end;
  s_isin := nil;           // Węzeł nieznaleziony
end;

// Dodaje do drzewa nowy węzeł, jesli w drzewie takiego węzła jeszcze nie ma
//--------------------------------------------------------------------------
procedure s_add (var A : PRBTNode; x : integer);
begin
  if s_isin (A, x) = nil then insertRBT (A, x);
end;

// Wyszukuje w drzewie węzeł o kluczu x i usuwa go
//------------------------------------------------
procedure s_remove (var A : PRBTNode; x : integer);
var
  p : PRBTNode;
begin
  p := s_isin (A, x);    // Szukamy węzła o kluczu x
  if p <> nil then removeRBT (A, p);
end;

// Usuwa wszystkie węzły z drzewa
//-------------------------------
procedure s_clear (var A : PRBTNode);
begin
  if A <> @S then
  begin
    s_clear (A^.left);   // Rekurencyjnie usuwamy lewe poddrzewo
    s_clear (A^.right);  // Rekurencyjnie usuwamy prawe poddrzewo
    dispose (A);         // Usuwamy węzeł
    A := @S;
  end;
end;

// Procedura kopiuje elementy z drzewa A do C
//-------------------------------------------
procedure s_copy (A : PRBTNode; var C : PRBTNode);
begin
  if A <> @S then
  begin
    s_add (C, A^.key);   // Dodajemy do C klucz bieżącego węzła
    s_copy (A^.left, C); // Rekurencyjnie dodajemy do C lewe poddrzewo
    s_copy (A^.right, C);// Rekurencyjnie dodajemy do C prawe poddrzewo
  end;
end;

// Procedura tworzy sumę zbiorów A i B w C
//----------------------------------------
procedure s_union (A, B : PRBTNode; var C : PRBTNode);
begin
  s_clear (c);           // Czyścimy C
  s_copy (A, C);         // W C umieszczamy A
  s_copy (B, C);         // Dodajemy B do C
end;

// Procedura kopiuje do C te elementy A, które również są w B
//-----------------------------------------------------------
procedure s_icopy (A, B : PRBTNode; var C : PRBTNode);
begin
  if A <> @S then
  begin
    if s_isin (B, A^.key) <> nil then s_add (C, A^.key);
    s_icopy (A^.left, B, C);
    s_icopy (A^.right, B, C);
  end;
end;

// Procedura tworzy w C iloczyn zbiorów A i B
//-------------------------------------------
procedure s_intersection (A, B : PRBTNode; var C : PRBTNode);
begin
  s_clear (c);           // Czyścimy C
  s_icopy (A, B, C);     // Tworzymy iloczyn zbiorów
end;

// Procedura kopiuje do C te elementy A, których nie ma w B
//---------------------------------------------------------
procedure s_dcopy (A, B : PRBTNode; var C : PRBTNode);
begin
  if A <> @S then
  begin
    if s_isin (B, A^.key) = nil then s_add (C, A^.key);
    s_dcopy (A^.left, B, C);
    s_dcopy (A^.right, B, C);
  end;
end;

// Procedura tworzy w C różnicę zbiorów A i B
//-------------------------------------------
procedure s_difference (A, B : PRBTNode; var C : PRBTNode);
begin
  s_clear (c);           // Czyścimy C
  s_dcopy (A, B, C);     // Tworzymy różnicę zbiorów
end;

// Funkcja zwraca true, jeśli zbiór A jest podzbiorem B
//-----------------------------------------------------
function s_subset (A, B : PRBTNode) : boolean;
begin
  if A = @S then Exit (true);
  if s_isin (B, A^.key) = nil then Exit (false);
  s_subset := s_subset (A^.left, B) and s_subset (A^.right, B);
end;

// Procedura zlicza rekurencyjnie węzły w drzewie
//-----------------------------------------------
procedure s_cnt (A : PRBTNode; var cnt : integer);
begin
  if A <> @S then
  begin
    inc (cnt);            // Zliczamy węzeł bieżący
    s_cnt (A^.left, cnt); // Rekurencyjnie liczymy węzły w lewym poddrzewie
    s_cnt (A^.right, cnt);// Rekurencyjnie liczymy węzły w prawym poddrzewie
  end;
end;

// Funkcja oblicza liczbę węzłów w drzewie
//----------------------------------------
function s_size (A : PRBTNode) : integer;
var
  cnt : integer;          // Licznik węzłów
begin
  cnt := 0;               // Zerujemy licznik
  s_cnt (A, cnt);       // Zliczamy węzły
  s_size := cnt;          // Zwracamy wynik
end;

// Funkcja zwraca true, jeśli zbiór jest pusty
//--------------------------------------------
function s_empty (A : PRBTNode) : boolean;
begin
  s_empty := A = @S;
end;

// Procedura rekurencyjnie wyświetla zawartość drzewa
//---------------------------------------------------
procedure s_print (A : PRBTNode);
begin
  if A <> @S then
  begin
    s_print (A^.left);
    write (A^.key, ' ');
    s_print (A^.right);
  end;
end;

// **********************
// *** PROGRAM GŁÓWNY ***
// **********************

var
  A, B, C, D : PRBTNode;
  i, x     : integer;

begin
  randomize;              // Inicjujemy generator pseudolosowy

  // Tworzymy puste zbiory

  A := @S;
  B := @S;
  C := @S;
  D := @S;

  // Do zbioru A dodajemy 10 losowych elementów

  for i := 1 to 10 do s_add (A, -20 + random (41));

  // Do zbioru B dodajemy 15 losowych elementów

  for i := 1 to 15 do s_add (B, -20 + random (41));

  // Wyświetlamy je

  writeln('A:');
  s_print (A); writeln;
  writeln('SIZE OF A IS ', s_size (A));
  writeln;
  writeln('B:');
  s_print (B); writeln;
  writeln('SIZE OF B IS ', s_size (B));

  // Suma zbiorów

  writeln;
  writeln('UNION OF A AND B:');
  s_union (A, B, C);
  s_print (c); writeln;
  writeln('SIZE OF UNION IS ', s_size (c));

  // Iloczyn zbiorów

  writeln;
  writeln('INTERSECTION OF A AND B:');
  s_intersection (A, B, C);
  s_print (c); writeln;
  writeln('SIZE OF INTERSECTION IS ', s_size (c));

  // Różnica zbiorów

  writeln;
  writeln('DIFFERENCE OF A AND B:');
  s_difference (A, B, C);
  s_print (c); writeln;
  writeln('SIZE OF DIFFERENCE IS ', s_size (c));

  // Podzbiór

  s_union (A, A, C);            // Kopiujemy A do C
  for i := 1 to 7 do              // Usuwamy 7 elementów
    s_remove (C, -20 + random (41));
  writeln;
  writeln('IS:');
  s_print (c);
  writeln(' SUBSET OF A?');
  writeln(s_subset (C, A));

  s_difference (B, A, C);
  for i := 1 to 12 do              // Usuwamy 12 elementów
    s_remove (C, -20 + random (41));
  writeln;
  writeln('IS:');
  s_print (c);
  writeln(' SUBSET OF A?');
  writeln(s_subset (C, A));

  // Usuwanie

  writeln;
  write ('FROM A WE REMOVE');
  for i := 1 to 5 do
  begin
    x := -20 + random (41);
    write (x:4);
    s_remove (A, x);
  end;
  writeln;
  writeln('A:'); s_print (A); writeln;
  writeln('SIZE OF A IS ', s_size (A));
  writeln;

  // Sprawdzamy obecność wybranych elementów w B

  for i := 1 to 10 do
  begin
    x := -20 + random (41);
    write ('IS ELEMENT', x:4, ' IN SET B? ');
    if s_isin (B, x) <> nil then writeln('YES') else writeln('NO');
  end;
  writeln;

  // Sprawdzenie testu na zbiór pusty

  writeln('IS SET A EMPTY?');
  writeln(s_empty (A));
  writeln;

  writeln('IS INTERSECTION OF A AND DIFFERENCE OF B AND A EMPTY?');
  s_difference (B, A, C);
  s_intersection (A, C, D);
  writeln(s_empty (D));
  writeln;

  // Usuwamy zbiory

  s_clear (A);
  s_clear (B);
  s_clear (c);
  s_clear (D);

end.

' Zbiory zaimplementowane w drzewach czerwono-czarnych
' Data   : 9.07.2014
' (C)2014 mgr Jerzy Wałaszek
'-----------------------------------------------------

' Definicja węzła drzewa czerwono-czarnego

Type RBTNode
  up    As RBTNode Ptr
  left  As RBTNode Ptr
  right As RBTNode Ptr
  key   As Integer
  color As String * 1
End Type

' Zmienne globalne

Dim Shared As RBTNode S => (@S, @S, @S, 0, "B")

' Procedury obsługi drzew czerwono-czarnych

' Wykonuje rotację w lewo względem A
'-----------------------------------
Sub rot_L (ByRef root As RBTNode Ptr, ByVal A As RBTNode Ptr)

  Dim As RBTNode Ptr B, p

  B = A->Right
  If B <> @S Then
    p = A->up
    A->right = B->Left
    If A->right <> @S then A->right->up = A

    B->left = A
    B->up = p
    A->up = B

    If p <> @S Then
      If p->left = A then p->left = B: Else p->right = B
    Else
      root = B
    End If
   
  End If
End Sub

' Wykonuje rotację w prawo względem A
'------------------------------------
Sub rot_R (ByRef root As RBTNode Ptr, ByVal A As RBTNode Ptr)

  Dim As RBTNode Ptr B, p

  B = A->Left
  if B <> @S Then
    p = A->up
    A->left = B->Right
    if A->left <> @S Then A->left->up = A

    B->right = A
    B->up = p
    A->up = B

    If p <> @S Then
      If p->left = A then p->left = B: Else p->right = B
    Else
      root = B
    End If
  End If
End Sub

' Wstawia do drzewa węzeł o kluczu k
'-----------------------------------
Sub insertRBT (ByRef root As RBTNode Ptr, ByVal k As Integer)

  Dim As RBTNode Ptr X, Y

  X = new RBTNode  ' Tworzymy nowy węzeł
  X->left  = @S    ' Inicjujemy pola
  X->right = @S
  X->up    = root
  X->key   = k
  If X->up = @S Then
  	  root = X ' X staje się korzeniem
  Else
    Do             ' Szukamy liścia do zastąpienia przez X
 
      If k < X->up->key Then
        If X->up->left = @S Then
          X->up->left = X  ' X zastępuje lewy liść
          Exit Do
        End If
        X->up = X->up->Left
      Else
        If X->up->right = @S Then
          X->up->right = X ' X zastępuje prawy liść
          Exit Do
        End If
        X->up = X->up->Right
      End If
     
    Loop
  End If
 
  X->color = "R"         ' Węzeł kolorujemy na czerwono
 
  while(X <> root) AndAlso (X->up->color = "R")
    If X->up = X->up->up->Left Then

      Y = X->up->up->Right ' Y -> wujek X

      If Y->color = "R" Then  ' Przypadek 1
        X->up->color = "B"
        Y->color = "B"
        X->up->up->color = "R"
        X = X->up->up
        Continue While
      End If

      If X = X->up->Right Then ' Przypadek 2
        X = X->up
        rot_L (root, X)
      End If

      X->up->color = "B" ' Przypadek 3
      X->up->up->color = "R"
      rot_R (root, X->up->up)
      Exit While
   
    Else              ' Przypadki lustrzane
    
      Y = X->up->up->Left

      if Y->color = "R" Then ' Przypadek 1
        X->up->color = "B"
        Y->color = "B"
        X->up->up->color = "R"
        X = X->up->up
        Continue While
      End If

      if X = X->up->Left Then ' Przypadek 2
        X = X->up
        rot_R (root, X)
      End If

      X->up->color = "B" ' Przypadek 3
      X->up->up->color = "R"
      rot_L (root, X->up->up)
      Exit While
    End If
  Wend
  root->color = "B"
End Sub

' Wyszukuje najmniejszy węzeł w poddrzewie
' o korzeniu p
'-----------------------------------------
Function minRBT (ByVal p As RBTNode Ptr) As RBTNode Ptr
  If p <> @S Then While p->left <> @S: p = p->Left: Wend
  Return p
End Function

' Zwraca następnik p
'-------------------
Function succRBT (ByVal p As RBTNode Ptr) As RBTNode Ptr

  Dim As RBTNode Ptr r

  If p <> @S Then
    If p->right <> @S Then
      Return minRBT (p->right)
    Else
      r = p->up
      while(r <> @S) AndAlso (p = r->right)
        p = r
        r = r->up
      Wend
      Return r
    End If
  End If
  Return @S
End Function

' Usuwa z drzewa węzeł X
'-----------------------
Sub removeRBT (ByRef root As RBTNode Ptr, ByVal X As RBTNode Ptr)

  Dim As RBTNode Ptr W, Y, Z

  if(X->left = @S) OrElse (X->right = @S) Then
  	 Y = X
  Else
    Y = succRBT (X)
  End If

  if Y->left <> @S Then
    Z = Y->Left
  Else
    Z = Y->Right
  End If
 
  Z->up = Y->up

  If Y->up = @S Then
  	 root = Z
  ElseIf Y = Y->up->Left Then
    Y->up->Left = Z
  Else
    Y->up->right = Z
  End If
 
  If Y <> X Then X->key = Y->key

  If Y->color = "B" Then   ' Naprawa struktury drzewa czerwono-czarnego
    while(Z <> root) AndAlso (Z->color = "B")
      If Z = Z->up->Left Then
      	
        W = Z->up->Right

        If W->color = "R" Then ' Przypadek 1
          W->color = "B"
          Z->up->color = "R"
          rot_L (root, Z->up)
          W = Z->up->Right
        End If

        if(W->left->color = "B") AndAlso (W->right->color = "B") Then ' Przypadek 2
          W->color = "R"
          Z = Z->up
          Continue While
        End If

        if W->right->color = "B" Then ' Przypadek 3
          W->left->color = "B"
          W->color = "R"
          rot_R (root, W)
          W = Z->up->Right
        End If

        W->color = Z->up->Color ' Przypadek 4
        Z->up->color = "B"
        W->right->color = "B"
        rot_L (root, Z->up)
        Z = root         ' To spowoduje zakończenie pętli
      Else               ' Przypadki lustrzane
       
        W = Z->up->Left

        If W->color = "R" Then ' Przypadek 1
          W->color = "B"
          Z->up->color = "R"
          rot_R (root, Z->up)
          W = Z->up->Left
        End If

        if(W->left->color = "B") AndAlso (W->right->color = "B") Then ' Przypadek 2
          W->color = "R"
          Z = Z->up
          Continue While
        End If

        if W->left->color = "B" Then ' Przypadek 3
          W->right->color = "B"
          W->color = "R"
          rot_L (root, W)
          W = Z->up->Left
        End If

        W->color = Z->up->Color  ' Przypadek 4
        Z->up->color = "B"
        W->left->color = "B"
        rot_R (root, Z->up)
        Z = root         ' To spowoduje zakończenie pętli
      End If
    Wend
  End If
  Z->color = "B"

  Delete Y
 
End Sub

' Procedury obsługi zbioru

' Szuka w drzewie węzła o danej wartości klucza x. Jeśli węzeł zostanie
' znaleziony, to zwraca jego adres. Inaczej zwraca wskazanie puste.
'----------------------------------------------------------------------
Function s_isin (ByVal A As RBTNode Ptr, ByVal x As Integer) As RBTNode Ptr
  While A <> @S
    If A->key = x Then Return A   ' Węzeł znaleziony
    If x < A->key Then
    	 A = A->Left
    Else
       A = A->Right
    End If
  Wend
  Return 0                        ' Węzeł nieznaleziony
End Function

' Dodaje do drzewa nowy węzeł, jesli w drzewie takiego węzła jeszcze nie ma
'--------------------------------------------------------------------------
Sub s_add (ByRef A As RBTNode Ptr, byval x As Integer)
  If s_isin (A, x) = 0 Then insertRBT (A, x)
End Sub

' Wyszukuje w drzewie węzeł o kluczu x i usuwa go
'------------------------------------------------
Sub s_remove (ByRef A As RBTNode Ptr, ByVal x As Integer)
  Dim As RBTNode Ptr p = s_isin (A, x) ' Szukamy węzła o kluczu x
  If p Then removeRBT (A, p)
End Sub

' Usuwa wszystkie węzły z drzewa
'-------------------------------
Sub s_clear (ByRef A As RBTNode Ptr)
  If A <> @S Then
    s_clear (A->left)           ' Rekurencyjnie usuwamy lewe poddrzewo
    s_clear (A->right)          ' Rekurencyjnie usuwamy prawe poddrzewo
    Delete A                      ' Usuwamy węzeł
    A = @S
  End If
End Sub

' Procedura kopiuje elementy z drzewa A do C
'-------------------------------------------
Sub s_copy (Byval A As RBTNode Ptr, ByRef C As RBTNode Ptr)
  If A <> @S Then
    s_add (C, A->key)           ' Dodajemy do C klucz bieżącego węzła
    s_copy (A->left, C)         ' Rekurencyjnie dodajemy do C lewe poddrzewo
    s_copy (A->right, C)        ' Rekurencyjnie dodajemy do C prawe poddrzewo
  End If
End Sub

' Procedura tworzy sumę zbiorów A i B w C
'----------------------------------------
Sub s_union (ByVal A As RBTNode Ptr, ByVal B As RBTNode Ptr, ByRef C As RBTNode Ptr)
  s_clear (c)                   ' Czyścimy C
  s_copy (A, C)                 ' W C umieszczamy A
  s_copy (B, C)                 ' Dodajemy B do C
End Sub

' Procedura kopiuje do C te elementy A, które również są w B
'-----------------------------------------------------------
Sub s_icopy (ByVal A As RBTNode Ptr, ByVal B As RBTNode Ptr, ByRef C As RBTNode Ptr)
  If A <> @S Then
    If s_isin (B, A->key) Then s_add (C, A->key)
    s_icopy (A->left, B, C)
    s_icopy (A->right, B, C)
  End If
End Sub

' Procedura tworzy w C iloczyn zbiorów A i B
'-------------------------------------------
Sub s_intersection (ByVal A As RBTNode Ptr, ByVal B As RBTNode Ptr, ByRef C As RBTNode Ptr)
  s_clear (c)                   ' Czyścimy C
  s_icopy (A, B, C)             ' Tworzymy iloczyn zbiorów
End Sub

' Procedura kopiuje do C te elementy A, których nie ma w B
'---------------------------------------------------------
Sub s_dcopy (ByVal A As RBTNode Ptr, ByVal B As RBTNode Ptr, ByRef C As RBTNode Ptr)
  If A <> @S Then
    If s_isin (B, A->key) = 0 Then s_add (C, A->key)
    s_dcopy (A->left, B, C)
    s_dcopy (A->right, B, C)
  End If
End Sub

' Procedura tworzy w C różnicę zbiorów A i B
'-------------------------------------------
Sub s_difference (ByVal A As RBTNode Ptr, ByVal B As RBTNode Ptr, ByRef C As RBTNode Ptr)
  s_clear (c)                   ' Czyścimy C
  s_dcopy (A, B, C)             ' Tworzymy różnicę zbiorów
End Sub

' Funkcja zwraca true, jeśli zbiór A jest podzbiorem B
' Inaczej zwraca false
'-----------------------------------------------------
Function s_subset (ByVal A As RBTNode Ptr, ByVal B As RBTNode Ptr) As Integer
  If A = @S Then Return -1
  If s_isin (B, A->key) = 0  Then Return 0
  Return s_subset (A->left, B) AndAlso s_subset (A->right, B)
End Function

' Procedura zlicza rekurencyjnie węzły w drzewie
'-----------------------------------------------
Sub s_cnt (ByVal A As RBTNode Ptr, ByRef cnt As Integer)
  If A <> @S Then
    cnt += 1                      ' Zliczamy węzeł bieżący
    s_cnt (A->left, cnt)        ' Rekurencyjnie liczymy węzły w lewym poddrzewie
    s_cnt (A->right, cnt)       ' Rekurencyjnie liczymy węzły w prawym poddrzewie
  End If
End Sub

' Funkcja oblicza liczbę węzłów w drzewie
'----------------------------------------
Function s_size (ByVal A As RBTNode Ptr) As Integer
  Dim As Integer cnt = 0          ' Zerujemy licznik
  s_cnt (A, cnt)                ' Zliczamy węzły
  Return cnt                      ' Zwracamy wynik
End Function

' Funkcja zwraca true, jeśli zbiór jest pusty
'--------------------------------------------
Function s_empty (byval A As RBTNode Ptr) As Integer
  Return A = @S
End Function

' Procedura rekurencyjnie wyświetla zawartość drzewa
'---------------------------------------------------
Sub s_print (byval A As RBTNode Ptr)
  If A <> @S Then
    s_print (A->left)
    Print Using "& ";A->key;
    s_print (A->right)
  End If
End Sub

' **********************
' *** PROGRAM GŁÓWNY ***
' **********************

Dim As RBTNode Ptr A, B, C, D
Dim As Integer i, x

Randomize                         ' Inicjujemy generator pseudolosowy

' Tworzymy puste zbiory

A = @S
B = @S
C = @S
D = @S

' Do zbioru A dodajemy 10 losowych elementów

For i = 1 To 10: s_add (A, -20 + Int (rnd() * 41)): Next

' Do zbioru B dodajemy 15 losowych elementów

For i = 1 To 15: s_add (B, -20 + Int (rnd() * 41)): Next

' Wyświetlamy je

Print "A:"
s_print (A): Print
Print "SIZE OF A IS";s_size (A)
Print
Print "B:"
s_print (B): Print
Print "SIZE OF B IS";s_size (B)
Print

' Suma zbiorów

Print "UNION OF A AND B:"
s_union (A, B, C)
s_print (c): Print
Print "SIZE OF UNION IS";s_size (c)
Print

' Iloczyn zbiorów

Print "INTERSECTION OF A AND B:"
s_intersection (A, B, C)
s_print (c): Print
Print "SIZE OF INTERSECTION IS";s_size (c)
Print

' Różnica zbiorów

Print "DIFFERENCE OF A AND B:"
s_difference (A, B, C)
s_print (c): Print
Print "SIZE OF DIFFERENCE IS";s_size (c)
Print

' Podzbiór

s_union (A, A, C)               ' Kopiujemy A do C
For i = 1 To 7                    ' Usuwamy 7 elementów
  s_remove (C, -20 + Int (rnd() * 41))
Next
Print "IS:";
s_print (c)
Print " SUBSET OF A?"
If s_subset (C, A) Then
  Print "YES"
Else
  Print "NO"
End If
Print

s_difference (B, A, C)
For i = 1 To 12                   ' Usuwamy 12 elementów
  s_remove (C, -20 + Int (rnd() * 41))
Next
Print "IS:"
s_print (c)
Print " SUBSET OF A?"
If s_subset (C, A) Then
  Print "YES"
Else
  Print "NO"
End If
Print

' Usuwanie

Print "FROM A WE REMOVE";
For i = 1 To 5
  x = -20 + Int (rnd() * 41)
  Print Using "& ";x;
  s_remove (A, x)
Next
Print
Print "A:"
s_print (A): Print
Print "SIZE OF A IS";s_size (A)
Print

' Sprawdzamy obecność wybranych elementów w B

For i = 1 To 10
  x = -20 + Int (rnd() * 41)
  Print Using "IS ELEMENT#### IN SET B? ";x;
  If s_isin (B, x) Then
  	 Print "YES"
  Else
  	 Print "NO"
  End If
Next
Print

' Sprawdzenie testu na zbiór pusty

Print "IS SET A EMPTY?"
If s_empty (A) Then
  Print "YES"
Else
  Print "NO"
End If
Print

Print "IS INTERSECTION OF A AND DIFFERENCE OF B AND A EMPTY?"
s_difference (B, A, C)
s_intersection (A, C, C)
If s_empty (c) Then
  Print "YES"
Else
  Print "NO"
End If
Print

' Usuwamy zbiory

s_clear (A)
s_clear (B)
s_clear (c)
s_clear (D)

End