4th vocabulary database on PABC

Перейти вниз

4th vocabulary database on PABC

Сообщение автор _KROL в Вт Окт 16, 2018 8:05 pm

Название темы говорит само за себя Very Happy

_KROL

Сообщения : 90
Дата регистрации : 2017-07-28
Возраст : 19
Откуда : Беларусь

Посмотреть профиль

Вернуться к началу Перейти вниз

Re: 4th vocabulary database on PABC

Сообщение автор _KROL в Вт Окт 16, 2018 8:05 pm

// Программа forthdb.pas
Код:
uses db, vcl, containers, utils, graphabc, events;

type
 mtSet = (mtWarning, mtError, mtInformation, mtConfirmation, mtCustom);

const
 __font: string = 'Lucida Console';
 __fontsize: integer = 11;
 __ftype = '4VOC';
 __ffilter = '4th vocabulary (*.4VOC)|*.4VOC';
 __fmark    = '::::::::::::';
 __fresolve = ';;;;;;;;;;;;';
 __autosave = false;
 __about = '4VOC database v.1.0' + #10 + '2018 _KROL (C)';
 __hotkeys = 'Hot keys:'            + #10 +
             'F10 - New'            + #10 +
             'F2  - Save As'        + #10 +
             'F3  - Open'           + #10 +
             'F4  - Save Text'      + #10 +
             'F5  - Restore Text'   + #10 +
             'F9  - Autosave Text'  + #10 +
             'INSERT - Add record'  + #10 +
             'DEL - Delete record'  + #10 +
             'RETURN - Edit record';
var
 db: tdb;
 _autosave: boolean;
 _font: string;
 _fontsize: integer;
 _editing: boolean;
 _changed: boolean;
 
 Form1: Form; // MainForm
 ListBox1: ListBox;
 TextBox1: TextBox;
 MainMenu1: MainMenu;
 Spl_1:Splitter;

 Form2: Form; // EditForm
 TextLabel1: TextLabel;
 Edit1: Edit;
 Button01: Button;
 Button02: Button;
 
 OpenDialog1: OpenDialog;
 SaveDialog1: SaveDialog;
 
procedure MessageBox(s: string; mt: mtSet);
 begin
   MessageDlg(s, mt, [mbok]);
 end;
 
function trimspaces(s: string): string;
 begin
   while (s[1]<=' ')and(length(s)>0) do
     delete(s, 1, 1);
   while (s[length(s)]<=' ')and(length(s)>0) do
     delete(s, length(s), 1);
   trimspaces:= s;
 end;
 
procedure onkeydown_graphabc(i :integer);
 begin
   Form1.Show;
 end;
 
procedure SetFont(name: string; size: integer);
 begin
   _font:= name;
   _fontsize:= size;
   SetFontName(_font);
   SetFontSize(_fontsize);
 end;

procedure SetFont;
 begin
   SetFont(__font, __fontsize);
 end;
 
// Handlers

procedure text_save; forward;
procedure ListBox1_Enter;
 begin
   if (_changed)and(_autosave) then
     begin
       text_save;
     end;
 end;

procedure file_new; forward;
procedure file_open; forward;
procedure file_saveas; forward;
procedure record_add; forward;
procedure record_edit; forward;
procedure record_delete; forward;
procedure text_save; forward;
procedure text_restore; forward;
procedure text_autosave; forward;
procedure Form1_OnKeyDown(key: integer);
 begin
   case key of
     vk_F10:
       file_new;
     vk_F3:
       file_open;
     vk_F2:
       file_saveas;
     vk_insert:
       record_add;
     vk_return:
       record_edit;
     vk_delete:
       record_delete;
     vk_F4:
       text_save;
     vk_F5:
       text_restore;
     vk_F9:
       text_autosave;
   end;
 end;

procedure text_restore; forward;
procedure ListBox1_OnKeyUp(key: integer);
 begin
   case key of
     vk_up, vk_down:
       text_restore;
   end;
 end;

