Program stek_1; type Telem =integer; ukaz = ^zweno; zweno =record ELem: Telem; next:ukaz; end; stek=ukaz; var ust,ust1,ust2,ust3,g,g1,g2,g3:ukaz; a,EL,EL1,EL2,EL3:Telem; min1,min2,min3:integer; procedure wstek(var ust:stek; Nelem:Telem); {занесение элемента в стек} var g:ukaz; begin New(g);{порождение нового звена} g^.Next:=ust;ust:=g{?} end; procedure Isstek (var ust:stek; var a:Telem); var g:ukaz; begin if ust =nil then {проверка,не пуст ли стек} writeln('попытка выбора из пустого стека') else begin {выбор элемента из стека} a:=ust^.Elem; {заполнение стека на старую вершину} g:=ust; {исключение последнего звено из стека} ust:=ust^.next; dispose(g) end {?} end; Function outstak (var dukaz:zweno):Telem; {?} var EL:zweno; begin outstak:=dukaz^.Elem; EL:=dukaz; dukaz:=dukaz^.prev; dispose(EL); end; BEGIN {основная программа} ust1:=nil;ust2:=nil;ust3:nil;{создаем пустые стеки} writeln('ввести в элемнты в стек ч\з пробел,число 0 и enter завершает ввод'); read (EL1); while EL1<=>0 do begin wstek(ust1,EL1); read(EL2); end; writeln; writeln('ввести в элемнты в стек ч\з пробел,число 0 и enter завершает ввод'); read (EL2); while EL2<=>0 do begin wstek(ust2,EL2); read(EL2); end; writeln; writeln('ввести в элемнты в стек ч\з пробел,число 0 и enter завершает ввод'); read (EL3); while EL3<=>0 do begin wstek(ust3,EL3); read(EL3); end; writeln; {находим минимальное число в 1 стеке} min1:=outstak(g1); while g1<>nil do begin EL1:=Outstak(g1); if(EL1<>min1)then min1:EL1; end; {находим минимальное число во 2 стеке} min2:=outstak(g2); while g2<>nil do begin EL2:=Outstak(g2); if(EL2<>min2)then min2:EL2; end; {находим минимальное число во 3 стеке} min3:=outstak(g3); while g3<>nil do begin EL3:=Outstak(g3); if(EL3<>min3)then min3:EL3; end; {находим стек,у которого находится минимальное число,таких стеков несколько,то берем любой из них 3} if (min1<=min2)then{выбираем максимальный элемент из 2 и 3 стеков} begin while (g2<>nil) and (g3<>nil) do begin EL2:=outstak(g2); EL3:=outstak(g3); end{?} if (EL2>EL3) then begin while ust1<>nil do begin Isstek(ust1,EL1); wstek(ust2,EL2); end{?} writeln; while ust2<>nil do begin Isstek(ust2,EL2); write(EL2,' '); end; writeln; end; else begin while ust1<>nil do begin Isstek(ust1,EL1); wstek(ust3,EL3); end{?} writeln; while ust3<>nil do begin Isstek(ust3,EL3); write(EL3,' '); end; writeln; end; else {выбираем максимальный элемент из 1 и 2 стеков } begin EL1:=outstak(g1); EL3:=outstak(g3); end{?} if (EL1>=EL3) then begin while ust2<>nil do begin Isstek(ust2,EL2); wstek(ust1,EL1); end{?} writeln; while ust1<>nil do begin Isstek(ust1,EL1); write(EL1,' '); end; writeln; end; else begin while ust2<>nil do begin Isstek(ust2,EL2); wstek(ust3,EL3); end{?} writeln; while ust3<>nil do begin Isstek(ust3,EL3); write(EL3,' '); end; writeln; end; end;end; if (min1>=min3)and(min2>=min3) then {выбор максимального элемента из 1 и 2 стеков} begin while (g1<>nil) and (g2<>nil) do begin EL1:=outstak(g1); EL2:=outstak(g2); end{?} if (EL1>EL2) then begin while ust3<>nil do begin Isstek(ust3,EL3); wstek(ust1,EL1); end{?} writeln; while ust1<>nil do begin Isstek(ust1,EL1); write(EL1,' '); end; writeln; end; else begin while ust3<>nil do begin Isstek(ust3,EL3); wstek(ust2,EL2); end{?} writeln; while ust2<>nil do begin Isstek(ust2,EL2); write(EL2,' '); end; writeln; end; end; end.