Форум

Data.BG Форуми: Архив от програми: Pascal/Delphi/Visual C/Visual Basic - Data.BG Форуми

Прехвърляне към съдържание

  • (3 Страници) +
  • 1
  • 2
  • 3
  • Вие не можете да започнете нова тема
  • Вие не може да отговаряте на тази тема

Архив от програми: Pascal/Delphi/Visual C/Visual Basic

#1
Потребителят е неактивен   mcwolfmm 

  • Група: Потребители
  • Мнения: 9008
  • Регистриран: 16-November 04
  • Репутация: 2
В тази тема ще се събират програми на Pascal/Delphi/Visual C/Visual Basic
. Ако на някой му трябва нещо конкретно - да потърси.
Моля всеки, който направи по-често искана програма на един от езиците Delphi/Visual C/Visual Basic
, да я пейства тук като мнение, съобразно вида:

1. Условие
2. Код

В темата се дават само кодове и не се дискутира нищо. Ако има някакви предложения, свързани с темата, можете да ми ги напишете на лично съобщение!
0

#2
Потребителят е неактивен   mcwolfmm 

  • Група: Потребители
  • Мнения: 9008
  • Регистриран: 16-November 04
  • Репутация: 2
За к студента са зададени: факултетен номер, оценка по физика, оценка по математика и оценка по ПИИК. Да се състави алгоритъм за определяне на средния успех по физика на студентите, които са положили успешно изпита по математика.

program prog002;

uses crt;



type ratings = record

		physics : real;

		mathematics : real;

		piik : real;

end;



type student = record

		uid : string;

		rating : ratings;

end;



var	 students : array of student;

		K : integer;



function max_students() : integer;

begin

		write('Input max students (K): ');

		readln(max_students);

end;



procedure input_students();

var	 i : integer;

begin

		writeln('-------------------------');

		writeln(' input data for students');

		writeln('-------------------------');

		for i := 1 to K do

		begin

				writeln('student ', i);

				write('  uid: ');

				readln(students[i].uid);

				repeat

								write('  physics: ');

								readln(students[i].rating.physics);

				until((students[i].rating.physics >= 2.0) and (students[i].rating.physics <= 6.0));

				repeat

								write('  mathematics: ');

								readln(students[i].rating.mathematics);

				until((students[i].rating.mathematics >= 2.0) and (students[i].rating.mathematics <= 6.0));

				repeat

								write('  piik: ');

								readln(students[i].rating.piik);

				until((students[i].rating.piik >= 2.0) and (students[i].rating.piik <= 6.0));

		end;

		writeln('-------------------------');

end;



procedure average_rating();

var	 average : real;

		max : integer;

		i : integer;

begin

		max := 0;

		average := 0.0;

		for i := 1 to K do

				if (students[i].rating.mathematics >= 3.0) then

				begin

						max := max + 1;

						average := average + students[i].rating.physics;

				end;



		if(max > 0) then

		begin

				average := average / max;

				writeln('average rating: ', average:1:2);

		end;

end;



begin

		repeat

				K := max_students();

		until (K > 0);

		setlength(students, K);



		input_students();

		average_rating();

end.

за сефте пиша такова чудо та ако има забележки по кодът казвайте на ЛС (не са правени проверки за типът на въвежданите данни - ако трябва да се направят пак казвайте)

http://linux-index.org/
Цитат(abozhilov @ Mar 28 2009, 16:55 ) <{POST_SNAPBACK}>
Писнало ми е да чета. ИЕ има дупки в сигурноста. Това са хлапашки наизустени изрази. Дай да ги видим дупките в него и тогава ще ни се изяснят на всички много неща ....
0

#3
Потребителят е неактивен   mcwolfmm 

  • Група: Потребители
  • Мнения: 9008
  • Регистриран: 16-November 04
  • Репутация: 2
даден е масив C [15] съдържащ реални числа. Да се сортират елементите на масива в нарастващ ред и да се отпечата новополученият масив, както и сумата на отрицателните елементи.
(оригиналното условие е "даден е двумерен масив C [15] съдържащ реални числа." което нещо не ми се връзва)

program prog001;

uses crt;



var	 C : array [1..15] of real;



procedure input();

var	 i : integer;

		obj : string;

begin

		writeln('input array');

		for i := 1 to 15 do

		begin

				write('C[', i, '] = ');

				readln(C[i]);

		end;

end;



procedure sort();

var	 a, b : integer;

		obj : real;

begin

		for a := 1 to 15 do

				for b := 1 to (15 - a) do

				begin

						if C[b] > C[b + 1] then

						begin

								obj := C[b];

								C[b] := C[b + 1];

								C[b + 1] := obj;

						end;

				end;

end;



procedure display();

var	 i : integer;

begin

		writeln('new array:');

		for i := 1 to 15 do

		begin

				writeln('C[', i, '] = ', C[i]:8:2);

		end;

end;



function sum(): real;

var	 i : integer;

