Skocz do zawartości

program w turbo pascalu nie zapisuje zmienionej nazwy pliku


Pliks

Polecane posty

Witam, od jakiegoś czasu chcę stworzyć program do generowania liczb losowych lotto w Turbo Pascalu, w taki sposób, żeby losował mi 6 liczb z 49, szeregował je od najmniejszej do największej i zapisywał do pliku w takim formacie nazwy np. : 2014-4-30_13;20;54. Najpierw udało mi się stworzyć program, który nie sortuje w kolejności od najmniejszej do największej, ale zapisuje do pliku pod odpowiednią nazwą:

 

 

program zadanie4;
uses dos,crt;
var a,i,j,p:byte;
z:char;
tab:array[1..6] of byte;
spr:boolean;
plik2:text;
opis: String;
KoniecPetli: boolean;
procedure losujzapisz; {poczatek  procedury losujzapisz}

begin
clrscr;
randomize;
Begin
 assign(plik2, 'd:\lot.txt');
 rewrite(plik2);
spr:=false;
for p:=1 to 1 do
begin
for i:=1 to 6 do
  begin
repeat
  	spr:=false;
  	a:=random(49)+1;
	for j:=1 to i do
	begin
     	if a=tab[j] then spr:=true;
	end;
 	until spr<>true;
tab[i]:=a;
  	write(plik2, tab[i],' ');

writeln(tab[i],' ');
end;
end;
writeln(plik2);
write('Liczby zapisane do pliku txt: ');
for i:=1 to 6 do
write(tab[i],' ');
close(plik2);
  readln;

End;

end; {koniec procedury losujzapisz}

procedure dopisz; {porczatek procedury dopisz}
var a,i,j: byte;
Begin
 assign(plik2, 'd:\lot.txt');
 append(plik2);
randomize;
spr:=false;

begin
for i:=1 to 6 do
  begin
repeat
  	spr:=false;
  	a:=random(49)+1;
	for j:=1 to i do
	begin
     	if a=tab[j] then spr:=true;
	end;
 	until spr<>true;
tab[i]:=a;
  	write(plik2, tab[i],' ');
writeln(tab[i],' ');
end;
end;
writeln(plik2);
write('Liczby zapisane do pliku txt: ');
for i:=1 to 6 do
write(tab[i],' ');
close(plik2);
end;{koniec procedury dopisz}
procedure wybierz; {poczatek procedury wybierz}
begin
z:= Readkey;
if z=#27 then
exit;
Writeln('Wtamy w programie Lotto.');
Write('Wcisnij enter aby wylosowac i dopisac lub escape aby zakonczyc.');
begin
readln(z);
repeat
z:=ReadKey;
if z=#27 then
exit;
read;
dopisz;
until z = #27;

