Chủ đề này có 77 trả lời

[Master Kaiser]

Làm theo kiểu file được không ạ.

Code đó là cách làm theo  kiểu file đó bạn 

[Master Kaiser]

bài 1 :cho hỏi bài tìm số hoàn hảo cho biết có bao nhiêu số hoàn hảo và in ra các số đó. ( làm theo file được không ạ).

PROGRAM So_hoan_hao; 
uses crt; 

Var S,n,i,j: integer; 
BEGIN
Clrscr; 
Write('Nhap so n : '); readln(n); 
For i:=1 to n do 
begin 
S:=0; 
For j:=1 to i do 
if i mod j = 0 then 
S:=S+j; 
if S = 2*i then 
write(i:6); 
end; 
Readln; 
END.

(Mấy bài bạn nói rõ đề ra giùm ... như vậy thì chả biết nó là dạng gì ... ví dụ như dãy fibonacci thì mình cũng chat hiểu là viết dãy hay tìm số hay tìm dãy ... nữa :3)

[spiritfoxll]

PROGRAM So_hoan_hao; 
uses crt; 

Var S,n,i,j: integer; 
BEGIN
Clrscr; 
Write('Nhap so n : '); readln(n); 
For i:=1 to n do 
begin 
S:=0; 
For j:=1 to i do 
if i mod j = 0 then 
S:=S+j; 
if S = 2*i then 
write(i:6); 
end; 
Readln; 
END.

(Mấy bài bạn nói rõ đề ra giùm ... như vậy thì chả biết nó là dạng gì ... ví dụ như dãy fibonacci thì mình cũng chat hiểu là viết dãy hay tìm số hay tìm dãy ... nữa :3)

In dãy fibonacci ạ. Làm giúp mình mấy bài kia luôn với ạ.

[Master Kaiser]

In dãy fibonacci ạ. Làm giúp mình mấy bài kia luôn với ạ.

Sau đây là chương trình in ra n số fibonacci ( n lấy từ file FIBO.INP ) 

{Đây là cách đơn giản nhất nhưng hơi khó nhớ }

PROGRAM FIBONACCI;

uses crt;
var i,n,f1,f2: integer;

    g:text;
BEGIN

 assign(g,'FIBO.INP');reset(g);
 readln(g,n);

 close(g);

 assign(g,'FIBO.OUT');rewrite(g);

 f1:=0;
 f2:=1;
 for i:=1 to n do
 begin
  writeln(g,f1);
  f2:=f2+f1;
  f1:=f2-f1;
 end;

 close(g);
END. 

[Master Kaiser]

In dãy fibonacci ạ. Làm giúp mình mấy bài kia luôn với ạ.

Còn đây là làm theo mảng sẽ dễ nhớ và dễ hiểu

Program FIBONACI; 
Uses CRT; 
Var F:array[1..100] of integer; 
      N,I:Longint; f:text;
BEGIN 
Assign(f,'FIBO.INP');reset(f);

Readln(f,n);close(f);

Assign(f,'FIBO.OUT');rewrite(f);

F[1]:=1; F[2]:=1; 
For i:=1 to N do 
Begin 
If i>2 then F[i]:=F[i-1]+F[i-2]; 
Writeln(f,F[i]); 
End; 
Close(f);

 

END. 

[spiritfoxll]

Còn đây là làm theo mảng sẽ dễ nhớ và dễ hiểu

Program FIBONACI; 
Uses CRT; 
Var F:array[1..100] of integer; 
      N,I:Longint; f:text;
BEGIN 
Assign(f,'FIBO.INP');reset(f);

Readln(f,n);close(f);

Assign(f,'FIBO.OUT');rewrite(f);

F[1]:=1; F[2]:=1; 
For i:=1 to N do 
Begin 
If i>2 then F[i]:=F[i-1]+F[i-2]; 
Writeln(f,F[i]); 
End; 
Close(f);

 

END. 

Cảm ơn bạn. Làm giúp mình mấy bài kia với ạ. 

[spiritfoxll]