procedure updmenu; forward;
procedure ListBox1_MouseUp(x, y, b: integer);
 begin
   updmenu;
 end;

procedure updmenu; forward;
procedure TextBox1_Change;
 begin
   if not _changed then
     begin
       _changed:= true;
       updmenu;
     end;
 end;

procedure file_new;
 begin
   db.Clear;
   ListBox1.Clear;
   TextBox1.Clear;
 end;
 
procedure listbox_refresh; forward;
procedure text_restore; forward;
function getwords(s: string): stringarray; forward;
procedure file_open;
label
 __ok__, __error__;
var
 s, w: stringarray; i: integer; rec: trec;
 begin
   s:= stringarray.create;
   rec:= trec.create;
   rec.text:= stringarraybase.create;
   if OpenDialog1.Execute then
     if fileexists(OpenDialog1.FileName) then
       begin
         db.clear;
         s.loadfromfile(OpenDialog1.FileName);
         if s[1]<>__fmark then
           goto __error__;
         i:=2;
         while i<s.count do
           begin
             w:= getwords(s[i]);
             if (w[1]<>__fmark)or(w.count<>2) then
               goto __error__;
             rec.name:= w[2];
             rec.text.clear;
             w.destroy;
             inc(i);
             while (i<s.count)and(s[i]<>__fresolve) do
               begin
                 rec.text.add(s[i]);
                 inc(i);
               end;
             db.add(rec);
             inc(i);
           end;
         goto __ok__;
         __error__:
         MessageBox('File corrupted!', mtError);
         __ok__:
         s.destroy;
         listbox_refresh;
         if db.length>0 then
           ListBox1.ItemIndex:=0
         else
           ListBox1.ItemIndex:=-1;
         text_restore;
       end;
 end;

 function getwords(s: string): stringarray;
 var
   r: stringarray; i, t: integer; see: char; _space, _end: boolean;
   procedure next;
     begin
       inc(i);
       _end:= i>length(s);
       if not(_end) then
         _space:= s[i] <= ' ';
     end;

   procedure skipspaces;
     begin
       while (_space)and(not(_end)) do
         next;
     end;
     
   procedure skipsymbols;
     begin
       while (not(_space))and(not(_end)) do
         next;
     end;

   begin
     r:= stringarray.create;
     i:=0;
     next;
     while not(_end) do
       begin
         skipspaces;
         if _end then
           break;
         t:=i;
         skipsymbols;
         r.add(copy(s, t, i-t));
       end;
     getwords:= r;
   end;

procedure file_saveas;
label
 __start__;
var
 fn: string; f: text; i, j: integer; t: stringarraybase;
 begin
   __start__:
   if SaveDialog1.Execute then
     begin
       fn:= SaveDialog1.filename;
       i:= length(fn);
       if uppercase(copy(fn, i-4, 5))<>'.4VOC' then
         fn:= fn + '.4VOC';
       if fileexists(fn) then
         if MessageDlg('File is already exists. Replace?', mtWarning, [mbyes,mbno]) = mrno then
           goto __start__;
       assign(f, fn);
       rewrite(f);
       writeln(f, __fmark);
       for j:=1 to db.length do
         begin
           writeln(f, __fmark, ' ', db.getname(j));
           t:= db.gettext(j);
           for i:=1 to t.count do
             writeln(f, t[i]);
           writeln(f, __fresolve);
         end;
       close(f);
     end;
 end;
 
procedure file_exit;
 begin
   form1.close;
 end;

procedure record_add;
 begin
   _editing:= false;
   Edit1.text:='';
   Form1.enabled:=false;
   Form2.Caption:= 'Adding';
   Form2.ActiveControl:=Edit1;
   Form2.Position:= poScreenCenter;
   Form2.Show;
 end;
 
