Экспертная система Delphi.int.ru

Сообщество программистов
Общение, помощь, обмен опытом

Логин:
Пароль:
Регистрация | Забыли пароль?

Delphi.int.ru Expert

Другие разделы портала

Переход к вопросу:

#   

Статистика за сегодня:  


Лучшие эксперты

Подробнее »



Вопрос # 2 664

/ вопрос открыт /

Здравствуйте, эксперты! есть процедура генерации случайных вопросов (номеров) я внутри использую рекурсию ... немогли бы помочь исправить мою процедуру для выборки случайных чисел и чтобы они не повторялись только не рекурсивно ...ниже привел процедуру :

Приложение:
  1.  
  2.  
  3. var
  4.  
  5.  
  6.  
  7.  
  8.  
  9.  
  10.  
  11.  
  12.  
  13.  
  14. procedure TTestForm.QuestGen(N:integer);
  15. var
  16. i,qnum : integer;
  17. fnd:boolean;
  18. begin
  19. fnd:=FALSE;
  20.  
  21. IDQuest:=qnum;
  22. Showmessage(InttoStr(IDQuest));
  23. i:=1;
  24. while(i<=QCount)and not(fnd) do
  25. if (Qmass[i]=qnum)
  26. then fnd:=true
  27. else inc(i); QMass[qnum]:=qnum;
  28.  
  29.  
  30. if qsum = QCount then TestForm.Close;
  31.  
  32. end;
  33.  
  34.  
  35.  
  36.  
  37.  
  38. procedure TTestForm.DBOpenHTMLFile(var Q_N:integer; WB: TWebBrowser);
  39. var
  40. Flags: OLEVariant;
  41. FileName:string;
  42. i,CurRow,RCount:integer;
  43. begin
  44. Flags := 0;
  45. TestData.ADOQuery2.SQL.Text := 'Select QFileName,QTheme from Quest WHERE Quest.QTheme = '+ IntToStr(IDTest) +' GROUP BY QFileName,QTheme';
  46. TestData.ADOQuery2.Open;
  47.  
  48.  
  49. i:=1;
  50. while i<=RCount do
  51. begin
  52.  
  53. if Q_N = CurRow
  54. then begin
  55. // showmessage ('Nashli');
  56. TestData.ADOQuery2.Fields[0].AsString;
  57. FileName:=TestData.ADOQuery2.Fields[0].Value;
  58. WebBrowser1.Navigate(WideString(FileName), Flags, Flags, Flags, Flags);
  59. TestData.ADOQuery2.CursorPosChanged;
  60. end
  61. else // showmessage ('NE Nashli');
  62. inc(i);
  63. inc(CurRow);
  64. TestData.ADOQuery2.RecNo:=CurRow;
  65.  
  66. end;
  67. end;


Motor Вопрос ожидает решения (принимаются ответы, доступен мини-форум)

Вопрос задал: Motor (статус: Посетитель)
Вопрос отправлен: 20 апреля 2009, 03:08
Состояние вопроса: открыт, ответов: 1.

Ответ #1. Отвечает эксперт: min@y™

Для зарядки мозгов я взялся накропать тебе примерчик. Итак, берём массив целых чисел и заполняем его последовательно числами от 0 до (размер массива минус 1). Затем просто несколько (тысяч) раз переставляем пары случайных элементов внутри массива местами. Это даёт гарантию того, что все числа будут уникальные. Повторяющимся числам просто взяться неоткуда. После такой перетасовки можно брать из массива числа последовательно, они будут случайными и неповторяющмися.

Вот исходник с камментами:

program p2664;
 
{$APPTYPE CONSOLE}
 
const
  N = 300; // 1000 // Кол-во элементов
 
type
  TQMass = array[0..N - 1] of Integer;
 
// Перестановка местами двух целых чисел с использованием дополнительной переменной
{procedure Exchange(const P1, P2: PInteger);
var
  Temp: Integer;
begin
  Temp:= P1^;
  P1^:= P2^;
  P2^:= Temp;
end;}
 
// Перестановка местами двух целых чисел без использования дополнительной переменной.
// Работает в разы быстрее предыдущей.
procedure Exchange(const P1, P2: PInteger); assembler;
asm
  push [P1]
  push [P2]
  pop  [P1]
  pop  [P2]
end;
 
// Заполнение массива последовательными числами от 0 до N - 1
procedure FillQMass(var QMass: TQMass);
var
  Index: Integer;
begin
  for Index:= Low(TQMass) to High(TQMass) do
    QMass[Index]:= Index;
end;
 