begin

		sum := 0.0;

		for i := 0 to 15 do

		begin

				if C[i] < 0.0 then

								sum := sum + C[i];

		end;

end;



begin

		input();

		sort();

		display();

		writeln('Sum: ', sum():8:2);

end.


за сефте пиша такова чудо та ако има забележки по кодът казвайте на ЛС (не са правени проверки за типът на въвежданите данни - ако трябва да се направят пак казвайте)

http://linux-index.org/
Цитат(abozhilov @ Mar 28 2009, 16:55 ) <{POST_SNAPBACK}>
Писнало ми е да чета. ИЕ има дупки в сигурноста. Това са хлапашки наизустени изрази. Дай да ги видим дупките в него и тогава ще ни се изяснят на всички много неща ....
0

#4
Потребителят е неактивен   orangert 

  • Група: Потребители
  • Мнения: 47
  • Регистриран: 06-November 06
  • Репутация: 0
Ще напиша "рецептите" за някой по-лесни програмки, ако някой модератор прецени, че програмките ми не са достойни за темата, моля да ми изтрие мнението.

Програмен Език - Visual Basic 6.0



1. Сумиране на 2 числа

Правим 1 CommandButton, 1 Label, 2 TextBox

За код пишем : (или просто цъкаме 2 пъти на командния бутон)

Private Sub Command1_Click()
Dim a As Single
Dim b As Single
Dim c As Single

a = CStr(Text1.Text)
b = CStr(Text2.Text)
Label1.Caption = c

Label1.Caption = a + b
End Sub


- За да ви изчислява трябва да напишете стойности във 2те текстови полета.
- Ако искате да умножавате/делите/степенувате/изваждате просто сменяте:

Label1.Caption = a - b за изваждане.
Label1.Caption = a / b за да ги разделите.
Label1.Caption = a * b за да ги умножите.
Label1.Caption = a ^ b за да степенувате.


- Ако искате това да стане с произволни числа правите следното:
a = CStr(Text1.Text)
b = CStr(Text2.Text)

Вместо горното пишете следното:
a=int(rnd*10)
b=int(rnd*10)

Като числата ще са напълно пройзволни но само от 0 до 10, ако искате числата да са от 1 до 10 пишете a=int(rnd*10+1)

2. Как да си направим програмка която да ни показва час и дата

Правим 2 CommandButton, 1 Label, 1 Timer

на Command1 пишем:
Private Sub Command1_Click()
Label1.Caption = Date
End Sub


на Command2 пишем:
Private Sub Command2_Click()
Label1.Caption = Date
End Sub


На таймера:
Private Sub Timer1_Timer()
If Label1.Caption = Date = False Then
Label1.Caption = Time
End If
End Sub


- Така като натиснете командата за дата ще се покаже датата, ако натиснете командата за часовника той сам ще отброява, примерно 12:12:12 -> 12:12:13 -> 12:12:14 и т.н.

Ето малко украшения към програмките

Как да си пуснем .wav

Правите нов модул (Project -> Add Module) и пишете

Declare Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal _
hwndCallback As Long) As Long


След това създавате 4 команд бутони (CommandButton)

Private Sub Command1_Click()
i = mciSendString("open c:OMG.wav type waveaudio alias voice1", 0&, 0, 0)
i = mciSendString("play voice1", 0&, 0, 0)
End Sub

Тук трябва да напишете директорията и името на файла.

Private Sub Command2_Click()
i = mciSendString("pause voice1", 0&, 0, 0)
End Sub

Private Sub Command3_Click()
i = mciSendString("resume voice1", 0&, 0, 0)
End Sub

Private Sub Command4_Click()
i = mciSendString("stop voice1", 0&, 0, 0)
End Sub


Първата команда служи за изсвирване на .wav
Втората за паузиране
При паузиране третата команда пуска отново .wav-чето, но откъдето сте го паузнали
С четвъртата спирате .wav (след това ако дадете Play ще се пусне отначало)

Как да променяме текст (цвят, болд, италик, фонт сайз)

Създаваме 1 Label и 3 CommandButton, напишете нещо във лейбъла,
след това пишете:

Private Sub Command1_Click()
Label1.FontSize = 24
End Sub

Private Sub Command2_Click()
Label1.ForeColor = &H80C0FF
End Sub

Private Sub Command3_Click()
Label1.FontBold = True
End Sub


За да направите текста нормален направете нова команда и напишете:

Private Sub Command4_Click()
Label1.FontSize = 8
Label1.FontBold = False
Label1.ForeColor = &H00000000&
End Sub

0

#5
Потребителят е неактивен   anatolk 

  • Група: Потребители
  • Мнения: 916
  • Регистриран: 02-April 05
  • Репутация: 1
  • Град:София

Цитат

Съставете рекурсивна функция , която проверява дали даден знаков низ е цяло число без знак.
Нека S е низ от десетични цифри. съставете рекурсивна подпрограма, която преобразува низа S в цяло число.



PROGRAM XXX;