procedure record_edit;
 begin
   if ListBox1.ItemIndex = -1 then
     exit;
   _editing:= true;
   Edit1.text:=db.getname(ListBox1.ItemIndex+1);
   Form1.enabled:=false;
   Form2.Caption:= 'Editing';
   Form2.ActiveControl:=Edit1;
   Form2.Position:= poScreenCenter;
   Form2.Show;
 end;

 procedure text_save; forward;
 procedure Button02_OnClick; forward;
 procedure Button01_OnClick;
 var
   rec: trec; s:string;
   begin
     s:= trimspaces(Edit1.text);
     Edit1.text:= s;
     rec:= db.search(s);
     if rec.name<>'' then
       begin
         rec.destroy;
         MessageBox('Identifier was exited!', mtError);
         Form2.Show;
         exit;
       end;
     if length(s)=0 then
       exit;
     if (_changed)and(_autosave) then
       begin
         text_save;
       end;
     if _editing then
       begin
         db.setname(ListBox1.ItemIndex+1, s);
         listbox1.strings[ListBox1.ItemIndex+1]:= s;
       end
     else
       begin
         rec:= trec.create;
         rec.name:=s;
         rec.text:=stringarraybase.create;
         rec.text.clear;
         db.add(rec);
         listbox1.add(rec.name);
         if db.length=1 then
           listbox1.ItemIndex:=0;
       end;
     Button02_OnClick;
   end;
   
 procedure text_restore; forward;
 procedure Button02_OnClick;
   begin
     Form2.Hide;
     text_restore;
     Form1.Enabled:=true;
     Form1.Show;
   end;
   
procedure Form2_OnKeyDown(key: integer);
 begin
   case key of
     vk_return:
       Button01_OnClick;
     vk_escape:
       Button02_OnClick;
   end;
 end;
 
procedure updmenu; forward;
procedure record_delete;
var
 result: integer;
 begin
   if ListBox1.ItemIndex = -1 then
     exit;
   result:=MessageDlg('Delete?', mtWarning, [mbyes,mbno]);
   if result = mryes then
     begin
       db.gettext(ListBox1.ItemIndex+1).destroy;
       db.delete(ListBox1.ItemIndex+1);
       ListBox1.delete(ListBox1.ItemIndex+1);
       if db.length=0 then
         ListBox1.ItemIndex:= -1
       else
       if ListBox1.ItemIndex+1<db.length then
         ListBox1.ItemIndex:=db.length;
       updmenu;
     end;
 end;
 
procedure text_save;
var
 s: stringarraybase;
 begin
   if ListBox1.ItemIndex = -1 then
     exit;
   s:= TextBox1.lines;
   db.settext(ListBox1.ItemIndex+1, s);
   _changed:= false;
   updmenu;
 end;
 
procedure text_restore;
var
 i: integer; s: stringarraybase;
 begin
   TextBox1.clear;
   if ListBox1.ItemIndex <> -1 then
     begin
       s:= db.gettext(ListBox1.ItemIndex+1);
       for i:=1 to s.count do
         TextBox1.lines.add(s[i]);
       _changed:= false;
       updmenu;
     end;
 end;

procedure updmenu; forward;
procedure text_autosave;
 begin
   _autosave:= not _autosave;
   updmenu;
 end;

procedure help_hotkeys;
 begin
   MessageBox(__hotkeys, mtInformation);
 end;
 
procedure help_about;
 begin
   MessageBox(__about, mtInformation);
 end;

// Init and Set subprograms
 
function SplMinSize:integer;
var
 i, j, min: integer;
 begin
   min:= TextWidth('123456789012345');
   for i:=1 to db.length do
     begin
       j:=TextWidth(db.getname(i));
       if j>min then
         min:= j;
     end;
   SplMinSize:= min;
 end;
 
