Преоразование бинарного дерева в нерегулярное

[Cannibal]

вот алгоритм

Правило построения бинарного дерева из любого дерева:
1. В каждом узле оставить только ветвь к старшему сыну (вертикальное соединение);
2. Соединить горизонтальными ребрами всех братьев одного отца;
3. Таким образом перестроить дерево по правилу:
левый сын - вершина, расположенная под данной;
правый сын - вершина, расположенная справа от данной (т.е. на одном ярусе с ней).
4. Развернуть дерево таким образом, чтобы все вертикальные ветви отображали левых сыно-вей, а горизонтальные - правых.

Для обратного преобразования нужно выполнить следующие действия:
1. В каждом узле оставить левую ветвь
2. Правого потомка примсоединить к узлу, находящемуся на уровень выше.

вот реализация

TBinTree = ^TBinVersh;
TBinVersh = record
  inf : integer;
  left,right : TBinTree;
  end;

TArc =^TListVersh;
TTree = ^TVersh;
TVersh = record
  inf : integer;
  sons : TArc;
  end;
TListVersh = record
  versh : TTree;
  next : TArc;
  end;
  
function createVersh(key: Integer): TTree;
var
  versh: TTree;

begin
  new(versh);
  versh^.inf := key;
  versh^.sons := nil;
  createVersh := Versh;
end;


procedure ToTree(BinTree: TBinTree; var tree: TTree);
var
  Sons: TArc;
begin
  if binTree = nil then
    tree := nil
  Else begin
    write(bintree^.inf:3);
    Tree := CreateVersh(BinTree^.inf);
    new(sons);
    ToTree(BinTree^.Left, sons^.Versh);
    if binTree^.left <> nil then  begin
      new(sons);
      ToTree(BinTree^.Left^.Right, Sons^.versh);
  //    end;
      if sons^.versh<>Nil then begin
        sons^.next := Tree^.Sons;
        tree^.sons := sons;
      end
      else
        sons^.next := nil
      end
    else
      Sons := Nil;
  Tree^.Sons := Sons;
  end;
end;

почему-то процедура не обходит все вершины дерева и в рез. дереве только корневая вершина и вершина правого подподдерева левого поддерева