Графы, Графы Опции

[not_programmer]

Доброго времени суток.
Сделал вот прогу, но она почему-то не работает. Помогите в решении проблемы.

Вот условие:
1) Написать процедуру удаления из графа всех вершин с заданным значением информационного поля.
2) Написать процедуру «стягивания» в одну вершину всех вершин, информационное поле которых содержит заданное значение. При «стягивании» в графе остается только одна вершина, содержащая заданное значение, остальные вершины удаляются, но все исходящие из них и входящие в них дуги «передаются» оставшейся вершине. При этом петли, связывающие вершину с собой, не создаются. Не создаются также и параллельные дуги.

Вот код:

Program G4;

Uses
    Crt;

Type
    RefNode = ^Node;
    RefArc = ^Arc;
    Node = Record
             ID : Integer;
        InfNode : Integer;
           Next : RefNode;
        ArcList : RefArc;
           END;
     Arc = Record
        InfArc : Integer;
          Next : RefArc;
           Adj : RefNode;
           END;

Procedure Browse(Graph : RefNode);
 Var
                      A : RefArc;
    CountNode, CountArc : Integer;
 BEGIN
   CountNode := 0;
   CountArc := 0;
   While Graph <> NIL Do
     BEGIN
       WriteLn('  Top ',Graph^.ID,' with weight ',Graph^.InfNode);
       Write('  ArcList: ');
       A := Graph^.ArcList;
       If A = NIL Then
          Write('Empty');
       While A <> NIL Do
         BEGIN
           WriteLn(' Arc to Top ',(A^.Adj)^.ID,' weight of Arc ', A^.InfArc);
           CountArc := CountArc + 1;
           A := A^.Next;
         END;
       CountNode := CountNode + 1;
       Graph := Graph^.Next;
     END;
   WriteLn;
   WriteLn('  In Graph: ',CountNode,' Top and ',CountArc,' Arc ');
 END;

Procedure Destroy(Graph : RefNode);
 Var
    A, P : RefArc;
       Q : RefNode;
 BEGIN
   While Graph <> NIL Do
     BEGIN
       A := Graph^.ArcList;
       While A <> NIL Do
         BEGIN
           P := A^.Next;
           Dispose(A);
           A := P;
         END;
       Q := Graph^.Next;
       Dispose(Graph);
       Graph := Q;
     END;
 END;

Procedure AddNode(Var Graph : RefNode; NumberID, Weight : Integer);
 Var
    P : RefNode;
 BEGIN
   New(P);
   With P^ Do
     BEGIN
       ID := NumberID;
       InfNode := Weight;
       ArcList := NIL;
       Next := Graph;
     END;
   Graph := P;
 END;

Procedure AddArc(U, V : RefNode; Weight : Integer);
 Var
    A : RefArc;
 BEGIN
   If (U = NIL) OR (V = NIL) Then
      WriteLn('  Error : Top is not ')
   Else
      BEGIN
        New(A);
        With A^ Do
          BEGIN
            InfArc := Weight;
            Adj := V;
            Next := U^.ArcList;
          END;
        U^.ArcList := A;
      END;
 END;

Procedure DeleteArc(U, V : RefNode);
 Var
    A, Before : RefArc;
          Run : Boolean;
 BEGIN
   If U <> NIL Then
      BEGIN
        A := U^.ArcList;
        Run := True;
        While (A <> NIL) AND Run Do
          If A^.Adj = V Then
             Run := False
          Else
             BEGIN
               Before := A;
               A := A^.Next;
             END;
        If A <> NIL Then
           BEGIN
             If A = U^.ArcList Then
                U^.ArcList := A^.Next
             Else
                Before^.Next := A^.Next;
             Dispose(A);
           END;
      END;
 END;

Procedure DeleteNode(Var Graph : RefNode; V : RefNode);
 Var
    P, Q : RefNode;
    A, After : RefArc;
 BEGIN
   P := Graph;
   While P <> NIL Do
     BEGIN
       Q := P^.Next;
       If P <> V Then
          DeleteArc(P, V)
       Else
          BEGIN
            If P = Graph Then
               Graph := Q;
            A := P^.ArcList;
            While A <> NIL Do
              BEGIN
                After := A^.Next;
                Dispose(A);
                A := After;
              END;
            Dispose(P);
          END;
       P := Q;
     END;
 END;

Procedure Tightener(Var Graph : RefNode; V : RefNode);
 Var
     P, Q, R : RefNode;
    A, After : RefArc;
 BEGIN
   P := Graph;
   While P <> V Do
     P := P^.Next;
   R := P;
   While P <> NIL Do
     BEGIN
       Q := P^.Next;
       If P = V Then
          BEGIN
            If P = Graph Then
               Graph := Q;
            A := P^.ArcList;
            While A <> NIL Do
              BEGIN
                After := A^.Next;
                Dispose(A);
                A := After;
              END;
            Dispose(P);
          END;
       P := Q;
     END;
 END;

Procedure Menu;
 BEGIN
   ClrScr;
   WriteLn('  1) Add element in Graph ');
   WriteLn('  2) Add Arc in Graph ');
   WriteLn('  3) Browse Graph ');
   WriteLn('  4) Delete element from Graph ');
   WriteLn('  5) Tightener of Graph ');
   WriteLn('  6) Destroy Graph ');
   WriteLn('  7) Exit ');
   WriteLn;
   Write('     Your choose: ');
 END;


{=======MAIN PROGRAM=======}


Var
                  Graph, U, V : RefNode;
   Selector, NumberID, Weight : Integer;
BEGIN
  Repeat
    Menu;
    Read(Selector);
    WriteLn;
    Case Selector Of
      1 : BEGIN
            Write('  Enter ID of element: ');
            ReadLn(NumberID);
            Write('  Enter weight: ');
            ReadLn(Weight);
            AddNode(Graph, NumberID, Weight);
          END;
      2 : BEGIN
            Write('  One to Two: ');
            WriteLn;
            Write('Enter weight of Arc: ');
            ReadLn(Weight);
            AddArc(Graph^.ID, Graph, Weight);
            Write('  Two to One: ');
            WriteLn;
            Write('Enter weight of Arc: ');
            ReadLn(Weight);
            AddArc(Graph, Graph^.ID, Weight);
          END;
      3 : BEGIN
            Browse(Graph);
            ReadLn;
            ReadLn;
          END;
      4 : BEGIN
            Write('  Enter meaning of element: ');
            ReadLn(V^.InfNode);
            DeleteNode(Graph, V);
          END;
      5 : BEGIN
            Write('  Enter meaning of element: ');
            ReadLn(V^.InfNode);
            Tightener(Graph, V);
          END;
      6 : Destroy(Graph);
      7 : ClrScr;
    END;
  Until Selector = 7;
END.

Заранее благодарю за помощь.