IPB
ЛогинПароль:

> Игра "Виселица"
сообщение
Сообщение #1


Гость






uses crt; 
type
 tWiselicaSymbol=record
   x,y:byte; {Координаты символа}
   s:char;   {Номер символа}
   c:byte;   {Цвет символа}
 end;
 tWiselica=array[1..13] of tWiselicaSymbol;
 tSetOfChar=set of char;
const
 wiselica:tWiselica=((x:0;y:4;s:'¦';c:15),(x:0;y:3;s:'¦';c:15),(x:0;y:2;s :'¦';c:15),(x:0;y:1;s:'¦';c:15),
                     (x:0;y:0;s:'г';c:15),(x:1;y:0;s:'=';c:15),(x:2;y:0;s:'=';c:15),(x:3;y:0; s:'¬';c:15),
                     (x:3;y:1;s:'o';c:14), (x:3;y:2;s:'O';c:9), (x:2;y:2;s:'/';c:6), (x:4;y:2;s:'';c:6),
                     (x:3;y:3;s:'П';c:6));
var
 ourword:string;
 WordCharSet:tSetOfChar;
 quit:boolean;
 popitka:byte;
 c:string[1];

function GetRandomWordFromFile(FileName:string):string;
var {Возвращает случайным образом слово из файла FileName}
 f:text;
 p,o:word;
 s:string;
begin
 assign(f,filename);
 reset(f);
 p:=0;
 while not eof(f) do
 begin
   readln(f);
   inc(p);
 end;
 close(f);
 reset(f);
 o:=random(p)+1;
 p:=0;
 while not eof(f) do
 begin
   readln(f,s);
   inc(p);
   if p=o then break;
 end;
 close(f);
 GetRandomWordFromFile:=s;
end;

procedure ShowPartOfWiselica(x,y,PartNumber:byte);
begin {Изображает на экране в заданном месте определённую часть виселицы}
 if PartNumber=0 then exit;
 gotoxy(x+wiselica[PartNumber].x,y+wiselica[PartNumber].y);
 textcolor(wiselica[PartNumber].c);
 write(wiselica[PartNumber].s);
 textcolor(7);
 gotoxy(1,1);
end;

procedure ShowWord(x,y:byte);
var p:byte; {Показывает слово, учитывая известные буквы}
begin
 gotoxy(x,y);
 textcolor(15);
 for p:=1 to length(ourword) do
 if ourword[p] in WordCharSet then write(ourword[p]) else write('.');
 gotoxy(1,1);
 textcolor(7);
end;

function CheckForAllLetters:boolean;
var p:byte; {Проверяет, все ли буквы уже отгаданы}
begin
 checkforallLetters:=true;
 for p:=1 to length(ourword) do if not (ourword[p] in WordCharSet) then checkforallLetters:=false;
end;

function CheckForLetterInWord(c:string):boolean;
begin {Проверяет, есть ли буква С в слове}
 if(pos(c,OurWord)<>0)and not (c[1] in WordCharSet) then CheckForLetterInWord:=true else CheckForLetterInWord:=false;
end;

function up(s:string):string;
var p:byte; {Поднимает символ в верхний регистр}
begin
 up[0]:=s[0];
 for p:=1 to length(s) do
   up[p]:=char(byte(s[p])-$20*byte(s[p]>#96)-$30*byte(s[p]>#$DF));
end;

begin
 randomize;
 ourword:=up(GetRandomWordFromFile('word.txt'));
 wordcharset:=[ourword[1]];
 wordcharset:=wordcharset+[ourword[length(ourword)]];
 clrscr;
 writeln(' ':31,'ИГРА "ВИСЕЛИЦА"');
 writeln;
 write('Слово:',' ':50,' Попыток осталось:');
 popitka:=0;
 repeat
   ShowWord(8,3);
   ShowPartOfWiselica(60,5,popitka);
   gotoxy(75,3);
   textcolor(15);
   write((13-popitka):2);
   textcolor(7);
   gotoxy(1,5+popitka);
   if popitka=13 then
   begin
     writeln;
     writeln('ВЫ ПРОИГРАЛИ !!!!');
     halt;
   end else
   if CheckForAllLetters then
   begin
     writeln;
     writeln('ВЫ ВЫИГРАЛИ !!!!');
     halt;
   end;
   write('Введите букву (ESC - выход): ');
   c:=up(readkey);
   if c=#27 then halt;
   gotoxy(29,5+popitka);
   textcolor(15);
   write©;
   textcolor(7);
   if CheckForLetterInWord© then WordCharSet:=WordCharSet+[c[1]] else
   begin
     write(' - НЕПРАВИЛЬНО !');
     inc(popitka);
   end;
 until false;
end.
 К началу страницы 
+ Ответить 
 
 Ответить  Открыть новую тему 
Ответов
сообщение
Сообщение #2


...
*****

Группа: Пользователи
Сообщений: 1 347
Пол: Мужской

Репутация: -  3  +


Проснулся smile.gif
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

Сообщений в этой теме
Clane   Игра "Виселица"   9.01.2003 3:42
Clane   Re: Игра "Виселица"   9.01.2003 3:43
Some1   Re: Игра "Виселица"   2.02.2003 17:54
AlaRic   Re: Игра "Виселица"   2.02.2003 22:19
Some1   Re: Игра "Виселица"   3.02.2003 0:43
AlaRic   Re: Игра "Виселица"   3.02.2003 1:00
Some1   Re: Игра "Виселица"   3.02.2003 1:44


 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 29.03.2024 0:49
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name