Важные Чтиво - Программирование На Pascal

[Sascha]

01. Программа Hello Word на Pascal

Program Hello_World;
begin
Writeln('Здраствуй Мир!');
Readln;
End.


02. Является ли число степенью двойки? - Pascal

Function is_power_2(x: Word): Boolean;
Begin
is_power_2 := (x > 0) and ((x and Pred(x)) = 0)
End;
var N:integer;
begin
Writeln('Введите число');
Readln(N);
if is_power_2(N)=TRUE then
Writeln('Число является степенью 2')
Else
Writeln('Не я вляется степенью 2');
Readln;
End.

-----------------------------------------------------------------
Function is_power_2(x: Word): Boolean;
Begin
is_power_2 := ((x and Pred(x)) = 0)
End;



03. Является ли число степенью I(любого числа)? - Pascal

var i,r:integer;
begin
Writeln('Введите число которое мы будем проверять на степень');
readln(r);
Writeln('На какую степень мы будем проверять?');
readln(i);
r:=abs(r);
while (r>=i) do
begin
if r=i then write(', является степенью ',i);
r := r div i;
end;
readln;
end.



04. Возведение в степень(положительные числа) - Pascal

Function Step(X,Y:real):real;
begin
Step:=Exp(ln(X)*Y);
End;
var x,y:real;
Begin
Writeln('Введите X и Y, X - Число которое надо возвести. Y - Степень.');
Readln(x);
Readln(y);
Writeln(Step(x,y));
Readln;
End.



05. Как возвести (-1) в степень N? - Pascal

Способ xa = Exp(a*Ln(x)) не подходит, т.к. для вычисления по этой формуле основание степени x должно быть положительным. Используем функцию:
Function minusOnePower(n: Integer): Integer;
Begin
minusOnePower := (1 - 2*Byte(Odd(n)));
End;



06. Вычитание двоичных чисел с использованием строк. - Pascal

function IntToBin(bin: longint): string;
var
bin_s: string;
begin
bin_s := '';
if bin = 0 then bin_s := '0'
else
while bin <> 0 do begin
if (bin and 1) = 1 then
bin_s := '1' + bin_s
else bin_s := '0' + bin_s;

bin := bin shr 1;
end;
IntToBin := bin_s
end;

function BinToInt(bin_s: string): longint;
var
bin, mult: longint;
i: integer;
begin
mult := 1; bin := 0;
for i := length(bin_s) downto 1 do
begin
if bin_s = '1' then bin := bin + mult;
mult := mult shl 1;
end;
BinToInt := bin
end;

var
BO, BT: string;

begin
write('Введите первое число : ');
readln(BO);
write('Введите второе число : ');
readln(BT);

writeln( 'Результат: ', IntToBin(BinToInt(BO)-BinToInt(BT)) )
end.



07. Перемножение двоичных чисел с использованием строк. - Pascal

{ Дополнительная функция, реализующая сложение двоичных чисел }
function add_binary(s1, s2: string): string;
var
T, z: string;
i: byte; shift: char;
begin
{ Для удобства будем считать первой строкой более длинную строку... }
if length(s1) < length(s2) then
{ Если же длиннее вторая строка, то меняем ее местами с первой }
begin T := s1; s1 := s2; s2 := T end;

T := '';
{ Дополняем короткую строку спереди нулями (если необходимо) }
for i := 1 to length(s1) - length(s2) do
s2 := '0' + s2;

{ переменная содержит "сдвиг" }
shift := '0';

{ проходим по всей строке (с конца в начало) и выполняем "побитное"
сложение строк с учетом сдвига }
for i := length(s1) downto 1 do
begin
{ z содержит тройку значений: (1, 2) - очередные "биты" строк
(3) - сдвиг }
z := s1 + s2 + shift;

{ проверяем все возможные комбинации "троек" и добавляем
к результирующей строке спереди соответствующий "бит"
(не забываем учитывать и изменять значение сдвига) }
if z = '000' then T := '0' + T;

if (z = '001') or (z = '010') or (z = '100') then
begin
T := '1' + T;
shift := '0'
end;

if (z = '101') or (z = '011') or (z = '110') then
begin
T := '0' + T;
shift := '1'
end;

if z = '111' then
begin
T := '1' + T;
shift := '1'
end;
end;

{ если есть необходимость, добавляем "сдвиговый" "бит" к строке }
if (shift = '1') then
T := '1' + T;

{ и возвращаем результат - двоичную сумму строк s1 и s2 }
add_binary := T
end;

const
n = 4;

{ константы для проверки работоспособности...
s1: string = '0111';
s2: string = '0010';
}
result: string = '0';

var
i, j: byte;
s1, s2, toadd: string;
begin
Write( 'Введите первое число: ' ); ReadLn(s1);
Write( 'Введите второе число: ' ); ReadLn(s2);