VAR

  S:STRING;

  M:INTEGER;



FUNCTION CHECK(I:INTEGER):BOOLEAN;

VAR R:BOOLEAN;

BEGIN

  IF I>M THEN R:=TRUE

  ELSE

	IF S[I] IN ['0'..'9'] THEN

	  R:=CHECK(I+1)

	ELSE

	  R:=FALSE;

  CHECK:=R;

END;



FUNCTION CONVERT(I:INTEGER;D:WORD):WORD;

VAR R:INTEGER;

BEGIN

  IF I>M THEN R:=D

  ELSE

	R:=CONVERT(I+1,D*10+ORD(S[I])-48)
;

  CONVERT:=R;

END;



BEGIN

  READLN(S);

  M:=ORD(S[0]);

  IF CHECK(1) THEN

	BEGIN

	  WRITELN('RIGHT!');

	  WRITELN(CONVERT(1,0));

	END

  ELSE

	WRITELN('WRONG!');

END.

0

#6
Потребителят е неактивен   veryoldman 

  • Група: Потребители
  • Мнения: 62
  • Регистриран: 13-November 04
  • Репутация: 1

Цитат

Хей, дадоха ми задачка на езика Паскал, която си нямам хабер на идея как да реша.

Значи, единственото дето ни казаха е, че трябва да се реши с рекурсивна функция.

Условието е следното: Един робот може да прави крачки от по 1 и 2 метра. Да се напише програма, която да отпечатва всички начини, по които роботът може да измине N метра.



Program Robot;



uses Crt;



const

  N	   = 8;   {pyt, kojto trqbva da izmine spored zadanieto		}

  MinStep = 1;   {minimalna krachka 1 m							   }

  MaxStep = 2;   {maksimalna krachka 2 m, moje da se probva s poveche }





type THistory = Array [ 1..100 ] of Byte;



var

  History : THistory;



Procedure OneStep ( Road : Integer; Count : Byte; History : THistory );

var

  Step : Byte;

  I	: Byte;

begin

  For Step := MinStep to MaxStep do

  begin

	History [ Count + 1 ] := Step;

	If Road + Step < N then				   {pytqt ne e izminat - rekursiq }

	  OneStep ( Road + Step, Count + 1, History )

	else

	  If Road + Step = N then				 { pytqt e izminat - pechat	 }

	  begin

		For I := 1 to Count + 1 do

		  Write ( History [ I ] : 2 );

		Writeln;

	  end;

  end;

end;



begin

  ClrScr;

  OneStep ( 0, 0, History );

  Readln;

end.

0

#7
Потребителят е неактивен   veryoldman 

  • Група: Потребители
  • Мнения: 62
  • Регистриран: 13-November 04
  • Репутация: 1

Цитат

Моля ви няма ли кой да помогне
от тази задача зависи оценката ми. просто ще съм ви безкраино благодарен. Моля смилете се над мен

Напишете програма, която извежда възможните стойности на Х и У в зависимост от номера на квадранта, въвеждан с променливата
NumKvadrant : 1 - x>=0 ; y>=0 ; 2 - x<=0 ; y>=0 ; 3 - x<=0 ; y<=0 ; 4 - x>=0 ; y<=0. Решете задачата с Оператор " CASE ".



Program Kvadrant;

uses Crt;

var NumKvadrant : Byte;



begin

  ClrScr;

  Write ( 'Vyvedete nomer na kvadrant ==> ');

  Readln ( NumKvadrant );

  Case NumKvadrant of

	1 : Writeln ( 'X >= 0; Y >= 0' );

	2 : Writeln ( 'X <= 0; Y >= 0' );

	3 : Writeln ( 'X <= 0; Y <= 0' );

	4 : Writeln ( 'X >= 0; Y <= 0' );

  else

	Writeln ( 'Vyvedena e nepravilna stojnost' );

  end;

  Readln;

end.

0

#8
Потребителят е неактивен   hAcKeRboT 

  • Група: Потребители
  • Мнения: 1121
  • Регистриран: 21-November 05
  • Репутация: 0
  • Пол:Мъж
  • Град:beBoss™

Цитат

Да се напише програма, кята въвежда два знакови низа, определя дължината на всеки от тях с функцията lenght() и ги сравнява по дължина. Да се изведе на екран низът с по-малка дължина. Примерни низове: "symphony: и "patriot".


program nizove;





var s1,s2 : String;

begin

 Write('wywedete pyrvi niz: ');ReadLn(s1);

 Write('wywedete vtori niz: ');ReadLn(s2);

 if length(s1)>length(s2) then

  WriteLn('po malyk e vtoria niz: ',s2)

  else WriteLn('po malyk e pyrvia niz: ',s1);

  ReadLn;



end.

beBoss™ __ The KingPin!
0

#9
Потребителят е неактивен   hAcKeRboT 

  • Група: Потребители
  • Мнения: 1121
  • Регистриран: 21-November 05
  • Репутация: 0
  • Пол:Мъж
  • Град:beBoss™

