Hra na utek

Kategórie: KMP (Programy mladých programátorů)
Autor: Ivan Rebo
Program: Utek.pas,  Readme.txt,  Ed.pas,  Hp.pas,  Hpu.pas,  Ivo.pas,  Pismo.pas,  Pouzi.pas,  Prezri.pas,  Rutins.pas,  Setup.pas,  Txtp.pas,  Unpack.pas,  Utek.pas,  Vezmi.pas,  Instal.pas,  Makeins.pas,  Xla.pas,  Riki.txt,  Uvod.txt
Soubor exe: Utek.exe,  Ed.exe,  Setup.exe
Potřebné: Mods.obj,  Utek-working-dos.7z

{ RUTINS.PAS                                Copyright (c) Ivan Rebo }
{ https://github.com/IRebo/utek/tree/master/old-199x-version        }
{                                                                   }
{ Author: Ivan Rebo                                                 }
{ Datum: 20.01.1995                           http://www.trsek.com  }
 
{$a+,g+,B-,E-,I-,N-,O-,Q-,R-,S-,T-}
{$l-,y-,d-}
unit rutins;
INTERFACE
uses crt;
type typ1poi=array [1..64000] of byte;
     typ1=^typ1poi;
     fonttyppo=array [1..10000] of byte;
     fonttyp=^fonttyppo;
     typstrpo=array [0..255] of string[20];
     typstr=^typstrpo;
     typ2po=array [1..64786] of byte;
     typ2=^typ2po;
     palettpo=array [1..768] of byte;
     palett=^palettpo;
 
var font:fonttyp;
    predstr:array [0..40] of string[20];
    predm:array [1..40] of boolean;
    hlava:array[30..81] of byte;
    tmp:typ2;
    myska:array[1..400] of byte;
    sprites:typ1;
    predmal:array [1..40] of boolean;
    t:text;
    predreal:array [1..40] of byte;
    f:file;
    obrazok:typ1;
    fontpoi,tmppoi,strpoi,obrpoi,pallpoi,spritpoi,mappoi:pointer;
    paletta:palett;
    playing,soundis,win,pisat:boolean;
    strings:typstr;
    oldkurz,xpov,ypov:word;
    meno,temp,prikaz,predmet,sprloaded:string[20];
    key,k,xr,yr,har,izba,kl,cast,riad:byte;
    mapa:typ1;
    speed,cfg,a,b,c,d,e,m,o,s,predme,xsiz,ysiz,x2,y2:word;
    palletspri:array [1..138] of byte;
    x,y:word;
    Lave,Stredne,Prave:boolean;
 
procedure endee2;
procedure ende;
procedure thend;
procedure loadspr(meno:string);
procedure newspr(meno:string);
procedure kurzor(kurz:byte);
procedure nuluj;
procedure paleta;
procedure pis(xx,yy:word;a:string);
procedure setsound;
procedure mapaspod;
procedure zobrazpred;
procedure loadobrcele(nam:string);
procedure loadroom(meno:string);
procedure endee;
procedure zobraz;
procedure closewin;
procedure loadobr(nam:string);
procedure say(cis,cis2:word;sss:string);
procedure zobrazcele;
procedure tl(ku:byte);
procedure endeee;
procedure depack(siz:word;var pop:pointer);
procedure tloff;
procedure asminit;
procedure testinit;
procedure zmaz;
procedure hc;
procedure sc;
procedure pauza(del:word);
procedure menusvetlo;
procedure zmazcele;
procedure zmazcelemapa(bu,du:word);
procedure ob(poce:byte);
procedure zm(poce:byte);
procedure obcele(poce:byte);
procedure zmcele(poce:byte);
procedure obfont(poce:byte);
procedure zmfont(poce:byte);
procedure tmav;
procedure tmavcele;
procedure kabsvetlo;
procedure movepal(s,o:word);
function memo:longint;
procedure Stav;
procedure Umiestni(x,y:word);
function keypressed:boolean;
PROCEDURE INITSOUND(DEV,sp:integer;MODUL:STRING);
PROCEDURE STOPSOUND;
implementation
{$L MODS.OBJ}
{$F+}
PROCEDURE MODVOLUME(V1,V2,V3,V4:INTEGER); EXTERNAL;
PROCEDURE MODSETUP(VAR STATUS:INTEGER; DEVICE,MIXSPEED,PRO,LOOP:INTEGER; VAR STR:STRING); EXTERNAL;
PROCEDURE MODSTOP; EXTERNAL;
PROCEDURE MODINIT; EXTERNAL;
{$F-}
PROCEDURE INITSOUND(DEV,sp:integer; MODUL:STRING);
const prot:array [1..4] of byte=(ord('M'),ord('.'),ord('K'),ord('.'));
var stat:integer;po:byte;
BEGIN
 MODINIT;
 MODVOLUME(255,255,255,255);
 chdir('music');
 if IOResult <> 0 then begin writeln('Neviem najst hudbu.');halt(1);end;
 assign(f,modul);reset(f,1);close(f);
 if IOResult <> 0 then begin writeln('Neviem najst hudbu.');halt(1);end;
 assign(f,modul);reset(f,1);seek(f,1080);blockwrite(f,prot,4);
 close(f);
 MODSETUP(STAT,DEV,sp,0,0,MODUL);
 assign(f,modul);reset(f,1);close(f);
 if IOResult <> 0 then begin writeln('Neviem najst hudbu.');halt(1);end;
 assign(f,modul);reset(f,1);seek(f,1080);
 po:=random(250);blockwrite(f,po,1);po:=random(250);blockwrite(f,po,1);
 po:=random(250);blockwrite(f,po,1);po:=random(250);blockwrite(f,po,1);
 close(f);chdir('..');
 if stat <> 0 then
 begin
  asm mov ax,3;int 10h;end;
  CASE STAT OF
   1: WRITELN('Neviem najst hudbu !');
   2: writeln('Already playing ...');
   4: writeln('Malo pamati !');
   end;
   halt(1);
  END;
 playing:=true;
END;
 
PROCEDURE STOPSOUND;
BEGIN
  MODSTOP;
  playing:=false;
END;
 
var bufpal:array[0..767] of byte;
    zalpal:array[0..767] of byte;
    o2,s2,poc:word;
 
procedure mapaspod;
begin
 move(sprites^[35200],mapa^[49600],14400);
end;
 
function memo:longint;
var ivo:word;
    ii:longint;
begin
 asm
  mov ah,48h
  mov bx,$ffff
  int 21h
  mov ivo,bx
 end;
 ii:=ivo;
 memo:=ii*16;
end;
 
function keypressed:boolean;
begin if memw[0:$41a]<>memw[0:$41c] then keypressed:=true else keypressed:=false;end;
 
procedure paleta1;assembler;
label loop1;
asm
 mov cx,210
 mov dx,$3C8
 mov ax,s
 mov es,ax
 mov di,o
 xor bl,bl
loop1:
 mov al,bl
 out dx,al
 inc bl
 inc dx
 mov al,[es:di]
 out dx,al
 inc di
 mov al,[es:di]
 out dx,al
 inc di
 mov al,[es:di]
 out dx,al
 inc di
 dec dx
 loop loop1
end;
 
procedure paletacele;assembler;
label loop1;
asm
 mov cx,256
 mov dx,$3C8
 mov ax,s
 mov es,ax
 mov di,o
 xor bl,bl
loop1:
 mov al,bl
 out dx,al
 inc bl
 inc dx
 mov al,[es:di]
 out dx,al
 inc di
 mov al,[es:di]
 out dx,al
 inc di
 mov al,[es:di]
 out dx,al
 inc di
 dec dx
 loop loop1
end;
 
procedure zz;assembler;
label hore,dole;
asm
   push ds
   mov poc,0
   mov cx,630
   xor bx,bx
hore:
   mov si,o
   mov ds,s
   add si,bx
   mov es,s2
   mov di,o2
   add di,bx
   mov dh,[ds:si]
   cmp dh,1
   jnge dole
   mov di,o
   add di,bx
   mov es,s
   mov ax,[es:di]
   dec ax
   mov [es:di],ax
   inc poc
dole:
   inc bx
   loop hore
   pop ds
end;
 
procedure oo;assembler;
label hore,dole;
asm
   push ds
   mov poc,0
   mov cx,630
   xor bx,bx
hore:
   mov si,o
   mov ds,s
   add si,bx
   mov es,s2
   mov di,o2
   add di,bx
   mov dh,[ds:si]
   mov dl,[es:di]
   cmp dh,dl
   je dole
   mov di,o
   add di,bx
   mov es,s
   mov ax,[es:di]
   inc ax
   mov [es:di],ax
   inc poc
dole:
   inc bx
   loop hore
   pop ds
end;
 
procedure zzcele;assembler;
label hore,dole;
asm
   push ds
   mov poc,0
   mov cx,768
   xor bx,bx
hore:
   mov si,o
   mov ds,s
   add si,bx
   mov es,s2
   mov di,o2
   add di,bx
   mov dh,[ds:si]
   cmp dh,1
   jnge dole
   mov di,o
   add di,bx
   mov es,s
   mov ax,[es:di]
   dec ax
   mov [es:di],ax
   inc poc
dole:
   inc bx
   loop hore
   pop ds
end;
 
procedure oocele;assembler;
label hore,dole;
asm
   push ds
   mov poc,0
   mov cx,768
   xor bx,bx
hore:
   mov si,o
   mov ds,s
   add si,bx
   mov es,s2
   mov di,o2
   add di,bx
   mov dh,[ds:si]
   mov dl,[es:di]
   cmp dh,dl
   je dole
   mov di,o
   add di,bx
   mov es,s
   mov ax,[es:di]
   inc ax
   mov [es:di],ax
   inc poc
dole:
   inc bx
   loop hore
   pop ds
end;
 
procedure zzfont;assembler;
label hore,dole;
asm
   push ds
   mov poc,0
   mov cx,138
   mov bx,630
hore:
   mov si,o
   mov ds,s
   add si,bx
   mov es,s2
   mov di,o2
   add di,bx
   mov dh,[ds:si]
   cmp dh,1
   jnge dole
   mov di,o
   add di,bx
   mov es,s
   mov ax,[es:di]
   dec ax
   mov [es:di],ax
   inc poc
dole:
   inc bx
   loop hore
   pop ds
end;
 
procedure oofont;assembler;
label hore,dole;
asm
   push ds
   mov poc,0
   mov cx,138
   mov bx,630
hore:
   mov si,o
   mov ds,s
   add si,bx
   mov es,s2
   mov di,o2
   add di,bx
   mov dh,[ds:si]
   mov dl,[es:di]
   cmp dh,dl
   je dole
   mov di,o
   add di,bx
   mov es,s
   mov ax,[es:di]
   inc ax
   mov [es:di],ax
   inc poc
dole:
   inc bx
   loop hore
   pop ds
end;
 
procedure tmav;
begin
 for d:=0 to 629 do bufpal[d]:=0;
 o:=ofs(bufpal);
 s:=seg(bufpal);
 paleta1;
end;
 
procedure tmavcele;
begin
 for d:=0 to 767 do bufpal[d]:=0;
 o:=ofs(bufpal);
 s:=seg(bufpal);
 paletacele;
end;
 
procedure getpal;
begin
 asm
  mov ah,10h
  mov al,17h
  mov bx,0
  mov cx,256
  int 10h
  mov s,es
  mov o,dx
 end;
 move(ptr(s,o)^,bufpal,768);
 move(ptr(s,o)^,zalpal,768);
end;
 
procedure movepal(s,o:word);
begin
 move(ptr(s,o)^,bufpal,768);
 move(ptr(s,o)^,zalpal,768);
end;
 
procedure zm(poce:byte);
begin
 o:=ofs(bufpal);
 s:=seg(bufpal);
 o2:=ofs(zalpal);
 s2:=seg(zalpal);
 if poce=0 then
 repeat
  zz;paleta1;delay(20);
 until poc=0
 else
 repeat
  for d:=1 to poce do zz;
  paleta1;
 until poc=0;
end;
 
procedure ob(poce:byte);
label dole,hore;
begin
 o:=ofs(bufpal);
 s:=seg(bufpal);
 o2:=ofs(zalpal);
 s2:=seg(zalpal);
 if poce=0 then
 repeat
  oo;paleta1;delay(20);
 until poc=0
 else
 repeat
  for d:=1 to poce do oo;
  paleta1;
 until poc=0;
end;
 
procedure zmcele(poce:byte);
begin
 o:=ofs(bufpal);
 s:=seg(bufpal);
 o2:=ofs(zalpal);
 s2:=seg(zalpal);
 if poce=0 then
 repeat
  zzcele;paletacele;delay(20);
 until poc=0
 else
 repeat
  for d:=1 to poce do zzcele;
  paletacele;
 until poc=0;
end;
 
procedure obcele(poce:byte);
label dole,hore;
begin
 o:=ofs(bufpal);
 s:=seg(bufpal);
 o2:=ofs(zalpal);
 s2:=seg(zalpal);
 if poce=0 then
 repeat
  oocele;paletacele;delay(20);
 until poc=0
 else
 repeat
  for d:=1 to poce do oocele;
  paletacele;
 until poc=0;
end;
 
procedure zmfont(poce:byte);
begin
 o:=ofs(bufpal);
 s:=seg(bufpal);
 o2:=ofs(zalpal);
 s2:=seg(zalpal);
 repeat
  zzfont;paletacele;delay(30);
 until poc=0
end;
 
procedure obfont(poce:byte);
label dole,hore;
begin
 o:=ofs(bufpal);
 s:=seg(bufpal);
 o2:=ofs(zalpal);
 s2:=seg(zalpal);
 repeat
  oofont;paletacele;delay(30);
 until poc=0
end;
 
procedure pauza(del:word);
begin
 a:=0;repeat stav;inc(a);delay(2);
 until (lave)or(prave)or(keypressed)or(a=del);
 if prave then kl:=27;
 if lave then kl:=13;
 if keypressed then
 begin kl:=ord(readkey);
  if kl=0 then kl:=ord(readkey);end;
 tloff;
end;
 
procedure kabsvetlo;
begin
 for d:=0 to 629 do bufpal[d]:=zalpal[d] div 5;
 paleta1;
end;
 
procedure menusvetlo;
begin
 for d:=0 to 629 do bufpal[d]:=zalpal[d] div 2;
 paleta1;
end;
 
procedure ende;
begin
 zmcele(har);zmazcele;
 assign(f,'code\ktoco.nnp');reset(f,1);close(f);
 if IOResult=0 then
 begin
  assign(f,'code\ktoco.nnp');reset(f,1);blockread(f,obrazok^,filesize(f));
  depack(filesize(f),obrpoi);close(f);
  move(tmp^[19],paletta^,768);move(tmp^[787],obrazok^,64000);
  for a:=1 to 768 do paletta^[a]:=paletta^[a] div 4;
  for a:=1 to 255 do
  begin
   o:=paletta^[a*3+3];paletta^[a*3+3]:=paletta^[a*3+1];paletta^[a*3+1]:=o;
  end;
  movepal(seg(paletta^),ofs(paletta^));tmavcele;zobrazcele;obcele(har);
  repeat stav;until (lave)or(prave)or(keypressed);
  if keypressed then
  begin kl:=ord(readkey);if kl=0 then kl:=ord(readkey);end;
  tloff;zmcele(har);zmazcele;
 end;
 if soundis then begin if playing then stopsound;end;
 asm
  mov ax,03h
  int 10h
 end;
 freemem(strpoi,70*21);freemem(tmppoi,64786);
 freemem(spritpoi,6400);freemem(obrpoi,64000);
 freemem(pallpoi,64000);freemem(mappoi,64000);
 freemem(fontpoi,10000);
 writeln('Thanx for playing !                                       NoName Software');
 halt(0);
end;
 
procedure zmaz;assembler;
asm
 mov ax,0a000h
 mov es,ax
 xor di,di
 mov ax,0000h
 mov cx,24800
 rep stosw
end;
 
procedure zmazcele;assembler;
asm
 mov ax,0a000h
 mov es,ax
 xor di,di
 mov ax,0
 mov cx,32768
 rep stosw
end;
 
procedure zmazcelemapa(bu,du:word);assembler;
asm
 mov ax,bu
 mov es,ax
 mov di,du
 mov ax,0
 mov cx,32000
 rep stosw
end;
 
procedure asminit;assembler;
asm
 mov ax,13h
 int 10h
 mov ax,0
 int 33h
 mov ax,7
 mov cx,0
 mov dx,319*8
 int 33h
 mov ax,8
 mov cx,0
 mov dx,199*8
 int 33h
 mov ax,$f
 mov cx,2
 mov dx,2
 int 33h
end;
 
procedure testinit;
label go,go1;
begin
 if maxavail<281000 then
 begin
  writeln;writeln;
  writeln('Volna : ',maxavail,' z 281000.');
  writeln('Prilis malo volnej pamati. Skus dosiahnut 450 Kb volnej.');
  halt(3);
 end;
 asm
  mov ax,$a000
  xor bx,bx
  mov es,ax
  mov di,0
  mov ax,$1b00
  int 10h
  cmp al,$1b
  je go1
 end;
 writeln;writeln;
 writeln('VGA karta nenajdena. Sorry.');
 halt(2);
go1:
 asm
  xor ax,ax
  int 33h
  cmp ax,$ffff
  je go
 end;
 writeln;writeln;
 writeln('Nenajdeny ovladac mysky !');
 halt(2);
go:
end;
 
procedure hc;assembler;
asm
 mov ah,1
 mov ch,$20
 int 10h
end;
 
procedure sc;assembler;
asm
 mov ah,1
 mov ch,3
 mov cl,4
 int 10h
end;
 
procedure Stav;
var tlac:word;
begin
 asm
  mov ax,3
  int 33h
  mov x,cx
  mov y,dx
  mov tlac,bx
 end;
 x:=x div 8;
 y:=y div 8;
 Lave:=boolean(tlac and 1);
 Stredne:=boolean(tlac and 4);
 Prave:=boolean(tlac and 2);
end;
 
procedure Umiestni(x,y:word);assembler;
asm
 mov cx,x
 mov dx,y
 mov ax,4h
 int 33h
end;
 
{$i pismo.pas}
 
procedure tloff;
begin
 repeat
  stav;
 until (not lave)and(not prave);
 if keypressed then
 repeat
  readkey;
 until not keypressed;
end;
 
procedure zobrazcele;assembler;
asm
 push ds
 lds si,obrazok
 mov ax,0a000h
 mov es,ax
 xor di,di
 mov cx,32768
 rep movsw
 pop ds
end;
 
procedure endee;
begin
 if soundis then begin if playing then stopsound;end;
 asm
  mov ax,03h
  int 10h
 end;
 freemem(strpoi,sizeof(strings^));freemem(tmppoi,64786);
 freemem(spritpoi,6400);freemem(obrpoi,64000);freemem(pallpoi,64000);
 freemem(mappoi,64000);
 freemem(fontpoi,10000);sound(1502);delay(154);nosound;
 writeln('Chyba - 463465:56874 - Chyba dolezity subor !!!');
 writeln('Thanx for trying to play Utek ---------------------- NoName Software');
 halt(0);
end;
 
procedure myson(kurzor:byte);
label mensie,mensie2,loop;
var kurz:byte;
begin
 riad:=kurzor div 16;
 kurz:=kurzor mod 16;
 e:=19;if y>180 then e:=200-y-1;
 d:=19;if x>300 then d:=320-x-1;
 b:=y*320+x;
 for a:=0 to e do move(obrazok^[1+b+a*320],myska[a*20+1],d+1);
 for a:=0 to e do for c:=0 to d do
  if sprites^[(a+1)*320+c+2+kurz*20+riad*6400]<>0 then
   mem[$a000:b+a*320+c]:=sprites^[2+(a+1)*320+c+kurz*20+riad*6400];
 oldkurz:=kurzor;
 xr:=d;yr:=e;
end;
 
procedure mysoff;
begin
 riad:=oldkurz div 16;
 oldkurz:=oldkurz mod 16;
 for a:=0 to yr do
 begin
  if (y2+a>=y)and(y2+a<=y+yr) then
  begin
   d:=y2+a-y;
   for b:=0 to xr do
   begin
    if (x2+b>=x)and(x2+b<=x+xr) then
    begin
     e:=x2+b-x;
     c:=sprites^[e+2+(d+1)*320+riad*6400+oldkurz*20];
     if c=0 then
      mem[$a000:y2*320+x2+a*320+b]:=myska[a*20+1+b]
      else mem[$a000:y2*320+x2+a*320+b]:=c;
    end else mem[$a000:y2*320+x2+a*320+b]:=myska[a*20+1+b];
   end;
  end else move(myska[a*20+1],mem[$a000:y2*320+x2+a*320],xr+1);
 end;
end;
 
procedure mysoffall;
label loop1;
begin
 o:=ofs(myska);
 s:=seg(myska);
 asm
  push ds
  mov si,o
  mov ds,s
  mov ax,$a000
  mov es,ax
  mov di,b
  xor bh,bh
  mov bl,xr
  xor ch,ch
  mov cl,yr
  inc cl
  mov ax,319
  sub ax,bx
  xor bh,bh
  mov bl,19
  sub bl,xr
loop1:
  push cx
  mov cl,xr
  inc cx
  rep movsb
  add di,ax
  add si,bx
  pop cx
  loop loop1
  pop ds
 end;
end;
 
procedure klavesi;
begin
    kl:=ord(readkey);
    if chr(kl)='+' then begin if k<24 then k:=k+4 else k:=24;end;
    if chr(kl)='-' then begin if k>4 then k:=k-4 else k:=1;end;
    if kl=0 then
    begin
     kl:=ord(readkey);
     if ord(kl)=72 then
     begin
      stav;if y>=(k) then umiestni(x*8,(y-k)*8)
       else umiestni(x*8,0);
     end;
     if ord(kl)=80 then
     begin
      stav;umiestni(x*8,(y+k)*8);
     end;
     if ord(kl)=77 then
     begin
      stav;umiestni((x+k)*8,(y)*8);
     end;
     if ord(kl)=75 then
     begin stav;
      if x>=k then umiestni((x-k)*8,y*8)
       else umiestni(0,y*8);
     end;
    end;
end;
 
procedure kurzor(kurz:byte);
begin
 kl:=1;
 stav;
 if pisat then
 begin
  pis(192,9,'                                                  ');
  if mapa^[x+y*320+1]<>0 then
   pis(192,9,strings^[mapa^[x+y*320+1]]);
  m:=mapa^[x+y*320+1];
 end;
 c:=mapa^[x+y*320+1];
 if (c<>0) then
 begin
  temp:=strings^[c];
  if (temp[length(temp)]='`')and(kurz=3) then
   myson(1)
  else
   myson(kurz);
 end
 else
  myson(kurz);
 repeat
  x2:=x;y2:=y;stav;if keypressed then klavesi;
  if (x<>x2)or(y<>y2) then
  begin
   c:=mapa^[x+y*320+1];
   if c<>0 then
   begin
    temp:=strings^[c];
    if (temp[length(temp)]='`')and(kurz=3) then
     oldkurz:=1 else oldkurz:=kurz;
   end else oldkurz:=kurz;
   mysoff;
   if pisat then
   begin
    if m<>mapa^[x+y*320+1] then
    begin
     pis(192,9,'                                                  ');
     if mapa^[x+y*320+1]<>0 then
      pis(192,9,strings^[mapa^[x+y*320+1]]);
    end;
    m:=mapa^[x+y*320+1];
   end;
   c:=mapa^[x+y*320+1];
   if c<>0 then
   begin
    temp:=strings^[c];
    if (temp[length(temp)]='`')and(kurz=3) then
     myson(1)
    else
     myson(kurz);
   end
   else
    myson(kurz);
 end;
 until (prave)or(lave)or(kl=13)or(kl=27)or(kl=32);
 mysoffall;m:=0;
end;
 
procedure tl(ku:byte);
begin
 stav;
 if (lave)or(prave) then
 begin
  myson(ku);
  repeat
   x2:=x;y2:=y;stav;
   if (x<>x2)or(y<>y2) then
   begin
    mysoff;
    myson(ku);
   end;
  until (not lave)and(not prave);
  mysoffall;
 end;
 if keypressed then
  while not keypressed do begin readkey;end;
end;
 
procedure say(cis,cis2:word;sss:string);
begin
 tl(2);
 pis(cis,cis2,'                                                  ');
 pis(cis,cis2,sss);
 pisat:=false;
 kurzor(2);
 if keypressed then
 repeat
  kurzor(2);if keypressed then kl:=ord(readkey);
 until (kl=13);
 tl(2);pis(cis,cis2,'                                                  ');
 kl:=1;
 pisat:=true;
end;
 
procedure closewin;
begin
 for a:=0 to xsiz-1 do
 begin
  move(tmp^[1+a*ysiz+ysiz*xsiz],obrazok^[1+xpov+ypov*320+a*320],ysiz);
  move(tmp^[1+a*ysiz],mapa^[1+xpov+ypov*320+a*320],ysiz);
 end;
 win:=false;
 sprloaded:='';
end;
 
procedure depack(siz:word;var pop:pointer);
var o,s,o2,s2:word;
    pa:^typ1;
label loop,ne,no,jump;
begin
 pa:=pop;o:=ofs(pop^);s:=seg(pop^);o2:=ofs(tmp^);s2:=seg(tmp^);
 asm
  push ds
  xor ax,ax
  mov es,s2
  mov si,o2
  mov ds,s
  mov di,o
 jump:
  mov dx,siz
  cmp ax,dx
  je no
  mov bl,[ds:di]
  inc di
  mov dl,[ds:di]
  cmp bl,dl
  jne ne
  inc di
  mov dl,[ds:di]
  inc di
  inc ax
  inc ax
  inc ax
  mov cl,dl
 loop:
  mov [es:si],bl
  inc si
 loop loop
 jmp jump
 ne:
  dec di
  mov cl,[ds:di]
  mov [es:si],cl
  inc di
  inc si
  inc ax
 jmp jump
 no:
 pop ds
 end;
end;
 
procedure tgapalet;
begin
 for a:=1 to 630 do paletta^[a]:=paletta^[a] div 4;
 for a:=0 to 209 do
 begin
  o:=paletta^[a*3+3];paletta^[a*3+3]:=paletta^[a*3+1];paletta^[a*3+1]:=o;
 end;
end;
 
procedure tgapaletcele;
begin
 for a:=1 to 768 do paletta^[a]:=paletta^[a] div 4;
 for a:=0 to 255 do
 begin
  o:=paletta^[a*3+3];paletta^[a*3+3]:=paletta^[a*3+1];paletta^[a*3+1]:=o;
 end;
end;
 
procedure newspr(meno:string);
var xpovn,ypovn,xsizn,ysizn:word;
begin
 assign(f,meno+'.spr');reset(f,1);close(f);
 if IOResult <> 0 then endee;
 assign(f,meno+'.spr');reset(f,1);
 blockread(f,xpovn,2);
 blockread(f,ypovn,2);
 blockread(f,xsizn,2);
 blockread(f,ysizn,2);
 blockread(f,obrazok^,filesize(f)-8);
 close(f);
 for a:=0 to xsizn-1 do
 begin
  move(obrazok^[1+a*ysizn],mem[$a000:xpovn+ypovn*320+a*320],ysizn);
  move(obrazok^[1+a*ysizn+ysizn*xsizn],mapa^[1+xpovn+ypovn*320+a*320],ysizn);
 end;
 move(mem[$a000:0],obrazok^,49600);
end;
 
procedure loadobr(nam:string);
begin
 assign(f,nam+'.nnp');reset(f,1);close(f);
 if ioresult<>0 then endee;
 assign(f,nam+'.nnp');reset(f,1);
 blockread(f,mapa^,filesize(f));
 depack(filesize(f),mappoi);close(f);
 move(tmp^[19],paletta^,630);
 move(tmp^[787],obrazok^,49600);
 tgapalet;
end;
 
procedure loadobrcele(nam:string);
begin
 assign(f,nam+'.nnp');reset(f,1);close(f);
 if ioresult<>0 then endee;
 assign(f,nam+'.nnp');reset(f,1);
 blockread(f,obrazok^,filesize(f));
 depack(filesize(f),obrpoi);close(f);
 move(tmp^[19],paletta^,768);
 move(tmp^[787],obrazok^,64000);
 tgapaletcele;
end;
 
procedure loadspr(meno:string);
begin
 if sprloaded<>meno then
 begin
  if win then begin closewin;zobraz;end;
  sprloaded:=meno;
  assign(f,meno+'.spr');reset(f,1);close(f);
  if IOResult<>0 then endee;
  assign(f,meno+'.spr');reset(f,1);
  blockread(f,xpov,2);blockread(f,ypov,2);
  blockread(f,xsiz,2);blockread(f,ysiz,2);
  blockread(f,tmp^,filesize(f)-8);
  close(f);
  for a:=0 to xsiz-1 do
  begin move(tmp^[1+a*ysiz],obrazok^[1+xpov+ypov*320+a*320],ysiz);end;
  for a:=0 to xsiz-1 do
  begin move(mapa^[1+xpov+ypov*320+a*320],tmp^[1+a*ysiz],ysiz);end;
  for a:=0 to xsiz-1 do
  begin move(tmp^[1+a*ysiz+ysiz*xsiz],mapa^[1+xpov+ypov*320+a*320],ysiz);end;
  for a:=0 to xsiz-1 do
  begin move(mem[$a000:xpov+ypov*320+a*320],tmp^[1+a*ysiz+ysiz*xsiz],ysiz);end;
  zobraz;
  win:=true;
 end;
end;
 
procedure zobraz;assembler;
asm
 push ds
 lds si,obrazok
 mov ax,0a000h
 mov es,ax
 xor di,di
 mov cx,24800
 rep movsw
 pop ds
end;
 
procedure paleta;
var r,g,blue:byte;
begin
 for d:=0 to 255 do
 begin
  r:=paletta^[d*3+1];
  g:=paletta^[d*3+2];
  blue:=paletta^[d*3+3];
  asm
   mov dx,$3C8
   mov ax,d
   out dx,al
   inc dx
   mov al,r
   out dx,al
   mov al,g
   out dx,al
   mov al,blue
   out dx,al
  end;
 end;
end;
 
procedure loadroom(meno:string);
begin
 win:=false;
 sprloaded:='';
 zm(har);zmaz;
 loadobr(meno);
 assign(f,meno+'.nnm');reset(f,1);close(f);
 if IOResult <> 0 then endee;
 assign(f,meno+'.nnm');reset(f,1);
 blockread(f,mapa^,filesize(f));
 depack(filesize(f),mappoi);close(f);
 move(tmp^,mapa^,49600);
 mapaspod;
 assign(t,meno+'.nnt');reset(t);close(t);
 if IOResult <> 0 then endee;
 assign(t,meno+'.nnt');
 reset(t);
 a:=0;
 repeat inc(a);readln(t,strings^[a]);until eof(t);
 for b:=1 to a do
  for c:=1 to length(strings^[b]) do
   strings^[b][c]:=chr(ord(strings^[b][c])-30);
 close(t);movepal(seg(paletta^),ofs(paletta^));tmav;
 zobraz;if cast=1 then begin
 if (not predmal[11])and(meno='data\pivnica') then
  begin newspr('data\pivnica1');end;
 if (predmal[14])and(meno='data\chodba1') then
  begin newspr('data\chodba12');end;
 end else if cast=2 then
 begin
  if (predmal[1])and(meno='data2\posch1') then
   begin newspr('data2\poschpla');end;
  if (not predmal[2])and(meno='data2\posch1') then
   begin newspr('data2\poschdro');end;
  if (predmal[4])and(meno='data2\posch1') then
   begin newspr('data2\poschpa');end;
  if (not predmal[6])and(meno='data2\poschod') then
   begin newspr('data2\poschod1');end;
  if (not predmal[8])and(meno='data2\poschzac') then
   begin newspr('data2\poschza1');end;
  if (predmal[9])and(meno='data2\poschzac') then
   begin newspr('data2\poschsnu');end;
  if (not predmal[11])and(meno='data2\prizvcho') then
   begin newspr('data2\prizvch1');end;
  if (not predmal[14])and(meno='data2\prizkuch') then
   begin newspr('data2\prizkuc1');end;
  if (not predmal[15])and(meno='data2\prizjeda') then
   begin newspr('data2\prizjed1');end;
  if (not predmal[21])and(meno='data2\prizach') then
   begin newspr('data2\prizach1');end;
  if (predmal[24])and(meno='data2\prizchod') then
   begin newspr('data2\prizcho3');end else
  if (predmal[23])and(meno='data2\prizchod') then
   begin newspr('data2\prizcho2');end;
  if (predmal[25])and(meno='data2\poschkup') then
   begin newspr('data2\poschku1');end;
 end;
 ob(har);paleta;
end;
 
procedure nuluj;
begin
 for a:=1 to 40 do predm[a]:=false;
 for a:=1 to 40 do predmal[a]:=false;
 prikaz:='pouzi';
end;
 
procedure zobrazspod;assembler;
asm
 push ds
 lds si,obrazok
 mov ax,0a000h
 mov es,ax
 add si,49600
 mov di,49600
 mov cx,7968
 rep movsw
 pop ds
end;
 
procedure zobrazpred;
begin
 if predme>5 then predm[predme]:=false;b:=0;
 for a:=0 to 44 do move(sprites^[a*320+155*320+1],obrazok^[a*320+155*320+1],320);
 for a:=1 to 10 do strings^[241+a]:='';
 for a:=6 to 15 do
 begin
  if predm[a]=true then
  begin
   inc(b);predreal[b]:=a;strings^[241+b]:=predstr[a];
   for c:=1 to 19 do move(sprites^[a*20+c*320+2],obrazok^[b*20+c*320+160*320-11],19);
  end;
 end;
 for a:=16 to 31 do
 begin
  if predm[a]=true then
  begin
   inc(b);predreal[b]:=a;strings^[241+b]:=predstr[a];
   for c:=1 to 19 do move(sprites^[(a-16)*20+c*320+2+6400],obrazok^[b*20+c*320+160*320-11],19);
  end;
 end;
 for a:=32 to 40 do
 begin
  if predm[a]=true then
  begin
   inc(b);predreal[b]:=a;strings^[241+b]:=predstr[a];
   for c:=1 to 19 do move(sprites^[(a-32)*20+c*320+2+12800],obrazok^[b*20+c*320+160*320-11],19);
  end;
 end;
 if prikaz='pouzi' then for a:=1 to 21 do
  move(sprites^[88*320+a*320+1],obrazok^[159*320+a*320+214],25);
 if prikaz='zober' then for a:=1 to 21 do
  move(sprites^[88*320+a*320+26],obrazok^[159*320+a*320+239],25);
 if prikaz='prezri' then for a:=1 to 21 do
  move(sprites^[88*320+a*320+51],obrazok^[159*320+a*320+264],25);
 zobrazspod;
 if predme>5 then predm[predme]:=true;
end;
 
procedure set400mode;assembler;
const seqport=$3c4;
      crtcport=$3d4;
      grcontport=$3ce;
asm
 mov dx,grcontport
 mov al,5
 out dx,al
 inc dx
 in al,dx
 and al,11101111b
 out dx,al
 dec dx
 mov al,6
 out dx,al
 inc dx
 in al,dx
 and al,11111101b
 out dx,al
 mov dx,seqport
 mov al,4
 out dx,al
 inc dx
 in al,dx
 and al,11110111b
 or al,00000100b
 out dx,al
 mov dx,seqport
 mov ax,$0f02
 out dx,ax
 mov ax,$a000
 mov es,ax
 sub di,di
 sub ax,ax
 mov cx,$8000
 rep stosw
 mov dx,crtcport
 mov al,9h
 out dx,al
 inc dx
 in al,dx
 and al,01110000b
 out dx,al
 dec dx
 mov al,14h
 out dx,al
 inc dx
 in al,dx
 and al,10111111b
 out dx,al
 dec dx
 mov al,17h
 out dx,al
 inc dx
 in al,dx
 or al,01000000b
 out dx,al
end;
 
procedure changeoffset(num:word);
begin
 port[$3d4]:=$c;
 port[$3d5]:=num div 256;
 port[$3d4]:=$d;
 port[$3d5]:=num mod 256;
end;
 
procedure scroll(x2,y2:word);
begin
 changeoffset(y2 div 4+x2*80);
end;
 
procedure retraces;
begin
 asm
  mov dx,3DAh
@vent1:
  in al,dx
  test al,8
  jz @vent1
@vent2:
  in al,dx
  test al,8
  jnz @vent2
 end;
end;
 
procedure kresliciaru(bu:word;buf:typ1);
begin
 asm
  mov ah,1
  mov dx,03c4h
  mov al,02h
  out dx,al
  inc dx
  mov al,ah
  out dx,al
 end;
 for a:=0 to 79 do mem[$a000:400*80+b*80+a]:=buf^[bu*320+a*4+1];
 asm
  mov ah,2
  mov dx,03c4h
  mov al,02h
  out dx,al
  inc dx
  mov al,ah
  out dx,al
 end;
 for a:=0 to 79 do mem[$a000:400*80+b*80+a]:=buf^[bu*320+a*4+2];
 asm
  mov ah,4
  mov dx,03c4h
  mov al,02h
  out dx,al
  inc dx
  mov al,ah
  out dx,al
 end;
 for a:=0 to 79 do mem[$a000:400*80+b*80+a]:=buf^[bu*320+a*4+3];
 asm
  mov ah,8
  mov dx,03c4h
  mov al,02h
  out dx,al
  inc dx
  mov al,ah
  out dx,al
 end;
 for a:=0 to 79 do mem[$a000:400*80+b*80+a]:=buf^[bu*320+a*4+4];
end;
 
procedure doskrol;
begin
a:=150;
repeat
 for c:=0 to a div 3 do
 begin scroll(b-c*3,0);retraces;end;
 for c:=a div 3 downto 0 do
 begin scroll(b-c*3,0);retraces;end;
 a:=a div 4;
until a<10;
end;
 
procedure thend;
begin
 tloff;zm(har);zmcele(har);zmazcele;loadobrcele('data3\koniec');
 if soundis then begin stopsound;initsound(cfg,speed,'happyend.dom');end;
 movepal(seg(paletta^),ofs(paletta^));tmavcele;zobrazcele;
 obcele(0);pauza(4000);zmcele(0);zmazcele;
 set400mode;
 loadobrcele('ende\grat');
 movepal(seg(paletta^),ofs(paletta^));tmavcele;b:=0;
 repeat
  inc(b);
  scroll(b,0);
  kresliciaru(b-(b div 200)*200,obrazok);
 until (b=200);obcele(0);b:=200;
 loadobrcele('ende\grat1');
 repeat
  scroll(b,0);
  kresliciaru(b-(b div 200)*200,obrazok);
  dec(b);kresliciaru(b-(b div 200)*200,obrazok);
  dec(b);kresliciaru(b-(b div 200)*200,obrazok);
  dec(b);kresliciaru(b-(b div 200)*200,obrazok);
  inc(b,3);
  if b mod 1600=0 then begin doskrol;pauza(2000);end else
  if b mod 1400=0 then begin doskrol;loadobrcele('ende\kon');pauza(10000);end else
  if b mod 1200=0 then begin doskrol;loadobrcele('ende\hoe');pauza(5000);end else
  if b mod 1000=0 then begin doskrol;loadobrcele('ende\jano');pauza(12000);end else
  if b mod 800=0 then begin doskrol;loadobrcele('ende\vlado2');pauza(12000);end else
  if b mod 600=0 then begin doskrol;loadobrcele('ende\vlado1');pauza(12000);end else
  if b mod 400=0 then begin doskrol;loadobrcele('ende\dano1');pauza(3000);end;
  inc(b,4);
  retraces;stav;
 until (b=1604);tloff;
 zmcele(0);asm mov ax,13h;int 10h;end;
 ende;
end;
 
procedure endeee;
begin
 if hlava[51]<>$50 then
 begin endee;end;
 if hlava[52]<>$40 then
 begin endee;end;
 a:=52;repeat inc(a);
 until (hlava[a]<>mem[$f000:$78+(a-53)]+120)or(a=81);
 if a<>81 then
 begin endee;end;
 tloff;zm(har);zmcele(har);zmazcele;loadobrcele('data2\chytil');
 movepal(seg(paletta^),ofs(paletta^));tmavcele;zobrazcele;obcele(0);
 repeat stav;
 until (lave)or(prave)or(keypressed);
 if keypressed then
 begin kl:=ord(readkey);
  if kl=0 then kl:=ord(readkey);end;
 tloff;
 zmcele(0);zmazcele;
 loadobrcele('data2\cast2');
 if soundis then begin stopsound;initsound(cfg,speed,'music2-1.dom');end;
 movepal(seg(paletta^),ofs(paletta^));tmavcele;zobrazcele;obcele(0);
 pauza(1500);
 zmcele(0);zmazcele;
 move(palletspri,paletta^[631],138);paleta;nuluj;zobrazpred;
 izba:=1;cast:=2;loadroom('data2\posch1');
end;
 
procedure endee2;
begin
 if hlava[51]<>$50 then
 begin endee;end;
 if hlava[52]<>$40 then
 begin endee;end;
 a:=52;repeat inc(a);
 until (a=81)or(hlava[a]<>mem[$f000:$78+(a-53)]+120);
 if a<>81 then
 begin endee;end;
 tloff;zm(har);zmcele(har);zmazcele;loadobrcele('data3\taxikar');
 movepal(seg(paletta^),ofs(paletta^));tmavcele;zobrazcele;obcele(0);
 repeat stav;
 until (lave)or(prave)or(keypressed);
 if keypressed then
 begin kl:=ord(readkey);
  if kl=0 then kl:=ord(readkey);end;
 tloff;
 zmcele(0);zmazcele;
 loadobrcele('data3\cast3');
 if soundis then begin stopsound;initsound(cfg,speed,'music3-1.dom');end;
 movepal(seg(paletta^),ofs(paletta^));tmavcele;zobrazcele;obcele(0);
 pauza(1500);
 zmcele(0);zmazcele;
 move(palletspri,paletta^[631],138);paleta;nuluj;zobrazpred;
 izba:=1;cast:=3;loadroom('data3\vratnica');
end;
 
procedure setsound;
begin
 assign(f,'utek.cfg');reset(f,1);close(f);
 if IOResult <> 0 then
 begin
  soundis:=false;har:=4;
 end
 else
 begin
  a:=0;b:=0;
  assign(f,'utek.cfg');
  reset(f,1);blockread(f,a,1);blockread(f,b,1);
  close(f);har:=4;
  if a=1 then soundis:=false else soundis:=true;
 end;
 if (memo<157000)and(soundis) then begin writeln;
  writeln('Malo pamati pre hudbu.');writeln;
  writeln('Potrebna pamat pre hudbu : 157000.');
  writeln('Volnej je len : ',memo);
  writeln('Nechat hudbu ? [A/N]');
  c:=ord(readkey);
  if upcase(chr(c))<>'A' then soundis:=false;
  if keypressed then begin kl:=ord(readkey);
  if kl=0 then kl:=ord(readkey);end;tloff;
 end;
 asm
  mov ax,3567h
  int 21h
  mov s,es
 end;
 move(mem[s:$a],predreal,8);prikaz:='';
 for c:=1 to 8 do prikaz:=prikaz+chr(predreal[c]);
 if (prikaz='EMMXXXX0')and(soundis) then begin writeln;
  writeln('EMS manager found. EMS => LOW MUSIC. Press something.');
  repeat stav;until (lave)or(prave)or keypressed;
  if keypressed then begin kl:=ord(readkey);
  if kl=0 then kl:=ord(readkey);end;tloff;
  {b:=1;}
 end;
 if soundis then
 begin
  if b=1 then speed:=8000;
  if b=2 then speed:=12000;
  if b=3 then speed:=16000;
  if b=4 then speed:=22000;
  if a=2 then cfg:=0;
  if a=3 then cfg:=1;
  if a=4 then cfg:=6;
 end;
end;
end.