// Тасование "колоды". Changes - кол-во перестановок
procedure RandomQMass(var QMass: TQMass; const Changes: Integer);
var
  Index, Index1, Index2: Integer;
begin
  for Index:= 0 to Changes - 1 do
    begin
      Index1:= Random(N);
      Index2:= Random(N);
      Exchange(@QMass[Index1], @QMass[Index2]);
    end;
end;
 
// Вывод массива на экран
procedure WriteQMass(const QMass: TQMass);
var
  Index: Integer;
begin
  for Index:= Low(TQMass) to High(TQMass) do
    Write(' ', QMass[Index]);
 
  WriteLn(#13#10);
end;
 
var
  QMass: TQMass;
 
begin
  Randomize();
  FillQMass(QMass); // Заполнение массива последовательными числами от 0 до N - 1
  WriteLn('  Source array: '); 
  WriteQMass(QMass); // Вывод массива на экран
 
  RandomQMass(QMass, 10000);
  WriteLn('  Changed array: ');
  WriteQMass(QMass); // Вывод массива на экран
 
  Write('  Press "ENTER" to exit... ');
  ReadLn;
end.

З.Ы. Советую на будущее вести счёт чего бы то ни было с НУЛЯ, а не с единицы. Так, имхо, удобнее.

Ответ отправил: min@y™ (статус: Доктор наук)
Время отправки: 20 апреля 2009, 08:59
Оценка за ответ: 5

Комментарий к оценке:  

Мини-форум вопроса

Всего сообщений: 6; последнее сообщение — 20 апреля 2009, 14:40; участников в обсуждении: 2.
min@y™

min@y™ (статус: Доктор наук), 20 апреля 2009, 08:24 [#1]:

Как же тяжко с утра в понедельник после Пасхи ковыряться в чужих исходниках!...

Лучше скажи прямо, что тебе нужно, а?
Предположу: есть числа от 1 до 1000. Их надо ПЕРЕТАСОВАТЬ, как колоду карт?
Делаю лабы и курсачи по Delphi и Turbo Pascal. За ПИВО! Пишите в личку, а лучше в аську. А ещё лучше - звоните в скайп!
Motor

Motor (статус: Посетитель), 20 апреля 2009, 14:07 [#2]:

Нужно генерировать случайное число (номер вопроса) от 1 до N , где N - количество вопросов в тесте (оно задается произвольно зависит от выбранного теста) .... необходимо чтобы числа генерировались случайным образом и без повторений и либо как функция возвращала результат либо во внешнюю переменную этот номер вопроса сохранялся ...далее он будет передан другой процедуре в качестве параметра которая будет искать его сверяя во БД и двигая курсор к нужному номеру производя при этом выборку данных. ....вся фишка в том что все работает и с моей прошлой (рекурсивной процедурой) просто не учитывается последний шаг .... т.е. отрабатывает все вопросы выводит а последний нет ....может я просто счетчик который учитывает найденные вопросы не там поставил ? ниже скинул исходник всего модуля.
Motor

Motor (статус: Посетитель), 20 апреля 2009, 14:10 [#3]:

var
IDUser: integer; // ID пользователя
IDTest: integer; // ID теста
IDQuest: integer; // ID вопроса
QCOUNT: integer; // Кол-во вопросов в тесте
TestTimeOut: boolean; // признак завершения теста

QMass : array [1..1000] of integer; // Массив вопросов
qsum:integer; // Сумма найденныйх (FND) вопросов

{$R *.dfm}



//============= Открытие HTML Файла из БД =====================================
procedure TTestForm.DBOpenHTMLFile(var Q_N:integer; WB: TWebBrowser);
var
Flags: OLEVariant;
FileName:string;
i,CurRow,RCount:integer;
begin
Flags := 0;
TestData.ADOQuery2.SQL.Text := 'Select QFileName,QTheme from Quest WHERE Quest.QTheme = '+ IntToStr(IDTest) +' GROUP BY QFileName,QTheme';
TestData.ADOQuery2.Open;
CurRow:=TestData.ADOQuery2.RecNo; // Номер записи (положение курсора)
RCount:=TestData.ADOQuery2.RecordCount; // Всего записей
i:=1;
while i<=RCount do
begin
// showmessage('КУРСОР ВОПРОСА : ' + IntToStr(CurRow));
if Q_N = CurRow
then begin
// showmessage ('Nashli');
TestData.ADOQuery2.Fields[0].AsString;
FileName:=TestData.ADOQuery2.Fields[0].Value;
WebBrowser1.Navigate(WideString(FileName), Flags, Flags, Flags, Flags);
TestData.ADOQuery2.CursorPosChanged;

end
else // showmessage ('NE Nashli');
inc(i);
inc(CurRow);
TestData.ADOQuery2.RecNo:=CurRow;

end;
end;


//============ Подсчет количества вопросов в теме =========================
function TTestForm.QThemeCount:integer;
var
count:integer; // переменная для подсчета кол-ва вопросов
begin
// ---------- Кол-во вопросов по теме ---------------------
TestData.ADOQuery1.SQL.Text := 'Select count(*),QTheme from Quest WHERE Quest.QTheme ='+ IntToStr(IDTest) +' GROUP BY QTheme';
TestData.ADOQuery1.Open;
count:= TestData.ADOQuery1.Fields[0].AsInteger; // открываем запрос "Вопросов"
QThemeCount:=count;
TestData.ADOQuery1.Close;
//---------------------------------------------------------
end;


//===================== Обнуление массива QMass вопросов =====================
procedure TTestForm.ClearQMass;
var
i:integer;
begin
for i:=1 to 1000 do
begin
QMass[i]:=-1; // очищаем массив под выборку
end;
end;

//===================== Генерация вопроса случайным образом ==================
procedure TTestForm.QuestGen(N:integer);
var
i,qnum : integer;
fnd:boolean;
begin
fnd:=FALSE;
qnum:=Random(N)+1; // выбираем случайным образом вопрос
IDQuest:=qnum;
// Showmessage(InttoStr(IDQuest));
i:=1;
while(i<=QCount)and not(fnd) do
if (Qmass[i]=qnum)
then fnd:=true
else inc(i); QMass[qnum]:=qnum;
if fnd then QuestGen(N); // рекурсия на Random отработку
if qsum = QCount then TestForm.Close;

end;


//==================== Закрытие формы =========================================
procedure TTestForm.SpeedButton2Click(Sender: TObject);
begin
TestForm.Close;
end;

//===================== При появлении формы теста задаем параметры ============
procedure TTestForm.FormShow(Sender: TObject);
begin
qsum:=0; // Обнуление суммы выданных вопросов
IDUser:=TestData.ADODataSet4id.Value; // Определяем ID пользователя
IDTest:=TestData.ADODataSet5id.Value; // Определяем ID темы теста
QCOUNT:=QThemeCount; // Кол-во вопросов в тесте
ClearQMass; // Обнуления массива вопросов
//DBOpenHTMLFile(IDQuest, WebBrowser1);

end;


//===================== При закрытии формы теста задаем параметры ============
procedure TTestForm.FormDestroy(Sender: TObject);
begin
TestData.ADOQuery1.Close; // Закрываем запрос Вопросов
IDUser:=0; // ID пользователя
IDTest:=0; // ID теста
QCOUNT:=0; // Кол-во вопросов в тесте
qsum:=0; // Обнуление суммы выданных вопросов
ClearQMass; // Обнуления массива вопросов
end;

//====================== Обработчик кнопки ОТВЕТИТЬ ==========================
procedure TTestForm.SpeedButton1Click(Sender: TObject);
begin
QuestGen(QCount);
// ShowMessage('ВОПРОС № : ' + IntToStr(IDQuest))
DBOpenHTMLFile(IDQuest, WebBrowser1);


end;

procedure TTestForm.FormCreate(Sender: TObject);
begin
Randomize;
end;


// if qsum = QCount then TestForm.Close; -срабатывает раньше времени т.е. закрывает окно формы а потом выводит уже в него вопрос ...и никак от этого не могу избавиться :(
min@y™

min@y™ (статус: Доктор наук), 20 апреля 2009, 14:22 [#4]:

Я не буду ковыряться в твоих исходниках. Воспользуйся моим примером и не мучайся.
Делаю лабы и курсачи по Delphi и Turbo Pascal. За ПИВО! Пишите в личку, а лучше в аську. А ещё лучше - звоните в скайп!
Motor

Motor (статус: Посетитель), 20 апреля 2009, 14:34 [#5]:

пасиба буду разбираться
min@y™

min@y™ (статус: Доктор наук), 20 апреля 2009, 14:40 [#6]:

А чо там разбираться-то? Всё просто, как веник.
Делаю лабы и курсачи по Delphi и Turbo Pascal. За ПИВО! Пишите в личку, а лучше в аську. А ещё лучше - звоните в скайп!

Чтобы оставлять сообщения в мини-форумах, Вы должны авторизироваться на сайте.

Версия движка: 2.6+ (26.01.2011)
Текущее время: 26 мая 2020, 01:19
Выполнено за 0.02 сек.
Рейтинг@Mail.ru