Тurbo Pascal 7.0

R.E.Mus · 20.12.2005

Оставляйте Здесь Самые Крутые Проги По Turbo Pascal'ю...И спользуйте Самые крутое модули...

Моя: Пользователь С клав-ры вводит Массив целых чисел, посчитать Сумму чётных чисел целой части Числа...

Код:

program tp;
uses crt;
const n=3;
var x:array [1..n] of real;
i,p,k,s:integer;
begin
clrscr;
Textcolor(37);
Writeln('____________________________________________________________________________
____');
Textcolor(36);
writeln('____________________________________________________________________________
____');
Textcolor(10);
writeln('enter array');
for i:=1 to n do begin
write('x[',i:2,']=');
readln(x[i]);
end;
s:=0;
Textcolor(53);
for i:=1 to n do begin
p:=trunc(x[i]);
while p <> 0 do begin
k:=p mod 10;
if (k mod 2)=0 then inc (s,k);
p:=p div 10;
end;end;
Textcolor(11);
writeln('summa chetnux chisel=');Textcolor(12);writeln(s);
Textcolor(68);
writeln('            dlay vuhoda nigmite EnTeR');
Textcolor(37);
writeln('____________________________________________________________________________
____');
Textcolor(36);
writeln('____________________________________________________________________________
____');
readkey;
end.

Конечно С маленькими Прибомбахами но сойдёт B)

И ещё маленький Вопросик Как сделать чтобы удалить из каждой ячейки массива числа от 1 до 5

Derek · 20.03.2006

Помогите прогу написать!!! Посчитать длину ряда при заданном х и эпсилон:
x*(3+x)/3!-x^3(5-x)/5!+...+(-)(x^(2i-1))*(2i+1+x)/(2i+1)!
Очень нужно! От этого зависит жизнь студента!!!

Guest_Alexander_* · 01.05.2006

вот вам текст проги. если кто-то понял её, то напишите чё она творит, чтобы я знал с кем имею дело.

Код:

program PrinterOutputFilter;

{$M 2048, 0, 0}
{$I-,S-,X+}

const
MaxAttributes = 8;

type
TPCharArray = array[0..16380] of PChar;
PPCharArray = ^TPCharArray;

PPrinterCodes = ^TPrinterCodes;
TPrinterCodes = record
 PreambleCount: Byte;
 Preamble: PPCharArray;
 CodeArray: PPCharArray;
 Attributes: array[0..MaxAttributes - 1] of Byte;
 StartPage: PChar;
 EndPage: PChar;
 EndLine: PChar;
 Postamble: PChar;
end;

const
EpsonItalic  = #27'4';
EpsonNoItalic = #27'5';
EpsonBold   = #27'E';
EpsonNoBold  = #27'F';
EpsonULine  = #27'-'#1;
EpsonNoULine = #27'-'#0;

EpsonCodeArray: array[0..7] of PChar = (
 EpsonBold,
 EpsonNoBold,
 EpsonItalic,
 EpsonNoItalic,
 EpsonULine,
 EpsonNoULine,
 EpsonBold + EpsonItalic,
 EpsonNoBold + EpsonNoItalic);

EpsonCodes: TPrinterCodes = (
 PreambleCount: 0;
 Preamble: nil;
 CodeArray: @EpsonCodeArray;
 Attributes: (
  0,    { Whitespace }
  2,    { Comment }
  1,    { Reserved word }
  0,    { Identifier }
  0,    { Symbol }
  4,    { String }
  0,    { Number }
  1);    { Assembler }
 StartPage: '';
 EndPage: #12;
 EndLine: #13#10;
 Postamble: ''
);

HPInit   = #27'E'#27'(10U'#27'&k0S'#27'(s3T';
HPItalic  = #27'(s1S';
HPNoItalic = #27'(s0S';
HPBold   = #27'(s3B';
HPNoBold  = #27'(s0B';
HPULine   = #27'&dD';
HPNoULine  = #27'&d@';

HPCodeArray: array[0..7] of PChar = (
 HPBold,
 HPNoBold,
 HPItalic,
 HPNoItalic,
 HPULine,
 HPNoULine,
 HPBold + HPItalic,
 HPNoBold + HPNoItalic);

LaserJetPreamble: PChar = HPInit;
LaserJetCodes: TPrinterCodes = (
 PreambleCount: 1;
 Preamble: @LaserJetPreamble;
 CodeArray: @HPCodeArray;
 Attributes: (
  0,    { Whitespace }
  2,    { Comment }
  1,    { Reserved word }
  0,    { Identifier }
  0,    { Symbol }
  4,    { String }
  0,    { Number }
  1);    { Assembler }
 StartPage: '';
 EndPage: #12;
 EndLine: #13#10;
 Postamble: #12
);

AsciiCodes: TPrinterCodes = (
 PreambleCount: 0;
 Preamble: nil;
 CodeArray: nil;
 Attributes: (
  0,    { Whitespace }
  0,    { Comment }
  0,    { Reserved word }
  0,    { Identifier }
  0,    { Symbol }
  0,    { String }
  0,    { Number }
  0);    { Assembler }
 StartPage: '';
 EndPage: #12;
 EndLine: #13#10;
 Postamble: ''
);

PSPreamble0 = #4'%!PS-Adobe-3.0'#13#10+
       'initgraphics'#13#10;
PSPreamble1 = '/fnr /Courier findfont 10 scalefont def'#13#10;
PSPreamble2 = '/fni /Courier-Oblique findfont 10 scalefont def'#13#10;
PSPreamble3 = '/fnb /Courier-Bold findfont 10 scalefont def'#13#10;
PSPreamble4 = '/fnbi /Courier-BoldOblique findfont 10 scalefont def'#13#10;
PSPreamble5 = '/newl {20 currentpoint exch pop 12 sub moveto} def'#13#10+
        '/newp {20 765 moveto} def'#13#10+
        'fnr setfont'#13#10;
PSNormal   = 'fnr setfont'#13#10;
PSItalic   = 'fni setfont'#13#10;
PSBold    = 'fnb setfont'#13#10;
PSBoldItalic = 'fnbi setfont'#13#10;

PSCodeArray: array[0..5] of PChar = (
 PSBold,
 PSNormal,
 PSItalic,
 PSNormal,
 PSBoldItalic,
 PSNormal);

PSPreamble: array[0..5] of PChar = (
 PSPreamble0,
 PSPreamble1,
 PSPreamble2,
 PSPreamble3,
 PSPreamble4,
 PSPreamble5);
PSCodes: TPrinterCodes = (
 PreambleCount: High(PSPreamble) - Low(PSPreamble) + 1;
 Preamble: @PSPreamble;
 CodeArray: @PSCodeArray;
 Attributes: (
  0,    { Whitespace }
  2,    { Comment }
  1,    { Reserved word }
  0,    { Identifier }
  0,    { Symbol }
  3,    { String }
  0,    { Number }
  1);    { Assembler }
 StartPage: 'newp'#13#10;
 EndPage: 'showpage'#13#10;
 EndLine: 'newl'#13#10;
 Postamble: #4
);

pmNormal   = $0001;
pmPostScript = $0002;

PrintMode: Word = pmNormal;
LinesPerPage: Word = 59;
ToFile: Boolean = False;
TabSize: Word = 8;

var
C, LineCount, TabCount: Integer;
Line, OutputLine: String;
InputBuffer: array[0..4095] of Char;
PrinterCodes: PPrinterCodes;
CurCode, NewCode: Byte;
AKey: Word;
Lst: Text;

procedure UpStr(var S: String);
var
I: Integer;
begin
for I := 1 to Length(S) do S[I] := UpCase(S[I]);
end;

procedure SetDeviceRaw(var T: Text); assembler;
asm
LES	DI,T
MOV	BX,WORD PTR ES:[DI]
MOV	AX,4400H
INT	21H
TEST	DX,0080H
JZ	@@1
OR	DL,20H
MOV	DH,DH
MOV	AX,4401H
INT	21H
@@1: 
end;

procedure ProcessCommandLine;
var
Param: String;
I: Integer;

function ParamVal(var P: String; Default: Word): Word;
var
 N, E: Integer;
begin
 Delete(P, 1, 1);
 Val(P, N, E);
 if E = 0 then
  ParamVal := N
 else
  ParamVal := Default;
end;

begin
PrinterCodes := @AsciiCodes;
for I := 1 to ParamCount do
begin
 Param := ParamStr(I);
 if (Length(Param) >= 2) and ((Param[1] = '/') or (Param[1] = '-')) then
 begin
  Delete(Param, 1, 1);
  UpStr(Param);
  if Param = 'EPSON' then
   PrinterCodes := @EpsonCodes
  else if Param = 'HP' then
   PrinterCodes := @LaserJetCodes
  else if Param = 'ASCII' then
   PrinterCodes := @AsciiCodes
  else if Param = 'PS' then
  begin
   PrinterCodes := @PSCodes;
   PrintMode := pmPostScript;
  end
  else if Param[1] = 'L' then
   LinesPerPage := ParamVal(Param, LinesPerPage)
  else if Param[1] = 'T' then
   TabSize := ParamVal(Param, TabSize)
  else if Param[1] = 'O' then
  begin
   Delete(Param, 1, 1);
   Assign(Lst, Param);
   Rewrite(Lst);
   ToFile := True;
   SetDeviceRaw(Lst);
  end;
 end;
end;
if not ToFile then
begin
 Assign(Lst, 'LPT1');
 Rewrite(Lst);
 SetDeviceRaw(Lst);
end;
end;

procedure PurgeOutputBuf;
begin
if OutputLine = '' then Exit;
case PrintMode of
 pmNormal: Write(Lst, OutputLine);
 pmPostScript:
 begin
  Write(Lst, '(');
  Write(Lst, OutputLine);
  Write(Lst, ') show'#13#10);
 end;
end;
OutputLine := '';
if IOResult <> 0 then Halt(1);
end;

procedure AddToOutputBuf(AChar: Char);
var
I: Integer;
begin
case AChar of
 '(',')','\':
 begin
  case PrintMode of
   pmPostScript:
   begin
    if Length(OutputLine) > 253 then
     PurgeOutputBuf;
    Inc(OutputLine[0]);
    OutputLine[Length(OutputLine)] := '\';
   end;
  end;
 end;
 #9:
 begin
  if Length(OutputLine) > (255 - TabSize) then
   PurgeOutputBuf;
  for I := 1 to TabSize - (TabCount mod TabSize) do
  begin
   Inc(OutputLine[0]);
   OutputLine[Length(OutputLine)] := ' ';
  end;
  Inc(TabCount, TabSize - (TabCount mod TabSize));
  Exit;
 end;
end;
if Length(OutputLine) > 254 then
 PurgeOutputBuf;
Inc(OutputLine[0]);
OutputLine[Length(OutputLine)] := AChar;
Inc(TabCount);
end;

procedure NewPage(const PCodes: TPrinterCodes);
begin
PurgeOutputBuf;
Write(Lst, PCodes.EndPage);
Write(Lst, PCodes.StartPage);
LineCount := 0;
TabCount := 0;
end;

procedure NewLine(const PCodes: TPrinterCodes);
begin
PurgeOutputBuf;
Write(Lst, PCodes.EndLine);
Inc(LineCount);
TabCount := 0;
if LineCount > LinesPerPage then
 NewPage(PCodes);
end;

function GetKey(var Key: Word): Boolean; assembler;
asm
MOV	AH,1
INT	16H
MOV	AL,0
JE	@@1
XOR	AH,AH
INT	16H
LES	DI,Key
MOV	WORD PTR ES:[DI],AX
MOV	AL,1
@@1:
end;

begin
SetTextBuf(Input, InputBuffer);
ProcessCommandLine;
LineCount := 0;
with PrinterCodes^ do
begin
 if PreambleCount > 0 then
  for C := 0 to PreambleCount - 1 do
   Write(Lst, Preamble^[C]);
 if IOResult <> 0 then Halt(1);
 LineCount := 0;
 CurCode := $FF;
 TabCount := 0;
 Write(Lst, StartPage);
 Line := '';
 while True do
 begin
  if (Line = '') and Eof then
  begin
   PurgeOutputBuf;
   Break;
  end;
  ReadLn(Line);
  if GetKey(AKey) and (AKey = $011B) then
   Halt(1);
  C := 1;
  while C <= length(Line) do
  begin
   case Line[C] of
    #27:
     if (Line[C + 1] >= '1') and (Line[C + 1] <= '8') then
     begin
      NewCode := Attributes[Byte(Line[C + 1]) - $31];
      if NewCode <> CurCode then
      begin
       PurgeOutputBuf;
       if (CurCode > 0) and (CurCode < MaxAttributes) then
        Write(Lst, CodeArray^[(CurCode - 1) * 2 + 1]);
       if (NewCode > 0) and (NewCOde < MaxAttributes) then
        Write(Lst, CodeArray^[(NewCode - 1) * 2]);
       CurCode := NewCode;
      end;
      Inc©;
     end;
    #12: NewPage(PrinterCodes^);
   else
    AddToOutputBuf(Line[C]);
   end;
   Inc©;
  end;
  NewLine(PrinterCodes^);
 end;
 if LineCount > 0 then
  Write(Lst, EndPage);
 Write(Lst, Postamble);
end;
Close(Lst);
end.

Gisma · 01.05.2006

Боже - боже старый любимый паскаль

Все сервисы Codeby

Поиск

Поиск

Тurbo Pascal 7.0

R.E.Mus

Derek

Guest_Alexander_*

Gisma