procedure updmenu;
 begin
   MainMenu1.items[2].items[2].enabled:= true;
   MainMenu1.items[2].items[3].enabled:= true;
   if ListBox1.ItemIndex = -1 then
     begin
       MainMenu1.items[2].items[2].enabled:= false;
       MainMenu1.items[2].items[3].enabled:= false;
     end;
   MainMenu1.items[3].enabled:= true;
   MainMenu1.items[4].enabled:= true;
   if (not(_changed))or(ListBox1.ItemIndex = -1) then
     begin
       MainMenu1.items[3].enabled:= false;
       MainMenu1.items[4].enabled:= false;
     end;
   if _autosave then
     MainMenu1.items[5].caption:='&Autosave text: ON'
   else
     MainMenu1.items[5].caption:='&Autosave text: OFF';
 end;
 
procedure listbox_refresh;
var i: integer;
 begin
   ListBox1.clear;
   for i:=1 to db.length do
     ListBox1.add(db.getname(i));
 end;
 
procedure InitControls;
 begin
   // Form1
   Form1:= Form.Create(0,0,640,480);
   Form1.InitControl(True,False,alNone,crDefault,clBtnFace,'','');
   Form1.OnKeyDown:= Form1_OnKeyDown;
   // MainMenu1
   MainMenu1:= MainMenu.Create;
   Form1.Menu:= MainMenu1;
   MainMenu1.Add('File');
   MainMenu1.items[1].Add('New', file_new);
   MainMenu1.items[1].Add('Open', file_open);
   MainMenu1.items[1].Add('Save as', file_saveas);
   MainMenu1.items[1].Add('Exit', file_exit);
   MainMenu1.Add('Re&cord');
   MainMenu1.items[2].Add('Add', record_add);
   MainMenu1.items[2].Add('Edit', record_edit);
   MainMenu1.items[2].Add('Delete', record_delete);
   MainMenu1.Add('Save text', text_save);
   MainMenu1.Add('&Restore text', text_restore);
   MainMenu1.Add('&Autosave text: ', text_autosave);
   MainMenu1.Add('Help');
   MainMenu1.items[6].Add('Hot keys', help_hotkeys);
   MainMenu1.items[6].Add('About', help_about);
   // ListBox1
   ListBox1:= ListBox.Create(Form1,0,0,129,442);
   ListBox1.InitControl(True,True,alLeft,crDefault,clWindow,'','');
   ListBox1.Font.Name:= __font;
   ListBox1.Font.Size:= __fontsize;
   ListBox1.OnEnter:= ListBox1_Enter;
   ListBox1.OnKeyUp:= ListBox1_OnKeyUp;
   ListBox1.OnMouseUp:= ListBox1_MouseUp;
   // TextBox1
   TextBox1:= TextBox.Create(Form1,135,0,489,442);
   TextBox1.InitControl(True,True,alClient,crDefault,clWindow,'','');
   TextBox1.ScrollBars:= ssBoth;
   TextBox1.Font.Name:= __font;
   TextBox1.Font.Size:= __fontsize;
   TextBox1.OnChange:= TextBox1_Change;
   // Spl_1
   Spl_1:= Splitter.Create(Form1.Width div 2, 0);
   Spl_1.Align:=alLeft;
   Spl_1.MinSize:=SplMinSize();
   Spl_1.AutoSnap:=false;
   // Form2
   Form2:= Form.Create(0,0,480,66);
   Form2.InitControl(True,False,alNone,crDefault,clBtnFace,'','');
   Form2.BorderStyle:=bssingle;
   Form2.BorderIcons:=[];
   Form2.OnKeyDown:=Form2_OnKeyDown;
   // TextLabel1
   TextLabel1:= TextLabel.Create(Form2,8,12,34,13);
   TextLabel1.InitControl(True,True,alNone,crDefault,clBtnFace,'NAME:','');
   // Edit1
   Edit1:= Edit.Create(Form2,46,8,350,21);
   Edit1.InitControl(True,True,alNone,crDefault,clWindow,'','');
   // Button01
   Button01:= Button.Create(Form2,400,10,33,17);
   Button01.InitControl(True,True,alNone,crDefault,0,'OK','');
   Button01.OnClick:=Button01_OnClick;
   // Button02
   Button02:= Button.Create(Form2,440,10,33,17);
   Button02.InitControl(True,True,alNone,crDefault,0,'BACK','');
   Button02.OnClick:=Button02_OnClick;
   // OpenDialog1
   OpenDialog1:= OpenDialog.Create;
   OpenDialog1.InitialDir:=GetCurrentDir;
   OpenDialog1.Filter:= __ffilter;
   OpenDialog1.Title:= 'Open ' + __ftype;
   // SaveDialog1
   SaveDialog1:= SaveDialog.Create;
   SaveDialog1.InitialDir:=GetCurrentDir;
   SaveDialog1.Filter:= __ffilter;
   SaveDialog1.Title:= 'SAVE ' + __ftype;
   // Startup
   updmenu;
   Form1.Position:= poScreenCenter;
   Form1.Show;
 end;

