Program pro hru LODĚ. Program by měl umožnit hru dvou protihráčů nebo i hru proti počítači.

{ MCRT01.PAS                               Copyright (c) Ales Kucik }
{ Moje CRT ver. 01                                                  }
{ Modul s ruznymi uzitecnymi procedurami a funkcemi pro praci s v/v }
{                                                                   }
{ Datum:09.04.2002                             http://www.trsek.com }
 
unit MCRT01;
{
 KONSTANTY:
 
  page0, page1, page2, page3 - ofsety jednotlivych videostranek
  page_size - velikost videostranky (jen pro obrazovku 80x25)
 
 PROMENNE:
 
  ActivePage - aktivni videostranka;
  VideoSeg - segment pocatku videopameti
 
 PROCEDURY A FUNKCE:
 
 procedure SetCursor(h,d:byte);
   -nastavi velikost kurzoru (cisla v intervalu 0..7)
 
 procedure CursorOn;
   -nastavi velikost kurzoru na puvodni velikost
 
 procedure CursorOff;
   -skrije kurzor
 
 procedure GetChar(var character:char; var attr:byte);
   -cte znak z aktualni pozice kurzoru, vrati znak a jeho atribut
 
   Parametry:
   -character - vraci znak precteny z aktualni pozice kurzoru
   -attr - vraci cislo atributu precteneho znaku
 
 procedure SetActivePage(number:byte);
   -nastavi aktivni videostranku
 
   Parametr:
   -number - cila z intervalu 0..3
 
 procedure CopyPage(source, destination:word);
   -kopirovani videostranek (!! ZADAVAT OFSETY!!)
 
   Parametry:
   -source - ofset zdrojove videostranky
   -destination - oset cilove videostranky
 
 procedure WriteXY(x,y:byte; s:string);
   -zobrazi text na danych souradnicich
 
   Parametry:
   -x - cislo sloupce
   -y - cislo radky
   -s - text pro zobrazeni
 
 procedure HWriteXY(x,y,z,c:byte; s:string);
   -zobrazi text na danych souradnicich s jednim zviraznenym pismenem
 
   Parametry:
   -x - cilo sloupce
   -y - cislo radky
   -z - cislo zvirazneneho znaku text. retezce
   -c - barva zvirazneni
 
 procedure NormalWin(x1,y1,x2,y2:byte);
   -vytvori okno o danych souradnicich
 
   Parametry:
   -x1,y1 - souradnice leveho horniho rohu okna (cislo sloupce, radku)
   -x2,y2 - souradnice praveho dolniho rohu okna (sloupe, radek)
 
 procedure ErrorMes(s:string);
   -zobrazi hlaseni o chybe, zlutym pismem na cervenem podklade a
    ceka na stisk libovolne klavesy
   -max 28 znaku
 
   Parametr:
   -s - hlaseni o chybe
 
 function YesNo:boolean;
   -pri stisku klaves 'A','a' vraci true
   -pri stisku klaves 'N','n' vraci false
 
 function YesNoQ(s:string):boolean;
   -zobrazi dotaz a ceka na stisk klaves 'a,'A' pro ANO
    (pak vrati true) nebo 'n','N' pro NE (pak vrati false)
   -max 28 znaku
 
   Parametr:
   -s - text. retezec otazky
 
 function GetKey:integer;
   -Vraci cislo stisknute klavesy. Jsou zde osetreny i specialni
    klavesy, ktere nejprve posilaji znak cislo 0 a potom dalsi.
    Rozliseni je provedeno prictenim 256 k hodnote znaku.
 
 
 function GetTextMode:byte;
   -vraci cislo textoveho modu, precteno z datove oblasti BIOSu
 
 function GetActivePage:byte;
   -vraci cislo aktivni videostranky
}
 
interface
uses Crt;
const
  page0= $0000;
  page1= $1000;
  page2= $2000;
  page3= $3000;
 
  page_size=$FA0;
 
 
var
  ActivePage:byte;
  VideoSeg:word;
 
procedure SetCursor(h,d:byte); {Cisla v intervalu 0..7}
procedure CursorOn;
procedure CursorOff;
procedure GetChar(var character:char; var attr:byte);
procedure SetActivePage(number:byte);
procedure CopyPage(source, destination:word);
procedure WriteXY(x,y:byte; s:string);
procedure HWriteXY(x,y,z,c:byte; s:string);
procedure NormalWin(x1,y1,x2,y2:byte);
procedure ErrorMes(s:string);
 
 
function YesNoQ(s:string):boolean;
function YesNo:boolean;
function GetKey:integer;
function GetTextMode:byte; {Vraci cislo textoveho modu}
function GetActivePage:byte;
 
 
implementation
 
 
procedure SetCursor; assembler;
asm
        mov        ah, 01b
        mov        cl, d
        mov        ch, h
        int        10h
end;
 
procedure CursorOn; assembler;
asm
        mov        ah, 01h
        mov        cl, 07h
        mov        ch, 06h
        int        10h
end;
 
procedure CursorOff; assembler;
asm
        mov        ah, 01h
        mov        cl, 20h
        mov        ch, 20h
        int        10h
end;
 
procedure GetChar(var character:char; var attr:Byte);
var l,h:byte;
begin
  asm
        mov     bh, 0h
        mov     ah, 8h
        int     $10
        mov     l, al
        mov     h, ah
  end;
  character:=chr(l);
  attr:=h;
end;
 
function GetTextMode;
var b:byte absolute 0:$0449;
begin
  GetTextMode:=b;
end;
 
procedure SetActivePage;
begin
  asm
        mov     ah, 05h
        mov     al, number
        int     10h
  end;
  ActivePage:=number;
end;
 
procedure CopyPage;
begin
  move(mem[VideoSeg:source],mem[VideoSeg:destination],page_size);
end;
 
function GetActivePage:byte;
begin
   GetActivePage:=ActivePage;
end;
 
function GetKey:integer;
var a:integer;
begin
  a:=ord(readkey);
  while a=0 do a:=256+ord(readkey);
  GetKey:=a;
end;
 
procedure WriteXY;
begin
  gotoxy(x,y);
  write(s);
end;
 
procedure HWriteXY;
var attr:byte;
begin
  gotoxy(x,y);
  attr:=textattr;
  write(s);
  textcolor(c);
  gotoxy(x+z-1,y);
  write(s[z]);
  textattr:=attr;
end;
 
procedure NormalWin;
var
  i,j:byte;
 
begin
  window(x1,y1,x2,y2);
  clrscr;
  gotoxy(2,1);
  write(#201);
  for i:=1 to x2-x1-3 do write(#205);
  write(#187);
  for i:=2 to y2-y1 do
    begin
      gotoxy(2,i);
      write(#186);
      gotoxy(x2-x1,i);
      write(#186);
    end;
  gotoxy(2,y2-y1+1);
  write(#200);
  for i:=1 to x2-x1-3 do write(#205);
  write(#188);
  if lastmode>=256 then
    window(1,1,80,50)
  else
    window(1,1,80,25);
end;
 
procedure ErrorMes;
var
  x,l:byte;
  attr:byte;
begin
  attr:=TextAttr;
  textcolor(yellow);
  textbackground(red);
  l:=length(s);
  if l<28 then l:=28;
  x:=(80-l)div 2 -2;
  NormalWin(x,11,x+l+4,14);
  writeXY(x+2,12,s);
  l:=(l-28)div 2;
  writeXY(x+l+2,13,'Neco stiskni!');
  GetKey;
  TextAttr:=attr;
end;
 
 
function YesNo:boolean;
var
  nr:integer;       {cislo stisknute klavesy}
  c:char;           {znak stisknute klavesy}
 
begin
  c:='x';           {prednastaveni hodnoty (ruzne od A a N)}
  repeat
    nr:=getkey;     {precteni cisla znaku}
    if nr<256 then c:=upcase(chr(nr));
  until c in ['A','N'];
  YesNo:= c='A';
end;
 
 
function YesNoQ(s:string):boolean;
var
  x,l:byte;
  attr:byte;
 
begin
  attr:=TextAttr;
  textcolor(lightgreen);
  textbackground(lightblue);
  l:=length(s);
  if l<28 then l:=28;
  x:=(80-l)div 2 -2;
  NormalWin(x,11,x+l+4,14);
  writeXY(x+2,12,s);
  l:=(l-28)div 2;
  writeXY(x+l+2,13,'Stiskni ''A''=ANO ''N''=NE');
  YesNoQ:=YesNo;
  TextAttr:=attr;
end;
 
begin
   ActivePage:=0;
   if GetTextMode=7 then VideoSeg:=$B000
   else VideoSeg:=$B800;
end.