CONST   fi='XEPCHU.inp';

        fo='XEPCHU.out';

var st:array['A'..'Z'] of longint;

    i,j,N:longint;

    f:text;

    x:CHAR;

begin

     assign(f,fi); reset(f);

     readln(f,n);

     for i:=1 to n do

     begin

          read(f,x);

          ST[x]:=ST[x]+1;

     end;

     close(f);

     assign(f,fo); rewrite(f);

     for x:='A' to 'Z' do

     if st[x]<>0 then

     writeln(f,x, st[X]);

     close(f);

    END.

Đây là bài nén xâu, ai giúp mình giải xâu đi.

[spiritfoxll]

PROGRAM So_hoan_hao; 
uses crt; 

Var S,n,i,j: integer; 
BEGIN
Clrscr; 
Write('Nhap so n : '); readln(n); 
For i:=1 to n do 
begin 
S:=0; 
For j:=1 to i do 
if i mod j = 0 then 
S:=S+j; 
if S = 2*i then 
write(i:6); 
end; 
Readln; 
END.

(Mấy bài bạn nói rõ đề ra giùm ... như vậy thì chả biết nó là dạng gì ... ví dụ như dãy fibonacci thì mình cũng chat hiểu là viết dãy hay tìm số hay tìm dãy ... nữa :3)

Sao mình in không ra 8128 nhỉ.

[Master Kaiser]

Sao mình in không ra 8128 nhỉ.

Code mình thì mình nghĩ đúng rồi nhưng bạn thử xem lại cái test xem ?

[Master Kaiser]

 

CONST   fi='XEPCHU.inp';

        fo='XEPCHU.out';

var st:array['A'..'Z'] of longint;

    i,j,N:longint;

    f:text;

    x:CHAR;

begin

     assign(f,fi); reset(f);

     readln(f,n);

     for i:=1 to n do

     begin

          read(f,x);

          ST[x]:=ST[x]+1;

     end;

     close(f);

     assign(f,fo); rewrite(f);

     for x:='A' to 'Z' do

     if st[x]<>0 then

     writeln(f,x, st[X]);

     close(f);

    END.

Đây là bài nén xâu, ai giúp mình giải xâu đi.

 

Dưới đây là một code full từ nén xâu đến giải nén xâu (xâu thuần nhất) :

PROGRAM xau;
uses crt;
var s,ss,st,si:string; i,j,l:integer; f:text;
function kttn(s:string):boolean;
 var x:char; ok:boolean;
 begin
  kttn:=true;
  for i:=1 to length(s) do
   s[i]:=upcase(s[i]);
  for i:=1 to length(s) do
   begin
    ok:=false;
    for x:='A' to 'Z' do
     if s[i]=x then ok:=true;
    if not ok then begin kttn:=false;break;end;
   end;
 end;
procedure nen(s:string;var st:string);
 begin
  ss:='';
  while s<>'' do
   begin
    i:=1;
    while (s[i+1]=s[1])and(i<length(s)) do
     inc(i);
    if i>1 then
     begin
      str(i,si);
      ss:=ss+s[1]+si;
     end
    else ss:=ss+s[1];
    delete(s,1,i);
   end;

  s:=ss;l:=2;
  while l<length(s) do
   begin
    i:=1;
    while i<=length(s)-l do
     begin
      si:=copy(s,i,l);
      j:=i+l;
      ss:=copy(s,j,l);
      while ss=si do
       begin
        j:=j+l;
        ss:=copy(s,j,l);
       end;
      if j=i+l then inc(i)
      else
       begin
        str((j-i)div l,ss);
        delete(s,i,j-i);
        si:='('+si+')'+ss;
        insert(si,s,i);
        i:=i+l+2+length(ss);
       end;
     end;
    inc(l);
   end;
  st:=s;
 end;
function ktcd(st:string):boolean;
 begin
  ktcd:=false;
  for i:=1 to length(st) do
   if st[i]='(' then begin ktcd:=true; break; end;
 end;