procedure LoInit;
 begin
   // DB
   db:= tdb.create;
   _changed:= false;
   _autosave:= __autosave;
   // GraphABC
   SetFont();
   onkeydown:=onkeydown_graphabc;
   SetWindowPos(ScreenWidth, ScreenHeight); // Скрываем окно GraphABC
 end;

begin
 LoInit;
 InitControls;
end.


Последний раз редактировалось: _KROL (Вт Окт 16, 2018 8:07 pm), всего редактировалось 1 раз(а)

_KROL

Сообщения : 90
Дата регистрации : 2017-07-28
Возраст : 19
Откуда : Беларусь

Посмотреть профиль

Вернуться к началу Перейти вниз

Re: 4th vocabulary database on PABC

Сообщение автор _KROL в Вт Окт 16, 2018 8:06 pm

// Модуль db.pas
Код:
unit db;

uses vcl, containers;

type
 // pstringarraybase = ^stringarraybase;
 trec = class
   name: string;
   text: stringarraybase;
 end;
 tdb = class
 protected
   data: objectarray;
 public
   constructor create;
   procedure add(rec: trec);
   function getname(i: integer): string;
   procedure setname(i: integer; t: string);
   function gettext(i: integer): stringarraybase;
   procedure settext(i: integer; t: stringarraybase);
   function length: integer;
   function search(t: string): trec;
   procedure delete(i: integer);
   procedure clear;
   destructor destroy;
 end;
 
constructor tdb.create;
 begin
   data:= objectarray.create;
 end;
 
procedure tdb.add(rec: trec);
 begin
   data.add(rec);
 end;
 
function tdb.getname(i: integer): string;
var obj: trec;
 begin
   if (i > 0)and(i <= length) then
     begin
       obj:= trec(data[i]);
       getname:= obj.name;
     end
   else
     getname:= '';
 end;
 
procedure tdb.setname(i: integer; t: string);
var obj: trec;
 begin
   if (i > 0)and(i <= length) then
     begin
       obj:= trec(data[i]);
       obj.name:= t;
     end;
 end;
 
function tdb.gettext(i: integer): stringarraybase;
var obj: trec;
 begin
   if (i > 0)and(i <= length) then
     begin
       obj:= trec(data[i]);
       gettext:= obj.text;
     end
   else
     gettext:= nil;
 end;

procedure tdb.settext(i: integer; t: stringarraybase);
var obj: trec; j: integer;
 begin
   if (i > 0)and(i <= length)and(t <> nil) then
     begin
       obj:=trec(data[i]);
       obj.text.clear;
       for j:=1 to t.count do
         obj.text.add(t[j]);
     end;
 end;

function tdb.length: integer;
 begin
   length:= data.count;
 end;
 