end;
end; {koniec procedury wybierz}
procedure zapisdaty;
const
dni:array[0..6] of string=('Niedz','Pon','Wto','Sro','Czw','Pia','Sob');
var plik: text;
var godz, min, sek, sek100, rr, mm, dd, dztyg: word;
var g2,m2,s2, rr2, mm2, dd2: String;
begin
clrscr;
getdate(rr, mm, dd, dztyg);
Str(rr,rr2);
writeln(rr2);
Str(mm,mm2);
writeln(mm2);
Str(dd,dd2);
writeln(dd2);
gettime(godz, min, sek, sek100);
Str(godz,g2);
writeln(g2);
Str(min,m2);
writeln(m2);
Str(sek,s2);
writeln(s2);
rename(plik2, 'D:\' +rr2+'-'+mm2+'-'+dd2+'_'+g2+';' +m2+';' +s2+ '.txt' );

end;
{kod glowny}
begin
repeat
z:= Readkey;
if z=#27 then
exit;
losujzapisz;

wybierz;
until   z = #27;
zapisdaty;
clrscr;

end.
[/spoiler]

<code=delphi>
program zadanie4;
uses dos,crt;

var a,i,j,p:byte;
z:char;
tab:array[1..6] of byte;
spr:boolean;
plik2:text;
opis: String;
KoniecPetli: boolean;

procedure losujzapisz; {poczatek  procedury losujzapisz}

begin
clrscr;
randomize;
Begin
 assign(plik2, 'd:\lot.txt');
 rewrite(plik2);
spr:=false;

for p:=1 to 1 do
begin
for i:=1 to 6 do
  begin
repeat
  	spr:=false;
  	a:=random(49)+1;

	for j:=1 to i do
	begin
     	if a=tab[j] then spr:=true;
	end;
 	until spr<>true;
tab[i]:=a;
  	write(plik2, tab[i],' ');

writeln(tab[i],' ');
end;
end;

writeln(plik2);
write('Liczby zapisane do pliku txt: ');

for i:=1 to 6 do
write(tab[i],' ');
close(plik2);
  readln;

End;


end; {koniec procedury losujzapisz}


procedure dopisz; {porczatek procedury dopisz}

var a,i,j: byte;

Begin
 assign(plik2, 'd:\lot.txt');
 append(plik2);
randomize;
spr:=false;


begin
for i:=1 to 6 do
  begin
repeat
  	spr:=false;
  	a:=random(49)+1;

	for j:=1 to i do
	begin
     	if a=tab[j] then spr:=true;
	end;
 	until spr<>true;
tab[i]:=a;
  	write(plik2, tab[i],' ');
writeln(tab[i],' ');
end;
end;

writeln(plik2);
write('Liczby zapisane do pliku txt: ');

for i:=1 to 6 do
write(tab[i],' ');
close(plik2);

end;{koniec procedury dopisz}

procedure wybierz; {poczatek procedury wybierz}
begin
z:= Readkey;
if z=#27 then
exit;
Writeln('Wtamy w programie Lotto.');
Write('Wcisnij enter aby wylosowac i dopisac lub escape aby zakonczyc.');

begin
readln(z);

repeat
z:=ReadKey;
if z=#27 then
exit;

read;

dopisz;
until z = #27;  


end;
end; {koniec procedury wybierz}

procedure zapisdaty;
const
dni:array[0..6] of string=('Niedz','Pon','Wto','Sro','Czw','Pia','Sob');

var plik: text;
var godz, min, sek, sek100, rr, mm, dd, dztyg: word;
var g2,m2,s2, rr2, mm2, dd2: String;

begin
clrscr;

getdate(rr, mm, dd, dztyg);

Str(rr,rr2);
writeln(rr2);
Str(mm,mm2);
writeln(mm2);
Str(dd,dd2);
writeln(dd2);

gettime(godz, min, sek, sek100);

Str(godz,g2);
writeln(g2);
Str(min,m2);
writeln(m2);
Str(sek,s2);
writeln(s2);

rename(plik2, 'D:\' +rr2+'-'+mm2+'-'+dd2+'_'+g2+';' +m2+';' +s2+ '.txt' );


end;  
{kod glowny}
begin

repeat
z:= Readkey;
if z=#27 then
exit;

losujzapisz;


wybierz;
until   z = #27;
zapisdaty;
clrscr;


end.

 

 

po jakimś czasie stworzyłem program który zapisuje w kolejności rosnącej liczby do tablicy:

 

program sortowanie;
uses dos, crt;
const
 n = 6;

type
 tablica = array[1..n] of byte;

var plik: text;

procedure sortowanie_babelkowe(var tab : tablica);
var
  i, j, tmp: byte;

begin
 for i:=1 to n-1 do
for j := i+1 to n do
 	if tab[i] > tab[j] then
 	begin
   	tmp := tab[i];
   	tab[i] := tab[j];
   	tab[j] := tmp;
 	end;

end;




procedure wyswietl(tab : tablica);
var
  i : byte;
  plik: text;
  begin
assign (plik, 'D:\lotor.txt');
append(plik);
begin

 for i := 1 to n do
   	write(plik, tab[i],' ');
 writeln;


end;
 writeln(plik);
write('Liczby zapisane do pliku txt: ');
for i:=1 to n do
write(tab[i],',');
close(plik);
end;

procedure uzupelnij(var tab : tablica);
var
  a,i,j,p : integer;
  spr: boolean;
begin
randomize;
 	spr:=false;

for p:=1 to 1 do
begin
for i:=1 to n do
  begin
	repeat
  	spr:=false;
  	a:=random(49)+1;

    	for j:=1 to i do
    	begin
     	if a=tab[j] then spr:=true;
    	end;
 	until spr<>true;
	tab[i]:=a;
  	write( tab[i],' ');

end;

{procedure zapisz;
Begin
 assign(plik2, 'd:\lotos.txt');
 rewrite(plik2);
spr:=false;

for p:=1 to 1 do
begin
for i:=1 to n do
  begin
	repeat
  	spr:=false;
  	a:=random(49)+1;

    	for j:=1 to i do
    	begin
     	if a=tab[j] then spr:=true;
    	end;
 	until spr<>true;
	tab[i]:=a;
  	write(plik2, tab[i],' ');  }
  	end;
  	end;

procedure nowy;
var plik: text;
Begin
 assign(plik, 'D:\lotor.txt');
 rewrite(plik);
 close(plik);
 end;

procedure zapisdaty;
const
dni:array[0..6] of string=('Niedz','Pon','Wto','Sro','Czw','Pia','Sob');

var plik: text;
var godz, min, sek, sek100, rr, mm, dd, dztyg: word;
var g2,m2,s2, rr2, mm2, dd2: String;

begin
clrscr;

getdate(rr, mm, dd, dztyg);

Str(rr,rr2);
writeln(rr2);
Str(mm,mm2);
writeln(mm2);
Str(dd,dd2);
writeln(dd2);

gettime(godz, min, sek, sek100);

Str(godz,g2);
writeln(g2);
Str(min,m2);
writeln(m2);
Str(sek,s2);
writeln(s2);

rename(plik, 'D:\' +rr2+'-'+mm2+'-'+dd2+'_'+g2+';' +m2+';' +s2+ '.txt' );
end;

var
  tab : tablica;
  z: char;

begin
nowy;

repeat
z:= Readkey;
if z=#27 then
exit;
  uzupelnij(tab);
  {wyswietl(tab);}
  sortowanie_babelkowe(tab);
  wyswietl(tab);
  readln;
  until   z = #27;
  zapisdaty;
end.

 

 

ale nie działa z kolei zapis pliku pod nazwą w formacie daty i czasu utworzenia pliku, tak jakbym chciał...ma ktoś pomysł jak to dobrze zaimplementować do kodu? Z góry dzięki za pomoc. Pozdrawiam. :)

Link do komentarza
Udostępnij na innych stronach

  • 2 months later...

Masz:

 

Main_Unit

unit Main_Unit;
{$mode objfpc}{$H+}
interface
uses
 Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
 ComCtrls, Generate_Unit;
type
 { TForm1 }
 TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Label1: TLabel;
ProgressBar1: TProgressBar;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
 private
{ private declarations }
 public
{ public declarations }
 end;
var
 Form1: TForm1;
 Generate : TGenerate;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
var
 Max : LongWord;
 Err : Word;
begin
 Val(Edit1.Text, Max, Err);
 if Err <> 0 then
ShowMessage('Podaj Liczbę!')
 else
 begin
ProgressBar1.Position := 0;
ProgressBar1.Max := Max;
Generate := TGenerate.Create(false, Max);
 end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
 Randomize;
end;
end.

 

Generate_unit:

unit generate_unit;
{==============================================================================}
{$mode objfpc}{$H+}
{==============================================================================}
interface
uses
 {$ifdef unix}
 cthreads,
 cmem,
 {$endif}
 classes;
{==============================================================================}
type
 TDate = record
Day,
Month : Byte;
Year  : Word;
 end;
{------------------------------------------------------------------------------}
type
 TBet = record
Date   : TDate;
Number : array[0..5] of Byte;
 end;
{------------------------------------------------------------------------------}
type
 TGenerate = class(TThread)
 private
fMax  : LongWord;
fStep : LongWord;
procedure UpdateProgress;
procedure Disable;
procedure Enable;
 protected
procedure Execute; override;
 public
constructor Create(CreateSuspended : boolean; Max : LongInt);
 end;
{==============================================================================}
implementation
{==============================================================================}
uses Main_Unit;
{==============================================================================}
procedure Swap(var value1, value2 : Byte);
var
 tmp : Byte;
begin
 tmp := value1;
 value1 := value2;
 value2 := tmp;
end;
procedure BubbleSort(var Data : array of Byte);
var
 i, j : LongWord;
begin
 for i := Low(Data) to High(Data) - 1 do
for j := Low(Data) to High(Data) - 1 do
 	if Data[j] > Data[j+1] then
   	Swap(Data[j], Data[j+1]);
end;
function CheckUnique(Data : TBet) : Boolean;
begin
 result := false;
 if (Data.Number[0] <> Data.Number[1]) and
(Data.Number[0] <> Data.Number[2]) and
(Data.Number[0] <> Data.Number[3]) and
(Data.Number[0] <> Data.Number[4]) and
(Data.Number[0] <> Data.Number[5]) and
(Data.Number[1] <> Data.Number[2]) and
(Data.Number[1] <> Data.Number[3]) and
(Data.Number[1] <> Data.Number[4]) and
(Data.Number[1] <> Data.Number[5]) and
(Data.Number[2] <> Data.Number[3]) and
(Data.Number[2] <> Data.Number[4]) and
(Data.Number[2] <> Data.Number[5]) and
(Data.Number[3] <> Data.Number[4]) and
(Data.Number[3] <> Data.Number[5]) and
(Data.Number[4] <> Data.Number[5]) then
  	result := true;
end;
{==============================================================================}
constructor TGenerate.Create(CreateSuspended : boolean; Max : LongInt);
begin
 FreeOnTerminate := True;
 fMax := Max;
 fStep := Max div 100;
 inherited Create(CreateSuspended);
end;
{------------------------------------------------------------------------------}
procedure TGenerate.UpdateProgress;
begin
 Form1.ProgressBar1.Position := Form1.ProgressBar1.Position + fStep;
end;
{------------------------------------------------------------------------------}
procedure TGenerate.Disable;
begin
 Form1.Button1.Enabled := false;
end;
{------------------------------------------------------------------------------}
procedure TGenerate.Enable;
begin
 Form1.Button1.Enabled := true;
end;
{------------------------------------------------------------------------------}
procedure TGenerate.Execute;
var
 i 	: LongWord;
 j 	: Byte;
 Bet   : TBet;
 BFile : File of TBet;
begin
 Synchronize(@Disable);
 Bet.Date.Day := 0;
 Bet.Date.Month := 0;
 Bet.Date.Year := 0;
 AssignFile(BFile, 'random.nrs');
 Rewrite(BFile);
 for i := 0 to fMax - 1 do
 begin
repeat
 	for j := 0 to 5 do
   	Bet.Number[j] := Random(49) + 1;
until CheckUnique(Bet);
BubbleSort(Bet.Number);
Write(BFile, Bet);
if i mod fStep = 0 then Synchronize(@UpdateProgress);
 end;
 CloseFile(BFile);
 Synchronize(@Enable);
end;
{==============================================================================}
end.

Link do komentarza
Udostępnij na innych stronach

@babubabu: trochę odgrzałeś stary wątek, ale ok. I Ty z tym sprawdzanie unikatów tak na poważnie? Poza tym autorowi wątku zalecam przesiadkę na FPC, o ile jeszcze tutaj zajrzy. A i formatowanie kodu po ludzku by się przydało. I chyba w przypadku odpowiedzi parser rozwalił formatowanie. Ja pokażę jak najprościej można wylosować liczy z dużego lotka, które zrobiłem kiedyś w starym programie w D3.

 

procedure TMainForm.Losuj_Multi_Lotek;
const
 IleLiczb = 20;
 IloscKul = 80;
var
 Wyniki : array[1..IleLiczb] of Byte;
 I, J, Liczba : Byte;
 Losuj : Boolean;
 WynikiLosowania : string;
begin
 for I := 1 to IleLiczb do
 begin
Losuj := False;
while not Losuj do
begin
 	Losuj := True;
 	Liczba := Random(IloscKul) + 1;
 	if I > 1 then
   	for J := 1 to I - 1 do
     	if Wyniki[J] = Liczba then
       	Losuj := False;
end;
Wyniki[i] := Liczba;
 end;
 Sort_shell(Wyniki);
 for I := 1 to IleLiczb do
 begin
if I = 1 then
begin
 	WynikiLosowania := IntToStr(Wyniki[i]);
end
else
begin
 	WynikiLosowania := WynikiLosowania + #32 + IntToStr(Wyniki[i]);
end;
 end;
 TempSL.Add(WynikiLosowania);
end;

 

EDIT: tak, jednak to parser rozwala formatowanie, chyba chcąc stosować na już sformatowane kolejne.

Pozdrawiam: olesio

Link do komentarza
Udostępnij na innych stronach

  • 3 weeks later...

Zarchiwizowany

Ten temat jest archiwizowany i nie można dodawać nowych odpowiedzi.

×
×
  • Utwórz nowe...