Цитат

Напишете програма с която да се въвежда целочислена правоъгълна матрица от N реда и M стълба.
Да се пресметне:
S=x1y1+x2y2+...+xmym,
където xi (i= 1...m) е максималния елемент в и-тия стълб, yi - минималния елемент на и-тия стълб.
Да се изведат стойностите на S.


Const N = 10;

	  M = 10;



var i, j, min, max: byte;

	Matrix: array [1..N, 1..M] of byte;

	S: integer;



begin

  S:= 0;

  Randomize;



  for i:= 1 to N do begin

	for j:= 1 to M do begin

	  Matrix[i][j]:= Random(256);

	  Write(Matrix[i][j]:4);

	  //Write('[', i, '][', j, '] >> ');

	  //Read(Matrix[i][j]);

	end;

	WriteLn;

  end;



  for i:= 1 to N do begin

	min:= Matrix[i][1];

	max:= Matrix[i][1];

	for j:= 2 to M do begin

	  if min > Matrix[i][j] then

		min:= Matrix[i][j];

	  if max < Matrix[i][j] then

		max:= Matrix[i][j];

	end;

	S:= S + Min * Max;

  end;



  Writеln('Sum: ', S);

  ReadLn;

end.

beBoss™ __ The KingPin!
0

#10
Потребителят е неактивен   veryoldman 

  • Група: Потребители
  • Мнения: 62
  • Регистриран: 13-November 04
  • Репутация: 1

Цитат

- Дадена е географска карта и списък на двойки съседни държави. Да се напише програма за намиране на оцветяване на картата с минимален брой цветове, така че да няма двойка едноцветни съседни държави.
- Паскал
- nvm
- Turbo Pascal, Borland Pascal
- Еми учим за едни решетки, общо взето досега сме учили масиви, редици и всякакви такива неща, профил ми е информатиката, също ако може след програмката малко обяснение, кое защо се използва, защото ще ме питат после.

Ако не ви затруднява помогнете моля Crying or Very sad , напишете решението тук в темата или може да ми пратите решението в писмен вид или направо в pas файл на скайп hammerstrikebg, благодаря предварително за вашата помощ. Задачата е за Сряда сутринта.

Мерси на choo и на mcwolfmm за оказаната помощ, както естествено и на всичките други отзовали се.



Program MapColor;



uses Crt;



const MaxCountry = 10;

	  Colors	 : Array [ 1..4 ] of String =

					 ( '	Red', '  Green', '   Blue', ' Yellow' );



type TCountryColor = Array [ 1..MaxCountry ] of Byte;





var CountryNumber : Byte;

	BordersArray  : Array [ 1..MaxCountry, 1..MaxCountry ] of Boolean;

	CountryColor  : TCountryColor;

	Color		 : Byte;

	Counter	   : Word;



Procedure InputData;

var I, J : Byte;

	Ch   : Char;

begin

  ClrScr;

  Repeat

	Write ( 'Zadajte broj dyrjavi (2..', MaxCountry, ') ==> ');

	Readln ( CountryNumber );

  Until (( CountryNumber >= 2 ) and ( CountryNumber <= MaxCountry ));

  Writeln ( 'Zadajte granicheshtite dyrjavi' );

  For I := 1 to CountryNumber - 1 do

	For J := I + 1 to CountryNumber do

	  begin

		Write ( 'Dyrjava ', I, ' granichi li s dyrjava ', J, ' (Y/N) ' );

		Repeat Ch := ReadKey Until Ch in [ 'y', 'Y', 'n', 'N' ];

		Writeln ( Ch );

		If Ch in [ 'y', 'Y' ] then

		  BordersArray [ I, J ] := True

		else

		  BordersArray [ I, J ] := False;

	  end;

  Counter := 0;

end; (* InputData *)



Procedure PrintHeader;

var I : Byte;

begin

  Writeln;

  Write ( '  No  ' );

  For I := 1 to CountryNumber do

	Write ( I : 7 );

  Writeln;

  Write ( '=======' );

  For I := 1 to CountryNumber do

	Write ( '=======' );

  Writeln;

end; (* PrintHeader *)



Procedure Paint ( PaintCountryNumber : Byte; CountryColor : TCountryColor );

var Color : Byte;

	I	 : Byte;

	Flag  : Boolean;

begin

  Inc ( PaintCountryNumber );

  For Color := 1 to 4 do

	begin

	  CountryColor [ PaintCountryNumber ] := Color;

	  Flag := True;

	  For I := 1 to PaintCountryNumber - 1 do

		If BordersArray [ I, PaintCountryNumber ] and

		   ( CountryColor [ I ] = Color ) then

		  Flag := False;

	  If Flag then											{ OK }

		If PaintCountryNumber = CountryNumber then

		  begin

			Inc ( Counter );

			Write ( Counter : 5, ' ' );

			For I := 1 to CountryNumber do

			  Write ( Colors [ CountryColor [I]] );		   { Print }

			Writeln;

		  end

		else

		  If PaintCountryNumber < CountryNumber then

			Paint ( PaintCountryNumber, CountryColor );	   { Recursiq }

	end;

