Victor

Сухоруков В.В. Композиционная валидность В-индекса

Recommended Posts

В присоединённом файле публикую свою программу. По этой ссылке доступны официальные сведения о ней. А ниже представлен её исходный код:

 

unit churpat;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Menus;



type
Tpgcbas = array[1..5] of byte;
Tpgcadd = array[1..6] of byte;
Tsgcall = array[1..5] of int64;

TForm1 = class(TForm)
    Start: TButton;
    Demonstrator: TListBox;
    BasicQuestions: TGroupBox;
    NumberQuestions: TComboBox;
    NumberAnswers: TComboBox;
    AnswerTypology: TComboBox;
    AdditionalQuestions: TGroupBox;
    One: TRadioButton;
    Two: TRadioButton;
    UseSecondPart: TCheckBox;
    LabelQuestions: TLabel;
    LabelTypology: TLabel;
    LabelGroup: TLabel;
    LabelAnswers: TLabel;
    Bevel2: TBevel;
    LimitSecondPart: TCheckBox;
    Bevel1: TBevel;
    LabelLimit: TLabel;
    LabelAuthor: TLabel;
    LabelPart: TLabel;
    UseFirstPart: TCheckBox;
    Bevel3: TBevel;
    Bevel4: TBevel;
    StaticText1: TStaticText;
    StaticText2: TStaticText;
    StaticText3: TStaticText;
    StaticText4: TStaticText;
    StaticText5: TStaticText;
    StaticText6: TStaticText;
    GetHelp: TButton;

    procedure NumberQuestionsChange(Sender: TObject);
    procedure NumberAnswersChange(Sender: TObject);
    procedure AnswerTypologyChange(Sender: TObject);
    procedure UseFirstPartClick(Sender: TObject);
    procedure UseSecondPartClick(Sender: TObject);
    procedure OneClick(Sender: TObject);
    procedure TwoClick(Sender: TObject);
    procedure StartClick(Sender: TObject);
    procedure Demonstrating(SGCall: Tsgcall; SGCsum: int64);
    procedure Making (PGCbas: Tpgcbas);
    procedure Correcting (PGCadd: Tpgcadd);
    procedure Blocking(x1, x2, x3: integer);
    procedure Starting(var questions, answers, typology, kindadd, limit: byte; var SGCall: Tsgcall; var SGCsum: int64);
    procedure Cyclebodybas (y: Tpgcbas);
    procedure Cyclebodyadd (z: Tpgcadd);
    procedure LimitSecondPartClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure LabelLimitClick(Sender: TObject);
    procedure GetHelpClick(Sender: TObject);







  private
    { Private declarations }
  public
    { Public declarations }
  end;



const
titlesSGC: array[1..5] of string = ('О (очень слабо воцерковлённые, нулевая группа)', 'С (слабо воцерковлённые)', 'Н (немного воцерковлённые, начинающие)', 'П (полувоцерковлённые)', 'Ц (церковный народ, воцерковлённые)');
titlesservice: array[1..4] of string = ('Распределение ПГВ по ВГВ.', '    ', ' - ', 'Итого ПГВ: ');
titlebutton = 'Начать вычисления';
numq=1; numa=2; {это первые числа в списках вопросов и ответов соответственно}
{blockcolor: array[1..2] of TColor = (clRed, clFuchsia);}


var
  Form1: TForm1;
  PGCbas: Tpgcbas; PGCadd: Tpgcadd; {первичная группа воцерковлённости}
  SGCall: Tsgcall;  {количество первичных групп воцерковлённости во вторичных}
  SGCbas, limit, typology, questions, answers, kindadd, finaladd: byte;
  SGCsum: int64; {общее количество ПГВ, распределённых по всем ВГВ}
  blockedby: array[1..2] of boolean;
  blocklabel: array[1..4] of Tlabel;
  flaglimit: integer;
  labadd: array[1..6] of TStaticText;
  blockcolor: array[1..2] of TColor;


