procedure change; var p,n:integer; previous,temp,next:list; begin n:=1; write('入れ替える位置を指定しなさい'); readln(p); current:=init; while current^.pointer <> nil do begin previous:=current; current:=current^.pointer; next:=current^.pointer; n:=n+1; if n=p then begin temp:=next^.pointer; previous^.pointer:=next; next^.pointer:=current; current^.pointer:=temp end; end; current:=init; while current^.pointer <> nil do begin write(current^.name,' ',current^.id,' '); current:=current^.pointer end; writeln end;
手続きを仕えってなら、こんなのはどうだ? Program Enjoy2chList; type plist = ^listitem; listitem = record data : string; next : plist end; var top, tail : plist; s : string; toend : boolean;
procedure addtolist(s : string); var p : plist; begin new(p); p^.data := s; p^.next := top^.next; top^.next := p end;
procedure exchange(pprev : plist); var pnext, ptemp : plist; begin if pprev<>nil then begin ptemp := pprev^.next; pnext := ptemp^.next; if pnext <> tail then begin ptemp^.next := pnext^.next; pnext^.next := ptemp; pprev^.next := pnext end else writeln('The item is at the tail of the list...') end end;
function findprev(key : string) : plist; var p : plist; begin tail^.data := key; p := top; while p^.next^.data <> key do p := p^.next; if p^.next <> tail then findprev := p else begin writeln(key, ' is not found ... Orz'); findprev := nil end end;
procedure disp; var p : plist; i : integer; begin p := top^.next; i := 0; while p<>tail do begin i := succ(i); writeln(i, ' ', p^.data); p := p^.next end end;
begin initlist; toend := false; repeat write('ENTER Any word to add or NULL to quit: '); readln(s); if s='' then toend := true else begin addtolist(s); disp end until toend; toend := false; repeat write('ENTER Any word to exchange or NULL to quit: '); readln(s); if s='' then toend := true else begin exchange(findprev(s)); disp end until toend; disposelist end.
まず、基本的な型宣言から var SPACE:array[1..maxlegth] of record element:elementtype; next:integer end
elementtypeって何？って感じです・・・。
次にセルを移動するmove関数 function move(var p,q:integer):boolean; var temp:integer; begin if p=0 then begin writeln('セルがない'); return(false) {retuenってなに？} end else begin temp:=q; q:=p; p:=SPACE[q].next:=temp; retuen(true) end end;
手続きINSERT procedure INSERT(x:elementtype;p:position;var L:LIST); begin if p=0 then begin{最初の位置に挿入} if move(available,L) then SPACE[L].element:=x end else{最初以外の位置に挿入} if move(available,SPACE[p].next)then {xのセルをSPACE[p].nextがさしている} SPACE[SPACE[p].next].element:=x end;{INSERT}
次に手続きDELETE procedure DELETE(p:position;var L:LIST); begin if p=0 then move(L,available) else move(SPACE[p].next,available) end;{DELETE}
最後に手続きinitialize procedure initialize; var i:integer; begin for i:=mazsize-1 downto 1 do SPACE[i].next:=i+1; available:=1; SPACE[maxsize].next:=0 end;{inisialize}
Program Toi2; type time = record day, hour, minute, second : integer end; var t1, t2, t3 : time;
procedure add60(a, b : integer; var c : integer; var carry : boolean); (* a + b must be less than 120 *) begin c := a + b; carry := (c >= 60); c := c mod 60 end;
begin (* データを読む1 -> t1 *)(* データを読む2 -> t2 *) add60(t1.second, t2.second, t3.second, cry); add60(t1.minute, t2.minute + ord(cry), t3.minute, cry); with t3 do begin hour := t1.hour + t2.hour + ord(cry); if hour >= 24 then begin day := 1; hour := hour -24 end else day := 0 end; (* 表示 *) end.
var i,n: integer; f,z: array [0..1000] of integer;
function fibonacci(n : integer):integer;
begin case n of 3..1000 : fibonacci:=fibonacci(n-1)+fibonacci(n-2); 1,2 : fibonacci:=1; 0 : fibonacci:=0 end; { case } end;
begin write('n='); readln(n); for i:=0 to n do begin f[i]:=fibonacci(i); z[i]:=(f[n-1]-f[n-2])div(f[n]-f[n-1]); writeln('f(',i:2,')=',f[i]:1,', '); writeln(); writeln('z(',i:2,')=',z[i]:1,', '); end; end.
というのを作ったのですが、コンパイルはできるのに値を入力しても答えが出力されませんorz
194 名前：188 [2006/04/12(水) 15:20:31 ]
program Toi3(input,output);
var i,n: integer; f,z: array [0..1000] of integer;
function fibonacci(n : integer):integer;
begin case n of 3..1000 : fibonacci:=fibonacci(n-1)+fibonacci(n-2); 1,2 : fibonacci:=1; 0 : fibonacci:=0 end; { case } end;
begin write('n='); readln(n); for i:=0 to n do begin f[i]:=fibonacci(i); z[i]:=(f[n-1]-f[n-2])div(f[n]-f[n-1]); writeln('f(',i:2,')=',f[i]:1,', '); writeln(); writeln('z(',i:2,')=',z[i]:1,', '); end; end.
if n >= 2 then begin ●; end else begin case n of 0 : ■; 1 : ▲; end; じゃダメなのか？
211 名前：188 [2006/04/14(金) 17:06:52 ]
フィボナッチを以下のように書き換えたのですが、確かに走るし100項でもすぐ出るんですが、マイナスの値がでてくるんです。なぜでしょうか？ program kadai14_2(input,output); var m,k : integer; function fibonacci(n : integer):integer; function fib(i,old,new : integer):integer; begin if i=n then fib:=new else fib:=fib(i+1,new,old+new) end; { fib }
begin if n<=1 then fibonacci:=n else fibonacci:=fib(1,0,1) end; { fibonacci }
begin writeln('数列の長さを入力してください'); readln(m); for k:=1 to m do begin write(fibonacci(k):1); write(',') end; writeln; end.
文字列＋整数型の加算の例 function AddN(s:string;N:Integer):string; var i,M:Integer; var r:string; procedure afunc; begin M:=((N mod 10)+10) mod 10; r:=Char( ord('0') +M)+r; N:=N-M; N:=N div 10; end; begin r:=''; for i := length(s) downto 1 do begin N:=N+StrToInt(s[i]); afunc; end; while N<>0 do begin M:=((N mod 10)+10) mod 10; afunc; end; Result:=r; end; 文字列同士は、ループが３つ必要
function AddAB(a,b:string):string; var i,j,N,M:Integer; var r:string; procedure afunc; begin M:=((N mod 10)+10) mod 10; r:=Char( ord('0') +M)+r; N:=N-M; N:=N div 10; end; begin r:=''; j:=length(b); N:=0; for i := length(a) downto 1 do begin N:=N+StrToInt(a[i]); if j>=1 then N:=N+StrToInt(b[j]); afunc; dec(j); end; for i := j downto 1 do begin N:=N+StrToInt(b[i]); afunc; end; while N<>0 do begin M:=((N mod 10)+10) mod 10; afunc; end; Result:=r; end;
function fibonacci(n : string):string; function fib(i,old,new : string):string; begin if i=n then fib:=new else fib:=fib(AddN(i,1),new,AddAB(old,new)) end; { fib }
begin if (length(n)<2) and(StrToInt(n)<=1) then fibonacci:=n else fibonacci:=fib('1','0','1') end; { fibonacci }
begin for k := 1 to 100 do writeLn(k:5,':', fibonacci(IntToStr(k))) ;
program kadai21(input , output , opfile); type Kojindate = record name : packed array [1..10] of char; tel : packed array [1..15] of char; end; var opfile : file of Kojindate; a : Kojindate; begin repeat rewrite( opfile , 'intdate' ); writeln('名前：'); readln( a.name ); writeln('電話番号'); readln( a.tel); write(opfile , a); until a.name = 'end'; reset ( opfile , 'intdate' ); while not eof(opfile) do begin repeat read( opfile , a ); writeln( '名前：',a.name , '電話番号：' , a.tel); until a.name = 'end' end end.
>>227 procedure search; var name : packed array [1..10] of char; c : boolean; begin Readln(name); while name <> 'end' do begin Reset(opfile); c := true; while not eof(opfile) do begin Read(opfile, a); if a.name = name then begin Writeln(a.tel); c := false; end; end; Close(opfile); if c then Writeln('該当者なし'); Readln(name); end; end; { search }
>>228 program test1(input); var o,e : file of integer; i:integer;begin Assign(o,'oddsequence');Rewrite(o); Read(i);while i <> 0 do begin Write(o,i); Read(i); end; Assign(e,'evensequence');Rewrite(e); Read(i);while i <> 0 do begin Write(e,i); Read(i); end; Close(o);Close(e);end.
program test2(output); var o,e,s : file of integer; i,j:integer;begin Assign(o,'oddsequence');Reset(o); Assign(e,'evensequence');Reset(e); Assign(s,'sequence');Rewrite(s);i := 0; j := 0; while not (eof(o) and eof(e) and (i = 0) and (j = 0)) do begin if not eof(o) and (i = 0) then Read(o,i); if not eof(e) and (j = 0) then Read(e,j); if (i <> 0) and (i < j) then begin Write(s,i); i := 0; end else if j <> 0 then begin Write(s,j); j := 0; end; end; Reset(s); while not eof(s) do begin Read(s,i);Write(i);Write(' '); end;Close(o);Close(e);Close(s);end.
フィボナッチ数列の項は、その直前の連続する二つの項の和である。 f( n ) = f( n - 1 ) + f( n - 2 ) 但し、 f(0) = 0, f(1) = 1 である。 フィボナッチ数列の連続する項の差の比 z = { f( n - 1 ) - f( n - 2 ) }/ { f( n ) - f( n - 1 ) } は、 n が大きくなれば、ある値に収束する。この値の近似値を求める プログラムを書き、その値を示せ。この値は黄金分割比と呼ばれる。 フィボナッチ数列は関数 fibonacci を作って求め、項は配列に表せ。まず 30 項まで求め、黄金分割比の値が収束していく様子を出力して 確かめよ。収束判定のために定数 dif = 1.0 e -6 を宣言し、 連続する z の差の絶対値が dif 以下になったとき、 収束したとして計算を終了するプログラムを作り、プログラムとその 計算結果を提出せよ
235 名前：デフォルトの名無しさん [2006/04/24(月) 05:34:47 ]
コンパイルはできるんだけど、何かがおかしいです。 すみませんがわかる方教えてくれませんか？
program pe1_2(input,output); const dif = 1.0e-6; var i,m, g : integer; f, z,q : array [0..500] of real; function fibonacci(n: integer):integer; begin if (n >=0) and (n <=1) then fibonacci:=n else fibonacci:=fibonacci(n-1)+fibonacci(n-2); end; { fibonacci } begin f[i]:=fibonacci(i); writeln('30項まで求めます '); for i :=1 to 30 do begin writeln('f(',i:2,')=',f[i]:1); end; write('m='); readln(m); for i:= 3 to m do repeat z[i]:=(f[i-1]-f[i-2])/(f[i]-f[i-1]); until dif >= z[i]-z[i-1]; writeln(z[i]); {writeln('z(',i:3,')=',z[i]:1,','); } end.
236 名前：デフォルトの名無しさん [2006/04/24(月) 06:10:31 ]
こんな感じじゃないのか？
program pe1_2(input,output); const dif = 1.0e-6; var i : integer; f,z : array [1..30] of real;
function fibonacci(n: integer):integer; begin if (n >=0) and (n <=1) then fibonacci:=n else fibonacci:=fibonacci(n-1)+fibonacci(n-2); end; { fibonacci }
begin writeln('30項まで求めます'); for i :=1 to 30 do begin f[i]:=fibonacci(i); writeln('f(',i:2,')=',f[i]:1); end;
for i:= 3 to 30 do begin z[i]:=(f[i-1]-f[i-2])/(f[i]-f[i-1]); writeln('z(',i:2,')=',z[i]); if (i > 3) and (dif >= abs(z[i]-z[i-1])) then break; end; end.
function fibonacci(n: real):real; begin if (n >=0) and (n <=1) then fibonacci:=1 else fibonacci:=fibonacci(n-1)+fibonacci(n-2); end; { fibonacci }
begin writeln('30項まで求めます'); for i :=1 to 30 do begin f[i]:=fibonacci(i); writeln('f(',i:2,')=',f[i]:10:0); end;
for i:= 3 to 30 do begin z[i]:=(f[i-1]-f[i-2])/(f[i]-f[i-1]); writeln('z(',i:2,')=',z[i]); if (i > 3) and (dif >= abs(z[i]-z[i-1])) then break; end; end.
