Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > IT форум > Помощь студентам
Регистрация

Восстановить пароль

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 05.04.2009, 00:07   #1
REztor
Форумчанин
 
Регистрация: 28.02.2009
Сообщений: 302
По умолчанию Максимальный ключ в таблице

Код:
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, StdCtrls,unit2, Grids,unit3;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    MainMenu1: TMainMenu;
    ext1: TMenuItem;
    Pfuhepbnm1: TMenuItem;
    Save1: TMenuItem;
    Quit1: TMenuItem;
    Sort1: TMenuItem;
    MakeList1: TMenuItem;
    od: TOpenDialog;
    sd: TSaveDialog;
    ShowList1: TMenuItem;
    SelectWordsonFirstLetter1: TMenuItem;
    agrid: TStringGrid;
    OnfirstLetter1: TMenuItem;
    OnLetterCount1: TMenuItem;
    OnWords1: TMenuItem;
    OnSentences1: TMenuItem;
    procedure Quit1Click(Sender: TObject);
    procedure Pfuhepbnm1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
   { procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState); }
    procedure ShowList1Click(Sender: TObject);
    procedure Sort1Click(Sender: TObject);
    procedure OnfirstLetter1Click(Sender: TObject);
    procedure OnLetterCount1Click(Sender: TObject);
    procedure OnWords1Click(Sender: TObject);
    procedure OnSentences1Click(Sender: TObject);
   { procedure Sort1Click(Sender: TObject);
    procedure SelectWordsonFirstLetter1Click(Sender: TObject);}
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;myTab:tabl;

implementation

{$R *.dfm}

procedure TForm1.Quit1Click(Sender: TObject);
begin
  halt
end;

procedure TForm1.Pfuhepbnm1Click(Sender: TObject);
begin
 if od.execute then
 memo1.lines.loadfromfile(od.filename)
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 memo1.clear;
 myTab:=Tabl.create;
 with agrid do
 begin cells[1,0]:='Key';
 cells[2,0]:='N';
 end;
end;

{procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 if key=vk_escape then
 begin memo1.Clear;
 memo1.text:=myList.s end;
end;}

procedure TForm1.ShowList1Click(Sender: TObject);
begin
 myTab.showtab(agrid);
end;

{procedure TForm1.Sort1Click(Sender: TObject);
begin
 myList.sort.showlist(memo1);
end;}

procedure TForm1.Sort1Click(Sender: TObject);
begin
  mytab.sort.showtab(agrid);
end;

procedure TForm1.OnfirstLetter1Click(Sender: TObject);
 var c:char;s:List;
begin s:=List.create;
 c:=InputBox('Запрос','Введите начальную букву','')[1];
 s:=mytab.first(c);
 if s=nil then begin showmessage('Такого ключа в таблице нет !');
  exit end;
  s.showlist(memo1);
end;

procedure TForm1.OnLetterCount1Click(Sender: TObject);
var k:integer;
begin
 k:=strtoint(InputBox('Запрос','Введите число букв','3'));
 mytab.letters(k).showlist(memo1);
end;

procedure TForm1.OnWords1Click(Sender: TObject);
begin
 mytab.maketab(memo1);
 mytab.showtab(agrid);
end;

procedure TForm1.OnSentences1Click(Sender: TObject);
begin
mytab.sent(memo1).showtab(agrid);
end;

end.
Код:
unit Unit2;

interface uses sysutils,stdctrls;

type
     pe=^elem;
     elem=record w:string;next:pe end;

List=class
  head:pe;s:string;
  constructor create;
  procedure add(t:string);
  procedure makelist(m:TMemo);
  procedure showlist(m:TMemo);
  function sort:list;
  function first(c:char):list;
  procedure count(var t:List;k:integer);
    end;