implementation

{$R *.dfm}






                   {РАСЧЁТНАЯ ЧАСТЬ}


procedure TForm1.Making (PGCbas: Tpgcbas);
var bq1, bq2, bq3, bq4, bq5: byte; {основные вопросы}
begin
for bq1:=1 to answers do
    begin
    PGCbas[1]:=bq1;
    if questions > 1
       then for bq2:=1 to answers do
                begin
                PGCbas[2]:=bq2;
                if questions > 2
                   then for bq3:=1 to answers do
                            begin
                            PGCbas[3]:=bq3;
                            if questions > 3
                               then for bq4:=1 to answers do
                                        begin
                                        PGCbas[4]:=bq4;
                                        if questions > 4
                                           then for bq5:=1 to answers do
                                                    begin
                                                    PGCbas[5]:=bq5;
                                                    Cyclebodybas(PGCbas);
                                                    end
                                           else Cyclebodybas(PGCbas);
                                        end
                               else Cyclebodybas(PGCbas);
                            end
                   else Cyclebodybas(PGCbas);
                end
       else Cyclebodybas(PGCbas);
    end;
end;



procedure TForm1.Cyclebodybas (y: Tpgcbas);
var i, j, k, g: byte; x: Tpgcbas;
begin
x:=y;
{пузырьковая сортировка основных вопросов по возрастанию}
for i:=1 to questions-1 do for j:=1 to questions-1 do if x[j]>x[j+1] then begin k:=x[j+1]; x[j+1]:=x[j]; x[j]:=k; end;
{определение и подсчёт вторичной группы воцерковлённости по основным вопросам или запуск исправления}
for g:=1 to answers do if g=x[typology] then if (kindadd=0) then SGCall[g]:=SGCall[g]+1 else begin SGCbas:=g; Correcting (PGCadd); end;
end;


procedure TForm1.Correcting (PGCadd: Tpgcadd);
var aq1, aq2, aq3, aq4, aq5, aq6: byte; {дополнительные вопросы}
begin
for aq1:=1 to 4 do
    begin
    PGCadd[1]:=aq1;
    for aq2:=1 to 4 do
        begin
        PGCadd[2]:=aq2;
        for aq3:=1 to 4 do
            begin
            PGCadd[3]:=aq3;
            if kindadd > 1
               then for aq4:=1 to 4 do
                        begin
                        PGCadd[4]:=aq4;
                        if (kindadd=2) or (kindadd=4)
                           then for aq5:=1 to 4 do
                                    begin
                                    PGCadd[5]:=aq5;
                                    for aq6:=1 to 4 do
                                        begin
                                        PGCadd[6]:=aq6;
                                        Cyclebodyadd(PGCadd);
                                        end;
                                    end
                           else Cyclebodyadd(PGCadd);
                        end
               else Cyclebodyadd(PGCadd);
            end;
        end;
    end;
end;



