home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 February / Chip_2000-02_cd.bin / internet / BIBLECD / PREVOD.ZIP / FR_SOK.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-10-10  |  92.9 KB  |  2,707 lines
  1. {$N+}
  2. {$C FIXED PRELOAD PERMANENT}
  3. {┌────────────────────────────────────────────────────────┐
  4.  │Modul FR_SOK.TPU pro kreslení grafiky v textovém reæimu,│
  5.  │kreslení okének a dal¿í procedury.                      │
  6.  │Franti¿ek Sokolovskÿ, Praha 1995, 1996, 1997            │
  7.  └────────────────────────────────────────────────────────┘}
  8.  
  9. unit fr_sok;
  10.  
  11. INTERFACE
  12. uses    Crt,Chyby,Dos;
  13. const    hacky:String='çâêñ⌐¿ƒûæÇàëÑ₧¢åªÆ';
  14.     bezha:String='cdenrstuzCDENRSTUZ';
  15.     carky:String='áéíóúÿÅÉïòù¥';
  16.     bezca:String='aeiouyAEIOUY';
  17.     vypnuta=False;
  18.     zapnuta=True;
  19.  
  20.     NUL=0;        ShiftTab=15;
  21.     AltQ=16;    AltW=17;
  22.     AltE=18;    AltR=19;
  23.     AltT=20;    AltY=21;
  24.     AltU=22;    AltI=23;
  25.     AltO=24;    AltP=25;
  26.     AltA=30;    AltS=31;
  27.     AltD=32;    AltF=33;
  28.     AltG=34;    AltH=35;
  29.     AltJ=36;    AltK=37;
  30.     AltL=38;    AltZ=44;
  31.     AltX=45;    AltC=46;
  32.     AltV=47;    AltB=48;
  33.     AltN=49;    AltM=50;
  34.     F1=59;        F2=60;
  35.     F3=61;        F4=62;
  36.     F5=63;        F6=64;
  37.     F7=65;        F8=66;
  38.     F9=67;        F10=68;
  39.     Home=71;    Up=72;
  40.     PageUp=73;    Left=75;
  41.     Right=77;    KlavesaEnd=79;
  42.     Down=80;    PageDown=81;
  43.     Insert=82;    Delete=83;
  44.     ShiftF1=84;    ShiftF2=85;
  45.     ShiftF3=86;    ShiftF4=87;
  46.     ShiftF5=88;    ShiftF6=89;
  47.     ShiftF7=90;    ShiftF8=91;
  48.     ShiftF9=92;    ShiftF10=93;
  49.     CtrlF1=94;    CtrlF2=95;
  50.     CtrlF3=96;    CtrlF4=97;
  51.     CtrlF5=98;    CtrlF6=99;
  52.     CtrlF7=100;    CtrlF8=101;
  53.     CtrlF9=102;    CtrlF10=103;
  54.     AltF1=104;    AltF2=105;
  55.     AltF3=106;    AltF4=107;
  56.     AltF5=108;    AltF6=109;
  57.     AltF7=110;    AltF8=111;
  58.     AltF9=112;    AltF10=113;
  59.     CtrlPrintScreen=114;
  60.     CtrlLeft=115;    CtrlRigh=116;
  61.     CtrlEnd=117;    CtrlPageDown=118;
  62.     CtrlHome=119;
  63.     Alt1=120;    Alt2=121;
  64.     Alt3=122;    Alt4=123;
  65.     Alt5=124;    Alt6=125;
  66.     Alt7=126;    Alt8=127;
  67.     Alt9=128;    Alt10=129;
  68.     AltMinus=130;    AltRovnase=131;
  69.     CtrlPageUp=132;
  70. const    pocet0=16;
  71. type    smery=record
  72.       znak:Char;
  73.       nahoru,dolu,doleva,doprava:Boolean;
  74.     end;
  75.     PathStr=Dos.PathStr;
  76. type    PTextBuf = ^TTextBuf;
  77.     TTextBuf = array[0..127] of Char;
  78.     TTextRec = record
  79.       Handle: Word;
  80.       Mode: Word;
  81.       BufSize: Word;
  82.       Private: Word;
  83.       BufPos: Word;
  84.       BufEnd: Word;
  85.       BufPtr: PTextBuf;
  86.       OpenFunc: Pointer;
  87.       InOutFunc: Pointer;
  88.       FlushFunc: Pointer;
  89.       CloseFunc: Pointer;
  90.       UserData: array[1..16] of Byte;
  91.       Name: array[0..79] of Char;
  92.       Buffer: TTextBuf;
  93.     end;
  94.  
  95. const pole0:array[1..pocet0] of smery=(
  96.     (znak:'┌';nahoru:False;dolu:True;doleva:False;doprava:True),
  97.     (znak:'─';nahoru:False;dolu:False;doleva:True;doprava:True),
  98.     (znak:'─';nahoru:False;dolu:False;doleva:True;doprava:False),
  99.     (znak:'─';nahoru:False;dolu:False;doleva:False;doprava:True),
  100.     (znak:'┬';nahoru:False;dolu:True;doleva:True;doprava:True),
  101.     (znak:'┐';nahoru:False;dolu:True;doleva:True;doprava:False),
  102.     (znak:'│';nahoru:True;dolu:True;doleva:False;doprava:False),
  103.     (znak:'│';nahoru:False;dolu:True;doleva:False;doprava:False),
  104.     (znak:'│';nahoru:True;dolu:False;doleva:False;doprava:False),
  105.     (znak:'├';nahoru:True;dolu:True;doleva:False;doprava:True),
  106.     (znak:'┼';nahoru:True;dolu:True;doleva:True;doprava:True),
  107.     (znak:'┤';nahoru:True;dolu:True;doleva:True;doprava:False),
  108.     (znak:'└';nahoru:True;dolu:False;doleva:False;doprava:True),
  109.     (znak:'┴';nahoru:True;dolu:False;doleva:True;doprava:True),
  110.     (znak:'┘';nahoru:True;dolu:False;doleva:True;doprava:False),
  111.     (znak:'■';nahoru:False;dolu:False;doleva:False;doprava:False)
  112.     );
  113. type    zaznam=record f,p:Word;end;
  114.     TZnak=record Ascii,Barva:byte;end;
  115.     Tfce=function(cislo:Word):String;
  116. const    male :string[15]='áçâêéíñó⌐¿ƒúûÿæ';
  117.     mbez :string[15]='acdeeinorstuuyz';
  118.     velke:string[15]='ÅÇàëÉïÑò₧¢åùª¥Æ';
  119.     vbez :string[15]='ACDEEINORSTUUYZ';
  120.  
  121. var    stav,vrat,zvuk:Boolean;
  122.     zobraz:Boolean; {True - pokud jsou jiæ poloæky uæivatelskou funkcí
  123.     zobrazovány v menu p⌐i pouæití Menu5, False - pokud je pouze
  124.     vyhodnocována maximální délka poloæek
  125.     Pouæito v programu Jídla, kde je uæivatelskou funkcí vypisováno
  126.     na obrazovku, která je volána v Menu5 v první fázi Menu5 zji¿ƒuje
  127.     maximální délku poloæky menu vçetnê nápisu a v druhé fázi poloæky
  128.     uæ zapisuje do rolujícího se menu.}
  129.     pamatuj:Char;
  130.     cskod,posledni,MaxX,MaxY:Byte;
  131.     obraz:array[0..1999] of TZnak absolute $b800:$0000;
  132.     chyba:Integer;
  133.     Uziv1,Uziv2,Uziv3,Uziv4:Function:Boolean; {Volány funkcí "Posun2":
  134.     uziv1 p⌐ed pohybem kurzoru doprava
  135.     uziv2 p⌐ed pohybem kurzoru doleva
  136.     uziv3 p⌐ed pohybem kurzoru nahoru
  137.     uziv4 p⌐ed pohybem kurzoru dolu
  138. Poznámky:
  139. 1. Pokud tyto uæivatelské funkce vrátí True, provede se posun,
  140.    pokud False, posun kurzoru se neprovede.
  141. 2. Pokud nebudou tyto procedury definovány, pouæijí se standardní
  142.    funkce, která vædy vrátí True.
  143. 3. Programátor pouæívající tyto funkce mûæe svoji vlastní funkcí zakázat
  144.    pohyb kurzoru ve funkci Posun2 nebo udêlat nêjakou çinnost p⌐ed tím,
  145.    neæ se kurzor p⌐esune.
  146. 4. Definice své vlastní uæivatelské funkce:
  147.  
  148.  
  149.    function F1:Boolean;
  150.    begin
  151.      p⌐íkazy, které se provedou p⌐ed pohybem kurzoru doprava
  152.      F:=True; napi¿te v p⌐ípadê, æe opravdu chcete povolit p⌐esun kurzoru
  153.      jinak napi¿te F:=False;
  154.    end;
  155.  
  156.    function F2:Boolean;
  157.    begin
  158.      p⌐íkazy, které se provedou p⌐ed pohybem kurzoru doleva
  159.      F:=True; napi¿te v p⌐ípadê, æe opravdu chcete povolit p⌐esun kurzoru
  160.      jinak napi¿te F:=False;
  161.    end;
  162.  
  163.    function F3:Boolean;
  164.    begin
  165.      p⌐íkazy, které se provedou p⌐ed pohybem kurzoru nahoru
  166.      F:=True; napi¿te v p⌐ípadê, æe opravdu chcete povolit p⌐esun kurzoru
  167.      jinak napi¿te F:=False;
  168.    end;
  169.  
  170.    function F4:Boolean;
  171.    begin
  172.      p⌐íkazy, které se provedou p⌐ed pohybem kurzoru dolu
  173.      F:=True; napi¿te v p⌐ípadê, æe opravdu chcete povolit p⌐esun kurzoru
  174.      jinak napi¿te F:=False;
  175.    end;
  176.  
  177.    begin
  178.      Uziv1:=F1;
  179.      Uziv2:=F2;
  180.      Uziv3:=F3;
  181.      Uziv4:=F4;
  182.      promênná:=Posun2(parametry);
  183.    end.
  184.  
  185. ==============================================================================
  186.  
  187. Vÿhody:
  188. 1. Programátor nemusí vêdêt jak funguje funkce Posun2.
  189. 2. Programátor nemusí modifikovat zdrojovÿ test jednotky FR_SOK.
  190. 3. A hlavnê nemusí prohledávat dlouhÿ zdrojovÿ text této jednotky.
  191. }
  192.  
  193. procedure Bod(x,y:byte);
  194. procedure Usecka(xa,ya,xb,yb:integer);
  195. procedure Zacatek_Usecky(x,y:byte);
  196. procedure Konec_Usecky(x,y:byte);
  197. function  Klavesa:char;
  198. function  AnoNe(text:string):boolean;
  199. procedure Znak(x,y,ascii:byte);
  200. procedure Obdelnik(x,y,sirka,vyska,ram,pozadi:byte;typ:boolean);
  201. procedure Obdelnik2(x,y,sirka,vyska,ram,pozadi:byte;typ:boolean);
  202. procedure Kurzor(x,y,delka:byte);
  203. function  Posun(xmin,xmax,ymin,ymax:byte;var x,y:byte):byte;
  204. procedure Nastav;
  205. procedure P1(sirka:integer);
  206. procedure Zacatek(nadpis:string);
  207. procedure Radek(pom:string);
  208. procedure Radek2(pom:string;polozka:boolean);
  209. procedure Linka;
  210. function  Menu(x,y,ram:byte;kur:boolean):byte;
  211. function  Menu2(x,y,ram:byte;kur:boolean):byte;
  212. function  Zjisti(pol:byte):string;
  213. function  AnoNe2(text:string):boolean;
  214. procedure Zapni_Zvuk;
  215. procedure Vypni_Zvuk;
  216. procedure Sound1(f,d1,d2:word);
  217. procedure Sound2(f1,f2,d:word);
  218. procedure Proc1(text:string);
  219. procedure Proc2(text:string);
  220. function  Proc3(retezec1:string;cislo:real;retezec2:string):string;
  221. procedure Cekej;
  222. procedure Cekani0;
  223. procedure Dialogove_Okno;
  224. function  Hodiny:boolean;
  225. procedure Zapni_Hodiny(x,y:byte);
  226. procedure Vypni_Hodiny;
  227. function  Soubor_Existuje(jmeno:string):boolean;
  228. function  Menu3(x,y,ram:byte;kur:boolean):byte;
  229. function  Posun2(xmin,ymin,xmax,ymax,sirka,krokx,kroky:byte;var x,y:byte):byte;
  230. procedure Cekej2;
  231. procedure Kurzor2(x,y,delka:byte);
  232. procedure Cekani;
  233. function  Menu4(x,y,ram:byte;kur:boolean):byte;
  234. function  Dve(mocnina:Byte):Longint;
  235. function  TestBitu(hodnota:Longint;i:Byte):Boolean;
  236. function  Str(b:Longint):String;
  237. function  Str2(b:Longint;pocet:Byte):String;
  238. function  VyberSouboru(maska,text:String):String;
  239. function  Bin(n:Word):String;
  240. function  VyberJednotky(text:String):Char;
  241. function  Hacek(NadJakymPismenem:Char):Byte;
  242. function  Carka(NadJakymPismenem:Char):Byte;
  243. procedure Pipej(pole:Array of zaznam);
  244. function  Klavesa2:Char;
  245. procedure TvarKurzoru(StartLine,EndLine:Byte);
  246. function  CtiString(zprava:String):String;
  247. function  CtiString2(zprava:String;PouzeCisla,Tajne:Boolean):String;
  248. procedure NastavTajnyZnak(znak:Char);
  249. function  ZjistiTajnyZnak:Char;
  250. procedure NastavCekani(delka:Byte);
  251.  
  252. {Nové procedury a funkce:
  253. !!! Pokud je zde uvedeno jméno souboru, je moæné zde napsat i libovolné
  254. za⌐ízení s cestou, vædy je v¿ak nutné napsat jméno i s koncovkou !!!}
  255.  
  256. function  Prestupny(r:longint):boolean; {Je rok "r" p⌐estupnÿ?}
  257. function  Pocet2(mesic:Byte;rok:LongInt):Byte; {Poçet dní v mêsíci "mesic" v roce "rok":}
  258. function  SpravneDatum(d,m:Byte;r:LongInt):Boolean; {Je moæné datum "d"."m"."r"?}
  259. procedure Zitra(d1,m1:Byte;r1:Longint;var d2,m2:Byte;var r2:Longint); {Vrací zít⌐ej¿í den:}
  260. procedure Vcera(d1,m1:Byte;r1:Longint;var d2,m2:Byte;var r2:Longint); {Vrací vçerej¿í den:}
  261. {function Str(cislo:Longint):String;}
  262. procedure UlozBarvy; {Uloæí barvy textu a pozadí do svÿch promênnÿch.}
  263. procedure ObnovBarvy; {Obnoví barvy textu a pozadí ze svÿch promênnÿch.}
  264. function  Hledej(soubor,Hledat:String):Longint; {Hledá text "Hledat" v souboru pojmenovanÿm "soubor":}
  265. function  Hledej2(soubor,Hledat:String):Longint; {Rychlej¿í hledáni textu "Hledat" v souboru pojmenovanÿm "soubor":}
  266. procedure CopyFile(input,output:String); {Obdoba Copy v MS-DOSu, vstupy jsou jména souboru:}
  267. function  Dekoduj(co:String):String; {Sloæitê dekóduje nap⌐. heslo:}
  268. function  DelkaSouboru(jmeno:String):Longint; {Vrací délku souboru, kterÿ má jméno "jmeno".}
  269. function  Soucet1(jmeno:String):Longint; {Seçte jednotlivé Byty souboru a vÿsledek vrací jako vÿstup funkce:}
  270. function  Soucet2(jmeno:String):Longint; {Soucet2 Je rychlej¿í ekvivalent k funkci Soucet1:}
  271. function  CtiCislo(text:String):Real; {Zadání reálného çísla z klávesnice:}
  272. function  Cti_Byte(text:String):Byte; {Çtení çísla BYTE vyuæitím funkce CtiCislo:}
  273. function  Cti_Real(text:String):Real; {Çtení çísla REAL vyuæitím funkce CtiCislo:}
  274. function  Cti_LongInt(text:String):LongInt; {Çtení çíslo LONGINT vyuæitím funkce CtiCislo:}
  275. procedure BorderColor(barva:Byte); {Barva okraje na CGA, EGA, VGA:}
  276. procedure CtiString3(zprava:String;PouzeCisla,Tajne:Boolean;var text:String);
  277. {Zadání ⌐etêzce z klávesnice, promênná "text" je zároveñ vstupní ale i vÿstupní,
  278. jako vstup: ⌐etêzec, kterÿ se uloæí do vÿstupního ⌐ádku, takæe ho uæivatel mûæe pouze zmênit
  279. jako vÿstup: vlastní vÿstup z procedury, tj. text z rámeçku}
  280. function  DoplnNa(co:String;NaDelku:Byte):String; {Prodlouæí ⌐etêzec na délku uloæenou v promênné "NaDelku":}
  281. function Secti(x,y:Char):Char; {Seçte grafické znaky (viz p⌐íklad):
  282.  ┌─┬─┐ ╔═╦═╗ ╒═╤═╕ ╓─╥─╖ █████
  283.  │ │ │ ║ ║ ║ │ │ │ ║ ║ ║ █ █ █
  284.  ├─┼─┤ ╠═╬═╣ ╞═╪═╡ ╟─╫─╢ █████
  285.  │ │ │ ║ ║ ║ │ │ │ ║ ║ ║ █ █ █
  286.  └─┴─┘ ╚═╩═╝ ╘═╧═╛ ╙─╨─╜ █████
  287.  "┌" + "┐" = "┬"        "├" + "─" = "┼"
  288.  "└" + "│" = "├"        "┼" + " " = "┼"
  289. }
  290.  
  291. {Funkce Locate vrací znak, kterÿ je na obrazovce na pozici x,y:}
  292. {Parametr "znaku" udává poçet znakû na ⌐ádku v textovém reæimu:}
  293. function Locate(x,y:Byte):Char;
  294. {Poçítaç napí¿e na obrazovku na aktuální pozici kurzoru zadanÿ znak,
  295. nejedná se v¿ak o pouhÿ tisk, ale navíc poçítaç provede funkci "Secti"
  296. znaku, kterÿ je pod kurzorem s tisknutÿm znakem a vÿsledek zapí¿e
  297. na pozici kurzoru.}
  298. procedure PisZnak(ASCII:Char);
  299. function VratTrue:Boolean;
  300. function Sude(c:Longint):Boolean;
  301. function Liche(c:Longint):Boolean;
  302. function Min(c1,c2:Longint):Longint;
  303. function Max(c1,c2:Longint):Longint;
  304. procedure Tisk(x,y:Byte;text:String);
  305. procedure Prohlizec(max:Word;f:Tfce;napis:String);
  306. {Procedura Exec je p⌐evzata z helpu Borland Pascalu 7.0 (trochu upravena):}
  307. procedure Exec2(ProgramName,CmdLine:String); {ProgramName - jméno souboru
  308. i s cestou, kterÿ chcete spustit (moæné pouze soubory .EXE a .COM).
  309. CmdLine slouæí k zadání parametrû ekvivalentní parametrûm p⌐íkazové ⌐ádky
  310. DOSu.
  311. Pro provádêní .BAT souborû a p⌐íkazû DOSu slouæí pouze následující procedura
  312. Command, která volá interpret p⌐íkazû COMMAND.COM. Bez nêj není moæné tyto
  313. p⌐íkazy provádêt, coæ je logické...}
  314. procedure Command(Com:String); {Startuje COMMAND.COM a provede v nêm p⌐íkaz
  315. zadanÿ v ⌐etêzci Com.}
  316. function  Nekonecno:Double;
  317. procedure Konec;
  318. function  Str3(prom:Extended;celkem,desetinnych:Byte):String;
  319. function  UpCase(c:Char):Char;
  320. function  DownCase(c:Char):Char;
  321. function  DownCaseString(s:String):String;
  322. function  UpCaseString(s:string):string;
  323. function  OdstranMezery(s:String):String;
  324. {Pro naçítání logickÿch hodnot z textového souboru, ⌐ádek s logickou
  325.  hodnotou reprezentuje nápis TRUE (log.1) nebo FALSE (log.0):}
  326. function  StringBoolean(s:String):Boolean;
  327. {Obdoba systémové procedury Insert, ale tato moje vloæí ⌐etêzec "co"
  328.  skuteçnê ba pozici "pozice" v ⌐etêzci "kam". Systémová procedura Insert
  329.  totiæ, pokud je vÿstupní ⌐etêzec krátkÿ, zdroj ukládá na konec ⌐etêzce,
  330.  ale ne na pozici, kam chceme. Rozdíl je z⌐ejmÿ z tohoto p⌐íkladu:
  331.  
  332. uses fr_sok;
  333. var s:String;
  334. begin
  335.   s:='';
  336.   System.Insert('abc',s,3);
  337.   Writeln('s="',s,'".');
  338.   s:='';
  339.   Vloz('abc',s,3);
  340.   Writeln('s="',s,'".');
  341. end.
  342. }
  343. procedure Vloz(co:String;var kam:String;pozice:Byte);
  344. function Menu5(x,y,ram:byte;kur:boolean;pocet:Word;f:Tfce):Word;
  345. function Odstran_Hacky_Carky(s:string):string;
  346. function Kod852(c:Char):Char; {P⌐evod z kódu B⌐í Kamenickÿch - kód 852 - pouze 1 znak}
  347. function Kod1250(c:Char):Char; {P⌐evod z kódu B⌐í Kamenickÿch - kód 1250 - pouze 1 znak}
  348. function cs(text:String):String; {Konvertuje string z kódu B⌐í Kamenickÿch do jiného - zadaného v "cskod":}
  349. function Kod852String(s:String):String; {P⌐evod z kódu B⌐í Kamenickÿch - kód 852 - celÿ ⌐etêzec}
  350. function Kod1250String(s:String):String; {P⌐evod z kódu B⌐í Kamenickÿch - kód 1250 - celÿ ⌐etêzec}
  351.  
  352. function Hlaseni(s:String):String; {Vypí¿e hlá¿ení do menu a vyçká na stisk klávesy >Enter<.}
  353. function Adresar_Existuje(jmeno:string):Boolean;
  354. function OdstranZbytecneMezery(s:String):String; {Odstraní zbyteçné mezery p⌐ed prvním rozumnÿm znakem a v¿echny mezery za
  355.  posledním rozumnÿm znakem s dále v¿echny zdvojené mezery nahradí jednoduchÿmi}
  356. procedure Vypis(var f:System.Text);
  357. procedure UschovejPozici(var f:System.Text);
  358. procedure ObnovPozici(var f:System.Text);
  359. function Val(s:String):Byte;
  360. function Prevod(zdroj:String;vstupni,vystupni:Byte):String;
  361.  
  362. IMPLEMENTATION
  363. const    Dny:array[0..6] of string[7]=('Nedêle','Pondêlí','ùterÿ','St⌐eda','Çtvrtek','Pátek','Sobota');
  364.     max0=100;
  365.     bar=LightGray*16+Blue;
  366.         {0-7         0-15}
  367. const    Mouse=51; {Çíslo p⌐eru¿ení pro komunikaci s ovladaçem my¿i.}
  368. const    Pocty:array[1..12] of Byte=(31,28,31,30,31,30,31,31,30,31,30,31);
  369. var    b:Byte;
  370. var    barva,i,pocet,xo,xh,yo,yh,stand:Byte;
  371.     text:array[0..max0] of string[75];
  372.     cara,polozky:array[1..max0] of Boolean;
  373.     a1,a2,a3,a4,a5,a6,a7,a8:Byte;
  374.     Int1CSave:Pointer;
  375.     hod:Boolean;
  376.     r:Registers;
  377.     pole:Array[1..10000] of Boolean; {V p⌐ípadê, æe je adresá⌐, je zde
  378.     True, pokud se jedná o soubor, je zde False. Pouæívá se pro
  379.     rozhodování, zda daná adresá⌐ová poloæka p⌐edstavuje soubor çi
  380.     podadresá⌐ (podle koncovky to nelze poznat). Je zde uvedeno pole,
  381.     protoæe PC neví, co si uæivatel z menu vybere a aby nebylo nutné
  382.     po vÿbêru zvolenou poloæku vyhledávat a zji¿ƒovat její atributy, tak
  383.     se ukládá bit "Directory" (bit 4).}
  384.     TajnyZnak:Char;
  385.     OldTimer:Procedure;
  386.     doba:Byte;
  387.  
  388. { Procedura "Bod" odpovídá p⌐íkazu PutPixel v grafickém reæimu. Barvu bodu
  389.   lze nastavit p⌐íkazem TextColor. Bod C=[x,y]. }
  390. procedure Bod(x,y:byte);
  391. begin
  392.  gotoxy(x,y);write(chr(178));
  393. end;
  394.  
  395. { Procedura "Usecka" odpovídá p⌐íkazu Line v grafickém reæimu. Barvu úseçky
  396.   lze nastavit p⌐íkazem TextColor. ùseçka je vykreslena mezi bodem "A" a
  397.   bodem "B", A=[xa,ya], B=[xb,yb]. }
  398. procedure Usecka(xa,ya,xb,yb:integer);
  399. var dx,dy,x,y:integer;k:real;
  400. begin dx:=abs(xb-xa);dy:=abs(yb-ya);
  401.  if dx>dy then begin
  402.   k:=(yb-ya)/(xb-xa);if xb>xa then for x:=xa to xb do
  403.   begin y:=round(k*(x-xa)+ya);bod(x,y);end
  404.   else for x:=xa downto xb do begin y:=round(k*(x-xa)+ya);bod(x,y);end;
  405.  end;
  406.  if dx<=dy then begin
  407.   k:=(xb-xa)/(yb-ya);if yb>ya then for y:=ya to yb do
  408.   begin x:=round(k*(y-ya)+xa);bod(x,y);end
  409.   else for y:=ya downto yb do begin x:=round(k*(y-ya)+xa);bod(x,y);end;
  410.  end;
  411. end;
  412.  
  413. { Procedura "Zacatek_Usecky" nakreslí jako procedura "Bod" bod, navíc si
  414.   "zapamatuje" sou⌐adnice bodu. Tato procedura odpovídá procedu⌐e MoveTo.
  415.   Vstupem je bod se sou⌐adnicemi x,y, C=[x,y]. }
  416. procedure Zacatek_Usecky(x,y:byte);
  417. begin
  418.  bod(x,y);xo:=x;yo:=y;
  419. end;
  420.  
  421. { Procedure "Konec_Usecky" nakreslí jako procedure "Usecka" úseçku, která
  422.   bude mít zaçátek v bodê, kam se naposledy kreslil bod a konec v zadaném
  423.   bodê se sou⌐adnicemi x,y. Tato procedura odpovídá procedu⌐e LineTo.
  424.   Vstupem je bod se sou⌐adnicemi x,y, C=[x,y]. }
  425. procedure Konec_Usecky(x,y:byte);
  426. begin
  427.  usecka(xo,yo,x,y);xo:=x;yo:=y;
  428. end;
  429.  
  430. { Funkce "Klavesa" çeká na stisk klávesy, pokud je zadané písmeno, p⌐evede
  431.   malé písmeno na velké, které je vÿstupem funkce. }
  432. function Klavesa:char;
  433. var kl:char;
  434. begin
  435.  kl:=ReadKey;kl:=UpCase(kl);Klavesa:=kl;
  436. end;
  437.  
  438. { Funkce "AnoNe" nejprve vytiskne dotaz na obrazovku a çeká na uæivatelovu
  439.   odpovêd (Ano nebo Ne). V p⌐ípadê, æe uæivatel odpoví Ano, je vÿstupem
  440.   funkce True-log.1, pokud odpoví Ne, je vÿstupem funkce False-log.0 }
  441. function AnoNe(text:string):boolean;
  442. var pom:char;
  443. begin
  444.  write(cs(text),' (ano/ne)?');
  445.  repeat pom:=klavesa;until (pom='A') or (pom='N');
  446.  if pom='A' then begin writeln('Ano');anone:=true;end
  447.  else begin writeln('Ne');anone:=false;end;
  448. end;
  449.  
  450. { Procedura "Znak" vytiskne znak s ASCII kódem na sou⌐adnicích X,Y.
  451.   Proceduru lze samoz⌐ejmê nahradit p⌐íkazy:
  452.   GotoXY(x,y);Write(Chr(ascii))
  453.   ale v p⌐ípadê, æe tiskneme znak do pravého dolního rohu okna nastaveného
  454.   procedurou Window, tak se obraz od⌐ádkuje, coæ nêkdy uæivateli
  455.   nevyhovuje. }
  456. procedure Znak(x,y,ascii:byte);
  457. var adr:word;
  458. begin
  459.  x:=x-1;y:=y-1;adr:=x+y*MaxX;obraz[adr].ascii:=ascii;
  460. end;
  461.  
  462. { Procedure "Obdelnik" vykreslí v textovém reæimu rámeçek s jednoduchou,
  463.   dvojitou nebo tlustou çarou. Vstupem jsou x-ová a y-ová sou⌐adnice levého
  464.   horního rohu rámeçku, ¿í⌐ka, vÿ¿ka,typ çáry, ASCII kód znaku pozadí a
  465.   typ obdélníku (viz dále).
  466.  
  467.   Hodnoty typu çáry:
  468.   1    = jednoduchá çára (celÿ rámeçek)
  469.   2    = dvojitá çára    (celÿ rámeçek)
  470.   3    = svislé çáry jsou dvojité, vodorovné jsou jednoduché
  471.   4    = svislé çáry jsou jednoduché, vodorovné jsou dvojité
  472.   jiná = tlustá          (celÿ rámeçek)
  473.  
  474.   ASCII kód znaku pozadí: P⌐íklady:
  475.   32 = mezera
  476.   46 = teçka
  477.  
  478.   Typ obdélníku: "False" nebo "True"
  479.   ┌───────────────────┐
  480.   │                   │
  481.   │ Zadanÿ poçet ⌐ádek│ pro False:
  482.   │                   │ Obdelnik(...,False);
  483.   │                   │
  484.   └───────────────────┘
  485.   ┌───────────────────┐
  486.   │ Vædy 1 ⌐ádek      │
  487.   ├───────────────────┤
  488.   │                   │
  489.   │ Zadanÿ poçet ⌐ádek│ pro True:
  490.   │                   │ Obdelnik(...,True);
  491.   │                   │
  492.   └───────────────────┘
  493. }
  494. procedure Obdelnik(x,y,sirka,vyska,ram,pozadi:byte;typ:boolean);
  495. var i,w:byte;
  496. begin
  497.  a1:=219;a2:=219;a3:=219;a4:=219;a5:=219;a6:=219;a7:=219;a8:=219;
  498.  if ram=1 then begin a1:=218;a2:=196;a3:=191;a4:=179;a5:=195;a6:=180;a7:=192;a8:=217;end;
  499.  if ram=2 then begin a1:=201;a2:=205;a3:=187;a4:=186;a5:=204;a6:=185;a7:=200;a8:=188;end;
  500.  if ram=3 then begin a1:=214;a2:=196;a3:=183;a4:=186;a5:=199;a6:=182;a7:=211;a8:=189;end;
  501.  if ram=4 then begin a1:=213;a2:=205;a3:=184;a4:=179;a5:=198;a6:=181;a7:=212;a8:=190;end;
  502.  gotoxy(x,y);write(chr(a1));for i:=1 to sirka do write(chr(a2));write(chr(a3));
  503.  if typ=true then vyska:=vyska+2;
  504.  for w:=1 to vyska do
  505.  begin
  506.   gotoxy(x,y+w);write(chr(a4));for i:=1 to sirka do write(chr(pozadi));
  507.   write(chr(a4));
  508.  end;
  509.  if typ=true then
  510.  begin
  511.   gotoxy(x,y+2);write(chr(a5));for i:=1 to sirka do write(chr(a2));write(chr(a6));
  512.  end;
  513.  gotoxy(x,y+vyska+1);write(chr(a7));for i:=1 to sirka do write(chr(a2));write(chr(a8));
  514. end;
  515.  
  516. { Procedura "Obdelnik2" je stejná jako procedura Obdelnik, rozdíl je ve
  517.   zpûsobu kreslení obdelníku pomocí p⌐ímého ukládání znakû do videopamêti. Je
  518.   moæné nastavit barvu pozadí, kde je rámeçek (TextBackGround(barva)).
  519.   Vnêj¿ek obdélníku bude mít standartní nastavenou barvu. }
  520. procedure Obdelnik2(x,y,sirka,vyska,ram,pozadi:byte;typ:boolean);
  521. var i,w:byte;
  522. begin
  523.  if typ=false then window(x,y,x+sirka+1,y+vyska+1)
  524.           else window(x,y,x+sirka+1,y+vyska+3);
  525.  clrscr;
  526.  a1:=219;a2:=219;a3:=219;a4:=219;a5:=219;a6:=219;a7:=219;a8:=219;
  527.  if ram=1 then begin a1:=218;a2:=196;a3:=191;a4:=179;a5:=195;a6:=180;a7:=192;a8:=217;end;
  528.  if ram=2 then begin a1:=201;a2:=205;a3:=187;a4:=186;a5:=204;a6:=185;a7:=200;a8:=188;end;
  529.  if ram=3 then begin a1:=214;a2:=196;a3:=183;a4:=186;a5:=199;a6:=182;a7:=211;a8:=189;end;
  530.  if ram=4 then begin a1:=213;a2:=205;a3:=184;a4:=179;a5:=198;a6:=181;a7:=212;a8:=190;end;
  531.  if typ=true then vyska:=vyska+2;
  532.  Znak(x,y,a1);for i:=1 to sirka do Znak(x+i,y,a2);Znak(x+sirka+1,y,a3);
  533.  for w:=1 to vyska do begin Znak(x,y+w,a4);for i:=1 to sirka do Znak(x+i,y+w,pozadi);Znak(x+sirka+1,y+w,a4);end;
  534.  Znak(x,y+vyska+1,a7);for i:=1 to sirka do Znak(x+i,y+vyska+1,a2);Znak(x+sirka+1,y+vyska+1,a8);
  535.  if typ=true then begin Znak(x,y+2,a5);for i:=1 to sirka do Znak(x+i,y+2,a2);Znak(x+sirka+1,y+2,a6);vyska:=vyska+2;end;
  536. end;
  537.  
  538. { Procedura "Kurzor" zmêní pozadí znaku a tím vznikne dojem, æe na znaku je
  539.   kurzor. Vstupem jsou x-ová a y-ová sou⌐adnice kurzoru a ¿í⌐ka kurzoru. }
  540. procedure Kurzor(x,y,delka:byte);
  541. var adr:integer;
  542. begin adr:=(x-1)+(y-1)*MaxX;
  543.  for i:=0 to delka-1 do
  544.  if obraz[adr+i].barva=barva then obraz[adr+i].barva:=bar else obraz[adr+i].barva:=barva;
  545. end;
  546.  
  547. { Funkce "Posun" pohybuje kurzorem. }
  548. function Posun(xmin,xmax,ymin,ymax:byte;var x,y:byte):byte;
  549. label cek,opakuj;
  550. var kl,kl2:byte;
  551. begin
  552.  if xmin<1 then xmin:=1;
  553.  if ymin<1 then ymin:=1;
  554.  if xmax>MaxX then xmax:=MaxX;
  555.  if ymax>MaxY then ymax:=MaxY;
  556.  if (x<xmin) or (x>xmax) then x:=xmin;
  557.  if (y<ymin) or (y>ymax) then y:=ymin;
  558.  if (xmin>xmax) or (ymin>ymax) then begin Posun:=0;exit;end;
  559.  opakuj:
  560.  Kurzor(x,y,1);kl:=ord(ReadKey);
  561.  if kl=0 then begin
  562.   kl2:=ord(ReadKey);
  563.   if (kl2=77) and (x<xmax) then begin Kurzor(x,y,1);x:=x+1;goto opakuj;end;
  564.   if (kl2=75) and (x>xmin) then begin Kurzor(x,y,1);x:=x-1;goto opakuj;end;
  565.   if (kl2=72) and (y>ymin) then begin Kurzor(x,y,1);y:=y-1;goto opakuj;end;
  566.   if (kl2=80) and (y<ymax) then begin Kurzor(x,y,1);y:=y+1;goto opakuj;end;
  567.  end;
  568.  Kurzor(x,y,1);Posun:=kl;
  569. end;
  570.  
  571. { Procedure "Nastav" uloæí barvy znaku a pozadí, aby po zru¿ení kurzoru,
  572.   kurzor opravdu zmizel. Vybarví pozadí celé obrazovky na zeleno. }
  573. procedure Nastav;
  574. begin
  575.   case LastMode of
  576.     0..1: begin MaxX:=40;MaxY:=25;end; {text 40x25}
  577.     2..3: begin MaxX:=80;MaxY:=25;end; {text 80x25}
  578.     256: begin MaxX:=40;MaxY:=50;end; {text 40x50}
  579.     else begin Writeln(cs('Obrazovka p⌐epnuta do neznámého módu.'));end;
  580.   end;
  581.   Window(1,1,80,25);TextBackGround(Green);TextColor(Yellow);
  582.   ClrScr;barva:=obraz[1].barva;GotoXY(1,1);
  583. end;
  584.  
  585. { Procedure "P1" nakreslí jednoduchou vodorovnou çáru v textovém reæimu,
  586.   vstup je ¿í⌐ka ve znacích. }
  587. procedure P1(sirka:integer);
  588. var i:byte;
  589. begin
  590.   for i:=1 to sirka do write(chr(196));
  591. end;
  592.  
  593. { --------------------------------------------------------------------------
  594.   Následují procedury s okénky jako v Turbo-Vision. Pro zaçáteçníky je to
  595.   jednodu¿¿í, neæ se uçit ne p⌐íli¿ jednoduché Turbo-Vision.
  596.   Jedná se o procedury: Zacatek,Radek,Radek2,Linka,Menu a Menu2.
  597.  
  598.   Procedura "Zacatek" definuje zaçátek nového okénka, v p⌐ípadê, æe chcete,
  599.   aby okénko mêlo nadpis, zadejte ho mezi apostrofy: Zacatek('Nápis okénka').
  600.   Pokud nechcete mít nápis, zadejte Zacatek(''). Je nutné zdûraznit, æe je
  601.   nutné, aby byla procedura pouæita p⌐ed kaædÿm novÿm okénkem, protoæe nuluje
  602.   své promênné (vlastní ⌐etêzce a jejich poçet). }
  603. procedure Zacatek(nadpis:string);
  604. begin
  605.  pocet:=0;text[0]:=cs(nadpis);
  606.  for i:=1 to max0 do begin text[i]:='';polozky[i]:=true;cara[i]:=false;end;
  607. end;
  608.  
  609. { Procedure "Radek" definuje jednotlivé volby (⌐ádky) do okénka s poloækami.
  610.   Vstupem je ⌐etêzec jednotlivé poloæky okénka, zadává se do apostrofû:
  611.   Radek('1. poloæka'). }
  612. procedure Radek(pom:string);
  613. begin
  614.  if pocet>=max0 then exit;
  615.  pocet:=pocet+1;text[pocet]:=cs(pom);polozky[pocet]:=true;cara[pocet]:=false;
  616. end;
  617.  
  618. { Procedura "Radek2" definuje jednotlivé volby (⌐ádky) do okénka s poloækami.
  619.   Vstupem je ⌐etêzec jednotlivé poloæky okénka, zadává se do apostrofû:
  620.   Radek('1. poloæka'), dal¿í parametr je, zda-li poloæka bude aktivní - tzn.
  621.   jestli ji lze aktivovat stiskem klávesy Enter. P⌐íkladem neativních poloæek
  622.   je v Turbo-Pascalu menu Edit, poloæky Cut, Copy, Paste, které fungují pouze
  623.   v p⌐ípadê oznaçeného bloku textu v editoru. V p⌐ípadê, æe je vstupní pro-
  624.   mênná Polozka=True, potom je aktivní, jinak pasivní. }
  625. procedure Radek2(pom:string;polozka:boolean);
  626. begin
  627.  if pocet>=max0 then exit;
  628.  pocet:=pocet+1;text[pocet]:=cs(pom);polozky[pocet]:=polozka;cara[pocet]:=false;
  629. end;
  630.  
  631. { Procedura "Linka" vloæí do okénka vodorovnÿ ⌐ádek, kterÿ p⌐eskakuje kurzor.
  632.   Slouæí pro oddêlení poloæek rûzného vÿznamu v jednom menu. P⌐íklad ⌐ádku
  633.   je v Borland-Pascalu 7.0 v menu Edit ⌐ádky mezi Redo a Cut; mezi Clear a
  634.   Show clipboard. Procedura nemá æádnÿ vstup. }
  635. procedure Linka;
  636. begin
  637.  if (pocet<1) or (pocet>=max0) then exit;
  638.  if cara[pocet]=true then exit;
  639.  Radek2('',false);cara[pocet]:=true;
  640. end;
  641.  
  642. { Funkce "Menu" vykreslí rámeçek okna, jednotlivé poloæky, v menu je pak
  643.   moæné se pohybovat kurzorem pomocí kláves se ¿ipkami a zvolenou poloæku
  644.   vybrat klávesou Enter. Vstupy funkce jsou sou⌐adnice levého horního rohu
  645.   menu X a Y, druh çáry rámeçku (viz procedura "Obdelnik"), typ kurzoru:
  646.   True =log.1........kurzor p⌐es celé menu
  647.   False=log.0........kurzor je pouze p⌐es název poloæky
  648.   Vÿstup funkce je çíslo poloæky:
  649.   poloæka 1. (1. pouæití "Radek" po "Zacatek") má çíslo 1
  650.   poloæka 2. (2. pouæití "Radek" po "Zacatek") má çíslo 1
  651.   ...  atd. }
  652. function Menu(x,y,ram:byte;kur:boolean):byte;
  653. label opakuj;
  654. var i,del,l,max,w:byte;
  655. begin
  656.   if (WindMin<>0) or (WindMax<>6223) then Nastav;
  657.   textcolor(white);if cara[pocet]=true then pocet:=pocet-1;
  658.   max:=1;l:=1;for i:=0 to pocet do if length(text[i])>max then max:=length(text[i]);
  659.   if length(text[0])>0 then i:=i+2;
  660.   if (x=0) or (y=0) then begin x:=round((80-(max+2))/2);y:=round((25-(i+2))/2);end;
  661.   if length(text[0])>0 then i:=i-2;
  662.   if length(text[0])=0 then obdelnik(x,y,max,i,ram,32,false)
  663.                else begin obdelnik(x,y,max,i,ram,32,true);gotoxy(x+1,y+1);write(text[0]);y:=y+2;end;
  664.   barva:=obraz[(x-1)+(y-1)*160+1].barva;
  665.   for i:=1 to pocet do
  666.   begin
  667.    if cara[i]=true then
  668.    begin
  669.     TextColor(White);GotoXY(x,y+i);Write(chr(a5));for w:=1 to max do Write(chr(a2));Write(chr(a6));
  670.    end else begin
  671.     if polozky[i]=true then textcolor(white) else textcolor(black);
  672.     gotoxy(x+1,y+i);write(text[i]);for w:=length(text[i])+1 to max do write(' ');
  673.    end;
  674.   end;
  675.   opakuj:
  676.   if kur=false then del:=length(text[l]) else del:=max;
  677.   barva:=obraz[x+(y+l-1)*80+1].barva;Kurzor(x+1,y+l,del);
  678.   repeat
  679.    w:=ord(readkey);
  680.    if (w=72) and (l<=1) then begin Kurzor(x+1,y+l,del);l:=i;goto opakuj;end;
  681.    if w=72 then
  682.    begin
  683.     Kurzor(x+1,y+l,del);Dec(l);
  684.     if cara[l]=true then Dec(l);
  685.     goto opakuj;
  686.    end;
  687.    if (w=80) and (l>=i) then begin Kurzor(x+1,y+l,del);l:=1;goto opakuj;end;
  688.    if w=80 then
  689.    begin
  690.     Kurzor(x+1,y+l,del);Inc(l);
  691.     if cara[l]=true then Inc(l);
  692.     goto opakuj;
  693.    end;
  694.   until (w=13) and (polozky[l]=true);
  695.   Menu:=l;
  696. end;
  697.  
  698. { Funkce "Menu2" je stejná jako funkce "Menu", rozdíl je v hnêdém pozadí
  699.   vnit⌐ku okénka, odli¿ném zpûsobu kreslení rámeçku (viz procedura
  700.   "Obdelnik2"). Navíc jsou na obrazovku vypisované názvzy okének a poloæek
  701.   do dialogového okna, které lze otev⌐ít procedurou "Dialogove_Okno". }
  702. function Menu2(x,y,ram:byte;kur:boolean):byte;
  703. label opakuj;
  704. var i,del,l,max,pa,px,py,y0,w:byte;
  705.     wmin,wmax:word;
  706. begin
  707.   if (WindMin<>5377) or (WindMax<>5966) then Dialogove_Okno;
  708.   px:=WhereX;py:=WhereY;wmin:=WindMin;wmax:=WindMax;pa:=TextAttr;
  709.   clrscr;textcolor(white);if cara[pocet]=true then pocet:=pocet-1;
  710.   textbackground(brown);
  711.   max:=1;l:=1;for i:=0 to pocet do if length(text[i])>max then max:=length(text[i]);
  712.   if length(text[0])>0 then i:=i+2;
  713.   if (x=0) or (y=0) then begin x:=round((80-(max+2))/2);y:=round((25-(i+2))/2);end;
  714.   if length(text[0])>0 then i:=i-2;
  715.   if length(text[0])=0 then begin obdelnik2(x,y,max,i,ram,32,false);y0:=1;end
  716.                else begin obdelnik2(x,y,max,i,ram,32,true);gotoxy(2,2);write(text[0]);y:=y+2;y0:=3;end;
  717.   barva:=obraz[(x-1)+(y-1)*80+1].barva;
  718.   for i:=1 to pocet do
  719.   begin
  720.    if cara[i]=true then
  721.    begin
  722.     TextColor(White);GotoXY(1,y0+i);Write(chr(a5));for w:=1 to max do Write(chr(a2));Write(chr(a6));
  723.    end else begin
  724.     if polozky[i]=true then textcolor(white) else textcolor(black);
  725.     gotoxy(2,y0+i);write(text[i]);for w:=length(text[i])+1 to max do write(' ');
  726.    end;
  727.   end;
  728.   textcolor(white);textbackground(pa div 16);textcolor(pa mod 16);
  729.   window((wmin mod 256)+1,(wmin div 256)+1,(wmax mod 256)+1,(wmax div 256)+1);
  730.   gotoxy(1,1);if length(text[0])>0 then write(text[0],' ');
  731.   writeln(cs('Klávesami se ¿ipkami vyberte çinnost, pak stisknête ENTER.'));
  732.   opakuj:
  733.   GotoXY(1,2);DelLine;InsLine;Writeln(cs('Çinnost: '+text[l]));
  734.   if kur=False then del:=length(text[l]) else del:=max;
  735.   barva:=obraz[x+(y+l-1)*80+1].barva;Kurzor(x+1,y+l,del);
  736.   repeat
  737.    w:=ord(readkey);
  738.    if (w=72) and (l<=1) then begin Kurzor(x+1,y+l,del);l:=i;goto opakuj;end;
  739.    if w=72 then
  740.    begin
  741.     Kurzor(x+1,y+l,del);Dec(l);
  742.     if cara[l]=true then Dec(l);
  743.     goto opakuj;
  744.    end;
  745.    if (w=80) and (l>=i) then begin Kurzor(x+1,y+l,del);l:=1;goto opakuj;end;
  746.    if w=80 then
  747.    begin
  748.     Kurzor(x+1,y+l,del);Inc(l);
  749.     if cara[l]=true then Inc(l);
  750.     goto opakuj;
  751.    end;
  752.   until (w=13) and (polozky[l]=true);
  753.   Menu2:=l;
  754. end;
  755.  
  756. { Vÿstupem funkce "Zjisti" je název poloæky v menu: "Menu" nebo "Menu2".
  757.   Promênná "pol" udává çíslo poloæky v menu. V p⌐ípadê pol=0 vrací funkce
  758.   nadpis tabulky, pokud nadpis nebyl zadán, pak prázdnÿ ⌐etêzec. }
  759. function Zjisti(pol:byte):string;
  760. begin
  761.  if pol>pocet then begin Nastav;Writeln(cs('Tato poloæka nebyla je¿tê zadána !!!'));Readln;Halt(1);end;
  762.  Zjisti:=text[pol];
  763. end;
  764.  
  765. { Funkce "AnoNe2" je stejná jako funkce "AnoNe", av¿ak uæivatel má moænost
  766.   odpovêdêt pomocí menu. }
  767. function AnoNe2(text:string):boolean;
  768. var w:byte;
  769. begin
  770.  w:=length(text);
  771.  if w<3 then text:=cs('Souhlasíte?');
  772.  Zacatek(text);Radek('Ne');Radek('Ano');w:=Menu3(0,0,1,true);
  773.  if w=1 then AnoNe2:=False else AnoNe2:=True;
  774. end;
  775.  
  776. { Po pouæití procedury "Zapni_Zvuk" bude u procedur Sound1 a Sound2 sly¿et
  777.   zvuk. }
  778. procedure Zapni_Zvuk;
  779. begin
  780.  Zvuk:=True;
  781. end;
  782.  
  783. { Po pouæití procedury "Vypni_Zvuk" nebude u procedur Sound1 a Sound2 sly¿et
  784.   zvuk, pouze bude dané zpoædêní. }
  785. procedure Vypni_Zvuk;
  786. begin
  787.  Zvuk:=False;
  788. end;
  789.  
  790. { Procedura "Sound1" pípne frekvencí (f), poté çeká (d1) milisekund,
  791.   poté pípnutí p⌐eru¿í a çeká (d2) milisekund. Pípnutí se opakuje celkem
  792.   pêtkrát. }
  793. procedure Sound1(f,d1,d2:word);
  794. var i:byte;
  795. begin
  796.  for i:=1 to 5 do begin
  797.   if zvuk=true then sound(f);delay(d1);nosound;delay(d2);
  798.  end;
  799. end;
  800.  
  801. { Procedura "Sound2" zvy¿uje (sniæuje) frekvenci zvuku od (f1) do (f2), çímæ
  802.   dosáhne houkaçky. Je-li (f1)<(f2), tak se frekvence zvy¿uje, jinak se
  803.   sniæuje. Mezi zvÿ¿ením frekvence o 1 Hz se çeká (d) ms. }
  804. procedure Sound2(f1,f2,d:word);
  805. var i:word;
  806. begin
  807.  if f1<f2 then for i:=f1 to f2 do begin if zvuk=true then sound(i);delay(d);end;
  808.  if f1>f2 then for i:=f1 downto f2 do begin if zvuk=true then sound(i);delay(d);end;
  809.  nosound;
  810. end;
  811.  
  812. { Procedura "Proc1" vytiskne zadanÿ text v apostrofech a provede houkaçku. }
  813. procedure Proc1(text:string);
  814. begin
  815.  writeln(cs(text));sound2(50,200,2);
  816. end;
  817.  
  818. { Procedura "Proc2" vytiskne zadanÿ text a 5x pípne. }
  819. procedure Proc2(text:string);
  820. begin
  821.  writeln(cs(text));sound1(50,300,100);
  822. end;
  823.  
  824. { Funkce "Proc3" uloæí do 1 vÿstupního ⌐etêzce:
  825.   1. ⌐etêzec "retezec1", çíslo "cislo" a 2.⌐etêzec "retezec2". Pouæití
  826.   nap⌐íklad pro OutText v grafice, aby se nemusel p⌐íkaz OutText nêkolikrát
  827.   opakovat. }
  828. function Proc3(retezec1:string;cislo:real;retezec2:string):string;
  829. var ret1,ret2:string;
  830. begin
  831.  ret1:=cs(retezec1);System.Str(cislo:3:0,ret2);
  832.  system.insert(ret2,ret1,length(ret1)+1);
  833.  system.insert(retezec2,ret1,length(ret1)+1);proc3:=ret1;
  834. end;
  835.  
  836. { Procedura "Cekej" çeká na stisk libovolné klávesy. }
  837. procedure Cekej;
  838. begin
  839.  i:=ord(klavesa);if i=0 then i:=ord(klavesa);
  840. end;
  841.  
  842. { Procedura "Dialogove_Okno" otev⌐e dialogové okno, které je vhodné p⌐i
  843.   pouæívání funkcí "Menu2" a "AnoNe2". }
  844. procedure Dialogove_Okno;
  845. begin
  846.  Obdelnik2(1,21,78,3,1,32,false);TextBackGround(red);Window(2,22,79,24);ClrScr;GotoXY(1,1);
  847. end;
  848.  
  849.  
  850.  
  851. { Procedury a funkce pro pouæívání hodin, které se pí¿í na obrazovku
  852.   pomocí p⌐eru¿ení, které mikroprocesor pravidelnê vykonává a provádí
  853.   tudíæ proceduru "TimerHandler".
  854.   !!! Dûleæité upozornêní !!! Hodiny je nutné vypnout bêhem operací
  855.   se za⌐ízeními (harddisk, disketová jednotka apod.), jinak se systém
  856.   zasekne a bude nutné provést RESET. Hodiny jsou udêlané pouze pro
  857.   textovÿ reæim !!! }
  858.  
  859. { Tato procedura "TimerHandler" je automaticky volaná jako p⌐eru¿ení
  860.   systémem, kdyæ jsou hodiny zapnuté. }
  861. {$F+,S-,W-}
  862. procedure TimerHandler; interrupt;
  863. var    hod,min,sek,sek100,den,den_v_tydnu,mes,rok,wmax,wmin:word;
  864.     x,y:byte;
  865. begin
  866.  asm
  867.    STI
  868.  end;
  869.  wmin:=WindMin;wmax:=WindMax;x:=WhereX;y:=WhereY;Window(1,1,80,25);
  870.  GetDate(rok,mes,den,den_v_tydnu);GetTime(hod,min,sek,sek100);GotoXY(xh,yh);Write('Ças: ');
  871.  Write(hod:2,':',min:2,':',sek:2,' (',sek100:2,')   Datum: ',den:2,'.',mes:2,'.',rok,
  872.  '   Dnes je ',cs(DoplnNa(dny[den_v_tydnu],7)),'.');
  873.  Window((wmin mod 256)+1,(wmin div 256)+1,(wmax mod 256)+1,(wmax div 256)+1);GotoXY(x,y);
  874. { BorderColor(Random($20));}
  875.  OldTimer;
  876.  asm
  877.    CLI
  878.  end;
  879. end;
  880. {$F-,S+}
  881.  
  882. { Funkce "Hodiny" vrací True v p⌐ípadê, æe hodiny jdou a False, v p⌐ípadê,
  883.   æe hodiny nejdou. (Hodiny DOSu a CMOS samoz⌐ejmê jdou po⌐ád.) }
  884. function Hodiny:boolean;
  885. begin
  886.  Hodiny:=hod;
  887. end;
  888.  
  889. { Procedura "Zapni_Hodiny" zapne tisknutí çasu a datumu na obrazovku,
  890.   poçátek je v sou⌐adnicích "x","y" v textovém reæimu. }
  891. procedure Zapni_Hodiny(x,y:byte);
  892. begin
  893.  if hod=True then exit;
  894.  xh:=x;yh:=y;hod:=True;
  895.  GetIntVec($1C,@OldTimer);GetIntVec($1C,Int1CSave);
  896.  SetIntVec($1C,Addr(TimerHandler));
  897. end;
  898.  
  899. { Procedura "Vypni_Hodiny" vypne tisknutí hodin (hodiny na obrazovce
  900.   zûstanou s çasem, kdy byla tato procedura pouæita). Procedura p⌐esmêruje
  901.   vektor p⌐eru¿ení na standartní hodnotu. }
  902. procedure Vypni_Hodiny;
  903. begin
  904.  if hod=False then exit;
  905.  SetIntVec($01C,Int1CSave);hod:=False;
  906.  GotoXY(xh,yh);DelLine;GotoXY(xh,yh);InsLine;
  907. end;
  908.  
  909. { Funkce "Soubor_Existuje" má vÿstup True v p⌐ípadê, æe soubor "jmeno"
  910.   existuje, jinak má funkce vÿstup False. }
  911. function Soubor_Existuje(jmeno:string):boolean;
  912. var f:file;a:integer;
  913. begin
  914.  System.Assign(F,jmeno); {$I-} System.Reset(F); {$I+}
  915.  a:=IOResult;Soubor_Existuje:=(a=0);
  916.  {$I-}System.Close(F);{$I+};a:=IOResult;
  917. end;
  918.  
  919. { Funkce "Menu3" je stejná jako funkce "Menu2", narozdíl je umoænêñ vÿbêr
  920.   poloæek menu i my¿í. }
  921. function Menu3(x,y,ram:byte;kur:boolean):byte;
  922. label opakuj,konec;
  923. var i,del,l,max,pa,px,py,y0,w:byte;
  924.     tlacitka,xm,ym,wmin,wmax:word;
  925.     pom:Boolean;
  926. begin
  927.   if (WindMin<>5377) or (WindMax<>5966) then Dialogove_Okno;
  928.   px:=WhereX;py:=WhereY;wmin:=WindMin;wmax:=WindMax;pa:=TextAttr;
  929.   clrscr;textcolor(white);if cara[pocet]=true then pocet:=pocet-1;textbackground(brown);
  930.   max:=1;l:=1;for i:=0 to pocet do if length(text[i])>max then max:=length(text[i]);
  931.   if length(text[0])>0 then i:=i+2;
  932.   if (x=0) or (y=0) then begin x:=round((80-(max+2))/2);y:=round((25-(i+2))/2);end;
  933.   if length(text[0])>0 then i:=i-2;
  934.   if length(text[0])=0 then begin Obdelnik2(x,y,max,i,ram,32,false);y0:=1;end
  935.                else begin Obdelnik2(x,y,max,i,ram,32,true);gotoxy(2,2);write(text[0]);y:=y+2;y0:=3;end;
  936.   barva:=obraz[(x-1)+(y-1)*80+1].barva;
  937.   for i:=1 to pocet do begin
  938.    if cara[i]=true then begin
  939.     TextColor(White);GotoXY(1,y0+i);Write(chr(a5));for w:=1 to max do Write(chr(a2));Write(chr(a6));
  940.    end else begin
  941.     if polozky[i]=true then textcolor(white) else textcolor(black);
  942.     gotoxy(2,y0+i);write(text[i]);for w:=length(text[i])+1 to max do write(' ');
  943.    end;
  944.   end;
  945.   textcolor(white);textbackground(pa div 16);textcolor(pa mod 16);
  946.   window((wmin mod 256)+1,(wmin div 256)+1,(wmax mod 256)+1,(wmax div 256)+1);
  947.   gotoxy(1,1);if length(text[0])>0 then write(text[0],' ');
  948.   writeln(cs('Klávesami se ¿ipkami vyberte çinnost, pak stisknête ENTER.'));
  949.   r.ax:=1;Intr(Mouse,r);
  950.   opakuj:
  951.   GotoXY(1,2);DelLine;InsLine;Writeln(cs('Çinnost: '+text[l]));
  952.   if kur=False then del:=length(text[l]) else del:=max;
  953.   barva:=obraz[x+(y+l-1)*MaxX+1].barva;kurzor2(x+1,y+l,del);
  954.   r.ax:=1;Intr(Mouse,r);pom:=False;
  955.   repeat
  956.    repeat
  957.     r.ax:=3;Intr(Mouse,r);xm:=r.cx div 8;ym:=r.dx div 8;tlacitka:=r.bx;
  958.     if (tlacitka=0) and (pom) then goto konec;
  959.     if (tlacitka>0) and (xm>=x) and (xm<x+max) and (ym>=y) and (ym<y+pocet) then
  960.     begin
  961.      if polozky[ym-y+1]=True then
  962.      begin pom:=True;
  963.       if tlacitka>0 then
  964.       begin
  965.        if (l<>ym-y+1) then
  966.        begin
  967.     Kurzor2(x+1,y+l,del);l:=ym-y+1;r.ax:=2;Intr(Mouse,r);
  968.     GotoXY(1,2);DelLine;InsLine;Writeln(cs('Çinnost: '+text[l]));
  969.     r.ax:=1;Intr(Mouse,r);
  970.     Kurzor2(x+1,y+l,del);pom:=True;
  971.        end;
  972.       end;
  973.      end;
  974.     end else pom:=False;
  975.    until Keypressed;
  976.    w:=ord(readkey);
  977.    if (w=72) and (l<=1) then begin kurzor2(x+1,y+l,del);l:=i;goto opakuj;end;
  978.    if w=72 then
  979.    begin
  980.     kurzor2(x+1,y+l,del);Dec(l);
  981.     if cara[l]=true then Dec(l);
  982.     goto opakuj;
  983.    end;
  984.    if (w=80) and (l>=i) then begin kurzor2(x+1,y+l,del);l:=1;goto opakuj;end;
  985.    if w=80 then
  986.    begin
  987.     kurzor2(x+1,y+l,del);Inc(l);
  988.     if cara[l]=true then Inc(l);
  989.     goto opakuj;
  990.    end;
  991.   until (w=13) and (polozky[l]=true);
  992.   konec: r.ax:=2;Intr(Mouse,r);Menu3:=l;
  993. end;
  994.  
  995. { Funkce "Posun2" pohybuje kurzorem. }
  996. function Posun2(xmin,ymin,xmax,ymax,sirka,krokx,kroky:byte;var x,y:byte):byte;
  997. label    opakuj;
  998. var    kl,kl2:Byte;
  999. begin
  1000.  if xmin<1 then xmin:=1;
  1001.  if ymin<1 then ymin:=1;
  1002.  if xmax>MaxX then xmax:=MaxX;
  1003.  if ymax>MaxY then ymax:=MaxY;
  1004.  if (x<xmin) or (x>xmax) then x:=xmin;
  1005.  if (y<ymin) or (y>ymax) then y:=ymin;
  1006.  if (xmin>xmax) or (ymin>ymax) then begin Posun2:=0;Exit;end;
  1007.  opakuj:
  1008.  Kurzor(x,y,sirka);kl:=Ord(ReadKey);
  1009.  if kl=0 then begin
  1010.   kl2:=Ord(ReadKey);posledni:=kl2;
  1011.   if (kl2=77) and ((x+krokx)<=xmax) then if uziv1 then begin Kurzor(x,y,sirka);x:=x+krokx;Kurzor(x,y,sirka);end;
  1012.   if (kl2=75) and ((x-krokx)>=xmin) then if uziv2 then begin Kurzor(x,y,sirka);x:=x-krokx;Kurzor(x,y,sirka);end;
  1013.   if (kl2=72) and ((y-kroky)>=ymin) then if uziv3 then begin Kurzor(x,y,sirka);y:=y-kroky;Kurzor(x,y,sirka);end;
  1014.   if (kl2=80) and ((y+kroky)<=ymax) then if uziv4 then begin Kurzor(x,y,sirka);y:=y+kroky;Kurzor(x,y,sirka);end;
  1015.  end;
  1016.  Kurzor(x,y,sirka);Posun2:=kl;
  1017. end;
  1018.  
  1019. procedure Cekej2;
  1020. label    Konec;
  1021. var    tlacitka:Word;
  1022.     x,y:Byte;
  1023. begin
  1024.  r.ax:=1;Intr(Mouse,r);
  1025.  x:=WhereX;y:=WhereY;
  1026.  if doba=0 then
  1027.  begin {Nekoneçné çekání}
  1028.    repeat
  1029.     r.ax:=3;Intr(Mouse,r);tlacitka:=r.bx;
  1030.     if (tlacitka>0) then
  1031.     begin
  1032.      repeat
  1033.       r.ax:=3;Intr(Mouse,r);tlacitka:=r.bx;
  1034.      until tlacitka=0;
  1035.      goto Konec;
  1036.     end;
  1037.    until Keypressed;
  1038.    Cekej;
  1039.  end {Nekoneçné çekání}
  1040.  else
  1041.  begin {Çekání "doba" sekund}
  1042.    for i:=0 to doba*10 do
  1043.    begin
  1044.     GotoXY(x,y);Write(Str(1+(doba*10-i) div 10):3);
  1045.     r.ax:=3;Intr(Mouse,r);tlacitka:=r.bx;
  1046.     if (tlacitka>0) then {Stisknuto nêjaké tlaçítko na my¿i}
  1047.     begin
  1048.      repeat
  1049.       r.ax:=3;Intr(Mouse,r);tlacitka:=r.bx;
  1050.      until tlacitka=0; {Dokud tlaçítko nepustím}
  1051.      goto Konec;
  1052.     end;
  1053.     if KeyPressed then begin Cekej;goto Konec;end;
  1054.     Delay(100);
  1055.    end;
  1056.  end; {Çekání "doba" sekund}
  1057.  Konec: r.ax:=2;Intr(Mouse,r);GotoXY(x,y);ClrEol;
  1058. end;
  1059.  
  1060. { Procedura "Kurzor2" je podobná procedu⌐e "Kurzor", rozdíl je pouze v tom
  1061.   æe pro zobrazení a smazání kurzoru je pouæita funkce XOR. }
  1062. procedure Kurzor2;
  1063. var adr:integer;
  1064. begin r.ax:=2;Intr(Mouse,r);adr:=(x-1)+(y-1)*MaxX;
  1065.  for i:=0 to delka-1 do
  1066.  obraz[adr+i].barva:=obraz[adr+i].barva XOR 16;
  1067.  r.ax:=1;Intr(Mouse,r);
  1068. end;
  1069.  
  1070. { Vypí¿e zprávu "Stiskni libovolnou klávesu..." a potom
  1071.   çeká na stisk klávesy. }
  1072. procedure Cekani;
  1073. var x,y:Byte;
  1074. begin
  1075.  x:=WhereX;y:=WhereY;
  1076.  Write(cs('Stisknête libovolnou klávesu nebo tlaçítko na my¿i...'));
  1077.  Cekej2;GotoXY(x,y);ClrEol;
  1078. end;
  1079.  
  1080. procedure Cekani0;
  1081. begin
  1082.   Writeln;Cekani;
  1083. end;
  1084.  
  1085. { Funkce "Menu3" je stejná jako funkce "Menu2", narozdíl je umoænêñ vÿbêr
  1086.   poloæek menu i my¿í.
  1087.   Funkce "Menu4" je¿tê navíc umoæñuje jakési rolování menu v p⌐ípadê, æe se
  1088.   v¿echny poloæky na obrazovku nevejdou. }
  1089. function Menu4(x,y,ram:byte;kur:boolean):byte;
  1090. label    opakuj,prekresli,preskok,konec;
  1091. var    i,del,l,max,pa,px,py,y0,w:Byte;
  1092.     tlacitka,xm,ym,wmin,wmax:Word;
  1093.     pom:Boolean;
  1094.     radku:Byte; {Poçet ⌐ádkû, které zabírá menu na obrazovce:}
  1095.     od:Byte; {Çíslo první poloæky zobrazené v menu sníæené o 1, standartnê 0,
  1096.     av¿ak p⌐i pohybu dolû p⌐i rolování se zvy¿uje a p⌐i pohybu nahoru p⌐i
  1097.     rolování se sniæuje.}
  1098.     pomoc:Boolean; {Zda bylo provedeno rolování a proto potom bude nutno
  1099.     p⌐epsat poloæky menu:}
  1100. begin
  1101.   if (WindMin<>5377) or (WindMax<>5966) then Dialogove_Okno; {Získání parametrû nastavenÿch p⌐íkazem Window,
  1102.   umoæñuje zjistit, zda jiæ bylo pouæito Dialogove_Okno, jinak se vykreslí.}
  1103.   px:=WhereX;py:=WhereY;wmin:=WindMin;wmax:=WindMax;pa:=TextAttr; {Uloæení pûvodních hodnot.}
  1104.  
  1105.   od:=0;
  1106.  
  1107.   if cara[pocet]=True then Dec(pocet);
  1108.   max:=1;l:=1;for i:=0 to pocet do if Length(text[i])>max then max:=Length(text[i]);
  1109.   if Length(text[0])>0 then Inc(i,2); {V p⌐ípadê, æe je uveden nêjakÿ nadpis menu:}
  1110.   if i>10 then radku:=10 else radku:=i;
  1111.   if (x=0) or (y=0) then begin x:=Round((80-(max+2))/2);y:=Round((25-(radku+2))/2);end; {Automatická pozice menu:}
  1112.   if Length(text[0])>0 then Dec(radku,2); {V p⌐ípadê, æe je uveden nêjakÿ nadpis menu:}
  1113.  
  1114.   Prekresli: r.ax:=2;Intr(Mouse,r);
  1115.   ClrScr;TextColor(White);TextBackGround(Brown);
  1116.   barva:=obraz[(x-1)+(y-1)*80+1].barva;
  1117.  
  1118.   if Length(text[0])=0 then begin Obdelnik2(x,y,max,radku,ram,32,False);y0:=1;end
  1119.                else begin Obdelnik2(x,y,max,radku,ram,32,True);Gotoxy(2,2);Write(text[0]);Inc(y,2);y0:=3;end;
  1120.   for i:=1 to radku do begin
  1121.    if cara[od+i]=True then begin
  1122.     TextColor(White);GotoXY(1,y0+i);Write(chr(a5));for w:=1 to max do Write(chr(a2));Write(chr(a6));
  1123.    end else begin
  1124.     if polozky[od+i] then TextColor(White) else TextColor(Black);
  1125.     GotoXY(2,y0+i);Write(text[od+i]);for w:=Length(text[od+i])+1 to max do Write(' ');
  1126.    end;
  1127.   end;
  1128.   TextBackGround(pa div 16);TextColor(pa mod 16);
  1129.   Window((wmin mod 256)+1,(wmin div 256)+1,(wmax mod 256)+1,(wmax div 256)+1);
  1130.   GotoXY(1,1);if Length(text[0])>0 then Write(text[0],' ');
  1131.   Writeln(cs('Klávesami se ¿ipkami vyberte çinnost, pak stisknête ENTER.'));
  1132.   r.ax:=1;Intr(Mouse,r);
  1133.  
  1134.   opakuj:
  1135.   GotoXY(1,2);DelLine;InsLine;Writeln(cs('Çinnost: '+text[od+l]));
  1136.   if kur=False then del:=Length(text[l]) else del:=max;
  1137.   barva:=obraz[x+(y+l-1)*80+1].barva;Kurzor2(x+1,y+l,del);
  1138.   Znak(x+max+1,y+radku,25);Znak(x+max+1,y+1,24);
  1139.   r.ax:=1;Intr(Mouse,r);pom:=False;
  1140.   repeat
  1141.    repeat
  1142.     r.ax:=3;Intr(Mouse,r);xm:=r.cx div 8;ym:=r.dx div 8;tlacitka:=r.bx;
  1143.     if (tlacitka=0) and pom then goto konec;
  1144.     if (tlacitka>0) and (xm>=x) and (xm<x+max) and (ym>=y) and (ym<y+radku) then
  1145.     begin
  1146.      if polozky[ym-y+1]=True then
  1147.      begin pom:=True;
  1148.       if tlacitka>0 then
  1149.       begin
  1150.        if l<>ym-y+1 then
  1151.        begin
  1152.     Kurzor2(x+1,y+l,del);l:=ym-y+1;r.ax:=2;Intr(Mouse,r);
  1153.  
  1154. { Pozor p⌐i pohybu kurzorem my¿í p⌐i parametru kur=False se nemêní velikost
  1155.  kurzoru p⌐i rûznê dlouhÿch poloækách. Vylep¿it !!!}
  1156.  
  1157. {    if kur=False then del:=Length(text[l]) else del:=max;}
  1158.     GotoXY(1,2);DelLine;InsLine;Writeln(cs('Çinnost: '+text[od+l]));
  1159.     r.ax:=1;Intr(Mouse,r);
  1160.     Kurzor2(x+1,y+l,del);pom:=True;
  1161.        end;
  1162.       end;
  1163.      end;
  1164.     end else pom:=False;
  1165.     if (tlacitka>0) and (xm=x+max) and (ym=y) then begin w:=72;Delay(100);goto preskok;end;
  1166.     if (tlacitka>0) and (xm=x+max) and (ym=y+radku-1) then begin w:=80;Delay(100);goto preskok;end;
  1167.    until KeyPressed;
  1168.    w:=Ord(Readkey);
  1169.    preskok: Znak(x+max+1,y+radku,25);Znak(x+max+1,y+1,24);
  1170.  
  1171.    if (w=72) and (l+od<=1) then {Pohyb kurzorem nahoru:}
  1172.    begin
  1173.     if Length(text[0])>0 then Dec(y,2);
  1174.     Kurzor2(x+1,y+l,del);l:=radku;od:=pocet-radku;goto prekresli;
  1175.    end;
  1176.    if w=72 then
  1177.    begin
  1178.     Kurzor2(x+1,y+l,del);Dec(l);pomoc:=False;
  1179.     while l<1 do begin Inc(l);Dec(od);pomoc:=True;end;
  1180.     if cara[l]=True then Dec(l);
  1181.  
  1182.     while l<1 do begin Inc(l);Dec(od);pomoc:=True;end;
  1183.     if pomoc then
  1184.     begin
  1185.      if Length(text[0])>0 then Dec(y,2);
  1186.      goto Prekresli;
  1187.     end else goto opakuj;
  1188.     goto opakuj;
  1189.    end;
  1190.  
  1191.    if (w=80) and (l+od>=pocet) then {Pohyb kurzorem dolû:}
  1192.    begin
  1193.     if Length(text[0])>0 then Dec(y,2);
  1194.     Kurzor2(x+1,y+l,del);l:=1;od:=0;goto prekresli;
  1195.    end;
  1196.    if w=80 then {Pohyb kurzorem dolû:}
  1197.    begin
  1198.     Kurzor2(x+1,y+l,del);Inc(l);pomoc:=False;
  1199.     while l>radku do begin Dec(l);Inc(od);pomoc:=True;end;
  1200.     if cara[l] then Inc(l);
  1201.  
  1202.     while l>radku do begin Dec(l);Inc(od);pomoc:=True;end;
  1203.     if pomoc then
  1204.     begin
  1205.      if Length(text[0])>0 then Dec(y,2);
  1206.      goto Prekresli;
  1207.     end else goto opakuj;
  1208.    end;
  1209.   until (w=13) and (polozky[l]=true);
  1210.   konec: r.ax:=2;Intr(Mouse,r);Menu4:=od+l;
  1211. end;
  1212.  
  1213. {Vrací hodnotu 2 umocnênou na "mocnina".}
  1214. function Dve(mocnina:Byte):Longint;
  1215. var i:Byte;p:Longint;
  1216. begin
  1217.   if mocnina in [0..30] then
  1218.   begin
  1219.     p:=1;for i:=1 to mocnina do p:=p*2;
  1220.   end;
  1221.   Dve:=p;
  1222. end;
  1223.  
  1224. {Vrací hodnotu "i"-tého bitu v çísle "hodnota".
  1225.  Bity:  ... 15 14 13 12 11 10 09 08 07 06 05 04 03 02 01 00
  1226.  Çíslo: ...  X  X  X  X  X  X  X  X  X  X  X  X  X  X  X  X}
  1227. function TestBitu(hodnota:Longint;i:Byte):Boolean;
  1228. begin
  1229.   hodnota:=hodnota mod Dve(i+1); {Nastaví nulové bity od nejvy¿¿ího aæ
  1230.   k levému sousednímu bitu "i".}
  1231.   TestBitu:=hodnota>=Dve(i);
  1232. end;
  1233.  
  1234. {Lep¿í, kdyæ je Str funkce.}
  1235. function Str(b:Longint):String;
  1236. var p:String;
  1237. begin
  1238.   System.Str(b,p);Str:=p;
  1239. end;
  1240.  
  1241. {Umoæñuje zadat délku vÿstupního ⌐etêzce.}
  1242. function Str2;
  1243. var p:String;i:Byte;
  1244. begin
  1245.   System.Str(b:pocet,p);
  1246.   for i:=1 to Length(p) do if p[i]=' ' then p[i]:='0';
  1247.   Str2:=p;
  1248. end;
  1249.  
  1250. {Pomocí menu uæivatel vybere existující soubor na aktuálním disku,
  1251. umoæñuje mênit aktuální adresá⌐e, funkce vrátí disk:cestu:jméno souboru.
  1252. maska = nap⌐. *.*, *.exe, *.pas  apod.
  1253. text  = bude se vypisovat p⌐i vÿbêru soubru}
  1254. function VyberSouboru;
  1255. label    Opakuj;
  1256. var    DirInfo:SearchRec;
  1257.     path,S:String;
  1258.     p:Word;
  1259.     a,D:Byte;
  1260. begin
  1261.   {"S" bude obsahovat pûvodní adresá⌐, "path" se bude postupnê (nêkdy i
  1262.   chaoticky) mênit podle toho, jak bude uæivatel zu⌐ivê "jezdit" po souborech
  1263.   a adresá⌐ích kurzorem v menu:}
  1264.   GetDir(0,S);path:=S;D:=0;
  1265.   opakuj:
  1266.   GetDir(D,path);Nastav;Zacatek(text+' v adresá⌐i '+path);if path[Length(path)]<>'\' then path:=path+'\';
  1267.   FindFirst(path+maska,Directory,DirInfo);p:=1;
  1268.   while DosError = 0 do with DirInfo do
  1269.   begin
  1270.     {V podadresá⌐ích je poloæka "." - ukazující na stejnÿ podadresá⌐ (která
  1271.     se v menu neobjeví - proç taky - v VC nebo v NC se také nezobrazuje)}
  1272.     if Name<>'.' then begin pole[p]:=TestBitu(Attr,4);Radek(Name);Inc(p);end;
  1273.     FindNext(DirInfo);
  1274.   end;
  1275.   a:=Menu4(0,0,1,True);
  1276.   if pole[a] then {Zmêna adresá⌐e}
  1277.   begin
  1278.     ChDir(Zjisti(a));Goto opakuj;
  1279.   end else begin {Volba souboru}
  1280.     VyberSouboru:=path+Zjisti(a);
  1281.   end;
  1282.   ChDir(s); {Obnovení pûvodního adresá⌐e.}
  1283. end;
  1284.  
  1285. function Bin(n:Word):String;
  1286. begin
  1287.  for i:=15 downto 0 do
  1288.  begin
  1289.    Write(Ord(TestBitu(n,i)));
  1290.  end;
  1291.  Writeln(cs(' v binární soustavê.'));
  1292. end;
  1293.  
  1294. function VyberJednotky(text:String):Char;
  1295. var    i:Byte;
  1296.     DirInfo:SearchRec;
  1297.     p:String;
  1298. begin Zacatek(text);Radek('A:');Radek('B:');
  1299.   for i:=67 to 90 do
  1300.   begin
  1301.     FindFirst(Chr(i)+':\*.*',Directory,DirInfo);
  1302.     if (DosError=0) or (DosError=18) or (DosError=152) then Radek(Chr(i)+':');
  1303.   end;
  1304.   Nastav;
  1305.   i:=Menu4(0,0,1,True);
  1306.   p:=Zjisti(i);VyberJednotky:=p[1];Nastav;
  1307. end;
  1308.  
  1309. {Vrací ASCII kód písmene s háçkem a krouækem.}
  1310. function Hacek(NadJakymPismenem:Char):Byte;
  1311. var a:Byte;
  1312. begin
  1313.   a:=Pos(NadJakymPismenem,bezha);
  1314.   if a>0 then Hacek:=Ord(hacky[a])
  1315.   else Hacek:=0;
  1316. end;
  1317.  
  1318. {Vrací ASCII kód písmene s çárkou.}
  1319. function Carka(NadJakymPismenem:Char):Byte;
  1320. var a:Byte;
  1321. begin
  1322.   a:=Pos(NadJakymPismenem,bezca);
  1323.   if a>0 then Carka:=Ord(carky[a])
  1324.   else Carka:=0;
  1325. end;
  1326.  
  1327. procedure Pipej(pole:Array of zaznam);
  1328. var i:Byte;
  1329. begin
  1330.   for i:=0 to High(pole) do with pole[i] do if zvuk then
  1331.   begin
  1332.     Sound(f);Delay(p);
  1333.   end;
  1334.   NoSound;
  1335. end;
  1336.  
  1337. {Vrací znak podle çeské klávesnice, nêkteré znaky vrací v pûvodní podobê,
  1338. jiné konvertuje.}
  1339. function Klavesa2:Char;
  1340. label    preskok,opakuj;
  1341. const    z1:Array[1..9] of zaznam=
  1342.     ((f:50;p:100),(f:100;p:200),(f:200;p:100),
  1343.      (f:400;p:100),(f:200;p:200),(f:800;p:100),
  1344.      (f:600;p:100),(f:400;p:200),(f:200;p:100));
  1345.     z2:Array[1..3] of zaznam=
  1346.     ((f:50;p:50),(f:100;p:100),(f:200;p:50));
  1347. var    a:Char;
  1348. begin
  1349. { Pokud nebylo v minulém volání vráceny v¿echny kódy (nap⌐. p⌐i vracení
  1350.   roz¿í⌐eného kódu) se nejd⌐íve vrátila 0 a nyní je v promênné "pamatuj"
  1351.   roz¿í⌐enÿ ASCII kód speciální klávesy.
  1352.   Uæivatelskÿ program musí dostat i nulu i roz¿í⌐enÿ ASCII kód !!!
  1353.  
  1354.   Dûvod této metody je, æe samotná funkce testuje, zda není stisknutá
  1355.   kombinace kláves Alt+F1, která zapíná/vypíná çeskou klávesnici. Pokud
  1356.   je, zapne resp. vypne çeskou klávesu a volá funkci ReadKey a çeká na stisk
  1357.   dal¿í klávesy. Uæivatelskÿ program se o stisku kombinace kláves Alt+F1
  1358.   nedozví, funkce Klavesa vydá pouze zvukovÿ signál, æe je klávesa p⌐epnuta,
  1359.   p⌐i zapínání çeské klávesnice zahraje více tónû, p⌐i vypínání zahraje ménê
  1360.   tónû.
  1361.   Pokud je zapnutá çeská klávesnice a je stisknuta klávesa >=<, program
  1362.   çeká na stisk písmena, nad kterÿm se pí¿e çárka, kód písmena s çárkou
  1363.   vrátí jako vÿstup funkce.
  1364.   Podobnê p⌐i stisku '+' slouæí pro psaní písmen s háçkem, zde stejnê jako
  1365.   u çárky se çeká na stisk dal¿í klávesy s písmenem, funkce vrátí jako svûj
  1366.   vÿstup písmeno s háçkem.
  1367.  
  1368.   Uæivatelská otázka: A jak napí¿u písmeno: "û" nebo "ª"?
  1369.   Odpovêâ: 1. "û" napí¿ete stiskem ";".
  1370.        2. "û" i "ª" lze napsat stiskem "+" a potom "u" nebo "U".
  1371. }
  1372.   if vrat then begin Klavesa2:=pamatuj;vrat:=False;Exit;end;
  1373.   opakuj:
  1374.   a:=ReadKey;
  1375.   if stav=vypnuta then begin Klavesa2:=a;goto Preskok;end;
  1376.   case a of
  1377.    '1': Klavesa2:='+';
  1378.    '2': Klavesa2:='ê';
  1379.    '3': Klavesa2:='¿';
  1380.    '4': Klavesa2:='ç';
  1381.    '5': Klavesa2:='⌐';
  1382.    '6': Klavesa2:='æ';
  1383.    '7': Klavesa2:='ÿ';
  1384.    '8': Klavesa2:='á';
  1385.    '9': Klavesa2:='í';
  1386.    '0': Klavesa2:='é';
  1387.    '!': Klavesa2:='1';
  1388.    '@': Klavesa2:='2';
  1389.    '#': Klavesa2:='3';
  1390.    '$': Klavesa2:='4';
  1391.    '%': Klavesa2:='5';
  1392.    '^': Klavesa2:='6';
  1393.    '&': Klavesa2:='7';
  1394.    '*': Klavesa2:='8';
  1395.    '(': Klavesa2:='9';
  1396.    ')': Klavesa2:='0';
  1397.    '-': Klavesa2:='=';
  1398.    '_': Klavesa2:='%';
  1399.    '[': Klavesa2:='ú';
  1400.    '{': Klavesa2:='/';
  1401.    ']': Klavesa2:=')';
  1402.    '}': Klavesa2:='(';
  1403.    ';': Klavesa2:='û';
  1404.    ':': Klavesa2:='"';
  1405.    {apostrof} Chr(39): Klavesa2:='¡';
  1406.    '"': Klavesa2:='!';
  1407.    '=': begin a:=ReadKey;if Carka(a)>0 then Klavesa2:=Chr(Carka(a)) else Klavesa2:=a;end; {çárka nad písmenem}
  1408.    '+': begin a:=ReadKey;if Hacek(a)>0 then Klavesa2:=Chr(Hacek(a)) else Klavesa2:=a;end; {háçek nad písmenem}
  1409.    '<': Klavesa2:='?';
  1410.    '>': Klavesa2:=':';
  1411.    '/': Klavesa2:='-';
  1412.    '?': Klavesa2:='_';
  1413.    else Klavesa2:=a;
  1414.   end;
  1415.   preskok:
  1416.   if a=Chr(0) then begin {>Alt<+>F1<}
  1417.     a:=ReadKey;
  1418.     pamatuj:=a; {Pokud nebude Alt+F1, potom bude vrácena jako vÿstup funkce
  1419.     hodnota Chr(0) a p⌐i následujícím volání vrácena zapamatovaná klávesa,
  1420.     která je zapamatovaná v promênné "pamatuj".}
  1421.     if Ord(a)=AltF1 then
  1422.     begin
  1423.       if stav=Zapnuta then Pipej(z2) else Pipej(z1);
  1424.       stav:=Not(stav);goto opakuj;
  1425.     end else begin Klavesa2:=Chr(0);vrat:=True;end;
  1426.   end;{>Alt<+>F1<}
  1427. end;
  1428.  
  1429. procedure TvarKurzoru(StartLine,EndLine:Byte);
  1430. var r:Registers;
  1431. begin
  1432.   r.AH:=1;
  1433.   r.CH:=StartLine;
  1434.   r.CL:=EndLine;
  1435.   Intr($10,r);
  1436. end;
  1437.  
  1438. function CtiString;begin CtiString:=CtiString2(zprava,False,False);end;
  1439.  
  1440. {Funkce která v podobê malého textového editoru umoæní zadat z klávesnice
  1441.  1 ⌐ádek a vrátí ho jako vÿstup funkce.
  1442.  Vstupy: Zprava = Zpráva, která se objeví na rámeçku.
  1443.      PouzeCisla = True : Umoæní zadání pouze çíslice, desetinnou teçku a
  1444.                  minus
  1445.             = False: Jakÿkoliv text
  1446.      Tajne        = True : Nevypisuje p⌐i vstupu z klávesnice do ⌐ádku
  1447.                  znaky, pouze 1 nastavenÿ znak, aƒ je stisknutá
  1448.                  jakákoliv klávesa (znaková, çíselná, grafická).
  1449.                  Nastavení tohoto znaku viz: NastavTajnyZnak}
  1450. function CtiString2;
  1451. var pom:String;
  1452. begin
  1453.   pom:='';CtiString3(zprava,PouzeCisla,Tajne,pom);CtiString2:=pom;
  1454. end;
  1455.  
  1456. {Nastavení tajného znaku, pokud p⌐i funkci CtiString2 poæadujete nevypisovat
  1457.  znaky (nap⌐. p⌐i heslu), tak jakÿ znak má poçítaç vypisovat.}
  1458. procedure NastavTajnyZnak;
  1459. begin
  1460.   TajnyZnak:=znak;
  1461. end;
  1462.  
  1463. {Zji¿têní tajného znaku nastaveného procedurou NastavTajnyZnak. Poznámka:
  1464.  Pokud jako tajny znak zadáte mezeru ' ', potom ostatní lidé ¿patnê odhadnou,
  1465.  kolik znakû má heslo. Ale v tom p⌐ípadê neuvidíte, kolik znakû jste napsali.}
  1466. function ZjistiTajnyZnak;
  1467. begin
  1468.   ZjistiTajnyZnak:=TajnyZnak;
  1469. end;
  1470.  
  1471. procedure NastavCekani(delka:Byte);
  1472. begin
  1473.   doba:=delka;
  1474. end;
  1475.  
  1476. {Procedury z jednotky SYSTEM: Vêt¿inou vrací chyby a ukonçují program.}
  1477. procedure Assign(var f:System.Text;s:String);begin {$I-}System.Assign(f,s);{$I+}chyba:=IOResult;end;
  1478. procedure Reset(var f:System.Text);begin {$I-}System.Reset(f);{$I+}chyba:=IOResult;end;
  1479. procedure Rewrite(var f:System.Text);
  1480. begin
  1481.  {$I-}System.Rewrite(f);{$I+}
  1482.  chyba:=IOResult;
  1483. end;
  1484. procedure Append(var f:System.Text);begin {$I-}System.Append(f);{$I+}chyba:=IOResult;end;
  1485. procedure Close(var f:System.Text);begin {$I-}System.Close(f);{$I+}chyba:=IOResult;end;
  1486. procedure ChDir(s:String);var pom:String;
  1487.  begin
  1488.   if s[Length(s)]='\' then
  1489.    pom:=Copy(s,1,Length(s)-1)
  1490.   else
  1491.    pom:=s;
  1492.   {$I-}System.ChDir(pom);{$I+}chyba:=IOResult;
  1493.  end;
  1494. procedure MkDir(s:String);var pom:String;
  1495.  begin if s[Length(s)]='\' then pom:=Copy(s,1,Length(s)-1) else pom:=s;{$I-}System.MkDir(pom);{$I+}chyba:=IOResult;end;
  1496.  
  1497. {Nové procedury a funkce:}
  1498.  
  1499. {Vÿstupem funkce je Tru, v p⌐ípadê, æe je rok "r" p⌐estupnÿ, jinak False}
  1500. function Prestupny;
  1501. begin
  1502.  Prestupny:=((r/4)=Int(r/4)) and ((r/100)<>Int(r/100)) or ((r/500)=Int(r/500));
  1503. end;
  1504.  
  1505. {Vrací poçet dnû v mêsíci "mesic" v roce "rok":}
  1506. function Pocet2;
  1507. begin
  1508.  Pocet2:=0;if (mesic<1) or (mesic>12) then Exit;
  1509.  if mesic<>2 then Pocet2:=Pocty[mesic]
  1510.  else if Prestupny(rok) then Pocet2:=29 else Pocet2:=Pocty[mesic];
  1511. end;
  1512.  
  1513. {Vrací True v p⌐ípadê, æe datum d.m.r je moæné, jinak False}
  1514. function SpravneDatum;
  1515. begin
  1516.  SpravneDatum:=(m in [1..12]) and (d>=1) and (d<=Pocet2(m,r));
  1517. end;
  1518.  
  1519. {Do d2.m2.r2 uloæí zít⌐ej¿í datum, jestliæe dnes je d1.m1.r1}
  1520. procedure Zitra;
  1521. begin
  1522.  if SpravneDatum(d1,m1,r1)=False then begin Writeln(cs('Procedura Zitra: ¢patné datum.'));Cekani;Konec;end;
  1523.  if d1<Pocet2(m1,r1) then begin d2:=d1+1;m2:=m1;r2:=r1;end else
  1524.  begin
  1525.   d2:=1;m2:=m1;r2:=r1;Inc(m2);if m2>12 then begin m2:=1;Inc(r2);end;
  1526.  end;
  1527. end;
  1528.  
  1529. {Do d2.m2.r2 uloæí vçerej¿í datum, jestliæe dnes je d1.m1.r1}
  1530. procedure Vcera;
  1531. begin
  1532.  if SpravneDatum(d1,m1,r1)=False then begin Writeln(cs('Procedura Vcera: ¢patné datum.'));Cekani;Konec;end;
  1533.  if d1>1 then begin d2:=d1-1;m2:=m1;r2:=r1;end else
  1534.  begin
  1535.   m2:=m1;r2:=r1;Dec(m2);if m2<1 then begin m2:=12;Dec(r2);end;
  1536.   d2:=Pocet2(m2,r2);
  1537.  end;
  1538. end;
  1539.  
  1540. {function Str(cislo:Longint):String;
  1541. var s:String;
  1542. begin
  1543.  System.Str(cislo,s);Str:=s;
  1544. end;}
  1545.  
  1546. procedure UlozBarvy; {Uloæí barvy textu a pozadí do svÿch promênnÿch.}
  1547. begin
  1548.   b:=TextAttr;
  1549. end;
  1550.  
  1551. procedure ObnovBarvy; {Obnoví barvy textu a pozadí ze svÿch promênnÿch.}
  1552. begin
  1553.   TextBackGround(b div 16);TextColor(b mod 16);
  1554. end;
  1555.  
  1556. function Hledej(soubor,Hledat:String):Longint;
  1557. label    vyskok;
  1558. var    f:File of Byte; {Binární soubor}
  1559.     b,i:Byte; {Çtenÿ Byte}
  1560.     p:Longint; {Stará pozice v souboru}
  1561.     nalezeno:Byte;
  1562. begin
  1563.   nalezeno:=0;
  1564.   {$I-}
  1565.   System.Assign(f,soubor);System.Reset(f);
  1566.   {$I+}
  1567.   if IOResult = 0 then
  1568.   begin
  1569.     Writeln(cs('Testuji a prohledávám '+soubor));
  1570.     while Not(Eof(f)) do
  1571.     begin
  1572.       p:=FilePos(f);Read(f,b);
  1573.       if b=Ord(Hledat[1]) then
  1574.       begin
  1575.     for i:=2 to Length(hledat) do
  1576.     begin
  1577.       Seek(f,p+(i-1)*13);Read(f,b);
  1578.       if b<>Ord(Hledat[i]) then
  1579.       begin
  1580.         Seek(f,p+1);Write('x');Goto vyskok;
  1581.       end; {end of if}
  1582.     end; {end of for}
  1583.     Write('*');Hledej:=p;Inc(nalezeno);
  1584.  
  1585.     vyskok:
  1586.       end; {end of if}
  1587.     end; {end of while}
  1588.     System.Close(f);Writeln(cs(' O.K.,soubor '+soubor+' byl prohledán.'));Writeln;
  1589.     if nalezeno<>1 then Hledej:=-1;
  1590.   end else Hledej:=-1;
  1591. end;
  1592.  
  1593. function Hledej2(soubor,Hledat:String):Longint;
  1594. label    preskok,vyskok;
  1595. const    max=2048;
  1596. var    f:File;
  1597.     i,w:Word; {Çtenÿ Byte}
  1598.     p:Longint; {Stará pozice v souboru}
  1599.     nalezeno:Byte;
  1600.     NumRead,NumRead2:Word;
  1601.     Buf:array[1..max] of Char;
  1602. begin
  1603.   nalezeno:=0;
  1604.   {$I-}
  1605.   System.Assign(f,soubor);System.Reset(f,1);
  1606.   {$I+}
  1607.   if IOResult = 0 then
  1608.   begin
  1609.     Write(cs('Testuji a prohledávám '+soubor+'...'));
  1610.     repeat
  1611.       p:=FilePos(f); {uloæení pûvodní hodmoty ukazatele v souboru, protoæe
  1612.       se bude mênit}
  1613.       BlockRead(f,Buf,SizeOf(Buf),NumRead);
  1614.       if NumRead=0 then goto vyskok;
  1615.  
  1616.       for i:=1 to NumRead do {v¿echny znaky v bufferu se porovnají s 1. znakem v ⌐etêzci "hledat":}
  1617.       begin
  1618.     if Buf[i]=Hledat[1] then {nalezen znak v bufferu Buf na pozici "i":}
  1619.     begin
  1620.  
  1621.       for w:=2 to Length(hledat) do {kontrolují se dal¿í znaky textu:}
  1622.       begin
  1623.         {má bÿt nalezeno na pozici 9558 v souboru REGISTRA.EXE}
  1624.         Seek(f,p+i-1+(w-1)*13);BlockRead(f,Buf,1,NumRead2);
  1625.         if Buf[1]<>Hledat[w] then
  1626.         begin
  1627.           Seek(f,p);goto preskok; {vÿskok z cyklu for i}
  1628.         end; {end of if}
  1629.       end; {end of for}
  1630.       {Pokud je celÿ text nalezen:}
  1631.       Hledej2:=p+i-1;Seek(f,p);Inc(nalezeno);Write('*',#7);
  1632.       preskok:
  1633.  
  1634.     end; {end of if}
  1635. {    goto nalezen1znak;}
  1636.       end; {end of for}
  1637.       Seek(f,p+NumRead);
  1638.       goto vyskok; {prohledávání dal¿ího bloku souboru v bufferu:}
  1639.  
  1640.  
  1641.       vyskok:
  1642.     until NumRead=0;
  1643.     System.Close(f);Writeln('O.K.');
  1644.     if nalezeno<>1 then Hledej2:=-1;
  1645.   end else Hledej2:=-1;
  1646. end;
  1647.  
  1648. {Sample code for the BlockRead and BlockWrite procedures.}
  1649. procedure CopyFile(input,output:String);
  1650. label    preskok;
  1651. var    FromF, ToF: file;
  1652.     NumRead, NumWritten: Word;
  1653.     Buf: array[1..2048] of Char;
  1654. begin
  1655.   Writeln(cs('Kopíruji soubor '+input+' => '+output));
  1656.   {$I-}
  1657.   System.Assign(FromF,input); { Open input file }
  1658.   System.Reset(FromF, 1);  { Record size = 1 }
  1659.   {$I+}
  1660.   if IOResult=0 then {Otev⌐ení souboru pro çtení se poda⌐ilo.}
  1661.   begin
  1662.     {$I-}
  1663.     System.Assign(ToF,output); { Open output file }
  1664.     System.Rewrite(ToF, 1);  { Record size = 1 }
  1665.     {$I+}
  1666.  
  1667.     if IOResult=0 then {Otev⌐ení souboru pro zápis se poda⌐ilo.}
  1668.     begin
  1669.       Writeln(cs('Kopíruji celkem '+ Str(FileSize(FromF))+' bytû...'));
  1670.       repeat
  1671.     {$I-} BlockRead(FromF, Buf, SizeOf(Buf), NumRead); {$I+}
  1672.     if IOResult<>0 then
  1673.     begin
  1674.       Writeln(cs('!!! Chyba p⌐i çtení dat v souboru !!!'));goto preskok;
  1675.     end;
  1676.     {$I-} BlockWrite(ToF, Buf, NumRead, NumWritten); {$I+}
  1677.     if IOResult<>0 then
  1678.     begin
  1679.       Writeln(cs('!!! Chyba p⌐i zápisu dat do souboru !!!'));goto preskok;
  1680.     end;
  1681.       until (NumRead = 0) or (NumWritten <> NumRead);
  1682.       preskok:
  1683.       {$I-}System.Close(ToF);{$I+}if IOResult<>0 then Writeln(cs('Soubor '+output+' nelze zav⌐ít.'));
  1684.     end else Writeln(cs('!!! Chyba p⌐i zápisu, soubor '+output+' nelze otev⌐ít !!!'+Chr(7)));
  1685.  
  1686.     {$I-}System.Close(FromF);{$I+}if IOResult<>0 then Writeln(cs('Soubor '+input+' nelze zav⌐ít.'));
  1687.  
  1688.   end else Writeln(cs('!!! Chyba p⌐i çtení+soubor'+input+' nelze otev⌐ít !!!'+Chr(7)));
  1689. end;
  1690.  
  1691. function Dekoduj(co:String):String;
  1692. var a,b,i:Byte;
  1693. begin
  1694.   Dekoduj[0]:=co[0];
  1695.   for i:=1 to Length(co) do
  1696.   begin
  1697.     a:=Ord(co[i]);
  1698.     b:=a-10;
  1699.     b:=b XOR 2;
  1700.     b:=b+7;
  1701.     b:=b XOR 128;
  1702.     b:=b-5;
  1703.     Dekoduj[i]:=Chr(b);
  1704.   end;
  1705. end;
  1706.  
  1707. function DelkaSouboru(jmeno:String):Longint;
  1708. var f:File of Byte;
  1709. begin
  1710.   {$I-}
  1711.   System.Assign(f,jmeno);System.Reset(f);
  1712.   {$I+}
  1713.   if IOResult=0 then
  1714.   begin
  1715.     DelkaSouboru:=FileSize(f);
  1716.     System.Close(f);
  1717.   end else DelkaSouboru:=-1;
  1718. end;
  1719.  
  1720. {Funkce provádí kontrolní souçet souboru standarntí názornou metodou:
  1721.  V cyklu çteme jednotlivé Byty souboru a p⌐itom je sçítáme.}
  1722. function Soucet1;
  1723. var    s:Longint;
  1724.     b:Byte;
  1725.     f:File of Byte;
  1726. begin
  1727.   {$I-}
  1728.   System.Assign(f,jmeno);System.Reset(f);
  1729.   {$I+}
  1730.   s:=0;
  1731.   if IOResult=0 then
  1732.   begin
  1733.     while Not(Eof(f)) do begin Read(f,b);Inc(s,b);end;
  1734.     System.Close(f);Soucet1:=s;
  1735.   end else Soucet1:=-1;
  1736. end;
  1737.  
  1738. {Metoda pro kontrolní souçet souboru je naprogramován je¿tê jinak:
  1739.  Zde je definován typ "pamet", kterÿ je promênná typu pole. To se naçte
  1740.  ze souboru jako 1 promênná. Potom se teprve seçtou prvky v poli.
  1741.  Tato druhá metoda je sice pouæitelná pouze u souboru p⌐edem známé délky a
  1742.  dostateçnê velké pamêti (resp. zásobníku), ale je mnohokrát rychlej¿í.
  1743.  
  1744.  Dále je naprogramovaná funkce Soucet2:
  1745.  Funkce "Soucet1" a "Soucet2" udêlají totéæ, av¿ak "Soucet2" nêkolikrát
  1746.  rychleji.
  1747.  Zrovna mi to p⌐ipomíná programování na ATARI 800 XL/XE a to porovnání
  1748.  rychlosti mezi interpretem ATARI-BASIC (nepot⌐eboval ani zpoæâovací smyçky)
  1749.  s kompilátorem ACTION!, kde se rychlost dala srovnat s programem napsanÿm
  1750.  rovnou ve strojovém kódu µP 6502. Programátor v ATARI-BASICu musel (pokud
  1751.  chtêl mít alespoñ trochu rychlÿ program) hledat nêkolik rûznÿch metod
  1752.  (hlavnê p⌐i vÿpoçtech, ATARI totiæ nemêlo matematickÿ koprocesor) a nêkdy
  1753.  z programu v BASICu dokonce odstartovat p⌐eloæenÿ program ve strojovém
  1754.  kódu µP 6502. A také prográmky têchto programátorû poznáte podle toho, æe
  1755.  se v¿echny vejdou do 64 kB, vêt¿inou byl limit 48 kB a dále velká rychlost
  1756.  (kdyby se teoreticky spustili na ATARI nap⌐. s frekvencí 10 MHz.), potom
  1757.  by byly asi stejnê rychlé jako podobné algoritmy na 486 s koprocesorem
  1758.  a frekvencí 66 MHz a více.
  1759.  
  1760.  A nebo kdyby se v¿echny programy programovaly na XT nebo 286, potom by
  1761.  v¿echny programy byly dost rychlé (ale ne v¿ichni programáto⌐i to dêlají).}
  1762.  
  1763. function Soucet2;
  1764. var    s:Longint;
  1765.     f:File;
  1766.     i,NumRead:Word;
  1767.     Buf:array[1..2048] of Byte;
  1768. begin
  1769.   {$I-}
  1770.   System.Assign(f,jmeno);System.Reset(f,1);
  1771.   {$I+}
  1772.   s:=0;
  1773.   if IOResult=0 then
  1774.   begin
  1775.     repeat
  1776.       BlockRead(f,Buf,SizeOf(Buf),NumRead);
  1777.       for i:=1 to NumRead do Inc(s,Buf[i]);
  1778.     until (NumRead=0);
  1779.     System.Close(f);Soucet2:=s;
  1780.   end else Soucet2:=-1;
  1781. end;
  1782.  
  1783. { P⌐eçte çíslo z klávesnice:}
  1784. function CtiCislo(text:String):Real;
  1785. var s:String;pom:Real;i:Integer;stara:Boolean;
  1786. begin
  1787.   stara:=stav;stav:=vypnuta;
  1788.   repeat
  1789.     s:=CtiString2(text+' Potom ukonçete zadání çísla klávesou >Enter<.',True,False);
  1790.     System.Val(s,pom,i);
  1791.   until i=0;
  1792.   CtiCislo:=pom;stav:=stara;
  1793. end;
  1794.  
  1795. { Vÿznam procedur Cti_Byte, Cti_Real, Cti_LongInt je zamezení p⌐eru¿ení
  1796.   programu p⌐i zadáním nesmyslnÿch znakû, kdyæ poçítaç çeká na vstup çísla: }
  1797. function Cti_Byte;
  1798. var r:Real;
  1799. begin
  1800.  repeat
  1801.    r:=CtiCislo(text);
  1802.  until (r=Int(r)) and (r>=0) and (r<=255);
  1803.  Cti_Byte:=Round(r);
  1804. end;
  1805.  
  1806. function Cti_Real;
  1807. var r:Real;
  1808. begin
  1809.  Cti_Real:=CtiCislo(text);
  1810. end;
  1811.  
  1812. function Cti_LongInt;
  1813. var r:Real;
  1814. begin
  1815.  repeat
  1816.    r:=CtiCislo(text);
  1817.  until (r=Int(r)) and (r>=-2147483647) and (r<=2147483647);
  1818.  Cti_LongInt:=Round(r);
  1819. end;
  1820.  
  1821. procedure BorderColor(barva:Byte);
  1822. var r:Registers;
  1823. begin
  1824.  with r do
  1825.  begin
  1826.    r.ah:=$0B;r.bh:=0;r.bl:=barva;Intr($10,r);
  1827.  end;
  1828. end;
  1829.  
  1830. procedure CtiString3;
  1831. label    preskok,vykresli;
  1832. const    z1:Array[1..9] of zaznam=
  1833.     ((f:150;p:50),(f:300;p:100),(f:50;p:50),
  1834.      (f:400;p:50),(f:500;p:100),(f:1000;p:50),
  1835.      (f:600;p:50),(f:400;p:100),(f:800;p:50));
  1836.     z2:Array[1..3] of zaznam=
  1837.     ((f:500;p:50),(f:250;p:100),(f:400;p:50));
  1838.  
  1839. var    l,x,xmin,xmax,y:Byte;
  1840.     kl:Byte;
  1841.     pom:String; {Zde se ukládá text bêhem editace ⌐ádku.}
  1842.     ins:Boolean; {Obsahuje True v insert reæimu, jinak obsahuje False
  1843.     v p⌐episovacím reæimu.}
  1844.  
  1845.   procedure Vypis;
  1846.   var i:Byte;
  1847.   begin
  1848.     GotoXY(xmin,y);
  1849.     if Tajne then
  1850.     begin
  1851.       for i:=1 to Length(pom) do Write(TajnyZnak);
  1852.       Writeln(' ');
  1853.     end else
  1854.     if Length(pom)<l then Writeln(cs(pom),' ') else Writeln(cs(DoplnNa(pom,l)));
  1855.   end;
  1856.  
  1857. begin
  1858.   Window(1,1,80,25);Pipej(z1);pom:=text;TvarKurzoru($1E,$1F);ins:=True;
  1859.   l:=Length(zprava);if l>78 then begin zprava[0]:=Chr(78);l:=78;end;
  1860.   xmin:=1+((80-l) div 2);xmax:=xmin+l-1;
  1861.   x:=xmin;y:=11;x:=xmin+Length(pom);
  1862.   vykresli:
  1863.   Obdelnik(xmin-1,y-1,Length(zprava),1,1,32,False);
  1864.   Vypis;GotoXY(xmin,y-1);Writeln(cs(zprava));
  1865.   repeat
  1866.     GotoXY(xmin,y+1);if ins then Write(cs('Vkládací reæim───')) else Write(cs('P⌐episovací reæim'));
  1867.     Write(cs('─>F1<=nápovêda'));GotoXY(x,y);
  1868.     kl:=Ord(Klavesa2);
  1869.     case kl of
  1870.      0: begin
  1871.       kl:=Ord(Klavesa2);
  1872.       if (kl=Right) and (x<xmax) and (x<xmin+Length(pom)) then Inc(x);
  1873.       if (kl=Left) and (x>xmin) then Dec(x);
  1874.       if (kl=Home) then x:=xmin;
  1875.       if (kl=KlavesaEnd) then x:=xmin+Length(pom);
  1876.       if (kl=Delete) and (x<xmin+Length(pom)) then begin System.Delete(pom,x-xmin+1,1);Vypis;end;
  1877.       if (kl=Insert) then
  1878.       begin
  1879.         ins:=Not(ins);
  1880.         if ins then
  1881.         begin
  1882.           TvarKurzoru($1E,$1F);Pipej(z2);
  1883.         end else begin
  1884.           TvarKurzoru($00,$1F);Pipej(z1);
  1885.         end;
  1886.       end;
  1887.       if kl=F1 then
  1888.       begin
  1889.         Pipej(z1);Nastav;
  1890.         TextColor(Red);Writeln(cs('Nápovêda k editaci ⌐ádku:'));TextColor(Blue);
  1891.         Writeln(cs('Nyní poçítaç çeká na vstup z klávesnice (pokud ji nemáte, máte smûlu),'));
  1892.         Writeln(cs('protoæe se nedoçkáte. Mêli byste (ve vlastním zájmu) nêjakou tu klávesu'));
  1893.         Writeln(cs('stisknout nebo se nic nestane.'));Writeln;
  1894.         TextColor(White);Writeln(cs('Jedná se o malÿ textovÿ editor pro jeden ⌐ádek:'));TextColor(Yellow);
  1895.         Writeln(cs('1. Má dva reæimy: P⌐episovací (replace) a vkládací (insert). P⌐epínání'));
  1896.         Writeln(cs('   mezi obêma reæimy se provede stiskem klávesy >Insert<.'));
  1897.         Writeln(cs('2. Pohyb kurzoru po jiæ napsaném textu klávesami >'+Chr(27)+'<,>'+Chr(26)+'<.'));
  1898.         Writeln(cs('3. Ukonçení editace >Enter< nebo >Esc<.'));
  1899.         Writeln(cs('4. >Delete< mazání znaku pod kurzorem.'));
  1900.         Writeln(cs('5. >Back Space< na klávesnici oznaçena >'+Chr(27)+'< mazání levého znaku'));
  1901.         Writeln(cs('   a posun kurzoru doleva.'));
  1902.         Writeln(cs('6. >F1< tato nápovêda'));Writeln;
  1903.         TextColor(White);Writeln(cs('Funkce çeské klávesnice:'));TextColor(Yellow);
  1904.         Writeln(cs('1. >Alt<+>F1< zapnutí/vypnutí çeské klávesnice'));
  1905.         Writeln(cs('2. >=< znamená, æe nad následujícím písmenem se napí¿e çárka'));
  1906.         Writeln(cs('3. >+< znamená, æe nad následujícím písmenem se napí¿e háçek(krouæek)'));
  1907.         Writeln(cs('4. Ostatní çeská písmena - viz çervenÿ potisk na klávesnici (pokud ho'));
  1908.         Writeln(cs('   klávesnice má).'));
  1909.         Writeln(cs('!!! Volby 2,3,4 pouze v p⌐ípadê, æe je zapnutá çeská klávesa - viz bod 1, jinak'));
  1910.         Writeln(cs('se po stisku uvedenÿch kláves napí¿í normální çerné znaky na klávesnici !!!'));Writeln;
  1911.         Cekani;Nastav;Pipej(z2);goto vykresli;
  1912.       end;
  1913.     end;
  1914.      8: begin {Mazání znaku a posun kurzoru doleva:}
  1915.       if x>xmin then
  1916.       begin
  1917.         System.Delete(pom,x-xmin,1);Vypis;Dec(x);
  1918.       end;
  1919.     end;
  1920.      32..255: begin
  1921.         if PouzeCisla then
  1922.         begin
  1923.           if (kl=45) and (x<>xmin) then begin Write(#7);goto Preskok;end; {"-" je dovoleno jenom na 1. pozici}
  1924.           if (kl=46) and ((Pos('.',pom)<>0) or (x=xmin) or Not(pom[x-xmin] in ['0'..'9'])) then
  1925.           begin {desetinná "." je povolena jen 1x, nesmí bÿt na 1. pozici (x=xmin) a musí bÿt p⌐ed ní çíslice}
  1926.             Write(#7);goto Preskok;
  1927.           end;
  1928.           if Not(kl in [45,46,48..57]) then begin Write(#7);goto Preskok;end; {pokud není '.','-' nebo çíslice}
  1929.         end;
  1930.  
  1931.         if ((x<xmax) and ((Length(pom)+1)<l)) or
  1932.         ((ins=False) and (x<xmax)) then
  1933.         begin
  1934.           if ins then System.Insert(Chr(kl),pom,x-xmin+1)
  1935.           else
  1936.           begin
  1937.             if x>=xmin+Length(pom) then pom[0]:=Chr(x-xmin+1);
  1938.             pom[x-xmin+1]:=Chr(kl);
  1939.           end;
  1940.           Vypis;Inc(x);
  1941.         end;
  1942.         Preskok:
  1943.           end;
  1944.     end;
  1945.   until (kl=13) or (kl=27);
  1946.   Nastav;TvarKurzoru($1E,$1F);
  1947.   text:=pom;Pipej(z2);
  1948. end;
  1949.  
  1950. function DoplnNa(co:String;NaDelku:Byte):String;
  1951. begin
  1952.   if Length(co)>=NaDelku then co[0]:=Chr(NaDelku)
  1953.   else begin
  1954.     while Length(co)<NaDelku do co:=co+' ';
  1955.   end;
  1956.   DoplnNa:=co;
  1957. end;
  1958.  
  1959. function Secti(x,y:Char):Char;
  1960. var    i,i1,i2:Byte;
  1961.     pom:Smery;
  1962. begin
  1963.   i1:=0;i2:=0;
  1964.   for i:=1 to pocet0 do {Prohledání celého tabulky v poli "pole0":}
  1965.   begin
  1966.     if (x=pole0[i].znak) then i1:=i; {Pozice v poli, na které byl nalezen znak "x", uloæ do "i1":}
  1967.     if (y=pole0[i].znak) then i2:=i; {Pozice v poli, na které byl nalezen znak "y", uloæ do "i2":}
  1968.   end;
  1969.   if i1=0 then begin Secti:=y;Exit;end; {V tomto p⌐ípadê vraƒ znak "y", protoæe "x" nebylo nalezeno.}
  1970.   if i2=0 then begin Secti:=x;Exit;end; {V tomto p⌐ípadê vraƒ znak "x", protoæe "y" nebylo nalezeno.}
  1971.  
  1972.   {Nyní jiæ jsou vylouçené p⌐ípady, æe buâ "x" nebo "y" nebylo v tabulce nalezeno,
  1973.   tzn. "x" i "y" byly nalezeny v tabulce:}
  1974.   pom.nahoru:=pole0[i1].nahoru or pole0[i2].nahoru;
  1975.   pom.dolu:=pole0[i1].dolu or pole0[i2].dolu;
  1976.   pom.doleva:=pole0[i1].doleva or pole0[i2].doleva;
  1977.   pom.doprava:=pole0[i1].doprava or pole0[i2].doprava;
  1978.  
  1979.   for i:=1 to pocet0 do {Prohledání celého tabulky v poli "pole0":}
  1980.   begin
  1981.     if (pom.nahoru=pole0[i].nahoru) and (pom.dolu=pole0[i].dolu) and
  1982.        (pom.doleva=pole0[i].doleva) and (pom.doprava=pole0[i].doprava) then
  1983.     begin
  1984.       Secti:=pole0[i].znak;Exit; {Nalezen znak, kterÿ odpovídá seçtení "x" s "y":}
  1985.     end;
  1986.   end;
  1987.   Writeln(cs('Znak, kterÿ vznikl seçtením "'+x+'" s "'+y+'" nebyl nalezen.'));
  1988.   with pole0[i] do
  1989.   begin
  1990.     Writeln('Nahoru: ',nahoru,' Dolu: ',dolu,' Doleva: ',doleva,' Doprava: ',doprava);
  1991.     Cekani;Konec;
  1992.   end;
  1993. end;
  1994.  
  1995. {Funkce Locate vrací znak, kterÿ je na obrazovce na pozici x,y:}
  1996. {Parametr "znaku" udává poçet znakû na ⌐ádku v textovém reæimu:}
  1997. function Locate(x,y:Byte):Char;
  1998. var adr:Word;
  1999. begin
  2000.  adr:=x-1+(y-1)*MaxX;Locate:=Chr(Fr_Sok.obraz[adr].ascii);
  2001. end;
  2002.  
  2003. procedure PisZnak(ASCII:Char);
  2004. var x,y:Byte;
  2005. begin
  2006.   x:=WhereX;y:=WhereY;Znak(x,y,Ord(Secti(ASCII,Locate(x,y))));
  2007.   if x<MaxX then GotoXY(x+1,y) else GotoXY(1,y+1);
  2008. end;
  2009.  
  2010. function VratTrue:Boolean;
  2011. begin
  2012.   VratTrue:=True;
  2013. end;
  2014.  
  2015. function Sude(c:Longint):Boolean;
  2016. begin
  2017.   Sude:=(c mod 2)=0;
  2018. end;
  2019.  
  2020. function Liche(c:Longint):Boolean;
  2021. begin
  2022.   Liche:=(c mod 2)=1;
  2023. end;
  2024.  
  2025. function Min(c1,c2:Longint):Longint;
  2026. begin
  2027.   if c1<c2 then Min:=c1 else Min:=c2;
  2028. end;
  2029.  
  2030. function Max(c1,c2:Longint):Longint;
  2031. begin
  2032.   if c1>c2 then Max:=c1 else Max:=c2;
  2033. end;
  2034.  
  2035. {Tisk na obrazovku od pozice kurzoru bez rolování v p⌐ípadê tisku na poslední
  2036.  ⌐ádku obrazovky nebo bez p⌐echodu na novÿ ⌐ádek v p⌐ípadê tisku do posledního
  2037.  sloupce obrazovky.}
  2038. procedure Tisk;
  2039. var    adr:Integer;
  2040.     b,i:Byte;
  2041. begin
  2042.   adr:=x-2+(y-1)*MaxX;b:=TextAttr;
  2043.   for i:=1 to Length(text) do
  2044.   begin
  2045.     obraz[adr+i].barva:=b;obraz[adr+i].ascii:=Ord(text[i]);
  2046.   end;
  2047. end;
  2048.  
  2049. procedure Prohlizec;
  2050. var    a1,a2,chyba,posunX,radek:Byte;
  2051.     {a1,a2...stisknutá klávesa; posunX...hodnota,která se p⌐ipoçte ke v¿em indexûm v ⌐etêzci,
  2052.      její zmênou se umoæní horizontální rolování}
  2053.     posunY,i:Word; {posunY...hodnota,která se p⌐ipoçte ke v¿em indexûm v poli ⌐etêzci,její zmênou se
  2054.                  umoæní vertikální rolování}
  2055.     jmeno:String; {jméno souboru do kterého se uloæí obsah prohlíæeçe}
  2056.     soubor:System.Text; {soubor je normální textovÿ soubor,identifikátor Text byl jiæ pouæit v jednotce Fr_Sok,
  2057.     proto bylo nutné p⌐idat System.}
  2058.     stara:Boolean;
  2059.  
  2060.   function ZjistiRadek(cislo:Word):String;
  2061.   begin
  2062.     ZjistiRadek:=cs('₧ádek çíslo ')+Str(cislo);
  2063.   end;
  2064.  
  2065.   procedure Pis(text:String);
  2066.   var p:Boolean;i:Byte;
  2067.   begin
  2068.     p:=False;
  2069.     for i:=1 to Length(text) do
  2070.     begin
  2071.       if text[i]='~' then p:=Not(p) else Write(cs(text[i]));
  2072.       if p then TextColor(Crt.Red) else Textcolor(Crt.Black);
  2073.     end;
  2074.   end;
  2075.  
  2076.   {Tato funkce upravuje vÿstup funkce f definované uæivatelem na 78 znakû
  2077.    na ⌐ádce, zaji¿ƒuje vÿpis çásti ⌐etêzce a tím i horizontální (rolování):}
  2078.   function f0(cislo:Word):String;
  2079.   begin
  2080.     f0:=Copy(f(cislo),posunX,78);
  2081.   end;
  2082.  
  2083.   procedure Prekresli(vsechno:Boolean);
  2084.   var i:Byte;
  2085.   begin
  2086.     if vsechno then
  2087.     begin
  2088.       Nastav;TextColor(Crt.Yellow);
  2089.       TextBackGround(Crt.Blue);Window(1,2,80,24);ClrScr;
  2090.       TextColor(Crt.White);Obdelnik2(1,2,78,19,2,32,True);
  2091.       Window(1,1,80,1);TextBackGround(Crt.LightGray);ClrScr;
  2092.       Window(1,25,80,25);TextBackGround(Crt.LightGray);ClrScr;
  2093.     end;
  2094.     Window(2,5,79,23);TextColor(Crt.Yellow);TextBackGround(Crt.Blue);
  2095.     if Not(vsechno) then
  2096.     begin
  2097.       Window(2,5,79,23);ClrScr;
  2098.     end;
  2099.     for i:=1 to Min(19,max) do Tisk(2,4+i,cs(f0(posunY+i)));
  2100.     if vsechno then
  2101.     begin
  2102.       Window(1,1,80,25);GotoXY(2,3);Write(cs(napis));
  2103.       TextBackGround(Crt.LightGray);GotoXY(1,1);
  2104.       Pis('  ~F~ile  ~H~elp');
  2105.       GotoXY(1,25);Pis(' ~F1~ Help  ~F10~ Menu  ~Alt+X~ Exit');
  2106.     end;
  2107.     TextColor(Crt.Yellow);Window(2,5,79,23);TextBackGround(Crt.Blue);
  2108.   end;
  2109.  
  2110. begin
  2111.   posunX:=1;posunY:=0;Prekresli(True);
  2112.   repeat
  2113.     a1:=Ord(ReadKey);if a1=0 then a2:=Ord(ReadKey);
  2114.     if (a1=0) and (a2=59) then {F1}
  2115.     begin
  2116.       Nastav;Writeln(cs('Velice struçná nápovêda:'));
  2117.       Writeln(cs('Tento prohlíæeç má nastavením barev a nápisy p⌐ipomínat slavné Turbo-Vision,'));
  2118.       Writeln(cs('kde by ale ⌐e¿ení tohoto problému bylo dost obtíæné (snad to v¿echno uloæit'));
  2119.       Writeln(cs('do souboru a ten potom zobrazit v Turbo-Vision).'));
  2120.       Writeln;Writeln(cs('K prohlíæení slouæí tyto klávesy:'));
  2121.       Writeln(cs('>'+Chr(24)+'< pro pohyb o ⌐ádek nahoru'));
  2122.       Writeln(cs('>'+Chr(25)+'< pro pohyb o ⌐ádek dolu'));
  2123.       Writeln(cs('>F1< tato nápovêda'));
  2124.       Writeln(cs('>F2< uloæení prohlíæeného textu do souboru'));
  2125.       Writeln(cs('>Ctrl<+>PrintScreen< tisk obsah prohlíæeçe na tiskárnê SEP 510'));
  2126.       Writeln(cs('>F10< menu (není je¿tê dostupné v této verzi)'));
  2127.       Writeln(cs('>Esc< nebo >Alt<+>X< konec prohlíæení'));
  2128.       Writeln(cs('>PageUp< pro pohyb o stránku nahoru'));
  2129.       Writeln(cs('>PageDown< pro pohyb o stránku dolu'));
  2130.       Writeln(cs('>Home< pro posun na zaçátek'));
  2131.       Writeln(cs('>End< pro posun na konec'));
  2132.       Writeln;
  2133.       Cekani;Prekresli(True);
  2134.     end;
  2135.     if (a1=0) and (a2=60) then {F2}
  2136.     begin
  2137.       stara:=stav;stav:=vypnuta;Nastav;jmeno:=CtiString('Zadejte jméno souboru do tohoto rámeçku, potom stisknête >Enter<:');
  2138.       Writeln(cs('Çekejte, zapisuji do souboru '+jmeno));
  2139.       {$I-}Assign(soubor,jmeno);Rewrite(soubor);{$I+}
  2140.       chyba:=IOResult;
  2141.       if chyba<>0 then Writeln(cs('Chyba ç.'+Str(chyba)+' p⌐i otevírání souboru pro zápis - '+Chyby.Chyba(chyba)+'.'))
  2142.       else begin
  2143.     for i:=1 to max do
  2144.     begin
  2145.       {$I-}Writeln(soubor,f(i));{$I+}
  2146.       chyba:=IOResult;
  2147.       if chyba<>0 then
  2148.       begin
  2149.         Writeln(cs('Chyba ç.'+Str(chyba)+' p⌐i zápisu do souboru - '+Chyby.Chyba(chyba)+'.'));Break;
  2150.       end;
  2151.     end;
  2152.     {$I-}Close(soubor);{$I+}
  2153.     chyba:=IOResult;
  2154.     if chyba<>0 then
  2155.     begin
  2156.       Writeln(cs('Chyba ç.'+Str(chyba)+' p⌐i zavírání souboru - '+Chyby.Chyba(chyba)+'. Tato chyba se stává dost málo...'));
  2157.     end;
  2158.       end;
  2159.       Cekani;Prekresli(True);stav:=stara;
  2160.     end;
  2161.     if (a1=0) and (a2=114) then {>Ctrl<+>PrintScreen<}
  2162.     begin {Tisk na tiskárnê SEP 510:}
  2163.       Nastav;Writeln(cs('Pokud se Vám p⌐i tisku na tisku SEP 510 ohlasí PC chybu:'));
  2164.       Writeln(cs('1. splnêno?: propojení PC a funkçní zapnuté tiskárny SEP 510'));
  2165.       Writeln(cs('2. odstartovanÿ jako rezidentní PRINTFIX (nejlépe hned po nahrátí COMMAND.COM)'));
  2166.       Writeln(cs('Pokud nemáte PRINTFIX a budete chtít tisknout na tiskárnê SEP 510, máte prostê'));
  2167.       Writeln(cs('smûlu... (vêt¿inou je v adresá⌐i, kde je MS-DOS)'));Writeln;
  2168.       Writeln(cs('V p⌐ípadê, æe vlastníte tuto tiskárnu, rád bych si s Vámi popovídal na'));
  2169.       Writeln(cs('telefonu (02)4725312 nebo po Internetu: E-MAIL: SOKOLOVSKY@KM1.FJFI.CVUT.CZ'));
  2170.       Writeln(cs('Franti¿ek Sokolovskÿ'));
  2171.       stara:=stav;stav:=vypnuta;jmeno:='PRN';
  2172.       radek:=Cti_Byte('Zadejte poçet ⌐ádek na stránku (0-dostateçnê dlouhÿ traktorovÿ papír):');
  2173.       Writeln(cs('Çekejte, tisknu na tiskárnê SEP 510...'));
  2174.       {$I-}Assign(soubor,jmeno);Rewrite(soubor);{$I+}
  2175.       chyba:=IOResult;
  2176.       if chyba<>0 then Writeln(cs('Chyba ç.'+Str(chyba)+' p⌐i otevírání souboru pro tisk - '+Chyby.Chyba(chyba)+'.'))
  2177.       else begin
  2178.     for i:=1 to max do
  2179.     begin
  2180.       Writeln(cs('Nyní tisknu ⌐ádek çíslo '+Str(i)+'. Prosím, çekejte.'));
  2181.       {$I-}Write(soubor,f(i),#10);{$I+}
  2182.       chyba:=IOResult;
  2183.       if chyba<>0 then
  2184.       begin
  2185.         Writeln(cs('Chyba ç.'+Str(chyba)+' p⌐i tisku dat - '+Chyby.Chyba(chyba)+'.'));Break;
  2186.       end;
  2187.       if (radek>0) and (i mod radek=0) then
  2188.       begin
  2189.         Writeln(cs('Nyní je poçítaç p⌐inucen trochu poçkat na vÿmênu papíru...'));
  2190.         Cekani;
  2191.       end;
  2192.     end;
  2193.     {$I-}Close(soubor);{$I+}
  2194.     chyba:=IOResult;
  2195.     if chyba<>0 then
  2196.     begin
  2197.       Writeln(cs('Chyba ç.'+Str(chyba)+' p⌐i zavírání souboru - '+Chyby.Chyba(chyba)+'. Tato chyba se stává dost málo...'));
  2198.     end;
  2199.       end;
  2200.       Cekani;Prekresli(True);stav:=stara;
  2201.     end;
  2202.     if (a1=0) and (a2=68) then {F10}
  2203.     begin Nastav;Writeln(cs('Menu nefunguje. Snad v dal¿í verzi...'));Cekani;Prekresli(True);end;
  2204.     if (a1=0) and (a2=80) and (posunY+19<max) then
  2205.     begin {><}
  2206.       Inc(posunY);GotoXY(1,1);DelLine;Tisk(2,23,cs(f0(posunY+19)));
  2207.     end;
  2208.     if (a1=0) and (a2=72) and (posunY>0) then
  2209.     begin {><}
  2210.       GotoXY(1,1);InsLine;Tisk(2,5,cs(f0(posunY)));Dec(posunY);
  2211.     end;
  2212.     if (a1=0) and (a2=77) and (posunX<(255-78)) then {doprava}
  2213.     begin                     { 255=mamimální délka ⌐etêzce,
  2214.                   78=poçet znakû v ⌐ádku (reæim 80x25, ale
  2215.                      2 znaky zabírá rámeçek)}
  2216.       Inc(posunX);Prekresli(False);
  2217.     end;
  2218.     if (a1=0) and (a2=75) and (posunX>1) then {doleva}
  2219.     begin
  2220.       Dec(posunX);Prekresli(False);
  2221.     end;
  2222.     if (a1=0) and (a2=81) and (posunY+19<max) then
  2223.     begin {>PageDown<}
  2224.       if posunY+38<max then Inc(posunY,19) else if posunY>=19 then posunY:=max-19 else posunY:=0;
  2225.       Prekresli(False);
  2226.     end;
  2227.     if (a1=0) and (a2=73) and (posunY>0) then
  2228.     begin {>PageUp<}
  2229.       if posunY>=19 then Dec(posunY,19) else posunY:=0;
  2230.       Prekresli(False);
  2231.     end;
  2232.     if (a1=0) and (a2=79) and (max>19) and (posunY<max-19) then
  2233.     begin {End}
  2234.       if max-19>=0 then posunY:=max-19 else posunY:=0;
  2235.       Prekresli(False);
  2236.     end;
  2237.     if (a1=0) and (a2=71) and (posunY>0) then
  2238.     begin {Home}
  2239.       posunY:=0;Prekresli(False);
  2240.     end;
  2241.   until ((a1=0) and (a2=45)) or (a1=27);
  2242.   Nastav;
  2243. end;
  2244.  
  2245. procedure Exec2(ProgramName,CmdLine:String);
  2246. begin
  2247.   SwapVectors;Exec(ProgramName, CmdLine);SwapVectors;
  2248.   if DosError <> 0 then{ Error? }
  2249.   begin
  2250.     Write('Dos error #', DosError,' = ');
  2251.     case DosError of
  2252.      2: Writeln('File not found');
  2253.      3: Writeln('Path not found');
  2254.      5: Writeln('Access denied');
  2255.      6: Writeln('Invalid handle');
  2256.      8: begin
  2257.       Writeln('Not enough memory');
  2258.       Writeln(cs('Zkuste p⌐idat do svého programu na první ⌐ádek, kterÿ pouæívá jednotku Fr_Sok,'));
  2259.       Writeln(cs('tento p⌐íkaz: "{$M $4000,0,0}" a potom zkuste program znovu p⌐eloæit a spustit.'));
  2260.       Writeln(cs('Potom by mêlo jít program správnê pouæívat.'));
  2261.     end;
  2262.     10: Writeln('Invalid environment');
  2263.     11: Writeln('Invalid format');
  2264.     18: Writeln('No more files');
  2265.     else Writeln('Unknow error');
  2266.     end {end of case}
  2267.   end {end of if} else
  2268.     WriteLn('Exec successful. ',
  2269.         'Child process exit code = ',
  2270.         DosExitCode);
  2271. end;
  2272.  
  2273. procedure Command(Com:String);
  2274. begin
  2275.   if Com <> '' then
  2276.     Com := '/C ' + Com;
  2277.   SwapVectors;
  2278.   Exec(GetEnv('COMSPEC'), Com);
  2279.   SwapVectors;
  2280.   if DosError <> 0 then
  2281.   begin
  2282.     Writeln('Could not execute COMMAND.COM');
  2283.     Writeln(cs('P⌐esvêdçte se, æe promênná COMSPEC ukazuje na nezniçenÿ COMMAND.COM (mûæete ji'));
  2284.     Writeln(cs('nastavit i p⌐íkazem SHELL=disk:\cesta\COMMAND.COM) a æe máte v 1.⌐ádce Va¿eho'));
  2285.     Writeln(cs('programu uvedeno: "{$M $4000,0,0}". Potom by to mêlo jiæ fungovat.'));
  2286.   end;
  2287. end;
  2288.  
  2289. {$L NEKO.OBJ}
  2290. function Nekonecno:Double; External;
  2291.  
  2292. procedure Konec;
  2293. begin
  2294.   TextColor(stand mod 16);TextBackGround(stand div 16);
  2295.   Window(1,1,80,25);ClrScr;
  2296.   Writeln;Writeln('Konec programu:');Halt;
  2297. end;
  2298.  
  2299. function Str3(prom:Extended;celkem,desetinnych:Byte):String;
  2300. var pom:String;
  2301. begin
  2302.   System.Str(prom:celkem:desetinnych,pom);
  2303.   Str3:=pom;
  2304. end;
  2305.  
  2306. { P⌐evádí celÿ ⌐etêzec na velké písmena: }
  2307. function UpCaseString;
  2308. var i:byte;
  2309. begin
  2310.  for i:=0 to Length(s) do UpCaseString[i]:=UpCase(s[i]);
  2311. end;
  2312.  
  2313. function OdstranMezery(s:String):String;
  2314. begin
  2315.   while Pos(' ',s)>0 do System.Delete(s,Pos(' ',s),1);
  2316.   OdstranMezery:=s;
  2317. end;
  2318.  
  2319. function StringBoolean(s:String):Boolean;
  2320. begin
  2321.   s:=UpCaseString(OdstranMezery(s));
  2322.   StringBoolean:=s[1]='T'; {T - první písmeno slova TRUE}
  2323. end;
  2324.  
  2325. procedure Vloz(co:String;var kam:String;pozice:Byte);
  2326. begin
  2327.   while Length(kam)<pozice-1 do kam:=kam+' ';
  2328.   System.Insert(co,kam,pozice);
  2329. end;
  2330.  
  2331. { Funkce "Menu3" je stejná jako funkce "Menu2", narozdíl je umoænêñ vÿbêr
  2332.   poloæek menu i my¿í.
  2333.   Funkce "Menu4" je¿tê navíc umoæñuje jakési rolování menu v p⌐ípadê, æe se
  2334.   v¿echny poloæky na obrazovku nevejdou.
  2335.   Funkce "Menu5" vÿbêr z menu, jehoæ poloæky jsou vÿstupy funkce:
  2336.   - function f(cislo:Word):String;
  2337.   - tedy pro rûzné parametry se vrátí rûzné ⌐etêzce, pro cislo=i se vrátí
  2338.     i.⌐etêzec, kterÿ se zároveñ objeví jako i. poloæka v menu (kde i je
  2339.     p⌐irozené çíslo z intervalu 1..65535, coæ je horní mez typu Word), menu
  2340.     se samoz⌐ejmê roluje, pokud je poçet poloæek vêt¿í, neæ se vejde na
  2341.     obrazovku. }
  2342. function Menu5(x,y,ram:byte;kur:boolean;pocet:Word;f:Tfce):Word;
  2343. label    opakuj,prekresli,preskok,konec;
  2344. var    del,i,l,max,od,pa,px,py,radku,tlacitka,xm,y0,ym,w,wmin,wmax:Word;
  2345.     pom:Boolean;
  2346.     {radku = Poçet ⌐ádkû, které zabírá menu na obrazovce:}
  2347.     {od = Çíslo první poloæky zobrazené v menu sníæené o 1, standartnê 0,
  2348.     av¿ak p⌐i pohybu dolû p⌐i rolování se zvy¿uje a p⌐i pohybu nahoru p⌐i
  2349.     rolování se sniæuje.}
  2350.     pomoc:Boolean; {Zda bylo provedeno rolování a proto potom bude nutno
  2351.     p⌐epsat poloæky menu:}
  2352. begin
  2353.   zobraz:=False;
  2354.   if (WindMin<>5377) or (WindMax<>5966) then Dialogove_Okno; {Získání parametrû nastavenÿch p⌐íkazem Window,
  2355.   umoæñuje zjistit, zda jiæ bylo pouæito Dialogove_Okno, jinak se vykreslí.}
  2356.   px:=WhereX;py:=WhereY;wmin:=WindMin;wmax:=WindMax;pa:=TextAttr; {Uloæení pûvodních hodnot.}
  2357.  
  2358.   od:=0;
  2359.  
  2360.   max:=1;l:=1;for i:=0 to pocet do if Length(f(i))>max then max:=Length(f(i));
  2361.   if Length(f(0))>0 then Inc(i,2); {V p⌐ípadê, æe je uveden nêjakÿ nadpis menu:}
  2362.   if i>10 then radku:=10 else radku:=i;
  2363.   if (x=0) or (y=0) then begin x:=Round((80-(max+2))/2);y:=Round((25-(radku+2))/2);end; {Automatická pozice menu:}
  2364.   if Length(f(0))>0 then Dec(radku,2); {V p⌐ípadê, æe je uveden nêjakÿ nadpis menu:}
  2365.  
  2366.   Prekresli: r.ax:=2;Intr(Mouse,r);
  2367.   ClrScr;TextColor(White);TextBackGround(Brown);
  2368.   barva:=obraz[(x-1)+(y-1)*80+1].barva;zobraz:=True;
  2369.  
  2370.   if Length(f(0))=0 then begin Obdelnik2(x,y,max,radku,ram,32,False);y0:=1;end
  2371.                else begin Obdelnik2(x,y,max,radku,ram,32,True);Gotoxy(2,2);Write(f(0));Inc(y,2);y0:=3;end;
  2372.   for i:=1 to radku do begin
  2373.     TextColor(White);
  2374.     GotoXY(2,y0+i);Write(f(od+i));for w:=Length(f(od+i))+1 to max do Write(' ');
  2375.   end;
  2376.   TextBackGround(pa div 16);TextColor(pa mod 16);
  2377.   Window((wmin mod 256)+1,(wmin div 256)+1,(wmax mod 256)+1,(wmax div 256)+1);
  2378.   GotoXY(1,1);if Length(f(0))>0 then Write(f(0),' ');
  2379.   Writeln(cs('Klávesami se ¿ipkami vyberte çinnost, pak stisknête ENTER.'));
  2380.   r.ax:=1;Intr(Mouse,r);
  2381.  
  2382.   opakuj:
  2383.   GotoXY(1,2);DelLine;InsLine;Writeln(cs('Çinnost: '+f(od+l)));
  2384.   if kur=False then del:=Length(f(l)) else del:=max;
  2385.   barva:=obraz[x+(y+l-1)*80+1].barva;Kurzor2(x+1,y+l,del);
  2386.   Znak(x+max+1,y+radku,25);Znak(x+max+1,y+1,24);
  2387.   r.ax:=1;Intr(Mouse,r);pom:=False;
  2388.   repeat
  2389.    repeat
  2390.     r.ax:=3;Intr(Mouse,r);xm:=r.cx div 8;ym:=r.dx div 8;tlacitka:=r.bx;
  2391.     if (tlacitka=0) and pom then goto konec;
  2392.     if (tlacitka>0) and (xm>=x) and (xm<x+max) and (ym>=y) and (ym<y+radku) then
  2393.     begin
  2394.       pom:=True;
  2395.       if tlacitka>0 then
  2396.       begin
  2397.        if l<>ym-y+1 then
  2398.        begin
  2399.     Kurzor2(x+1,y+l,del);l:=ym-y+1;r.ax:=2;Intr(Mouse,r);
  2400.  
  2401. { Pozor p⌐i pohybu kurzorem my¿í p⌐i parametru kur=False se nemêní velikost
  2402.  kurzoru p⌐i rûznê dlouhÿch poloækách. Vylep¿it !!!}
  2403.  
  2404. {    if kur=False then del:=Length(f(l)) else del:=max;}
  2405.     GotoXY(1,2);DelLine;InsLine;Writeln(cs('Çinnost: '+f(od+l)));
  2406.     r.ax:=1;Intr(Mouse,r);
  2407.     Kurzor2(x+1,y+l,del);pom:=True;
  2408.        end;
  2409.       end;
  2410.     end else pom:=False;
  2411.     if (tlacitka>0) and (xm=x+max) and (ym=y) then begin w:=72;Delay(100);goto preskok;end;
  2412.     if (tlacitka>0) and (xm=x+max) and (ym=y+radku-1) then begin w:=80;Delay(100);goto preskok;end;
  2413.    until KeyPressed;
  2414.    w:=Ord(Readkey);
  2415.    preskok: Znak(x+max+1,y+radku,25);Znak(x+max+1,y+1,24);
  2416.  
  2417.    if (w=72) and (l+od<=1) then {Pohyb kurzorem nahoru:}
  2418.    begin
  2419.     if Length(f(0))>0 then Dec(y,2);
  2420.     Kurzor2(x+1,y+l,del);l:=radku;od:=pocet-radku;goto prekresli;
  2421.    end;
  2422.    if w=72 then
  2423.    begin
  2424.     Kurzor2(x+1,y+l,del);Dec(l);pomoc:=False;
  2425.     while l<1 do begin Inc(l);Dec(od);pomoc:=True;end;
  2426.     if cara[l]=True then Dec(l);
  2427.  
  2428.     while l<1 do begin Inc(l);Dec(od);pomoc:=True;end;
  2429.     if pomoc then
  2430.     begin
  2431.      if Length(f(0))>0 then Dec(y,2);
  2432.      goto Prekresli;
  2433.     end else goto opakuj;
  2434.     goto opakuj;
  2435.    end;
  2436.  
  2437.    if (w=80) and (l+od>=pocet) then {Pohyb kurzorem dolû:}
  2438.    begin
  2439.     if Length(f(0))>0 then Dec(y,2);
  2440.     Kurzor2(x+1,y+l,del);l:=1;od:=0;goto prekresli;
  2441.    end;
  2442.    if w=80 then {Pohyb kurzorem dolû:}
  2443.    begin
  2444.     Kurzor2(x+1,y+l,del);Inc(l);pomoc:=False;
  2445.     while l>radku do begin Dec(l);Inc(od);pomoc:=True;end;
  2446.     if cara[l] then Inc(l);
  2447.  
  2448.     while l>radku do begin Dec(l);Inc(od);pomoc:=True;end;
  2449.     if pomoc then
  2450.     begin
  2451.      if Length(f(0))>0 then Dec(y,2);
  2452.      goto Prekresli;
  2453.     end else goto opakuj;
  2454.    end;
  2455.   until (w=13);
  2456.   konec: r.ax:=2;Intr(Mouse,r);Menu5:=od+l;
  2457. end;
  2458.  
  2459. { Odstraní písmena s háçky a çárkami ze zadaného ⌐etêzce: }
  2460. function Odstran_Hacky_Carky;
  2461. var a,i:byte;
  2462. begin
  2463.  for i:=1 to Length(s) do
  2464.  begin
  2465.   a:=Pos(s[i],male);if a>0 then s[i]:=mbez[a];
  2466.   a:=Pos(s[i],velke);if a>0 then s[i]:=vbez[a];
  2467.  end;
  2468.  Odstran_Hacky_Carky:=s;
  2469. end;
  2470.  
  2471. function Kod852; {P⌐evod z kódu B⌐í Kamenickÿch - kód 852}
  2472. label vyskok;
  2473. begin
  2474.  case c of
  2475.   'é': begin c:=Chr(130);end;
  2476.   'û': begin c:=Chr(133);end;
  2477.   'É': begin c:=Chr(144);end;
  2478.   'å': begin c:=Chr(155);end;
  2479.   'ƒ': begin c:=Chr(156);end;
  2480.   'ç': begin c:=Chr(159);end;
  2481.   'á': begin c:=Chr(160);end;
  2482.   'í': begin c:=Chr(161);end;
  2483.   'ó': begin c:=Chr(162);end;
  2484.   'ú': begin c:=Chr(163);end;
  2485.   'Æ': begin c:=Chr(166);end;
  2486.   'æ': begin c:=Chr(167);end;
  2487.   'Ç': begin c:=Chr(172);end;
  2488.   'Å': begin c:=Chr(181);end;
  2489.   'ë': begin c:=Chr(183);end;
  2490.   'à': begin c:=Chr(210);end;
  2491.   'â': begin c:=Chr(212);end;
  2492.   'Ñ': begin c:=Chr(213);end;
  2493.   'ï': begin c:=Chr(214);end;
  2494.   'ê': begin c:=Chr(216);end;
  2495.   'ª': begin c:=Chr(222);end;
  2496.   'ò': begin c:=Chr(224);end;
  2497.   'ñ': begin c:=Chr(229);end;
  2498.   '¢': begin c:=Chr(230);end;
  2499.   '¿': begin c:=Chr(231);end;
  2500.   'ù': begin c:=Chr(233);end;
  2501.   'ÿ': begin c:=Chr(236);end;
  2502.   '¥': begin c:=Chr(237);end;
  2503.   '₧': begin c:=Chr(252);end;
  2504.   '⌐': begin c:=Chr(253);end;
  2505.  end;
  2506.  vyskok: Kod852:=c;
  2507. end;
  2508.  
  2509. function Kod1250; {P⌐evod z kódu B⌐í Kamenickÿch - kód 1250 (Windows)}
  2510. label vyskok;
  2511. begin
  2512.  case c of
  2513.   '¢': begin c:=Chr(138);goto vyskok;end;
  2514.   'å': begin c:=Chr(141);goto vyskok;end;
  2515.   'Æ': begin c:=Chr(142);goto vyskok;end;
  2516.   '¿': begin c:=Chr(154);goto vyskok;end;
  2517.   'ƒ': begin c:=Chr(157);goto vyskok;end;
  2518.   'æ': begin c:=Chr(158);goto vyskok;end;
  2519.   'Å': begin c:=Chr(193);goto vyskok;end;
  2520.   'Ç': begin c:=Chr(200);goto vyskok;end;
  2521.   'É': begin c:=Chr(201);goto vyskok;end;
  2522.   'ë': begin c:=Chr(204);goto vyskok;end;
  2523.   'ï': begin c:=Chr(205);goto vyskok;end;
  2524.   'à': begin c:=Chr(207);goto vyskok;end;
  2525.   'Ñ': begin c:=Chr(210);goto vyskok;end;
  2526.   'ò': begin c:=Chr(211);goto vyskok;end;
  2527.   '₧': begin c:=Chr(216);goto vyskok;end;
  2528.   'ª': begin c:=Chr(217);goto vyskok;end;
  2529.   'ù': begin c:=Chr(218);goto vyskok;end;
  2530.   '¥': begin c:=Chr(221);goto vyskok;end;
  2531.   'á': begin c:=Chr(225);goto vyskok;end;
  2532.   'ç': begin c:=Chr(232);goto vyskok;end;
  2533.   'é': begin c:=Chr(233);goto vyskok;end;
  2534.   'ê': begin c:=Chr(236);goto vyskok;end;
  2535.   'í': begin c:=Chr(237);goto vyskok;end;
  2536.   'â': begin c:=Chr(239);goto vyskok;end;
  2537.   'ñ': begin c:=Chr(242);goto vyskok;end;
  2538.   'ó': begin c:=Chr(243);goto vyskok;end;
  2539.   '⌐': begin c:=Chr(248);goto vyskok;end;
  2540.   'û': begin c:=Chr(249);goto vyskok;end;
  2541.   'ú': begin c:=Chr(250);goto vyskok;end;
  2542.   'ÿ': begin c:=Chr(253);goto vyskok;end;
  2543.  end;
  2544.  vyskok: Kod1250:=c;
  2545. end;
  2546.  
  2547. function cs;
  2548. begin
  2549.  case cskod of
  2550.   1: cs:=text; {vstup je v kódu B⌐í Kamenickÿch, vÿstup je také, beze zmêny}
  2551.   2: cs:=Kod852String(text);
  2552.   3: cs:=Kod1250String(text);
  2553.   4: cs:=Odstran_Hacky_Carky(text);
  2554.  end;
  2555. end;
  2556.  
  2557. function Kod852String; {P⌐evod z kódu B⌐í Kamenickÿch - kód 852}
  2558. var i:Byte;
  2559. begin
  2560.  Kod852String[0]:=s[0];for i:=1 to Length(s) do Kod852String[i]:=Kod852(s[i]);
  2561. end;
  2562.  
  2563. function Kod1250String; {P⌐evod z kódu B⌐í Kamenickÿch - kód 1250 (Windows)}
  2564. var i:Byte;
  2565. begin
  2566.  Kod1250String[0]:=s[0];for i:=1 to Length(s) do Kod1250String[i]:=Kod1250(s[i]);
  2567. end;
  2568.  
  2569. function Hlaseni(s:String):String;
  2570. var i:Byte;
  2571. begin
  2572.   Nastav;Zacatek(s);Radek('Stisknête Enter pro pokraçování...');i:=Menu3(0,0,2,True);
  2573. end;
  2574.  
  2575. function Adresar_Existuje(jmeno:string):Boolean;
  2576. var    puvodni:String;
  2577. begin
  2578.   {$I-}GetDir(0,puvodni);{$I+}chyba:=IOResult;
  2579.   if chyba<>0 then begin Writeln(cs('Není moæné zjistit aktuální adresá⌐. Mûæe to nêkdy nastat???'));Konec;end;
  2580.   ChDir(jmeno);if chyba<>0 then {Nepoda⌐ilo se nastavit adresá⌐, adresá⌐ buâ neexistuje nebo je ¿patnÿ?}
  2581.   begin {Adreá⌐ neexistoval, takæe se ani nemohl zmênit (snad)..., není nutné (snad) obnovovat pûvodní adresá⌐}
  2582.    Adresar_Existuje:=False;
  2583.   end else begin
  2584.    Chdir(puvodni); {Adreá⌐ existoval a zmênil se, je nutné nastavit pûvodní...}
  2585.    if chyba<>0 then
  2586.    begin
  2587.     Writeln(cs('Nebylo moæné zmênit aktuální adresá⌐ na pûvodní adresá⌐. Mûæe to nêkdy nastat???'));Konec;
  2588.    end;
  2589.    Adresar_Existuje:=True;
  2590.   end;
  2591. end;
  2592.  
  2593. {const    male :string[15]='áçâêéíñó⌐¿ƒúûÿæ';
  2594.     mbez :string[15]='acdeeinorstuuyz';
  2595.     velke:string[15]='ÅÇàëÉïÑò₧¢åùª¥Æ';
  2596.     vbez :string[15]='ACDEEINORSTUUYZ';}
  2597. function  UpCase(c:Char):Char;
  2598. var a:Byte;
  2599. begin
  2600.  if c in['a'..'z'] then Dec(c,32);
  2601.  a:=Pos(c,male);
  2602.  if a>0 then {bylo nalezeno malé písmeno} c:=velke[a];
  2603.  UpCase:=c;
  2604. end;
  2605.  
  2606. function  DownCase(c:Char):Char;
  2607. var a:Byte;
  2608. begin
  2609.  if c in['A'..'Z'] then Inc(c,32);
  2610.  a:=Pos(c,velke);
  2611.  if a>0 then {bylo nalezeno velké písmeno} c:=male[a];
  2612.  DownCase:=c;
  2613. end;
  2614.  
  2615. function  DownCaseString(s:String):String;
  2616. var i:Byte;
  2617. begin
  2618.  for i:=0 to Length(s) do DownCaseString[i]:=DownCase(s[i]);
  2619. end;
  2620.  
  2621. function OdstranZbytecneMezery(s:String):String;
  2622. begin
  2623.  if Length(s)>0 then while (s[1]=' ') do System.Delete(s,1,1);
  2624.  while (s[Length(s)]=' ') do System.Delete(s,Length(s),1);
  2625.  while (Pos('  ',s)>0) do System.Delete(s,Pos('  ',s),1);
  2626.  OdstranZbytecneMezery:=s;
  2627. end;
  2628.  
  2629. procedure Vypis(var f:System.Text);
  2630. var pom:TTextRec;
  2631. begin
  2632.  Move(f,pom,SizeOf(TTextRec));
  2633.  Writeln('Handle: ',pom.Handle);
  2634.  Writeln('Mode: ',pom.Mode);
  2635.  Writeln('BufSize: ',pom.BufSize);
  2636.  Writeln('Private: ',pom.Private);
  2637.  Writeln('BufPos: ',pom.BufPos);
  2638.  Writeln('BufEnd: ',pom.BufEnd);
  2639.  Write('UserData: ');for i:=1 to 16 do Write(pom.UserData[i]);Writeln;
  2640.  Write('Name: ');for i:=0 to 79 do Write(pom.Name[i]);Writeln;
  2641.  Write('Buffer: ');for i:=0 to 127 do Write(pom.Buffer[i]);Writeln;
  2642.  ReadKey;
  2643. end;
  2644.  
  2645. var    Stare0:TTextRec;
  2646.     l0:Longint;
  2647. procedure UschovejPozici(var f:System.Text);
  2648. begin
  2649.  Move(f,Stare0,SizeOf(System.Text));
  2650.  r.ah:=$42;r.al:=1;r.bx:=Stare0.Handle;r.cx:=0;r.dx:=0;MsDos(r);
  2651.  l0:=r.dx*65536+r.ax;
  2652. end;
  2653.  
  2654. procedure ObnovPozici(var f:System.Text);
  2655. begin
  2656.  Move(Stare0,f,SizeOf(System.Text));
  2657.  r.ah:=$42;r.al:=0;r.bx:=Stare0.Handle;r.cx:=l0 div 65535;r.dx:=l0 mod 65536;
  2658.  MsDos(r);
  2659. end;
  2660.  
  2661. function Val(s:String):Byte;
  2662. var    pom:Longint;
  2663.     i:Integer;
  2664. begin
  2665.  System.Val(s,pom,i);if pom<256 then Val:=pom else Val:=0;
  2666. end;
  2667.  
  2668. function Prevod(zdroj:String;vstupni,vystupni:Byte):String;
  2669. const    KodKam :String='áçâêéíîñó⌐¿ƒûúÿæÅÇàëÉï£Ñò₧¢åªù¥Æ';
  2670. const    Kod852 :String='áƒ╘╪éíûσó²τ£àú∞º╡¼╥╖É╓ò╒αⁿµ¢▐Θφª';
  2671. const    Kod1250:String='ßΦ∩∞Θφσ≥≤°Ü¥∙·²₧┴╚╧╠╔═╝╥╙╪èì┘┌▌Ä';
  2672. const    KodBez :String='acdeeilnorstuuyzACDEEILNORSTUUYZ';
  2673. var    pom,pom0,pom1:String;
  2674.     i,p:Integer;
  2675. begin
  2676.   case (vstupni) of
  2677.    1: pom0:=KodKam;
  2678.    2: pom0:=Kod852;
  2679.    3: pom0:=Kod1250;
  2680.    4: pom0:=KodBez;
  2681.   end;
  2682.   case (vystupni) of
  2683.    1: pom1:=KodKam;
  2684.    2: pom1:=Kod852;
  2685.    3: pom1:=Kod1250;
  2686.    4: pom1:=KodBez;
  2687.   end;
  2688.   for i:=1 to Length(zdroj) do
  2689.   begin
  2690.     p:=Pos(zdroj[i],pom0);
  2691.     if p>0 then zdroj[i]:=pom1[p];
  2692.   end;
  2693.   Prevod:=zdroj;
  2694. end;
  2695.  
  2696.  
  2697.  
  2698. { Poçáteçní nastavení promênnÿch p⌐i startu programu, kde je modul FR_SOK.TPU
  2699.   pouæíván. }
  2700. begin
  2701.   Uziv1:=VratTrue;Uziv2:=VratTrue;
  2702.   Uziv3:=VratTrue;Uziv4:=VratTrue;
  2703.   stand:=TextAttr;cskod:=1;{vÿstup v kódu B⌐í kamenickÿch}
  2704.   stav:=Zapnuta;vrat:=False;NastavTajnyZnak('*');NastavCekani(0);
  2705.   Zapni_Zvuk;TextColor(Yellow);r.ax:=0;Intr(Mouse,r);
  2706. end.
  2707.