implementation

 constructor List.create;
  begin head:=nil;s:='' end;

 procedure List.add(t:string);
 var p,q:pe;
 begin p:=head;new(q);
  q^.w:=t;q^.next:=nil;
  if p=nil then head:=q else
  begin
  while assigned(p^.next) do p:=p^.Next;
  p^.next:=q end end;

  procedure List.makelist(m:TMemo);
  var i:integer;p:string;
  begin s:=m.Text;i:=1;
    head:=nil;
   s:=trim(s);
   while s[i]<>#0 do begin p:='';
     while (s[i] in ['A'..'Z','a'..'z'])and(s[i]<>#0) do
     begin p:=p+s[i];i:=i+1 end;
     add(p);
     while not (s[i] in ['A'..'Z','a'..'z'])and(s[i]<>#0) do
     i:=i+1;
     end;
     end;

  procedure List.showlist(m:TMemo);
  var p:pe;
  begin p:=head;m.Clear;
  while assigned(p) do begin
   m.Text:=m.text+p^.w+', ';
   p:=p^.next end end;


  function List.sort:list;
  var p:pe;flag:boolean;t:string;
  begin repeat flag:=true;
  p:=head;
  while assigned(p^.next) do begin
  if lowercase(p^.w)>lowercase(p^.next^.w) then
  begin t:=p^.w;p^.w:=p^.next^.w;p^.next^.w:=t;
  flag:=false;
   end;
   p:=p^.next end;
   until flag;
   result:=self end;

  function List.first(c:char):list;
  var tmp:list;
  begin   result:=tmp end;

  procedure List.count(var t:List;k:integer);
  var p:pe;
   begin p:=head;
   while assigned(p) do begin
   if length(p^.w)=k then t.add(p^.w);
   p:=p^.next end; end;

end.
REztor вне форума Ответить с цитированием
Старый 05.04.2009, 00:08   #2
REztor
Форумчанин
 
Регистрация: 28.02.2009
Сообщений: 302
По умолчанию

Код:
unit Unit3;

interface uses sysutils,grids,unit2,stdctrls;

type
  rec=record key:char;k:integer;l:list; end;
 tabl=class
 a:array of rec;n:integer; s:string;
 constructor create;
 procedure add(t:string);
 procedure maketab(m:TMemo);
 procedure showtab(m:TStringGrid);
 function sort:tabl;
 function first(c:char):list;
 function letters(k:integer):list;
 function sent(m:TMemo):tabl;
 //function max:List;
 end;

implementation

 {function tabl.max:List;
 var i,mx,imax:integer;
 begin
 result:=a[imax].L;
 end; }

 constructor tabl.create;
 begin a:=nil;n:=0 end;

 procedure tabl.add(t:string);
 var i:integer;f:char;
 begin  f:=lowercase(t)[1];
 for i:=0 to n-1 do
 begin
 if a[i].key=f then
 begin a[i].l.add(t); a[i].k:=a[i].k+1;
 exit end;  end;
  setlength(a,n+1);
  a[n].key:=f;
  a[n].k:=1;
  a[n].l:=List.create;
  a[n].l.add(t);
  n:=n+1;
  end;

 procedure tabl.maketab(m:TMemo);
  var i:integer;p:string;
  begin s:=m.Text;i:=1;
     s:=trim(s);
   while s[i]<>#0 do begin p:='';
     while (s[i] in ['A'..'Z','a'..'z'])and(s[i]<>#0) do
     begin p:=p+s[i];i:=i+1 end;
     add(p);
     while not (s[i] in ['A'..'Z','a'..'z'])and(s[i]<>#0) do
     i:=i+1;
     end;end;


 function tabl.sent(m:TMemo):tabl;
  var i:integer;p:string;
  begin s:=m.Text;i:=1;
     s:=trim(s);
   while s[i]<>#0 do begin p:='';
     while (s[i] <>';')do
     begin p:=p+s[i];i:=i+1 end;
     p:=trim(p);p:=p+';';
     add(p);
     i:=i+1;
       end;
   result:=self;
       end;


 procedure tabl.showtab(m:TStringGrid);
  var i:integer;
  begin with m do begin
  rowcount:=n+1;
  for i:=0 to n-1 do
  begin
  cells[1,i+1]:=a[i].key;
  cells[2,i+1]:=inttostr(a[i].k);
  end;end; end;
   
 function tabl.sort:tabl;
 var i,j:integer;tmp:rec;
 begin for i:=0 to n-2  do
    for j:=i+1 to n-1 do
    if a[i].key>a[j].key then
    begin tmp:=a[i];a[i]:=a[j];
    a[j]:=tmp end;
    result:=self end;

 function tabl.first(c:char):list;
 var i:integer;
 begin result:=nil;
 for i:=0 to n-1 do
 if a[i].key=c then
 begin result:=a[i].l;
 break end;
 end;

function tabl.letters(k:integer):list;
var i:integer;t:List;
 begin t:=List.create;
   for i:=0 to n-1 do
   a[i].l.count(t,k);
   result:=t end;

end.
function tabl.max:List;
var i,mx,imax:integer;
begin
result:=a[imax].L;
end;
Помогите написать эту функцию, нужно чтобы максимальный ключ выводился из таблицы в мемо
REztor вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Слияние шаблона с данными из таблице, и как подсичтать значение количества полей в таблице n4ela Microsoft Office Access 3 07.03.2009 12:04
удалить максимальный элемент из квадратной матрицы rev1ver Паскаль, Turbo Pascal, PascalABC.NET 6 20.01.2009 15:31
максимальный размер массива в 32-битной оси Adamant Свободное общение 5 03.12.2008 21:14
Найти минимальный и максимальный из элементов deu4er Помощь студентам 3 13.11.2008 08:49
Максимальный элемент массива j_Q Assembler - Ассемблер (FASM, MASM, WASM, NASM, GoASM, Gas, RosAsm, HLA) и не рекомендуем TASM 0 04.11.2008 22:48