procedure TForm1.Cyclebodyadd (z: Tpgcadd);
var  m, n, f: byte;
{первый индекс в массиве - группа дополнительных вопросов (первая или вторая), второй - тип ответа (слабый или сильный)}
groupspositions: array [1..2, 1..2] of byte;
wasinc: boolean;
begin
for m:=1 to 2 do for n:=1 to 2 do groupspositions[m,n]:=0; wasinc:=false;
case kindadd of
     1: begin
        for m:=1 to 3 do if z[m]>2 then groupspositions[1,2]:=groupspositions[1,2]+1;
        if (groupspositions[1,2]>1) and (SGCbas<answers) then begin SGCbas:=SGCbas+1; wasinc:=true; end;
        for f:=1 to answers do if f=SGCbas then SGCall[f]:=SGCall[f]+1;
        if wasinc=true then SGCbas:=SGCbas-1;
        end;
     2: begin
        for m:=1 to 3 do begin
                         if z[m]>2 then groupspositions[1,2]:=groupspositions[1,2]+1;
                         if z[m]=2 then groupspositions[1,1]:=groupspositions[1,1]+1;
                         end;
        for n:=4 to 6 do if z[n]>2 then groupspositions[2,2]:=groupspositions[2,2]+1;
        if (groupspositions[1,2]>1) and (SGCbas<answers) then begin SGCbas:=SGCbas+1; wasinc:=true; end;
        if (groupspositions[1,1]>1) and (groupspositions[2,2]>1) and (SGCbas<limit) then begin SGCbas:=SGCbas+1; wasinc:=true; end;
        for f:=1 to answers do if f=SGCbas then SGCall[f]:=SGCall[f]+1;
        if wasinc=true then SGCbas:=SGCbas-1;
        end;
     3: begin
        for m:=1 to 4 do if z[m]>2 then groupspositions[1,2]:=groupspositions[1,2]+1;
        if (groupspositions[1,2]>2) and (SGCbas<answers) then begin SGCbas:=SGCbas+1; wasinc:=true; end;
        for f:=1 to answers do if f=SGCbas then SGCall[f]:=SGCall[f]+1;
        if wasinc=true then SGCbas:=SGCbas-1;
        end;
     4: begin
        for m:=1 to 4 do begin
                         if z[m]>2 then groupspositions[1,2]:=groupspositions[1,2]+1;
                         if z[m]=2 then groupspositions[1,1]:=groupspositions[1,1]+1;
                         end;
        for n:=5 to 6 do if z[n]>2 then groupspositions[2,2]:=groupspositions[2,2]+1;
        if (groupspositions[1,2]>2) and (SGCbas<answers) then begin SGCbas:=SGCbas+1; wasinc:=true; end;
        if (groupspositions[1,1]>2) and (groupspositions[2,2]>1) and (SGCbas<limit) then begin SGCbas:=SGCbas+1; wasinc:=true; end;
        for f:=1 to answers do if f=SGCbas then SGCall[f]:=SGCall[f]+1;
        if wasinc=true then SGCbas:=SGCbas-1;
        end;
     else messagebox(handle, 'Странная комбинация настроек дополнительных вопросов', 'Досадная недоработка', mb_OK+mb_iconwarning);
end;

end;

                   {/РАСЧЁТНАЯ ЧАСТЬ}


                   {ПОЛЬЗОВАТЕЛЬСКАЯ ЧАСТЬ}


procedure TForm1.FormCreate(Sender: TObject);
var c: byte;
begin
Application.HintColor:=RGB(185, 120, 255); Application.HintPause:=0; Application.HintHidePause:=20000; flaglimit:=1;
Start.Caption:=titlebutton; LimitSecondPart.Color:=LabelLimit.Color; LimitSecondPart.Hint:=LabelLimit.Hint;
blockcolor[1]:=RGB(255, 200, 25); blockcolor[2]:=RGB(241, 130, 122);
blocklabel[1]:=LabelQuestions; blocklabel[2]:=LabelAnswers; blocklabel[3]:=LabelTypology; blocklabel[4]:=LabelLimit;
labadd[1]:=StaticText1; labadd[2]:=StaticText2; labadd[3]:=StaticText3;
labadd[4]:=StaticText4; labadd[5]:=StaticText5; labadd[6]:=StaticText6;
for c:=1 to 6 do begin labadd[c].Height:=24; labadd[c].Width:=24; end;
end;

procedure TForm1.LabelLimitClick(Sender: TObject); {эта процедура нужна для малозаметности того, что текст отдельно от checkbox}
begin
Demonstrator.Clear;
if LimitSecondPart.Checked=true then LimitSecondPart.Checked:=false else LimitSecondPart.Checked:=true;
end;

procedure TForm1.OneClick(Sender: TObject);
var o: byte;
begin
Demonstrator.Clear;
for o:=1 to 6 do labadd[o].Top:=120;
labadd[6].Left:=580;
end;