end; (* Paint *)



begin

  InputData;

  PrintHeader;

  Paint ( 0, CountryColor );

  Readln;

end.

0

#11
Потребителят е неактивен   hAcKeRboT 

  • Група: Потребители
  • Мнения: 1121
  • Регистриран: 21-November 05
  • Репутация: 0
  • Пол:Мъж
  • Град:beBoss™

Цитат

може ли някой да реши тази задача на Pascal - > имаме 233лева трябва да изтеглим от банкомата парите като има банкноти от 1,2,5,10,20 и 50 лева, трябва чрез "алчен алгоритъм" ( евристичен) да пресметне програмата как ще ни върне парите.

program getmoney; 

var p:integer; 

	e_lv,d_lv,p_lv,de_lv,dv_lv,pe_lv,s_lv:integer; 

begin 

write('Vavedi Kolko pari 6te iztegli6 --->'); read(p); 

repeat 

if p div 100<>0 then 

  begin 

	s_lv:=s_lv+p div 100; 

	p:=p-100*(p div 100); 

  end; 

if p div 50<>0 then 

  begin 

	pe_lv:=pe_lv+p div 50; 

	p:=p-50*(p div 50); 

  end; 

if p div 20<>0 then 

  begin 

	dv_lv:=dv_lv+p div 20; 

	p:=p-20*(p div 20); 

  end; 

if p div 10<>0 then 

  begin 

	de_lv:=de_lv+p div 10; 

	p:=p-10*(p div 10); 

  end; 

if p div 5<>0 then 

  begin 

	p_lv:=p_lv+p div 5; 

	p:=p-5*(p div 5); 

  end; 

if p div 2<>0 then 

  begin 

	d_lv:=d_lv+p div 2; 

	p:=p-2*(p div 2); 

  end; 

if p div 1<>0 then 

  begin 

	e_lv:=e_lv+p div 1; 

	p:=p-1*(p div 1); 

  end; 

until p=0; 

writeln(s_lv,' po 100 leva.'); 

writeln(pe_lv,' po 50 leva.'); 

writeln(dv_lv,' po 20 leva.'); 

writeln(de_lv,' po 10 leva.'); 

writeln(p_lv,' po 5 leva.'); 

writeln(d_lv,' po 2 leva.'); 

writeln(e_lv,' po 1 lev.'); 

end.


тема: http://forums.data.b...howtopic=230910
beBoss™ __ The KingPin!
0

#12
Потребителят е неактивен   hAcKeRboT 

  • Група: Потребители
  • Мнения: 1121
  • Регистриран: 21-November 05
  • Репутация: 0
  • Пол:Мъж
  • Град:beBoss™

Цитат

Момчета... тъй като беше доста отдавна като го учих това нещо съм позабравил... пък и аз се занимавах предимно със масиви, а не със стрингове

Трябва ми подсказка как да разбера във един стринг от 200 символа колко думи има, коло цифри има, колко малки и колко главни букви...

Благодаря предварително


Цитат

Благодаря... вече се оправих... ето и програмката която пишех... това е курсова задача по паскал... дано е полезна на някои


program zad1; 

uses Crt; 

 var text,chkchar:string; 

	 menu,x,y,m,n,broi:integer; 

	 izhod:boolean; 



