Это популярное сообщение. Victor Опубликовано: 19 июня, 2015 Это популярное сообщение. Жалоба Share Опубликовано: 19 июня, 2015 В присоединённом файле публикую свою программу. По этой ссылке доступны официальные сведения о ней. А ниже представлен её исходный код: 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 Цитата Ссылка на комментарий Поделиться на других сайтах More sharing options...
Рекомендованные сообщения
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.