procedure TForm1.TwoClick(Sender: TObject);
var o: byte;
begin
Demonstrator.Clear;
for o:=1 to 6 do labadd[o].Top:=160;
labadd[6].Left:=370;
end;

procedure TForm1.StartClick(Sender: TObject);
begin
Demonstrator.Clear;
Starting(questions, answers, typology, kindadd, limit, SGCall, SGCsum); {начальные значения переменных}
Making(PGCbas);
Demonstrating(SGCall, SGCsum); {вывод результатов}
end;


procedure TForm1.Starting(var questions, answers, typology, kindadd, limit: byte; var SGCall: Tsgcall; var SGCsum: int64);
var s: byte;
begin
for s:=1 to 5 do SGCall[s]:=0; SGCsum:=0;
questions:=NumberQuestions.ItemIndex+numq; answers:=NumberAnswers.ItemIndex+numa;
case AnswerTypology.ItemIndex of
     0: typology:=1;
     1: typology:=(questions div 2) + 1;
     2: typology:=questions;
     else messagebox(handle, 'В списке типологий слишком много значений', 'Досадная недоработка', mb_OK+mb_iconwarning);
end;
if UseFirstPart.Checked=false
   then kindadd:=0
   else if One.Checked=true
           then if UseSecondPart.Checked=false
                   then kindadd:=1
                   else begin
                        kindadd:=2;
                        if LimitSecondPart.Checked=true
                           then limit:=(answers div 2) + 1
                           else limit:=answers;
                        end
           else if UseSecondPart.Checked=false
                   then kindadd:=3
                   else begin
                        kindadd:=4;
                        if LimitSecondPart.Checked=true
                           then limit:=(answers div 2) + 1
                           else limit:=answers;
                        end;
end;


procedure TForm1.Demonstrating(SGCall: Tsgcall; SGCsum: int64);
var d: byte;
begin
Demonstrator.Items[0]:=titlesservice[1];
for d:=1 to answers do
    begin
    Demonstrator.Items[d]:=titlesservice[2]+titlesSGC[d]+titlesservice[3]+floattostr(SGCall[d]);
    SGCsum:=SGCsum+SGCall[d];
    end;
Demonstrator.Items[answers+1]:=titlesservice[4]+inttostr(SGCsum);
messagebox(handle, 'Программа отработала в штатном режиме.', 'Вычисления закончены', mb_OK+mb_iconinformation);
end;



{блокировочные процедуры}

{блокировка по чётности и медианности}

procedure TForm1.Blocking(x1, x2, x3: integer);
var b, idresult: byte; blockedbyanother: boolean;
label fix;
begin
Demonstrator.Clear;
if (x1 mod 2 = 0) and (x2 = 1)
   then if blocklabel[x3].Color=blockcolor[x3]
           then begin
                messagebox(handle, 'Вы нарушили указание по решению технической проблемы, созданной Вами же.', 'Печальный факт', mb_OK+mb_iconwarning);
                goto fix;
                end
           else begin
                Start.Enabled:=false; blocklabel[x3].Color:=blockcolor[x3]; blocklabel[x3+2].Color:=blockcolor[x3];
                messagebox(handle, 'Если множество неметрических элементов имеет чётную мощность, то в нём нет медианы.', 'Фундаментальная проблема', mb_OK+mb_iconerror);
                messagebox(handle, 'Присвоив отмеченным параметрам текущие значения, Вы создали технический аналог фундаментальной проблемы, поэтому кнопка "'+titlebutton+'" заблокирована.', 'Техническая проблема', mb_OK+mb_iconwarning);
                fix:
                idresult:=messagebox(handle, 'Вы хотите исправить свою ошибку?', 'Психологический вопрос', mb_YesNo+mb_iconquestion);
                if idresult=idyes
                   then messagebox(handle, 'Чтобы разблокировать кнопку "'+titlebutton+'", поменяйте хотя бы одну из выделенных одинаковым цветом настроек, выбрав нечётное количество или отказавшись от использования медианы.', 'Важный совет', mb_OK+mb_iconwarning)
                   else begin
                        messagebox(handle, 'В сложившейся ситуации программе нецелесообразно продолжать работу с Вами.', 'Критический момент', mb_OK+mb_iconwarning);
                        Application.Terminate;
                        end;
                end
   else if blocklabel[x3].Color=blockcolor[x3]
           then begin
                blocklabel[x3].Color:=Form1.Color; blocklabel[x3+2].Color:=Form1.Color; blockedbyanother:=false;
                for b:=1 to 4 do if blocklabel[b].Color<>Form1.Color then blockedbyanother:=true;
                if blockedbyanother=true
                   then messagebox(handle, 'Одна техническая проблема уже решена, но другая - ещё нет, поэтому кнопка "'+titlebutton+'" до сих пор заблокирована.', 'Недостаточный прогресс', mb_OK+mb_iconwarning)
                   else begin
                        for b:=1 to 4 do blocklabel[b].Color:=Form1.Color;
                        Start.Enabled:=true;
                        messagebox(handle, 'Теперь кнопка "'+titlebutton+'" разблокирована.', 'Достаточный прогресс', mb_OK+mb_iconinformation);
                        end;
                end;