procedure vuvejdane; 

  begin 

	writeln('------------------------------------------------
---'); 

	writeln; 

	repeat write('Vuvedete tekst do 200 simvola: ');readln(text); 

	until (Length(text) <= 200) and (Length(text) > 0); 

	writeln; 

	writeln('Teksta e vuveden. Natisnete Enter za da produljite!'); 

	writeln('------------------------------------------------
---'); 

	readln; 

  end; {vuvejdane} 



procedure izvejdane; 

  begin 

  writeln('------------------------------------------------
-----'); 

  writeln; 

  write('Vuvedeniat tekst e: ');writeln(text);writeln; 

  writeln('Natisnete Enter za da produljite!'); 

  writeln('------------------------------------------------
-----'); 

  readln; 

  end; {izvejdane} 



procedure StrStr(chkstr:string); 

  begin 

	y:=Length(text); 

	n:=Length(chkstr); 

	broi:=0; 

	for x:=1 to y do 

	 for m:=1 to n do 

	   begin 

		if (text[x]=chkstr[m]) then broi:=broi + 1; 

	   end; 

	if (chkstr=' ') then broi:=broi + 1; 

	write(broi); 

  end; {StrStr} 



procedure preb_words; 

  begin 

	 writeln('------------------------------------------------
-----'); 

	 writeln; 

	 write('Vuv vuvedeniqt tekst ima: ');StrStr(' ');writeln(' dumi'); 

	 writeln; 

	 writeln('Natisnete Enter za da produljite!'); 

	 writeln('------------------------------------------------
-----'); 

	 readln; 

  end; {preb_words} 



procedure preb_elements; 

  begin 

	 writeln('------------------------------------------------
-----'); 

	 writeln; 

	 writeln('Vuv vuvedeniqt tekst ima...'); 

	 StrStr('1234567890');writeln(' cifri'); 

	 StrStr('qwertyuiopasdfghjklzxcvbnm');writeln(' malki bukvi'); 

	 StrStr('QWERTYUIOPASDFGHJKLZXCVBNM');writeln(' golemi bukvi'); 

	 writeln; 

	 writeln('Natisnete Enter za da produljite!'); 

	 writeln('------------------------------------------------
-----'); 

	 readln; 

  end; {preb_elements} 



procedure exit; 

  begin 

	writeln; 

	writeln('------------------------------------------------
---------------------------'); 

	writeln('|																		 |'); 

	writeln('|							Dovijdane !!!								|'); 

	writeln('|																		 |'); 

	writeln('------------------------------------------------
---------------------------'); 

	izhod:=false; 

  end; {exit} 



procedure action(n:integer); 

  begin 

  izhod:=true; 

	if (n=1) then vuvejdane; 

	if (n=2) then izvejdane; 

	if (n=3) then preb_words; 

	if (n=4) then preb_elements; 

	if (n=5) then exit; 

  end; {action} 



procedure display_menu; 

  begin 

	writeln; 

	writeln('1. Vuvejdane na teksta'); 

	writeln('2. Izvejdane na teksta'); 

	writeln('3. Prebroqvane na dumite v teksta'); 

	writeln('4. Prebroqvane na cifrite, malkite i glavnite bukvi v teksta'); 

	writeln('5. Exit'); 

	writeln;writeln; 

	write('Vashiat izbor e: ');readln(menu); 

	action(menu); 

  end; {display_menu} 



procedure ime; 

  begin 

	writeln('------------------------------------------------
---------------------------'); 

	writeln('|																		 |'); 

	writeln('|							Kursova zadacha							  |'); 

	writeln('|																		 |'); 

	writeln('|						  na ***************							 |'); 

	writeln('|																		 |'); 

	writeln('|	Uslovie: Daden e tekst s ne poveche ot 200 simvola.				  |'); 

	writeln('|	Da se sustavi programa oformena kato menu sus slednite vuzmojnosti:  |'); 

	writeln('|	1. Vuvejdane na teksta											   |'); 

	writeln('|	2. Izvejdane na teksta											   |'); 

	writeln('|	3. Prebroqvane na dumite v teksta									|'); 

	writeln('|	4. Prebroqvane na cifrite, malkite i glavnite bukvi v teksta		 |'); 

	writeln('|	5. Exit															  |'); 

	writeln('|																		 |'); 

	writeln('------------------------------------------------
---------------------------'); 

	writeln;writeln; 

  end; {ime} 



begin {main program} 

ClrScr; 

ime; 

repeat display_menu; 

until (izhod=false); 

readln; 

end. {main program}


тема: http://forums.data.b...howtopic=371099
beBoss™ __ The KingPin!
0

#13
Потребителят е неактивен   anatolk 

  • Група: Потребители
  • Мнения: 916
  • Регистриран: 02-April 05
  • Репутация: 1
  • Град:София

SummerBeat каза:

KП:
-условие: Да се състави програма, която извежда таблицата за умножение от 1 до 10.
-език: Pascal
-ОС: Windows
10х предварително



PROGRAM XXX;

VAR

  I,J:INTEGER;

BEGIN

  FOR I:=1 TO 10 DO

	BEGIN

	  FOR J:=1 TO 10 DO

		WRITE(J,'*',I,'=',J*I,CHR(9));

	  WRITELN;

	END;

END.

0

#14
Потребителят е неактивен   stoqnov 

  • Група: Потребители
  • Мнения: 404
  • Регистриран: 07-September 03
  • Репутация: 4

crazyroler каза:

Съставете програма която има за вход страните на триъгълник а за изход периметъра и лицето на триъгълника.


procedure swap(var x, y: real);

var

  temp: real;

begin

  temp:= x;

  x:= y;

  y:= temp;

end;



procedure sort(var a, b, c: real);

begin

  if (a > c) then swap(a, c);

  if (b > c) then swap(a, c);

  if (a > b) then swap(a, b);

end;





function IsValid(a, b, c: real): Boolean;

begin

  Result:= (a > 0) and (b > 0) and (c > 0) and

		   ( (a + b) > c );

end;



var

  a, b, c: real;

  P, S: real;

BEGIN

  WriteLn('Input triangle sides: ');

  Read(a);

  Read(b);

  Read(c);



  sort(a, b, c);

  if isValid(a, b, c) then begin

	P:= a + b + c;



	WriteLn('Perimeter is: ':20, P:6:2, ' <dim>');

	P:= P / 2;

	S:= sqrt( p * (p - a) * (p - b) * (p - c) );

	WriteLn('Surface is: ':20, S:6:2, ' <dim>^2');

  end

  else WriteLn('Incorrect triangle sides.');



  ReadLn;

  ReadLn;

END.


http://forums.data.b...111819#11111819
0

#15
Потребителят е неактивен   anatolk 

  • Група: Потребители
  • Мнения: 916
  • Регистриран: 02-April 05
  • Репутация: 1
  • Град:София

hemaroid каза:

Моля за Помощ за една задача на Delphi. Тя е следната :

Да се състави програма на Делфи,с която по зададена стойност на символна променлива "ред" или "стълб" и параметър L да се отпечатва посочения ред или стълб на зададената матрица (размерът на матрицата е 18 x 5)

Благодаря Предварително !



PROGRAM XXX;

CONST

  N=4;

  M=7;

VAR

  A:ARRAY [1..N,1..M] OF INTEGER;

  C:CHAR;

  I,J,L:INTEGER;

BEGIN

  FOR I:=1 TO N DO

	BEGIN

	  WRITELN('ROW ',I);

	  FOR J:=1 TO M DO

		BEGIN

		  WRITE(' ',J,'. ');

		  READLN(A[I,J]);

		END;

	END;

  REPEAT

	WRITELN('ENTER "R" FOR ROW OR "C" FOR COLUMN');

	READLN(C);

  UNTIL (C='R') OR (C='C');

  REPEAT

	WRITELN('ENTER ROW/COL NUMBER');

	READLN(L);

  UNTIL ((C='R') AND (L<=N)) OR ((C='C') AND (L<=M));

  IF C='R' THEN FOR I:=1 TO M DO WRITE(A[L][I],' ')

		   ELSE FOR I:=1 TO N DO WRITE(A[I][L],' ');

END.

0

#16
Потребителят е неактивен   veryoldman 

  • Група: Потребители
  • Мнения: 62
  • Регистриран: 13-November 04
  • Репутация: 1

Цитат

Спешно ми трябва решението на следните задача

Да се напише програма която установява дали даден стринг е симетричен.

мерси предварително





Program Simetric;

var S : String;

	L : Byte;

	I : Byte;

	F : Boolean;

begin

  Write ( ' Vyvedete string ==> ' );

  ReadLn ( S );

  F := True;

  L := Length ( S );

  If L > 0 then

	begin

	  For I := 1 to L div 2 do

		If S[I] <> S[L-I+1] then

		  F := False;

	  If F then

		Writeln ( 'Stringyt e simetrichen.' )

	  else

		Writeln ( 'Stringyt ne e simetrichen.' )

	end

  else

	Write ( 'Stringyt e s nuleva dyljina.' );

  Readln;

end.

0

#17
Потребителят е неактивен   divaex 

  • Група: Потребители
  • Мнения: 6
  • Регистриран: 03-December 05
  • Репутация: 0
Много моля за решение на следната задача, защото идея си нямам как да я реша

Да се състави програма, която въвежда редица от естествени числа. Въвеждането продължава до въвеждането на числото 1. Програмата намира и извежда средно аритметично на числата.

Език: Паскал
Мерси предварително.
0

#18
Потребителят е неактивен   caka 

  • Група: Потребители
  • Мнения: 10
  • Регистриран: 26-September 04
  • Репутация: 0
ЗА К студенти са зададени: факултетен номер, оценка по физика, по математика и по пиик. Да се състави програма на С++ за определяне на средния успех по физика на студентите, които са положили успешно изпита по математика.


PLS HELP HELP HELP SPESHNO

OS: WINDOWS XP
visual C++ 6.0
:cry: :cry: :cry:
0

#19
Потребителят е неактивен   rosenchokz 

  • Група: Потребители
  • Мнения: 1
  • Регистриран: 08-November 08
  • Репутация: 0
ДАДЕНА Е РЕДИЦА от N НА БРОИ РЕАЛНИ ЧИСЛА.
ДА СЕ НАМЕРИ ПРОИЗВИДЕНИЕТО И БРОЯ НА НЕНУЛЕВИТЕ ЕЛЕМЕНТИ НА РЕДИЦАТА,СТОЯЩИ НА НЕЧЕТНО МЯСТО.ДА СЕ НАМЕРИ МИНИМАЛНИЯТ ЕЛЕМЕНТ НА РЕДИЦАТА.Всеки елемент на редицата по малък от числото mk дасе замени с произведението от стоиността на елемента,квадрата на неговият индекс и числото mk + сумата от числото 18 и стойността наминималният елемент на редицата. Да се отпечатат:входната редица;произведенито и броят на ненулевите елементи на редицата;минималният елемент,числото mk ,получената след замяната редица. Език:паскал!
0

#20
Потребителят е неактивен   anatolk 

  • Група: Потребители
  • Мнения: 916
  • Регистриран: 02-April 05
  • Репутация: 1
  • Град:София

ironmankb каза:

За К студента са зададени : факултетен номер, оценка по физика, оценка по математика и оценка по ПИИК. Да се състави алгоритъм за определяне броя на студентите с по една двойка.

някои ако може да я направи за паксал много ще съм му благодарен също така ми трябва и блок схема. МОЛЯ ВИ ПОМОГНЕТЕ !



PROGRAM XXX;



CONST

  MAXS=20;						{ MAX STUDENTS }

  NR=3;						   { NUM RATES }

  FLEN=5;						 { FNUM LENGTH }

  RLOW=2.00;					  { LOWEST RATE }

  RLN=1;						  { NUMBER OF LOWEST RATES }

  FDAT='STUD.DAT';				{ FILE NAME }



TYPE

  STUD=RECORD

	F:STRING[FLEN];			   { FAC NUMBER }

	R:ARRAY[1..NR] OF REAL;	   { RATES }

  END;



VAR

  F:TEXT;						 { FILE }

  ST:ARRAY [1..MAXS] OF STUD;	 { STUDENTS }

  S:STRING[FLEN+1];			   { TEMP }

  R:REAL;						 { TEMP }

  C:CHAR;						 { TEMP }

  L,K:INTEGER;					{ LINE,ROW }



  { PRINT ERROR }



PROCEDURE ERROR(S:STRING);

BEGIN

  WRITE(S,' AT LINE ',L,' ROW ',K);

  HALT;

END;



  { READ RATE }



PROCEDURE READRT;

VAR I,M:INTEGER;

BEGIN

  REPEAT READ(F,C) UNTIL C<>' ';

  IF C IN ['2'..'6'] THEN R:=ORD(C)-48 ELSE ERROR('BAD RATE');

  READ(F,C);

  IF C<>'.' THEN ERROR('BAD RATE');

  I:=1;M:=10;

  REPEAT

	READ(F,C);

	IF I<=2 THEN

	  BEGIN

		IF NOT (C IN ['0'..'9']) THEN ERROR('BAD RATE');

		R:=R+((ORD(C)-48)/M);

		M:=M*10;

		I:=I+1;

	  END;

  UNTIL (C=',') OR (C=CHR(10));

END;



  { READ FNUM }



PROCEDURE READFN;

VAR I:INTEGER;

BEGIN

  REPEAT READ(F,C) UNTIL C<>' ';

  I:=1;

  S[0]:=CHR(FLEN);

  WHILE C<>',' DO

	BEGIN

	  IF I<=FLEN THEN

		BEGIN

		  IF (C<'0') OR (C>'9') THEN ERROR('BAD FACNUM');

		  S[I]:=C;

		  I:=I+1;

		END;

	  READ(F,C);

	END;

END;



  { READ LINE }



PROCEDURE READLN;

VAR I:INTEGER;

BEGIN

  K:=1;

  REPEAT

	READFN;

	ST[L].F:=S;

	FOR I:=1 TO NR DO

	  BEGIN

		K:=K+1;

		READRT;

		ST[L].R[I]:=R;

	END;

  UNTIL C=CHR(10);

END;



  { PARSE FILE }



PROCEDURE PARSE;

BEGIN

  L:=1;

  REPEAT

	READLN;

	L:=L+1;

  UNTIL EOF(F);

END;



  { NUMBER OF FAILED STUDENTS }



FUNCTION HOWMANY:INTEGER;

VAR I,J,D,M:INTEGER;

BEGIN

  M:=0;

  FOR I:=1 TO L DO

	BEGIN D:=0;

	  FOR J:=1 TO NR DO

		IF ST[I].R[J]=RLOW THEN D:=D+1;

	  IF D=RLN THEN M:=M+1;

	END;

  HOWMANY:=M;

END;



  { MAIN }



BEGIN

  ASSIGN(F,FDAT);

  RESET(F);

  PARSE;

  CLOSE(F);

  WRITELN('S EDNA DVOIKA V GRUPATA: ',HOWMANY);

END.


Файлът с данните ти е в такъв формат:


10001 , 5.25 , 4.50 , 6.00

10002 , 5.85 , 3.25 , 4.75

10003 , 2.00 , 2.00 , 4.00

10004 , 3.00 , 2.00 , 3.00


където 1-ва колона ти е факултетния номер, а следващите 3 - оценките. Интервалите не са задължителни.
0

Споделете тази тема чрез:


  • (3 Страници) +
  • 1
  • 2
  • 3
  • Вие не можете да започнете нова тема
  • Вие не може да отговаряте на тази тема

1 потребители четат тази тема
0 регистрирани потребители, 1 гости и 0 анонимни потребители


Data.BG e форум за дискусии. Data.BG не носи отговорност за съдържанието и достоверността на публикуваните в дискусиите материали.

Никаква част от съдържанието на тази страница не може да бъде репродуцирана, записвана или предавана под каквато и да е форма или по какъвто и да е повод без писменото съгласие на Data.BG.

Close  Member Login