procedure giainen(st:string;var s:string);
 var d,c:byte; code:integer;
 begin
  while ktcd(st) do
   begin
    i:=1; c:=0;
    while st[i]<>'(' do inc(i);
    d:=1; j:=i+1;
    while c<d do
     begin
      inc(j);
      if st[j]='(' then inc(d);
      if st[j]=')' then inc(c);
     end;
    si:=copy(st,i,j-i+1);
    delete(st,i,j-i+1);
    delete(si,1,1);
    delete(si,length(si),1);
    j:=i;
    while st[j+1] in['0'..'9'] do inc(j);
    ss:=copy(st,i,j-i+1);
    delete(st,i,j-i+1);
    val(ss,l,code);
    for j:=1 to l do
     insert(si,st,i);
   end;
  i:=1;
  while i<=length(st) do
   begin
    inc(i);
    if st[i] in['0'..'9'] then
     begin
      j:=i;
      while st[j+1] in['0'..'9'] do inc(j);
      ss:=copy(st,i,j-i+1);
      delete(st,i,j-i+1);
      val(ss,l,code);
      ss:=st[i-1];
      for j:=1 to l-1 do insert(ss,st,i);
      i:=i+l-1;
     end;
   end;

  s:=st;
 end;
BEGIN

 assign(f,'XAU.INP');reset(f);

readln(f,s);close(f);

assign(f,'XAU.OUT');rewrite(f);
 if kttn(s) then
  begin
   nen(s,st);
   writeln(f,'Chuoi sau khi nen la: ',st);
   giainen(st,s);
   writeln(f,'Chuoi sau khi giai nen la: ',s);
  end
 else write(f,'Xau ko thuan nhat.');

close(f);
END.

[spiritfoxll]

Dưới đây là một code full từ nén xâu đến giải nén xâu (xâu thuần nhất) :

PROGRAM xau;
uses crt;
var s,ss,st,si:string; i,j,l:integer; f:text;
function kttn(s:string):boolean;
 var x:char; ok:boolean;
 begin
  kttn:=true;
  for i:=1 to length(s) do
   s[i]:=upcase(s[i]);
  for i:=1 to length(s) do
   begin
    ok:=false;
    for x:='A' to 'Z' do
     if s[i]=x then ok:=true;
    if not ok then begin kttn:=false;break;end;
   end;
 end;
procedure nen(s:string;var st:string);
 begin
  ss:='';
  while s<>'' do
   begin
    i:=1;
    while (s[i+1]=s[1])and(i<length(s)) do
     inc(i);
    if i>1 then
     begin
      str(i,si);
      ss:=ss+s[1]+si;
     end
    else ss:=ss+s[1];
    delete(s,1,i);
   end;

  s:=ss;l:=2;
  while l<length(s) do
   begin
    i:=1;
    while i<=length(s)-l do
     begin
      si:=copy(s,i,l);
      j:=i+l;
      ss:=copy(s,j,l);
      while ss=si do
       begin
        j:=j+l;
        ss:=copy(s,j,l);
       end;
      if j=i+l then inc(i)
      else
       begin
        str((j-i)div l,ss);
        delete(s,i,j-i);
        si:='('+si+')'+ss;
        insert(si,s,i);
        i:=i+l+2+length(ss);
       end;
     end;
    inc(l);
   end;
  st:=s;
 end;
function ktcd(st:string):boolean;
 begin
  ktcd:=false;
  for i:=1 to length(st) do
   if st[i]='(' then begin ktcd:=true; break; end;
 end;
