fork download
copy 
  1. program Lab23;
  2.  
  3. {$APPTYPE CONSOLE}
  4. {$MODE OBJFPC}
  5.  
  6. uses
  7.  SysUtils, Classes;
  8.  
  9. type
  10.  TMonth = (January, February, March, April, May, June,
  11.  July, August, September, October, November, December);
  12.  TEvent = record
  13.  EventName : string[100];
  14.  Day : byte;
  15.  Month : TMonth;
  16.  Year : integer;
  17.   end;
  18.  
  19. function MonthFromInt(m: integer): TMonth;
  20. begin
  21.  Result := TMonth(m - 1);
  22. end;
  23.  
  24. function MonthToStr(m: TMonth): string;
  25. const
  26.  Names: array[January..December] of string = (
  27.     'январь', 'февраль', 'март', 'апрель', 'май', 'июнь',
  28.     'июль', 'август', 'сентябрь', 'октябрь', 'ноябрь', 'декабрь');
  29. begin
  30.  Result := Names[m];
  31. end;
  32.  
  33. function IsLater(A, B: TEvent): Boolean;
  34. begin
  35.  Result := (A.Year > B.Year) or
  36.             ((A.Year = B.Year) and (Ord(A.Month) > Ord(B.Month))) or
  37.             ((A.Year = B.Year) and (A.Month = B.Month) and (A.Day > B.Day));
  38. end;
  39.  
  40. procedure SplitString(const S: string; Separator: char; var Parts: TStringList);
  41. var
  42.   i, Start: integer;
  43. begin
  44.   Parts.Clear;
  45.   Start := 1;
  46.   for i := 1 to Length(S) do
  47.     if S[i] = Separator then
  48.     begin
  49.       Parts.Add(Copy(S, Start, i - Start));
  50.       Start := i + 1;
  51.     end;
  52.   Parts.Add(Copy(S, Start, Length(S) - Start + 1));
  53. end;
  54.  
  55. function GetTypedFileName: string;
  56. begin
  57.   if ParamCount >= 1 then
  58.     Result := ParamStr(1)
  59.   else
  60.   begin
  61.     Write('Введите имя типизированного файла: ');
  62.     ReadLn(Result);
  63.   end;
  64. end;
  65.  
  66. procedure CreateTypedFileDialog;
  67. var
  68.   f: file of TEvent;
  69.   rec: TEvent;
  70.   m: integer;
  71.   answer: char;
  72.   fname: string;
  73. begin
  74.   fname := GetTypedFileName;
  75.   AssignFile(f, fname);
  76.   try
  77.     Rewrite(f);
  78.   except
  79.     Writeln('Ошибка создания файла ', fname);
  80.     ReadLn;
  81.     Exit;
  82.   end;
  83.  
  84.   repeat
  85.     Writeln('--- Новая запись ---');
  86.     Write('Событие: '); ReadLn(rec.EventName);
  87.     Write('День (1..31): '); ReadLn(rec.Day);
  88.     repeat
  89.       Write('Месяц (1..12): '); ReadLn(m);
  90.     until (m >= 1) and (m <= 12);
  91.     rec.Month := MonthFromInt(m);
  92.     Write('Год: '); ReadLn(rec.Year);
  93.     Write(f, rec);
  94.     Write('Добавить ещё? (y/n): '); ReadLn(answer);
  95.   until UpCase(answer) = 'N';
  96.  
  97.   CloseFile(f);
  98.   Writeln('Файл ', fname, ' успешно создан.');
  99.   ReadLn;
  100. end;
  101.  
  102. procedure CreateTypedFileFromText;
  103. var
  104.   tf: TextFile;
  105.   f: file of TEvent;
  106.   rec: TEvent;
  107.   line: string;
  108.   parts: TStringList;
  109.   fname_typed, fname_text: string;
  110. begin
  111.   if ParamCount >= 2 then
  112.     fname_text := ParamStr(2)
  113.   else
  114.   begin
  115.     Write('Введите имя текстового файла: ');
  116.     ReadLn(fname_text);
  117.   end;
  118.   fname_typed := GetTypedFileName;
  119.  
  120.   AssignFile(tf, fname_text);
  121.   try
  122.     Reset(tf);
  123.   except
  124.     Writeln('Не удалось открыть текстовый файл ', fname_text);
  125.     ReadLn;
  126.     Exit;
  127.   end;
  128.  
  129.   AssignFile(f, fname_typed);
  130.   try
  131.     Rewrite(f);
  132.   except
  133.     Writeln('Ошибка создания типизированного файла ', fname_typed);
  134.     CloseFile(tf);
  135.     ReadLn;
  136.     Exit;
  137.   end;
  138.  
  139.   parts := TStringList.Create;
  140.   try
  141.     while not Eof(tf) do
  142.     begin
  143.       ReadLn(tf, line);
  144.       if Trim(line) = '' then Continue;
  145.       SplitString(line, ';', parts);
  146.       if parts.Count < 4 then
  147.       begin
  148.         Writeln('Ошибка в строке: ', line, ' – пропущена');
  149.         Continue;
  150.       end;
  151.       rec.EventName := parts[0];
  152.       rec.Day := StrToIntDef(parts[1], 1);
  153.       rec.Month := MonthFromInt(StrToIntDef(parts[2], 1));
  154.       rec.Year := StrToIntDef(parts[3], 2000);
  155.       Write(f, rec);
  156.     end;
  157.   finally
  158.     parts.Free;
  159.   end;
  160.  
  161.   CloseFile(tf);
  162.   CloseFile(f);
  163.   Writeln('Типизированный файл создан из ', fname_text);
  164.   ReadLn;
  165. end;
  166.  
  167. procedure ViewFile;
  168. var
  169.   f: file of TEvent;
  170.   rec: TEvent;
  171.   count: integer;
  172.   fname: string;
  173. begin
  174.   fname := GetTypedFileName;
  175.   AssignFile(f, fname);
  176.   try
  177.     Reset(f);
  178.   except
  179.     Writeln('Ошибка открытия файла ', fname);
  180.     ReadLn;
  181.     Exit;
  182.   end;
  183.  
  184.   count := 0;
  185.   while not Eof(f) do
  186.   begin
  187.     Read(f, rec);
  188.     Inc(count);
  189.     Writeln(count, ': ', rec.EventName, ', ', rec.Day, ' ', MonthToStr(rec.Month),
  190.             ' ', rec.Year, ' г.');
  191.   end;
  192.   if count = 0 then
  193.     Writeln('Файл пуст.')
  194.   else
  195.     Writeln('Всего записей: ', count);
  196.   CloseFile(f);
  197.   ReadLn;
  198. end;
  199.  
  200. procedure FindAndSwapWithLast;
  201. var
  202.   f: file of TEvent;
  203.   rec, candidate, lastRec: TEvent;
  204.   bestPos, lastPos, curPos: integer;
  205.   found: boolean;
  206.  letter: string;
  207.  fname: string;
  208. begin
  209.  fname := GetTypedFileName;
  210.  AssignFile(f, fname);
  211.   try
  212.  Reset(f);
  213.   except
  214.     Writeln('Ошибка открытия файла ', fname);
  215.     ReadLn;
  216.  Exit;
  217.   end;
  218.  
  219.   Write('Введите букву, с которой начинается событие: ');
  220.   ReadLn(letter);
  221.   if letter = '' then
  222.   begin
  223.     Writeln('Буква не введена.');
  224.  CloseFile(f);
  225.     ReadLn;
  226.  Exit;
  227.   end;
  228.  letter := UpperCase(letter)[1];
  229.  
  230.  found := False;
  231.  bestPos := -1;
  232.   while not Eof(f) do
  233.   begin
  234.     Read(f, rec);
  235.     if (Length(rec.EventName) > 0) and (UpperCase(rec.EventName)[1] = letter) then
  236.     begin
  237.       if not found then
  238.       begin
  239. 		candidate := rec;
  240. 		bestPos := FilePos(f);
  241. 		found := True;
  242.       end
  243.       else if IsLater(rec, candidate) then
  244.       begin
  245.         candidate := rec;
  246. 		bestPos := FilePos(f);
  247.       end;
  248.     end;
  249.   end;
  250.  
  251.   if not found then
  252.   begin
  253.     Writeln('Записей, начинающихся на букву "', letter, '", не найдено.');
  254.  CloseFile(f);
  255.     ReadLn;
  256.  Exit;
  257.   end;
  258.  
  259.  lastPos := FileSize(f) - 1;
  260.   if bestPos = lastPos then
  261.   begin
  262.     Writeln('Найденная запись уже является последней. Перестановка не требуется.');
  263.  CloseFile(f);
  264.     ReadLn;
  265.  Exit;
  266.   end;
  267.  
  268.  Seek(f, lastPos);
  269.   Read(f, lastRec);
  270.  Seek(f, lastPos);
  271.   Write(f, candidate);
  272.  Seek(f, bestPos);
  273.   Write(f, lastRec);
  274.  
  275.   Writeln('Перестановка выполнена: запись ', bestPos+1,
  276.           ' (', candidate.EventName, ') и запись ', lastPos+1,
  277.           ' (', lastRec.EventName, ') поменяны местами.');
  278.   CloseFile(f);
  279.   ReadLn;
  280. end;
  281.  
  282. var
  283.  ch: char;
  284. begin
  285.   repeat
  286.     Writeln('-----------------------------------');
  287.     Writeln('D - создать типизированный файл (диалог)');
  288.     Writeln('N - создать из текстового файла');
  289.     Writeln('F - найти запись и переставить с последней');
  290.     Writeln('V - просмотр файла');
  291.     Writeln('E - выход');
  292.     Write('Ваш выбор: ');
  293.     ReadLn(ch);
  294.     Writeln('-----------------------------------');
  295.  ch := UpCase(ch);
  296.     case ch of
  297.       'D': CreateTypedFileDialog;
  298.       'N': CreateTypedFileFromText;
  299.       'F': FindAndSwapWithLast;
  300.       'V': ViewFile;
  301.       'E': Exit;
  302.     else
  303.       Writeln('Нет такой команды');
  304.       Write('Press ENTER');
  305.       ReadLn;
  306.     end;
  307.   until ch = 'E';
  308. end.
Success #stdin #stdout 0s 5320KB
comments (?)
stdin
copy 
E
stdout
copy 
-----------------------------------
D - создать типизированный файл (диалог)
N - создать из текстового файла
F - найти запись и переставить с последней
V - просмотр файла
E - выход
Ваш выбор: -----------------------------------
https://ideone.com/mPZUsy
language:
Pascal (fpc 3.0.4)
created:
6 hours ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!