Отсортировать столбцы матрицы в порядке невозрастания количества отрицательных элементов содержащихсяв них - Free Pascal
Формулировка задачи:
Задание\
Отсортировать столбцы матрицы в порядке невозрастания количества отрицательных элементов содержащихсяв них . Сортировка простыми включениями
Что можно сделать последовательно расскажите плиз))
{Можно ли какому нибудь элементу сопоставить столбец таким образом чтобы от положения элемента зависело положение столбца ??}
\\ у меня была мысль составить последовательность содержащую количество отр чисел для каждого столбца потом отсортировать последовательность
Решение задачи: «Отсортировать столбцы матрицы в порядке невозрастания количества отрицательных элементов содержащихсяв них»
textual
Листинг программы
program rakhim; uses crt; {$R-} const nad1 = ' Òàáëèöà íå ñîçäàíà! '; nad2 = ' Ââåäèòå êîëè÷åñòâî ñòðîê '; nad3 = ' Ââåäèòå êîëè÷åñòâî ñòîëáöîâ '; nad4 = ' Íåäîñòàòî÷íî ïàìÿòè'; nad5 = ' The table is created! '; nad6 = ' Ââåäèòå ïóíêò'; nad7 = ' 1|Çàïîëíèòü òàáëèöó âðó÷íóþ'; nad8 = ' 2| Çàïîëíèòü òàáëèöó ñëó÷àéíûì îáðàçîì'; nad9 = ' 3| Çàïîëíèòü èç ôàéëà'; nad10 = ' 4| Íàçàä'; nad11 = ' 1 - Çàïîëíèòü òàáëèöó'; nad12 = ' 2 - Âûïîëíèòü çàäàíèå'; nad13 = ' 3 - Ïîêàçàòü òàáëèöó'; nad14 = ' 4 - Çàïèñàòü òàáëèöó â ôàéë'; nad15 = ' 5 - Âûõîä'; Type TElem=Single; Tmas=array[1..1] of Telem; Pmas=^Tmas; Ttable=array[1..1] of Pmas; Ptable=^Ttable; const maxi=65521; var mas:Ptable; g: text; i,j,a,b:byte; ns1,ns2,t,i1:integer; w,w1:char; f:boolean; nameFILE:string; s:single; ntext:double; function rand(mqw:integer): TElem; begin rand := random(2 * mqw + 1) - mqw end; procedure pr3(var b:TMas; ns2:integer); { сортирует последовательность } procedure pr1(var mas:PTable; ns1,ns2:integer); { возвращает последовательность (содержащую количество отриц чисел для каждого столбца) } var y,u:integer; c:TMas; begin for y:=1 to ns1 do c^[y]:=0; for y:=1 to ns2 do begin for u:=1 to ns1 do if mas^[u]^[y]<0 then inc(c^[y]); end; end; procedure pr2(var mas:PTable; ns1,ns2,y1,y2:integer); { Меняет два столбца местами } var r:TElem; begin for i:=1 to ns1 do begin r:=mas^[i]^[y1]; mas^[i]^[y1]:=mas^[i]^[y2]; mas^[i]^[y2]:=r; end; end; var i,j:integer; x:TElem; begin for i:=2 to ns1 do if b^[i-1]<>b^[i] then begin x:=b^[i]; j:=i-1; while (j>0) and (b^[j]>x) do begin b^[j+1]:=b^[j]; j:j-1; end; b^[j+1]:=x; pr2(mas,ns1,ns,i,j); end; end; procedure FramePlot({Left,Top,}Hight,Width: integer); var i: integer; Left,Top: integer; const qp = 176; begin Left:=10; Top :=2; gotoxy(left,top); write(char(qp)); gotoxy(left+width,top); write(char(qp)); gotoxy(left,top+hight); write(char(qp)); gotoxy(left+width,top+hight); write(char(qp)); for i:=left+1 to left+width-1 do begin gotoxy(i,top); write(char(qp)); gotoxy(i,top+hight); write(char(qp)); end; for i:=top+1 to top+hight-1 do begin gotoxy(left,i); write(char(qp)); gotoxy(left+width,i); write(char(qp)); end; end; procedure showtable(var ns1,ns2:integer; var mas:Ptable); var i,j: byte; a:single; begin textcolor(1); if (ns1=0) or (ns2=0) then begin clrscr; writeln(nad1); readln; end else begin clrscr; textcolor(6); FramePlot(ns1{*4}+ns1*2+ns1+ns1,ns2{*11}+ns2*9+ns2); textcolor(15); for i:=1 to ns1 do begin writeln; for j:=1 to ns2 do begin gotoxy(j*10+2,i*3+2); write(' ',mas^[i]^[j]:3:2,' '); end; end; readln; end; textcolor(15); end; procedure createtable; //////////////////////////////////////////////////////////////////////////////////// procedure ctkeyboard(var n,m:integer; f: boolean; var x:Ptable); // ðóêè var i,j: byte; k:boolean; begin f:=false; repeat writeln(nad2); {$I-} readln (n); {$I+} if Ioresult = 0 then f:= true until f; f:=false; repeat writeln(nad3); {$I-} readln(m); {$I-} if IOresult = 0 then F:=true; until f; f:=False; if (maxi<n*sizeof(Pmas)) and (maxi<m*sizeof(Telem)) then begin writeln(nad4); f:=true; readln; end else begin Getmem(x,n*sizeof(Pmas)); for i:=1 to n do Getmem(x^[i],m*sizeof(telem)); end; for i:=1 to n do for j:=1 to m do begin repeat Write('[',i,',',j,'] : '); k:=false; {$I-} readln(x^[i]^[j]); {$I+} if IOResult = 0 then k:=true; until k; end; end; procedure ctrandom(var n,m:integer; f: boolean; var x:Ptable); var i,j: byte; k:boolean; begin f:=false; repeat writeln(nad2); {$I-} readln(n); {$I+} if Ioresult = 0 then f:= true until f; f:=false; repeat writeln(nad3); {$I-} readln(m); {$I-} if IOresult = 0 then F:=true; until f; f:=False; if (maxi<n*sizeof(Pmas)) and (maxi<m*sizeof(Telem)) then begin writeln(nad4); writeln(nad1); delay(1000); f:=true; readln; end else begin Getmem(x,n*sizeof(Pmas)); for i:=1 to n do Getmem(x^[i],m*sizeof(telem)); end; for i:=1 to n do for j:=1 to m do begin x^[i]^[j]:=rand(100); { x^[i]^[j]:=x^[i]^[j]*pi } end; writeln(nad5); delay(500); end; procedure readfile(var n,m:integer; var x:Ptable); var i,j,z,q:integer; nf:string; f:file of TElem; c:TElem; t:boolean; begin clrscr; writeln('Ââåäèòå èìÿ ôàéëà'); readln(nf); assign (f,nf); {$I-} reset(f); {$I+} if IOResult <> 0 then begin writeln (' Ôàéë íå íàéäåí! '); delay(500); end else begin {$I-} read(f,c); {$I+} n:=trunc(c); {$I-} read(f,c); {$I+} m:=trunc(c); if (ioresult=0) and (n>0) and (m>0) then begin t:=true; Getmem(x,n*sizeof(Pmas)); for i:=1 to n do Getmem(x^[i],m*sizeof(telem)); for i:=1 to n do for j:=1 to m do begin {$I-} read(f,x^[i]^[j]); {$I+} if ioresult<>0 then t:=false; end; writeln(nad5); delay(500); end else begin writeln (' Ðàçìåðû íåâåðíû! '); writeln(nad1); delay(1000); end; readln; {$I-} close(f); {$I+} end; end; ///////////////////////////////////////////////////////////////////////////////////// begin repeat clrscr; gotoxy(12,4); Writeln(nad6,#10,#13,nad7,#10,#13,nad8,#10,#13,nad9,#10,#13,nad10); writeln; repeat w1:=readkey(); until w1 in ['1'..'4']; case w1 of '1': ctkeyboard(ns1,ns2,f,mas); '2': ctrandom(ns1,ns2,f,mas); '3': readfile(ns1,ns2,mas); end; until w1='4'; end; {} procedure task(i1:integer); function yes(el: telem): integer; var i, j: integer; begin yes := 0; for j := 1 to ns2 do begin i := 1; while (i <= ns1) and (mas^[i]^[j] <> el) do inc(i); if i <= ns1 then inc(yes); end; end; var max,j1,j2,i2:integer; begin max:=0; for j1:=1 to ns2 do if yes(mas^[i1]^[j1]) >= max then begin i2:=i1; j2:=j1; max:=yes(mas^[i1]^[j1]); end; writeln; writeln(' Ýëåìåíò ' ,mas^[i2]^[j2]:3:3,' ñîäåðæèòñÿ â ',max,'- ñòîëáöàõ'); readln; end; procedure recordfile(n,m:integer; x:Ptable); var nf: string; i,j: byte; f: file of TELem; g: integer; k: boolean; begin clrscr; if (n=0) or (m=0) then begin writeln(nad1); readln(); end else begin clrscr; repeat writeln('Ââåäèòå èìÿ ôàéëà'); k:=false; {$I-} readln(nf); if IOResult = 0 then k:=true; until k; {$I+} repeat repeat k:=false; {$I-} if ioresult = 0 then k:=true; until k; until ioresult = 0; repeat repeat k:=false; {$I-} if ioresult = 0 then k:=true; until k; until ioresult = 0; if (n>0) or (m>0) then begin {$I-} Assign(f,nf); rewrite(f); write(f,n,m); { write(f,m); } for i:=1 to n do for j:=1 to m do begin if (x^[i]^[j]=0) then g:=g+1; write(f,x^[i]^[j]); end; {$I+} Close(f); if g=n*m then writeln('Òàáëèöà èç íóëåé!'); end else begin writeln('Íå âåðíûå ãðàíèöû òàáëèöû'); readln; end; end; end; begin repeat clrscr; textcolor(15); gotoxy(12,4); Writeln(nad6,#10,#13,nad11,#10,#13,nad12,#10,#13,nad13,#10,#13,nad14,#10,#13,nad15); writeln; repeat w:=readkey(); until w in ['1'..'5']; case w of '1': createtable; '2': begin i1:=-1; showtable(ns1,ns2,mas); if (ns1=0) or (ns2=0) then writeln('') else begin while not (ioresult=0) or (i1<=0) or (i1>ns1) do begin write(' ââåäèòå íîìåð ëèíèé: '); {$I-} readln(i1); {$I+} end; writeln; task(i1); end; end; '3': showtable(ns1,ns2,mas); '4': recordfile(ns1,ns2,mas); end; until w='5'; end.