end;


procedure TForm1.NumberQuestionsChange(Sender: TObject);
begin
Blocking(NumberQuestions.Itemindex+numq, AnswerTypology.Itemindex, numq);
end;

procedure TForm1.AnswerTypologyChange(Sender: TObject);
begin
Blocking(NumberQuestions.Itemindex+numq, AnswerTypology.Itemindex, numq);
end;

procedure TForm1.NumberAnswersChange(Sender: TObject);
begin
Blocking(NumberAnswers.Itemindex+numa, flaglimit, numa);
end;

procedure TForm1.LimitSecondPartClick(Sender: TObject);
begin
if LimitSecondPart.Checked=false then flaglimit:=0 else flaglimit:=1;
Blocking(NumberAnswers.Itemindex+numa, flaglimit, numa);
end;

{/блокировка по чётности и медианности}

{блокировка по частям вопросов}

procedure TForm1.UseFirstPartClick(Sender: TObject);
begin
Demonstrator.Clear;
if UseFirstPart.Checked=true
   then begin One.Enabled:=true; Two.Enabled:=true; UseSecondPart.Enabled:=true; end
   else begin One.Enabled:=false; Two.Enabled:=false; UseSecondPart.Enabled:=false; UseSecondPart.Checked:=false; end;
end;

procedure TForm1.UseSecondPartClick(Sender: TObject);
begin
Demonstrator.Clear;
if UseSecondPart.Checked=true
   then begin LabelLimit.Enabled:=true; LabelLimit.ShowHint:=true; LimitSecondPart.Enabled:=true; end
   else begin LabelLimit.Enabled:=false; LabelLimit.ShowHint:=false; LimitSecondPart.Enabled:=false; LimitSecondPart.Checked:=false; end;
end;

{/блокировка по частям вопросов}

{/блокировочные процедуры}



procedure TForm1.GetHelpClick(Sender: TObject);
begin
messagebox(handle, 'Чеснокова В.Ф. Тесным путем: Процесс воцерковления населения России в конце XX века.- М.: Академический Проект, 2005.- 304 с.', 'Социологический первоисточник', mb_OK+mb_iconinformation);
end;


                   {/ПОЛЬЗОВАТЕЛЬСКАЯ ЧАСТЬ}



end. 

Композиционная валидность В-индекса.exe

  • Хорошо 2

Поделиться этим сообщением


Ссылка на сообщение
Поделиться на других сайтах

Создайте аккаунт или авторизуйтесь, чтобы оставить комментарий

Комментарии могут оставлять только зарегистрированные пользователи

Создать аккаунт

Зарегистрировать новый аккаунт в нашем сообществе. Это несложно!

Зарегистрировать новый аккаунт

Войти

Есть аккаунт? Войти.

Войти