procedure giainen(st:string;var s:string);
 var d,c:byte; code:integer;
 begin
  while ktcd(st) do
   begin
    i:=1; c:=0;
    while st[i]<>'(' do inc(i);
    d:=1; j:=i+1;
    while c<d do
     begin
      inc(j);
      if st[j]='(' then inc(d);
      if st[j]=')' then inc(c);
     end;
    si:=copy(st,i,j-i+1);
    delete(st,i,j-i+1);
    delete(si,1,1);
    delete(si,length(si),1);
    j:=i;
    while st[j+1] in['0'..'9'] do inc(j);
    ss:=copy(st,i,j-i+1);
    delete(st,i,j-i+1);
    val(ss,l,code);
    for j:=1 to l do
     insert(si,st,i);
   end;
  i:=1;
  while i<=length(st) do
   begin
    inc(i);
    if st[i] in['0'..'9'] then
     begin
      j:=i;
      while st[j+1] in['0'..'9'] do inc(j);
      ss:=copy(st,i,j-i+1);
      delete(st,i,j-i+1);
      val(ss,l,code);
      ss:=st[i-1];
      for j:=1 to l-1 do insert(ss,st,i);
      i:=i+l-1;
     end;
   end;

  s:=st;
 end;
BEGIN

 assign(f,'XAU.INP');reset(f);

readln(f,s);close(f);

assign(f,'XAU.OUT');rewrite(f);
 if kttn(s) then
  begin
   nen(s,st);
   writeln(f,'Chuoi sau khi nen la: ',st);
   giainen(st,s);
   writeln(f,'Chuoi sau khi giai nen la: ',s);
  end
 else write(f,'Xau ko thuan nhat.');

close(f);
END.

Tách riếng cho mình bài giải nén theo dạng file với ạ.  Với sao bạn không giúp mình mấy bài trước với. Mình có đưa lên rồi.

[Master Kaiser]

Tách riếng cho mình bài giải nén theo dạng file với ạ.  Với sao bạn không giúp mình mấy bài trước với. Mình có đưa lên rồi.

Lồng ghép đoạn Procedure giainen đó bạn

mấy bài kia ok mình sẽ up lời giải sau nhé ^^

[vansonqtqb]

bài tập pascal mong các bạn giúp đỡ

Cho dãy số gồm n (n < = 10000) số nguyên a1, a2, … , an (|ai| <= 10^9), tìm số nguyên X bất kì ñể S = |a1 — X| + |a2 — X| + … + |an — X| ñạt giá trị nhỏ nhất, có bao nhiêu giá trị nguyên khác nhau thoả mãn.

Ví dụ 1: dãy gồm 5 số 3, 1, 5, 4, 5, ta có duy nhất một giá trị X = 4 ñể S ñạt giá trị nhỏ nhất bằng 6.
Ví dụ 2: dãy gồm 6 số 3, 1, 7, 2, 5, 7 ta có ba giá trị nguyên của X là 3, 4, 5 ñể S ñạt giá trị nhỏ nhất bằng 13.

[TeTeTe]

Cho mình hỏi bài này với

cho số k và n (k<n)

Hãy xóa k phần tử để được số n là lớn nhất?

VD1:

n=58916

k=2

--> 916

VD2:

n=69257502

k=4

--> 9752

[dangkhuong]

Cho mình hỏi bài này: Nhập số nguyên dương $N$. Tìm số chữ số của $N$.

[TeTeTe]

Cho mình hỏi bài này: Nhập số nguyên dương $N$. Tìm số chữ số của $N$.

bạn đổi số sang xâu

str(n;s);

rồi tính 

[ghghgh]

Từ 5 chữ số 1, 2, 3, 4, 5 ta lập ra tất cả các con số có đúng 5 chữ số.Các con số này được xếp theo thứ tự từ nhỏ đến lớn, con số nhỏ nhất là 11111 được đánh mã số 1; số kế tiếp là 11112 được đánh mã số 2; số kế tiếp 11113 được đánh mã số 3; tiếp tục cho đến hết các con số. 

Yêu cầu: 
Cho trước một số n có đúng 5 chữ số lấy từ các chữ số 1, 2, 3, 4, 5. Tìm mã số của con số n.

[ghghgh]

cho tên của một số ngọn núi và độ cao của chúng. Hãy xác định ngọn núi có độ cao gần nhất với độ cao ưa thích tùy chọn. 

vd: cho: 

Everest 8850 

bahamas 10 

kamet 7756​ 

độ cao tùy chọn : 5 

Kết quả : bahamas