function tdb.search(t: string): trec;
var i:integer; r:trec;
 begin
   for i:=1 to length do
     if t = trec(data[i]).name then
       begin
         search:=trec(data[i]);
         exit;
       end;
   r:= trec.create;
   r.name:= '';
   r.text:= nil;
   search:= r;
 end;
 
procedure tdb.delete(i: integer);
 begin
   if (i > 0)and(i <= length) then
     data.delete(i);
 end;
 
procedure tdb.clear;
var i: integer;
 begin
   for i:=1 to length do
     data[i].destroy;
   data.clear;
 end;
 
destructor tdb.destroy;
 begin
   data.destroy;
 end;

begin
end.

_KROL

Сообщения : 90
Дата регистрации : 2017-07-28
Возраст : 19
Откуда : Беларусь

Посмотреть профиль

Вернуться к началу Перейти вниз

Re: 4th vocabulary database on PABC

Сообщение автор _KROL в Вт Окт 16, 2018 8:10 pm


Формат файла:
Код:
::::::::::::
:::::::::::: hello
: hello
  ." Hello World!"
;
;;;;;;;;;;;;

_KROL

Сообщения : 90
Дата регистрации : 2017-07-28
Возраст : 19
Откуда : Беларусь

Посмотреть профиль

Вернуться к началу Перейти вниз

Re: 4th vocabulary database on PABC

Сообщение автор Gudleifr в Ср Окт 17, 2018 12:27 pm

Я понял так:

1. Цели и средства:
Язык A - объектно-ориентированная разновидность PASCAL. Способ использования ООП - "чтоб как у людей". В части использования WinAPI - "быдлокодерский".
Язык F - Две машины: 1) язык Win-Controls (цикл замкнут в Win-форме), 2) язык словаря (только часть первого цикла).
Язык P - не просматривается.

1. Составные части 1-й машины:
ОК - Управление ПОТОКОМ Win-сообщений.
СИМВОЛ - Интерпретация Win-сообщений.
ИСПОЛНИТЬ - Исполнение Win-сообщений, запуск 2-й машины.
КОМПИЛИРОВАТЬ - Заполнение ассоциативного массива (СЛОВАРЯ 2-й машины) вручную.
СЛЕДУЮЩИЙ - Обычная Win-PASCAL-программа (r-code).

2. Составные части 2-й машины:
ОК - Чтение файла.
СИМВОЛ - Осуществляет поиск символа в ассоциативном массиве (СЛОВАРЕ).
ИСПОЛНИТЬ - см. КОМПИЛИРОВАТЬ, за исключением регистрации меток начала-конца и сохранения СЛОВАРЯ в файл.
КОМПИЛИРОВАТЬ - Добавляет символ в ассоциативный массив (СЛОВАРЬ).
СЛЕДУЮЩИЙ - реализуется первой машиной, при сохранении СЛОВАРЯ в файл - перебор СЛОВАРЯ по порядку (n-code).

Правильно?
avatar
Gudleifr
Admin

Сообщения : 931
Дата регистрации : 2017-03-29

Посмотреть профиль

Вернуться к началу Перейти вниз

Re: 4th vocabulary database on PABC

Сообщение автор _KROL в Ср Окт 17, 2018 10:18 pm

Думаю да...

_KROL

Сообщения : 90
Дата регистрации : 2017-07-28
Возраст : 19
Откуда : Беларусь

Посмотреть профиль

Вернуться к началу Перейти вниз

Re: 4th vocabulary database on PABC

Сообщение автор Gudleifr в Чт Окт 18, 2018 11:21 am

Тогда становится интересно, что будет дальше.
avatar
Gudleifr
Admin

Сообщения : 931
Дата регистрации : 2017-03-29

Посмотреть профиль

Вернуться к началу Перейти вниз

Re: 4th vocabulary database on PABC

Сообщение автор Спонсируемый контент


Спонсируемый контент


Вернуться к началу Перейти вниз

Вернуться к началу


 
Права доступа к этому форуму:
Вы не можете отвечать на сообщения