for i := 1 to n do
begin
{ 1-я строка содержит в последнем бите 1 }
if s2[ length(s2) ] = '1' then
begin
{ для промежуточного результата нам необходимо значение
второй строки... }
toadd := s1;

{ ... сдвинутое на количество бит, соответствующее позиции
единицы в 1-ой строке }
for j := 1 to pred(i) do
toadd := toadd + '0';

{ добавляем промежуточный результат к окончательному }
result := add_binary(result, toadd)
end;

{ по окончании обработки очередного бита 1-ой строки удаляем его... }
delete(s2, length(s2), 1)
end;

{ удаляем лидирующие (незначащие) нули из результата }
while result[1] = '0' do
delete(result, 1, 1);

{ печатаем результат }
writeln( 'result = ', result );
readln;
end.



08. Как вычислить арксинус аргумента?. - Pascal

Function ArcSin(x: Real): Real;
Begin
If Abs(x) = 1 Then ArcSin := 0
Else ArcSin := ArcTan( x / Sqrt(1 - Sqr(x)) )
End;



09.Как вычислить арккосинус аргумента?. - Pascal

Function ArcCos(x: Real): Real;
Begin
If x = 0 Then ArcCos := Pi/2
Else ArcCos := ArcTan(Sqrt(1 - Sqr(x)) / x) + Pi * Byte(x < 0)
End;



10.Как проверить простое ли число?. - Pascal

function isPrime(X: word): boolean;
var
i: integer;
Begin
isPrime:=false;
for i:=2 to sqrt(x) do
if x mod i = 0 then Exit;
isPrime:=true;
End;



11.Как скопировать файл?. - Pascal

A:> Читать его в буфер через BlockWrite, а затем записывать через
BlockWrite. Hапример:

procedure FileCopy(fileFrom, fileTo: string);
var
f1,f2:file;
p:pointer;
rb:word;
Begin
Assign(f1,fs); FileMode:=0; Reset(f1,1);
Assign(f2,fd); ReWrite(f1,1);
GetMem(p,32768);
If p=nil then begin WriteLn('Not enough memory !'); Halt; end;
Repeat
BlockRead(f1,p^,32768,rb);
BlockWrite(f2,p^,rb);
Until rb<>32768;
FreeMem(p,32768);
Close(f2); Close(f1);
End;



12.Как Включить/Выключить Курсор. - Pascal

Две процедуры для отключения и восстановления курсора на экране.

Q:> А как убрать курсор в текстовом режиме?
A:
procedure CursorOff; assembler;
asm
mov ah,1
mov cx,2020h {Убрать мерцание за пределы знакоместа}
int 10h
end;

Q:> А как его потом обратно включить?
A:
procedure CursorOn; assembler;
asm
mov ah,1
mov cx,0607h {Установить мерцание 6й и 7й строк}
int 10h
end;



13. Как найти файлы на ВСЕХ дисках. - Pascal

Uses DOS,CRT;
var
Stop:boolean;
Procedure FileFind(Dir,FindName : PathStr);
Procedure SearchDir(Dir : PathStr);
Var
SRec : SearchRec;
i:integer;
begin
if Stop then Exit;
if Dir[Length(Dir)] <> '\' then Dir := Dir+'\';
ClrEol;
Write(Dir,#13);
if KeyPressed then Stop := ReadKey = #27;

FindFirst(Dir + FindName, AnyFile, SRec);
While DosError = 0 do
begin
With SRec do
if Attr and (VolumeID + Directory) = 0 then
WriteLn(Dir + Name);
FindNext(SRec);
end;

FindFirst(Dir+'*.*', $17, SRec);
While DosError = 0 do
begin
With SRec do
if (Attr and Directory <> 0) and (Name[1] <> '.') then
SearchDir(Dir+Name);
FindNext(SRec);
end;
end;
begin
Stop:=False;
SearchDir(Dir);
end;

function GetCurDrive: Char;
var
r: Registers;
begin
r.ah := $19;
MSDOS(r);
GetCurDrive := Char(r.al + $41);
end;

procedure SetCurDrive(Drive: Char);
var
r: Registers;
begin
r.ah := $0E;
r.dl := Byte(Drive) - $41;
MSDOS(r);
end;

procedure WalkDrives(Name : String);
var
SaveDrive, Drive, Ch: Char;
begin
if Pos('.', Name) = 0 then Name := Name + '*.*';
SaveDrive := GetCurDrive;
for Ch := 'C' to 'Z' do
begin
SetCurDrive(Ch);
Drive := GetCurDrive;
if Drive = Ch then
begin
FileFind(Drive + ':\',Name);
if Stop then Break;
end;
end;
SetCurDrive(SaveDrive);
end;

begin
FileFind('C:','*.bak'); {search *.bak in C:}
WalkDrives('*.pas'); {search *.pas in all drives}
end.