(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(*  Soubor: GRAFIKA4.PAS                                                   *)
(*  Obsah: ruzne kramy pro praci v grafice                                 *)
(*  Autor: Mircosoft (http://mircosoft.mzf.cz)                             *)
(*         Marc Palms (napad s retezcovou grafikou)                        *)
(*         Milan Visniar (ScrOn a ScrOff)                                  *)
(*  Posledni uprava: 5.11.2024                                             *)
(*  Pro kompilaci: VESA2.TPU, ERRMSG.TPU, RETEZCE.TPU, NFSUP.TPU, XMS.TPU  *)
(*                 MATYKA.TPU                                              *)
(*  Pro spusteni: nic                                                      *)
(*  Upozorneni: tyto zdrojove kody pouzivate na vlastni nebezpeci          *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
unit Grafika4;
{$R-,G+,I-} {dulezite}
{$B-,X-,S-,Q-} {podruzne}

interface

type
sprite = object
         sprp:pointer;{ukazatel na graficka data}
         sirka,vyska:word;{sirka a vyska vyrezu v pixelech}
         function init(is,iv:word):boolean;{getmem apod.. Vraci true, pokud se operace zdarila}
         procedure nacti(nx,ny:integer);{kdyz obrazek zasahuje mimo obrazovku,automaticky se posune tak,aby se dal cely nacist}
         procedure zobraz(zx,zy:integer);{- '' -}
         procedure zrus;{freemem apod.}
         end;
{Objekt pro zjednoduseni nacitani a zobrazovani vyrezu obrazovky
(s procedurami _getsprite, _putsprite a _fillsprite z jednotky VESA2
nema nic spolecneho).}

XmsImage = object
           handle:word;
           sirka,vyska:word;
           procedure Init(iSirka,iVyska:word); {alokuje prostor v XMS}
           procedure Nacti(x,y:integer); {nacte z obrazovky}
           procedure Zobraz(x,y:integer); {zobrazi na obrazovku}
           procedure Zrus; {dealokuje prostor v XMS}
           end;
{Dalsi objekt pro pohodlnejsi nacitani a zobrazovani vyrezu obrazovky,
tentokrat s ukladanim do XMS.
Po initu zkontrolujte handle: pokud je 0, alokace se nepovedla a ostatni
metody nebudou nic delat.
Maximalni velikost obrazku je dobre udrzet pod 2 MB, aby nebyly problemy pri
spousteni programu z IDE TP, jinak muze teoreticky zabrat treba celych 64 MB
dostupne XMS. Sirka max. 65527 px, aby sel alokovat pomocny buffer na nacitani
a zobrazovani.
X,y pri nacitani a zobrazovani je levy horni roh na obrazovce.
Nacita se jenom oblast uvnitr obrazovky. Co precuhuje, to se ignoruje a v XMS
na odpovidajicich mistech zustane puvodni obsah.
Pri zobrazovani se orezava podle orezavaciho okna.}


procedure Napis(x,y:integer; BarvaTextu,BarvaPodkladu:byte; Hlaska:string);
{Na souradnice x,y vypise danou Hlasku podlozenou jednobarevnym obdelnikem.
Vhodne pro prepisovani textu pres sebe, aby se ten puvodni smazal.
Podkladovy obdelnik presahuje text vlevo a vpravo o 2 px, nahore a dole o 1.}

procedure StinText(x,y:integer; BarvaTextu,BarvaStinu:byte; Delta:shortint; textik:string);
{Stinovany text. Aby do barvy stinu nekecaly ridici kody v textu, procedura
je docasne vypina, takze nebudou fungovat ani ty ostatni (poloha, meritko
nebo specialni znaky).
Delta - vzdalenost stinu od textu ve smeru doprava a dolu, muze byt i zaporna
        (v takovem pripade vznika neco jako reliefni efekt)}

procedure KresliVStrafek(x,y:integer; sirka,vyska,cislo:word; bl,bp:byte);
{Nazorny popis:         °°°°°°°° :-). Vhodne napr. do her jako ukazatel
poctu zivotu apod.
x,y - souradnice leveho horniho rohu celeho obdelniku
sirka, vyska - sirka a vyska celeho obdelniku v pixelech
cislo - sirka leve casti obdelniku (z intervalu 0..sirka)
bl - barva leve casti obdelniku
bp - barva prave casti obdelniku}

procedure KresliSStrafek(x,y:integer; sirka,vyska,cislo:word; bh,bd:byte);
{Totez, ale svisle. Cislo se pocita od spodniho okraje obdelniku nahoru.
bh - barva horni casti
bd - barva dolni casti}

procedure StinCara(x1,y1,x2,y2:integer; Barva:byte);
{Stinovana cara. Barva = barva cary, stin je vzdy cerny (barva 0).}

procedure Bublina(x1,y1,x2,y2:integer; hlaska:string);
{Komiksova bublina.
x1,y1 - konec ocasku bubliny
x2,y2 - stred bubliny
hlaska - text k napsani, dlouhe radky se zalamuji automaticky nebo znakem '|'}

procedure Ramecek(lhx,lhy,pdx,pdy:integer; svetlo,stin,txt,pozadi:byte; nadpis:string);
{Kresli stinovany ramecek podobny tomu ve Windows, ktery ohranicuje treba
skupinu pribuznych tlacitek. Nevybarvuje plochu uvnitr ramecku.
lhx,lhy - levy horni roh
pdx,pdy - pravy dolni roh
svetlo - barva osvetlenych hran ramecku
stin - barva zastinenych hran ramecku
txt - barva nadpisu
pozadi - barva pozadi ramecku, pouzije se pod nadpis
nadpis - vypise se pres horni okraj ramecku}

procedure __Oblouk(stredX,stredY,PocUhel,KoncUhel:integer; prirustek,rx,ry:Word; barva:byte);
{Nakresli elipticky oblouk.
stredX,stredY - souradnice stredu
PocUhel,KoncUhel - pocatecni a koncovy uhel ve stupnich, mereno proti smeru
                   hodinovych rucicek, nula je vodorovne doprava (jako v BGI)
prirustek - oblouk se sklada z kratkych primkovych useku. Tenhle parametr
            urcuje interval ve stupnich mezi dvema body na oblouku, mezi
            kterymi se natahne usecka. Napr. kdyz je prirustek 90, nakresli se
            misto elipsy kosoctverec, pri hodnote 10 uz prakticky nerozeznate
            mnohouhelnik od krivky.
rx,ry - delka vodorovne a svisle poloosy
barva - no cemment}

procedure __Vysec(stredX,stredY,PocUhel,KoncUhel:integer; prirustek,rx,ry:Word; barva:byte);
{Kresli vyplnenou vysec elipsy. Parametry stejne jako u oblouku.}

procedure ScrOff;
{vypne obrazovku, tj. obrazovka cela zcerna, ale vsechny graficke operace,
ktere provedete, budou po opetovnem zapnuti videt. Pri vypnute obrazovce je
zapis do VRAM o neco rychlejsi.}

procedure ScrOn;
{opet zapne obrazovku}


(************************** retezcova grafika: ******************************)

{...$define zviditelni}
{nedefinovano => normalni stav
 definovano => vykresli se i ty useky, kdy je kresleni vypnuto a jen se
               presouva kurzor. Pro ucely ladeni. Bude to v barve 1
               (obvykle modra).}

const DSmx:word=1; {meritko ve vodorovnem a svislem smeru}
      DSmy:word=1;
      DSbarvaA:byte=15; {barvy, kterymi se muze kreslit}
      DSbarvaB:byte=7;
      DSbarvaC:byte=8;
      getX:integer=0; {aktualni souradnice "kurzoru"}
      getY:integer=0;
      DSpridavek:integer=0; {pridavek k rozteci pisma (muze byt i zaporny)}

procedure DrSt(Co:string);
{Vykresli zadany retezec Co. Zacatek je na souradnicich getX a getY,
po skonceni tyto souradnice budou tam, kam je retezec umisti.
Retezec se muze skladat z techto prikazu:
a     \
b      \ odtedka kreslime touhle barvou
c      /
n  - odtedka nekreslime, kurzor se bude pohybovat jen tak. Toto je vychozi
     nastaveni, kresleni je na zacatku procedury DrSt vzdy vypnute.
Pohyb kurzoru a kresleni: \ h /   - to je 8 zakladnich smeru.
                          l   p     Nasledujici znak urcuje, o kolik jednotek
                          [ d ]     se ma kurzor posunout: 0, 1, 2, ... 9,
Znaky byly schvalne vybrany tak,    a kdyz to nestaci, tak:
aby se nemusely mackat shifty.      :  ;  <  =  >  ?  @  A  B ...   atd.
                            coz je: 10 11 12 13 14 15 16 17 18 ... (ASCII kod)
Kreslit se da i v obecnem smeru: oABCD (A je l nebo p, B je delka ve
vodorovnem smeru, C je h nebo d a D je delka ve svislem smeru).

Vyhodnocovani retezcu je citlive na velka a mala pismena.
Do retezce se daji vkladat mezery, komentare (piste velkymi pismeny, aby se
nepletly s kody smeru) apod., protoze vsechny znaky, kterymi nezacina zadny
vyse uvedeny prikaz, se ignoruji.

Priklad: 'a h3 /1 p2 ]1 d3 [1 l2 \1 n p4  CARKY: b op2h4 n p2 c ol2d4'
 Nakresli kolecko v barve A a vpravo od nej dve rovnobezne sikme cary
 v barvach B a C.
 Mezery jsou tam jen pro prehlednost, fungovat bude s nimi i bez nich uplne
 stejne. Komentar CARKY: bude take ignorovan.

Je mozne kreslit i oblouky, staci za prikaz pro kresleni cary pripsat bud ')'
(oblouk toceny proti smeru hodinovych rucicek) nebo '(' (oblouk toceny
po smeru hodinovych rucicek). Tady uz mi bohuzel dosly bezshiftove znaky :-(.

Oblouky maji vzdy uhel 90 stupnu, tj. ctvrtina kruznice nebo elipsy. Proto
nebudou fungovat s prikazy 'l', 'p', 'h' a 'd', ale jenom se sikmymi smery
('\', '/', '[', ']' a 'o'). Jestli potrebujete uhel 180 stupnu nebo vic,
napojte jich nekolik za sebe.

Priklad: 'a d3 [2( \2(' - vykresli neco jako pismeno J,
         'b l1 [1) ]1) ]1( [1( l1' - pismeno S, zacatek vpravo nahore.
Mezery jsou tu opet jen pro prehlednost, prakticky nejsou nutne. Pokud
odstranite kulate zavorky, budou pismenka hranata, ale jejich proporce se
nezmeni.}

procedure nastavDSbarvy(a,b,c:word);
{Nastavi barvy pro kresleni. Pokud zadate nejakou hodnotu vetsi nez 255,
prislusna barva zustane nezmenena.}
procedure nastavDSmeritko(vodorovne,svisle:word; pridavek:integer);
{Nastavi meritko pro kresleni a pridavek k rozteci znaku (pro texty - viz
dale). Rozsah meritek 1..kolik chcete, pokud zadate 0, zustane nastavena
puvodni hodnota. Pridavek dle libosti (hodnota v pixelech nezavisla na
meritku), kladne hodnoty roztec zvetsuji a zaporne zmensuji.}
procedure MoveTo(x,y:integer);
{jako v BGI - presun imaginarniho kurzoru na dane souradnice}
procedure DrStXY(x,y:integer; co:string);
{presune kurzor na dane souradnice a pak vykresli retezec uplne stejne jako
DrSt.}

{bylo by skoda nevyuzit retezcovou grafiku k vytvoreni vektoroveho fontu:}

type PoleZnaku=array[0..255] of char;  UkNaPoleZnaku=^PoleZnaku;
     PoleWordu=array[0..255] of word;  UkNaPoleWordu=^PoleWordu;{pomocne typy}

     DSFont = record {uzivatelsky typ}
              adresy:uknapolewordu;
              data:uknapoleznaku;
              VelikostDat:word;
              end;

procedure NactiDSFont(var Kam:dsfont; var Odkud:text);
{Nacte retezcovy font ze souboru. Soubor musi byt otevreny pro cteni a
ukazatel musi byt presne na zacatku fontu. Soubor pak zustane otevreny.
Procedura potrebuje aspon 64 volnych KB na pomocny buffer (po skonceni
procedury bude uvolnen) a k tomu jeste pamet na finalni ulozeni fontu.}
procedure NactiDSFont2(var Kam:dsfont; Odkud:string);
{To same, ale zadavate jmeno souboru (i s koncovkou), ten bude otevren,
precten a zavren.
Pro soubory tohoto typu pouzivam neoficialni koncovku DSF, ale jde o uplne
normalni rucne psane textove soubory. Format je popsan na konci teto jednotky.}
procedure ZrusDSFont(var ktery:dsfont);
{vymaze font z pameti, Velikostdat pak bude 0 a oba ukazatele Nil}
procedure DSprint(x,y:integer; var JakymFontem:dsfont; Co:string);
{Napise text retezcovym fontem na danych souradnicich. Barvy a meritko podle
prislusnych globalnich promennych.}

(****************************************************************************)

implementation
uses vesa2,errmsg,retezce,nfsup,xms;

function sprite.init(is,iv:word):boolean;
var velikost:longint;
Begin
sirka:=is; vyska:=iv;
velikost:=longint(is)*iv;
safegetmem(sprp,velikost);
init:=sprp<>nil;
End;{sprite.init}

procedure sprite.nacti(nx,ny:integer);
Begin
if sprp<>nil then begin
                  if nx<0 then nx:=0; if ny<0 then ny:=0;
                  if nx+sirka>_maxx then nx:=_maxx-sirka+1;
                  if ny+vyska>_maxy then ny:=_maxy-vyska+1;
                  _getimage(nx,ny,nx+sirka-1,ny+vyska-1,sprp);
                  end;
End;{sprite.nacti}

procedure sprite.zobraz(zx,zy:integer);
Begin
if sprp<>nil then begin
                  if zx<0 then zx:=0; if zy<0 then zy:=0;
                  if zx+sirka>_maxx then zx:=_maxx-sirka+1;
                  if zy+vyska>_maxy then zy:=_maxy-vyska+1;
                  __putimage(zx,zy,sirka,vyska,sprp);
                  end;
End;{sprite.zobraz}

procedure sprite.zrus;
Begin
safefreemem(sprp);
End;{sprite.zrus}


procedure xmsimage.init(iSirka,iVyska:word);
var velikost:longint;
Begin
if (isirka=0) or (ivyska=0) or (isirka>65527)
  then begin handle:=0; exit; end;
sirka:=isirka; vyska:=ivyska;
velikost:=longint(sirka)*vyska;
getxms(handle,(velikost shr 10)+1); {radsi o 1 KB vic nez aby neco chybelo}
if xmsresult<>0 then handle:=0;
End;{xmsimage.init}

procedure xmsimage.nacti(x,y:integer);
var buffer:pointer;
    i:longint;
    skutecnaSirka:word;
    pom,oriznutiVlevo:integer;
Begin
if (handle=0) or (x>_maxx) or (x+sirka-1<0) or (y>_maxy) or (y+vyska-1<0) then
  exit; {neni kam ukladat nebo jsme uplne mimo obrazovku}
{orez vlevo:}
if x<0 then oriznutivlevo:=-x else oriznutivlevo:=0;
skutecnasirka:=sirka-oriznutivlevo;
{orez vpravo:}
pom:=_maxx-(x+sirka-1);
if pom<0 then inc(skutecnasirka,pom);
{muzeme nacitat:}
safegetmem(buffer,skutecnasirka+1);
if buffer=nil then exit;
for i:=0 to vyska-1 do
  begin
  pom:=y+i;
  if (pom>0) and (pom<=_maxy) then {orez nahore a dole}
    begin
    _getimage(x+oriznutivlevo,pom,x+sirka-1,pom,buffer);
    doxms(handle,i*sirka+oriznutivlevo,buffer^,skutecnasirka);
    end;
  end;
safefreemem(buffer);
End;{xmsimage.nacti}

procedure xmsimage.zobraz(x,y:integer);
var buffer:pointer;
    i:longint;
    pom:integer;
Begin
if handle=0 then exit;
safegetmem(buffer,sirka+1);
if buffer=nil then exit;
for i:=0 to vyska-1 do
  begin
  pom:=y+i;
  if (pom>0) and (pom<=_maxy) then
    begin
    zexms(buffer^,handle,i*sirka,sirka);
    __putimage(x,pom,sirka,1,buffer);
    end;
  end;
safefreemem(buffer);
End;{xmsimage.zobraz}

procedure xmsimage.zrus;
Begin
if handle=0 then exit;
freexms(handle);
handle:=0;
End;{xmsimage.zrus}


procedure napis(x,y:integer; BarvaTextu,BarvaPodkladu:byte; hlaska:string);
var v:word;
Begin
_measuretext(hlaska);
if _height=0 then _height:=_textheight;
__bar(x-2+_deltax,y-1+_deltay,x+_deltax+_width+1,y+_deltay+_height,barvapodkladu,0);
__print(x,y,barvatextu,0,hlaska);
End;{napis}

procedure stintext(x,y:integer; BarvaTextu,BarvaStinu:byte; delta:shortint; textik:string);
var minrk:byte;
Begin
minrk:=_controlcodes;
if _controlcodes=_use then _controlcodes:=_skip;
__print(x+delta,y+delta,barvastinu,0,textik);
_controlcodes:=minrk;
__print(x,y,barvatextu,0,textik);
End;{stintext}

procedure scroff;
Begin
port[$3C4]:=1;
port[$3C5]:=port[$3C5] or $20;
End;{scroff}

procedure scron;
Begin
port[$3C4]:=1;
port[$3C5]:=port[$3C5] and $DF;
End;{scron}

procedure KresliVStrafek(x,y:integer;sirka,vyska,cislo:word;bl,bp:byte);
Begin
if cislo>sirka then cislo:=sirka;{blbuvzdornost predevsim}
dec(vyska);
if cislo<sirka then __bar(x+cislo,y,x+sirka-1,y+vyska,bp,0);
if cislo>0 then __bar(x,y,x+cislo-1,y+vyska,bl,0);
End;{kreslivstrafek}

procedure KresliSStrafek(x,y:integer;sirka,vyska,cislo:word;bh,bd:byte);
Begin
if cislo>vyska then cislo:=vyska;
dec(sirka);
if cislo<vyska then __bar(x,y,x+sirka,y+vyska-cislo-1,bh,0);
if cislo>0 then __bar(x,y+vyska-cislo,x+sirka,y+vyska-1,bd,0);
End;{kreslisstrafek}

procedure StinCara(x1,y1,x2,y2:integer;barva:byte);
Begin
__line(x1+1,y1+1,x2+1,y2+1,0,0);{stin, vzdy v barve 0}
__line(x1,y1,x2,y2,barva,0);{cara}
End;{stincara}

procedure bublina(x1,y1,x2,y2:integer; hlaska:string);
{Z vetsi casti jde o upravenou proceduru InfOkno z jednotky Woknows4. Pokud
byste radi podrobnejsi komentare, hledejte je tam.}
var seznam,vybrany:uknaradek;{viz jednotku Retezce}
    sirka,vyska:word;
    i:byte;
    lhx,lhy:integer;
    svisla:boolean;
Begin
{upravy textu:}
while (hlaska<>'')and(hlaska[length(hlaska)]=' ') do dec(hlaska[0]);
if hlaska='' then exit;
{urceni, jestli pujde ocasek bubliny spis vodorovne nebo svisle:}
svisla:=abs(y1-y2)>abs(x1-x2);
{nacteni textu a jeho rozlozeni do radku:}
seznam:=nil;
nactitexty(seznam,hlaska,20);
{potrebne rozmery bubliny:}
sirka:=_textwidth(nejdelsiradek(seznam))+11;
vyska:=pocetradkuvseznamu(seznam)*(_textheight+3)+3;
{levy horni roh:}
lhx:=x2-sirka shr 1;
lhy:=y2-vyska shr 1;
{cerny obrys ocasku:}
if svisla then begin
               __line(x2-6,y2,x1,y1,0,0);
               __line(x2+6,y2,x1,y1,0,0);
               end
          else begin
               __line(x2,y2-6,x1,y1,0,0);
               __line(x2,y2+6,x1,y1,0,0);
               end;
{ramecek pro text:}
__box(lhx,lhy,lhx+sirka,lhy+vyska,0,0,15,_filled);
{bila vypln ocasku:}
if svisla then __triangle(x2-5,y2,x2+5,y2,x1,y1,15,_filled)
          else __triangle(x2,y2-5,x2,y2+5,x1,y1,15,_filled);
{zobrazeni textu}
vybrany:=seznam;
i:=0;
 repeat
 __print(lhx+6,lhy+3+i*(_textheight+3),0,0,vybrany^.obsah);
 vybrany:=vybrany^.dalsi;
 inc(i);
 until vybrany=nil;
zrustexty(seznam);
End;{bublina}

procedure nastavDSbarvy(a,b,c:word);
Begin
if a<=255 then dsbarvaA:=a;
if b<=255 then dsbarvaB:=b;
if b<=255 then dsbarvaC:=c;
End;{nastavdsbarvy}

procedure nastavDSmeritko(vodorovne,svisle:word;pridavek:integer);
Begin
if vodorovne<>0 then dsmx:=vodorovne;
if svisle<>0 then dsmy:=svisle;
dspridavek:=pridavek;
End;{nastavdsmeritko}

procedure MoveTo(x,y:integer);
Begin
getx:=x; gety:=y;
End;{moveto}

procedure DrSt(co:string);
const d=10;{prirustek uhlu pro oblouky}
var i:word;{index pro pohyb v retezci}
    b:word;{aktualni barva (257 = nekresli se)}
    v,s:integer;{vodorovny a svisly rozmer aktualniho useku}
    kreslime:boolean;
Begin
i:=1; b:=257;
while i<byte(co[0]) do {dokud nejsme na konci retezce}
  begin
  v:=0; s:=0; kreslime:=false;
  case co[i] of
    'a':b:=dsbarvaA;
    'b':b:=dsbarvaB;
    'c':b:=dsbarvaC;
    'n':b:=257;
    'l','p':begin {doLeva nebo doPrava}
            v:=dsmx*(byte(co[i+1])-48);{spocitame delku, 48 je ordinalni cislo znaku '0'}
            if co[i]='l' then v:=-v;{kdyz doleva, tak zaporne}
            s:=0;{svisleho nebude nic}
            inc(i);{na zacatek dalsiho prikazu}
            kreslime:=true; {tohle byl kreslici prikaz}
            end;
    'h','d':begin {naHoru nebo Dolu}
            s:=dsmy*(byte(co[i+1])-48);
            if co[i]='h' then s:=-s;{nahoru = zaporne}
            v:=0;{vodorovne nic}
            inc(i);
            kreslime:=true;
            end;
    '\','/','[',']':begin {sikmo}
                    v:=dsmx*(byte(co[i+1])-48);
                    s:=dsmy*(byte(co[i+1])-48);
                    if co[i] in ['\','['] then v:=-v; {doleva?}
                    if co[i] in ['\','/'] then s:=-s; {nahoru?}
                    inc(i);
                    kreslime:=true;
                    end;
    'o':begin {Obecny smer}
        v:=dsmx*(byte(co[i+2])-48);
        s:=dsmy*(byte(co[i+4])-48);
        if co[i+1]='l' then v:=-v;
        if co[i+3]='h' then s:=-s;
        inc(i,4);
        kreslime:=true;
        end;
    end;
  inc(i);
  {kresleni:}
  if (v=0)or(s=0)or((co[i]<>'(')and(co[i]<>')')) then
    begin {cara nebo bod}
    {$ifndef zviditelni}if b<>257 then{$endif}
    __line(getx,gety,getx+v,gety+s,b,0)
    end
  else
    begin {oblouk}
    {$ifndef zviditelni}if b<>257 then{$endif}
    if co[i]=')' then
      begin {CCW}
      if (s>0)and(v>0) then __oblouk(getx+v,gety,180,270,d,v,s,b)
      else if (s>0)and(v<0) then __oblouk(getx,gety+s,90,180,d,-v,s,b)
      else if (s<0)and(v<0) then __oblouk(getx+v,gety,0,90,d,-v,-s,b)
      else __oblouk(getx,gety+s,270,0,d,v,-s,b);
      end
    else
      if co[i]='(' then
        begin {CW}
        if (s>0)and(v>0) then __oblouk(getx,gety+s,0,90,d,v,s,b)
        else if (s>0)and(v<0) then __oblouk(getx+v,gety,270,0,d,-v,s,b)
        else if (s<0)and(v<0) then __oblouk(getx,gety+s,180,270,d,-v,-s,b)
        else __oblouk(getx+v,gety,90,180,d,v,-s,b);
        end;
    inc(i); {preskocit kulatou zavorku}
    end;
  inc(getx,v); inc(gety,s); {posunout kurzor na konec cary}
  end;
End;{drst}

procedure DrStXY(x,y:integer;co:string);
Begin
getx:=x; gety:=y;
drst(co);
End;{drstxy}

procedure NactiDSFont(var Kam:dsfont; var Odkud:text);
type PomTyp=array[0..255]of string[249];
var prvni,posledni:byte;
    i,w,pocet:word;
    znak:string;
    PomPole:^pomtyp;
Begin
with kam do
  begin
  adresy:=nil; data:=nil; velikostdat:=0;
  readln(odkud,prvni);
  readln(odkud,posledni);
  if (ioresult<>0){kdyz nastala chyba pri cteni...}
       or(maxavail<512+pocet*250){...nebo kdyz nebude misto na predbezne nacteni fontu a adresy}
    then exit;
  pocet:=posledni-prvni+1;{kolik znaku ve fontu je}
  safegetmem(pompole,(pocet+1)*250);{nevim, jak budou jednotlive znaky dlouhe
     a nemuzu cist soubor dvakrat, tak si pro jistotu pripravim hodne pameti.
     Pocet+1 je tam proto, ze mozna bude potreba dodefinovat mezeru, cili bude
     znak navic.}
  new(adresy);
  velikostdat:=0; {aktualni adresa a zaroven pamet potrebna pro pole Data}
  w:=0; {index pro pole retezcu}
  for i:=prvni to posledni do
    begin
    readln(odkud,znak);{precteme retezec}
    if i=32 then begin{vyplnime nedefinovane adresy adresou mezery}
                 if prvni<>0 then fillword32(adresy^[0],prvni,velikostdat);
                 if posledni<>255 then fillword32(adresy^[posledni+1],255-posledni,velikostdat);
                 end;
    adresy^[i]:=velikostdat;{ulozime jeho adresu}
    inc(velikostdat,byte(znak[0])+1);{adresu posuneme o velikost retezce dal}
    pompole^[w]:=znak;{retezec ulozime}
    inc(w);
    end;
  if (ioresult<>0)or(velikostdat>maxavail) then
    begin{kdyz se nepovedlo nacitani nebo neni misto na ulozeni fontu "nacisto"}
    dispose(adresy);
    adresy:=nil;
    safefreemem(pompole);
    velikostdat:=0;
    exit;
    end;
  if (prvni>32)or(posledni<32) then
    begin{v souboru s fontem neni definovan znak "mezera"}
    znak:='p5';{dodefinujeme mezeru}
    pompole^[w]:=znak;{ulozime ji do fontu; vubec nevadi, ze bude az na konci}
    {vsechny nedefinovane znaky ve fontu nasmerujeme na mezeru:}
    if prvni<>0 then fillword32(adresy^[0],prvni,velikostdat);
    if posledni<>255 then fillword32(adresy^[posledni+1],255-posledni,velikostdat);
    inc(velikostdat,3);{tim vsim jsme font zvetsili o dalsi 3 byty...}
    inc(pocet);{...a pridali jsme jeden znak}
    end;
  safegetmem(data,velikostdat);
  w:=0;{index pro pohyb v datech}
  for i:=0 to pocet-1 do
    begin{pro kazdy nacteny znak}
    move32(pompole^[i],data^[w],byte(pompole^[i][0])+1);{presun znaku do finalniho datoveho pole}
    inc(w,byte(pompole^[i][0])+1);{posun indexu o jeho delku dal}
    end;
  safefreemem(pompole);{zruseni pomocneho pole}
  end;{with}
End;{nactidsfont}

{Proc vlastne neudelam pole ukazatelu na retezce nebo rovnou pole retezcu?
Protoze chci setrit pameti. Pole 256 ukazatelu by zabralo 1 KB plus k tomu
jeste ztraty vlivem granularity dynamicke pameti u kazdeho dynamicky
alokovaneho retezce (v nejhorsim pripade klidne dalsi 3 KB navic). Pole adres
zabere konstantne 512 B a k tomu jen jeden ukazatel (4 B) na pole dat, coz je
podle mne vyhodnejsi.}

procedure NactiDSFont2(var Kam:dsfont; Odkud:string);
var f:text;
Begin
assign(f,odkud);
reset(f);
if ioresult=0 then begin
                   nactidsfont(Kam,f);
                   close(f);
                   if ioresult=0 then ;{jen pro jistotu}
                   end;
End;{nactidsfont2}

procedure ZrusDSFont(var ktery:dsfont);
Begin
with ktery do begin
              if velikostdat=0 then exit;{neni co rusit}
              dispose(adresy);
              safefreemem(data);
              adresy:=nil; velikostdat:=0;
              end;
End;{zrusdsfont}

procedure DSprint(x,y:integer; var jakymfontem:dsfont; co:string);
type uknastring=^string;
var b:byte;
Begin
getx:=x; gety:=y;
with jakymfontem do
  for b:=1 to byte(co[0]) do
    begin
    drst(uknastring(@(data^[adresy^[byte(co[b])]]))^);
    inc(getx,dspridavek);
    end;
{Co tim chtel basnik rici:
1) Index pro pole adres: index=byte(co[b]) (ord. cislo znaku zadaneho retezce)
2) Adresa grafickeho retezce v poli Data: adresa=adresy^[index]
3) Zacatek (nulty znak) toho retezce v poli Data: nultyznak=data^[adresa]
4) Jeho pretypovani na string (je nutna oklika pres ukazatele, protoze
   normalne by nesedely rozmery promenne a nejde to pretypovat primo):
    grafickyretezec=uknastring(@nultyznak)^  (tj. obsah ukazatele na adresu
                                              nulteho znaku).}
End;{dsprint}

procedure ramecek(lhx,lhy,pdx,pdy:integer; svetlo,stin,txt,pozadi:byte; nadpis:string);
Begin
__box(lhx,lhy,pdx,pdy,stin,svetlo,0,_outline);
__box(lhx+1,lhy+1,pdx-1,pdy-1,svetlo,stin,0,_outline);
if nadpis<>'' then napis(lhx+5,lhy-_textheight shr 1,txt,pozadi,nadpis);
End;{ramecek}

procedure __Oblouk(stredX,stredY,PocUhel,KoncUhel:integer; prirustek,rx,ry:Word; barva:byte);
var uhel:integer;
    x1,y1,x2,y2:integer;
Begin
while pocuhel<=0 do inc(pocuhel,360);{aby byl pocatecni uhel vzdy kladny}
while koncuhel<pocuhel do inc(koncuhel,360);{aby byl koncovy uhel vzdy vetsi nez pocatecni}
if prirustek=0 then prirustek:=1; {0 by zpusobila zaseknuti v nekonecne smycce}
uhel:=pocuhel;
{vypocet pocatecniho bodu eliptickeho oblouku:}
x1:=stredx+(longint(rx)*rychlycos(uhel)) div 10000;
y1:=stredy-(longint(ry)*rychlysin(uhel)) div 10000;
{Pretypovani na longint je nutne, protoze do integeru se mezivysledek nevejde.
Po zaverecnem vydeleni 10000 (protoze rychlysin a cos davaji cislo 10000krat
vetsi) uz je to v pohode a integer staci. Minus je u sinu proto, protoze je
osa y kladnou pulkou dolu, tak aby se otocil smer uhlu.}
__putpixel(x1,y1,barva,0); {zobrazeni pocatecniho bodu (aby bylo aspon neco videt, kdyby byl stejny pocatecni a koncovy uhel}
while uhel<koncuhel do begin
                       inc(uhel,prirustek);
                       if uhel>koncuhel then uhel:=koncuhel;
                       x2:=stredx+(longint(rx)*rychlycos(uhel)) div 10000;
                       y2:=stredy-(longint(ry)*rychlysin(uhel)) div 10000;
                       __line(x1,y1,x2,y2,barva,0);
                       x1:=x2; y1:=y2;
                       end;
End;{__oblouk}

procedure __Vysec(stredX,stredY,PocUhel,KoncUhel:integer; prirustek,rx,ry:Word; barva:byte);
var uhel:integer;
    x1,y1,x2,y2:integer;
Begin
while pocuhel<=0 do inc(pocuhel,360);
while koncuhel<pocuhel do inc(koncuhel,360);
if prirustek=0 then prirustek:=1;
uhel:=pocuhel;
x1:=stredx+(longint(rx)*rychlycos(uhel)) div 10000;
y1:=stredy-(longint(ry)*rychlysin(uhel)) div 10000;
while uhel<koncuhel do begin
                       inc(uhel,prirustek);
                       if uhel>koncuhel then uhel:=koncuhel;
                       x2:=stredx+(longint(rx)*rychlycos(uhel)) div 10000;
                       y2:=stredy-(longint(ry)*rychlysin(uhel)) div 10000;
                       __triangle(x1,y1,x2,y2,stredx,stredy,barva,_filled);
                       x1:=x2; y1:=y2;
                       end;
End;{__vysec}

END.


{struktura souboru *.DSF (retezcove vektorove fonty):

cislo prvniho definovaneho znaku (desitkove cislo v rozsahu 0..255)
cislo posledniho definovaneho znaku (desitkove cislo v rozsahu 0..255)
prvni definovany znak (textovy retezec)
dalsi definovany znak (textovy retezec)
...
posledni znak (textovy retezec)

Jde o textovy soubor, kazda polozka je na samostatnem radku.
Vsechny nedefinovane znaky budou presmerovany na znak #32 (mezera); pokud neni
definovana ani ta, bude pri nacitani fontu dodefinovana automaticky jako
"posun o pet kroku vpravo bez kresleni" ('p5') a pridana do fontu.

Opet zadny oficialni format.
Graficky editor neexistuje, nejlepe se osvedcil ctvereckovany papir, tuzka
a libovolny textovy editor, ve kterem se neplete '1' a 'l'.}