type TWordStr = string[100]; TDelimiter = set of Char; PTItem = ^TItem; TItem = record Data: TWordStr; next: PTItem; end; TWordList = record first, last: PTItem; end; procedure InsertWord(var L: TWordList; s: string); var p: PTItem; begin New(p); p^.Data := s; p^.next := nil; if L.first = nil then L.first := p else L.last^.next := p; L.last := p end; function GetWords(s: string; var L: TWordList; delimiters: TDelimiter): Byte; var i, p: Byte; begin for i := 1 to Length(s) do if s[i] In delimiters then s[i] := #32; repeat p := Pos(' ', s); if p > 0 then Delete(s, p, 1) until p = 0; if s[1] = ' ' then Delete(s, 1, 1); if s[Length(s)] = ' ' then Delete(s, Length(s), 1); i := 0; repeat p := Pos(' ', s); Inc(i); if p > 0 then begin InsertWord(L, Copy(s, 1, Pred(p))); Delete(s, 1, p) end else InsertWord(L, s) until p = 0; GetWords := i end; const max_answers = 10; type QuestType = (ans1, ans2, ans3, ans4, ans5); TS = record first, second: integer; end; TArrType = array[1 .. max_answers] of integer; TTest = record quest: string[50]; ans_count: 0 .. max_answers; answers: array[1 .. max_answers] of string[50]; case qType: QuestType of ans1: ( good_ans1: string[50]; ); ans2: ( good_ans2: integer; ); ans3: ( good_count3: 0 .. max_answers; good_ans3: array[1 .. max_answers] of integer; ); ans4: ( good_count4: 1 .. max_answers; good_ans4: array[1 .. max_answers] of TS; ); ans5: ( good_ans5: array[1 .. max_answers] of integer; ); end; TestFile = file of TTest; const msg: array[QuestType] of string = ( 'type #1 - enter the answer: ', 'type #2 - enter the good answer index: ', 'type #3 - enter the good answer index: ', 'type #4 - enter the pairs (first - second): ', 'type #5 - enter the good-sorted indexes: ' ); procedure get_quest(var R: TTest); function get_integer(const title: string; range_start, range_finish: integer): integer; var X: integer; begin write(title + '[', range_start, ' .. ', range_finish, '] '); repeat readln(X); until (X >= range_start) and (X <= range_finish); get_integer := X; end; var i, X: integer; begin write('question: '); readln(R.quest); R.qType := QuestType(get_integer('test', 1, 5) - 1); case R.qType of ans1: begin R.ans_count := 0; write(msg[ans1]); readln(R.good_ans1); end; ans2 .. ans5: begin R.ans_count := get_integer('answers count', 1, max_answers); for i := 1 to R.ans_count do begin write('answer #', i:2, '':2); readln(R.answers[i]); end; end; end; writeln('good answers:'); case R.qType of ans2: begin R.good_ans2 := get_integer(msg[ans2], 1, R.ans_count); end; ans3: begin R.good_count3 := 0; i := 1; repeat X := get_integer(msg[ans3] + ' (0 to finish) ', 0, R.ans_count); if X <> 0 then begin R.good_ans3[i] := X; inc(R.good_count3); inc(i); end; until X = 0; end; ans4: begin write(msg[ans4]); for i := 1 to R.ans_count do begin R.good_ans4[i].first := get_integer('first', 1, R.ans_count); R.good_ans4[i].second := get_integer('second', 1, R.ans_count); end; end; ans5: begin write(msg[ans5]); for i := 1 to R.ans_count do begin write('will be #', i); R.good_ans5[i] := get_integer('', 1, R.ans_count); end; end; end; end; function get_answer(const R: TTest): boolean; function find_shuffle(const shuffle_arr: TArrType; X: integer): Integer; var i: integer; begin find_shuffle := -1; for i := 1 to max_answers do if shuffle_arr[i] = X then begin find_shuffle := i; exit end; end; procedure print_options(b: boolean; var shuffle: TArrType); var i, k, X: integer; values: set of 1 .. max_answers; begin if b then begin values := []; for i := 1 to R.ans_count do begin repeat X := random(R.ans_count) + 1; until not (X in values); Include(values, X); shuffle[i] := X; end; end; for i := 1 to R.ans_count do begin if b then k := shuffle[i] else k := i; write(i:2, ') ', R.answers[k] + ' '); end; end; var s: string; { #1 } L: TWordList; p: ptitem; count, positive, negative: integer; { #2 } i, choice: integer; { #4 } pair: TS; j: integer; shuffle_arr: TArrType; begin writeln(msg[R.qType]); writeln(R.quest); case R.qType of ans1: begin readln(s); L.first := nil; count := GetWords(s, L, [#32]); p := L.first; positive := 0; negative := 0; while p <> nil do begin writeln(p^.Data); if pos(p^.Data, R.good_ans1) > 0 then inc(positive) else inc(negative); p := p^.next; end; get_answer := (positive > negative); end; ans2: begin print_options(true, shuffle_arr); writeln; write('your choice: '); readln(choice); get_answer := (choice = find_shuffle(shuffle_arr, R.good_ans2)); end; ans3: begin print_options(true, shuffle_arr); writeln; write('your choice: '); readln(choice); get_answer := false; for i := 1 to R.good_count3 do if choice = find_shuffle(shuffle_arr, R.good_ans3[i]) then get_answer := true; end; ans4: begin print_options(true, shuffle_arr); writeln; writeln('answer:'); count := 0; for i := 1 to R.ans_count do begin write('C1) '); readln(pair.first); write('C2) '); readln(pair.second); for j := 1 to R.ans_count do begin if (R.good_ans4[j].first = pair.first) and (R.good_ans4[j].second = pair.second) then inc(count); end; end; get_answer := (count = R.ans_count); end; ans5: begin print_options(true, shuffle_arr); writeln; writeln('answer (sorted index array)'); get_answer := true; for i := 1 to R.ans_count do begin write('-> '); readln(choice); if choice <> find_shuffle(shuffle_arr, R.good_ans5[i]) then get_answer := false; end; end; end; end; var Rec: TTest; F: TestFile; i, n: integer; b: boolean; begin assign(F, 'quest.dat'); {$i-} reset(F); {$i+} if ioResult <> 0 then begin rewrite(F); write('questions to enter: '); readln(n); for i := 1 to n do begin get_quest(Rec); write(F, Rec); end; reset(F); end else begin randomize; while not eof(F) do begin read(F, Rec); b := get_answer(Rec); writeln('result = ', b); end; end; close(F); end.