Подобрать значения таким образом, чтобы бинарное дерево совпало с рисунком

program derevo;
uses crt;
const
n = 11;
Type
  pnode= ^node;
  node = record
  v : integer;
  right, left : pnode;
  lf, rf : boolean;
  end;
var
root : pnode;
st : boolean;
v : integer;
right, left : pnode;
j, h, i, answ, answ2 : integer;
m : array[1..n] of integer;
procedure Insert(var root: pnode; X: integer);
procedure CreateNode(var p : pnode; n : integer);
begin
new(p);
p^.v := n;
p^.left := nil;
p^.right := nil;
end;
begin
if root = nil then
CreateNode(root, X)
else
with root^ do
begin
if v < X then
Insert(right, X)
else
if v > X then
Insert(left, X)
else
begin
writeln('Такой элемент уже есть');
exit;
end;
end;
end;
procedure ViewTree(root : pnode);
var
mas1, mas2 : array[1..11] of integer;
q, m1, m2 : integer;
Sch, Chl, Chr : pnode;
function sc(s : integer) : integer;
var c, c1, w : integer;
begin
c := 0;
sc := 0;
s := s-1;
if s = 0 then
exit;
for w := 1 to s do
begin
c1 := 1+2*c;
c := c1;
end;
sc := c1;
end;
procedure Search(root : pnode; s : integer);
begin
if root^.v = s then
begin
Sch := root;
exit;
end;
if root = nil then
exit
else
begin
Search(root^.right, s);
Search(root^.left, s);
end;
end;
procedure ToMas2;
begin
 if Sch^.left <> nil then
 begin
  Chl := Sch^.left;
  m2 := m2+1;
  mas2[m2] := Chl^.v;
 end
 else
 begin
  m2 := m2+1;
  mas2[m2] := 0;
 end;
 if Sch^.right <> nil then
 begin
  Chr := Sch^.right;
  m2 := m2+1;
  mas2[m2] := Chr^.v;
 end
else
 begin
m2 := m2+1;
mas2[m2] := 0;
end;
end;
procedure ToMas1;
begin
if Sch^.left <> nil then
begin
Chl := Sch^.left;
m1 := m1+1;
mas1[m1] := Chl^.v;
end
else
begin
m1 := m1+1;
mas1[m1] := 0;
end;
if Sch^.right <> nil then
begin
Chr := Sch^.right;
m1 := m1+1;
mas1[m1] := Chr^.v;
end
else
begin
m1 := m1+1;
mas1[m1] := 0;
end;
end;
procedure NilToMas1;
begin
if i > 1 then
begin
m1 := m1+1;
mas1[m1] := 0;
m1 := m1+1;
mas1[m1] := 0;
end;
end;
procedure NilToMas2;
begin
if i > 1 then
begin
m2 := m2+1;
mas2[m2] := 0;
m2 := m2+1;
mas2[m2] := 0;
end;
end;
begin
mas1[1] := root^.v;
m1 := 1;
m2 := 9;
for i := h downto 1 do
begin
writeln;
if mas1[1] = 0 then
begin
NilToMas2;
write('':(sc(i)+1));
end
else
begin
write('':sc(i), mas1[1]);
Search(root, mas1[1]);
ToMas2;
end;
if m1 > 1 then
begin
for q := 2 to m1 do
if mas1[q] = 0 then
begin
NilToMas2;
write('':(sc(i+1)+1));
end
else
begin
write('':sc(i+1), mas1[q]);
Search(root, mas1[q]);
ToMas2;
end;
end;
m1 := 0;
if i = 1 then
break
else
i := i-1;
writeln;
if mas2[1] = 0 then
begin
NilToMas1;
write('':(sc(i)+1));
end
else
begin
write('':sc(i), mas2[1]);
Search(root, mas2[1]);
ToMas1;
end;
for q := 2 to m2 do
begin
if mas2[q] = 0 then
begin
NilToMas1;
write('':(sc(i+1)+1));
end
else
begin
write('':sc(i+1), mas2[q]);
Search(root, mas2[q]);
ToMas1;
end;
end;
m2 := 0;
end;end;
procedure PrintDown(level : integer; root : pnode);
begin
if root = nil then
exit;
with root^ do
begin
if right = nil then
rf := false;
lf := false;
if (left = nil) and (right = nil) then
begin
j := j+1;
if h < j then
h := j;
j := 0;
end;
writeln('':2*level, v);
j := j+1;
PrintDown(level+1, left);
PrintDown(level+1, right)
end;end;
procedure PrintLex(level : integer; root : pnode);
begin
if root = nil then
exit;
with root^ do
begin
PrintLex(level+1, left);
writeln('':2*level, v);
PrintLex(level+1, right);
end; end;
procedure PrintUp(level : integer; root : pnode);
begin
if root = nil then
exit;
with root^ do
begin
PrintUp(level+1, left);
PrintUp(level+1, right);
writeln('':2*level, v);
end; end;
procedure Threading(x : pnode);
var
p : pnode;
stop : boolean;
procedure rightPointer(y : pnode; i : integer);
begin
if stop = true then
exit;
j := j+1;
if y = nil then
exit;
with y^ do
begin
rightPointer(left, i);
if (j > i) and (rf = true) then
begin
j := 0;
writeln('Прошиваем ', x^.v, ' элемент с ', v);
x^.right := y;
stop := true;
x^.lf := true;
exit;
end;
if lf = true then
exit;
rightPointer(right, i);
end ;
end;
begin
i:= i+1;
if x = nil then
exit;
with x^ do
begin
rf := true;
Threading(left);
if (rf = true) and (right = nil) then
begin
stop := false;
rightPointer(root, i);
end;
if (left = nil) and (right = nil) then
begin
stop := false;
rightPointer(root, i);
end;
writeln(' ',v);
if lf = true then
exit;
Threading(right);
end;end;
procedure Cycle;
begin
for i := 1 to n do
Insert(root, m[i]);
end;
begin
clrscr;
m[1]:=1;
m[2]:=1;
m[3]:=1;
m[4]:=1;
m[5]:=1;
m[6]:=1;
m[7]:=1;
m[8]:=1;
m[9]:=1;
m[10]:=1;
m[11]:=1;
Cycle;
PrintDown(1, root);
writeln('Выберите действие');
repeat
 writeln('1 - провести обход, 2 - отобразить дерево, 3 - выполнить прошивку, 4 - выход');
 readln(answ);
 case (answ) of
 1 :
  begin
    if st = true then
      writeln('Обход невозможен - дерево прошито')
    else
      begin
      writeln('Выберите обход: 1 - сверху-вниз, 2 - слева-направо, 3 - снизу-вверх');
      readln(answ2);
      case (answ2) of
        1 :
          begin
          writeln('Обход сверху-вниз:');
          PrintDown(1, root);
          end;
        2 :
          begin
          writeln('Обход слева-направо:');
          PrintLex(1, root);
          end;
        3 :
          begin
          writeln('Обход снизу-вверх:');
          PrintUp(1, root);
          end;
     end;
  end;
 end;
  2 :
  begin
  if st = true then
  writeln('Дерево прошито - его представление невозможно')
  else
  begin
   writeln('Представление дерева:');
   ViewTree(root);
  end;
end;
  3 :
  begin
if st = true then
writeln('Дерево уже прошито')
else
begin
writeln('Прошивка:');
i := 0;
j := 0;
Threading(root);
st := true;
end;
  end;
  4 : exit;
end
until answ=4
end.