Delphi & Pascal (èeská wiki)
{ INSTAL.PAS Copyright (c) Ivan Rebo } { Instalacka pre hru utek. } { https://github.com/IRebo/utek/tree/master/old-199x-version } { } { Author: Ivan Rebo } { Datum: 20.01.1995 http://www.trsek.com } {$I-} {$G+,N-,E-} program instalacia; uses crt,dos,xla; type TCharArray = array[0..0] of char; var f : file; S : SearchRec; n : NameStr; d,d1 : DirStr; e : ExtStr; tmp : boolean; nlines, nfiles, i : integer; totratio, size, compsize, origsize : longint; mode : word; buf:array [1..60000] of byte; zal1,zal2,b:byte; filename : string; kl,disk:char; diskces,cesta,temp:string; a:integer; DirInfo: SearchRec; label cest; function xexists( filename : string ) : boolean; var f : file; tmp : boolean; begin assign( f, filename ); reset( f ); tmp := ioresult=0; if tmp then close(f); xexists := tmp; end; procedure xstrupcase( var s : string ); assembler; asm les di, s mov cx, 0 mov cl, es:[di] inc di or cl, cl jz @@Done @@ChangeChar: mov al, es:[di] cmp al, 'a' jl @@Next cmp al, 'z' jg @@Next sub al, 32 mov es:[di], al @@Next: inc di loop @@ChangeChar @@Done: end; procedure ReadFile( var data; s : word; var actual : longint ); far; var amountread : word; begin blockread( f, data, s, amountread ); actual := amountread; end; procedure WriteFile( var data; blocksize : word ); far; begin blockwrite( f, data, blocksize ); end; procedure hc; begin asm mov ah,1;mov ch,$20;int $10;end; end; procedure sc; begin asm mov ah,1;mov ch,3;mov cl,4;int $10;end; end; procedure vc; begin asm mov ah,1;mov ch,0;mov cl,4;int $10;end; end; procedure getdrive; label iov; begin textcolor(15);textbackground(1); gotoxy(15,10); write('Zadaj disk pre hru Utek : '); textbackground(7);iov:textbackground(1); gotoxy(2,8); write(' '); textbackground(7);gotoxy(41,10); write(' '); gotoxy(41,10);write(disk); kl:=readkey; if ord(kl)=0 then begin kl:=readkey;goto iov;end; if kl=#27 then begin textcolor(7);textbackground(0);sc;clrscr;textcolor(lightred); writeln('Instalacia predcasne ukoncena !!!'); sound(2000);delay(100);nosound;textcolor(7);chdir(diskces);halt(1); end; if kl<>#13 then begin if upcase(kl) in ['A'..'Z'] then disk:=kl; goto iov; end else begin if disk=#0 then begin goto iov;end; if upcase(disk)='A' then begin goto iov;end; if upcase(disk)='B' then begin goto iov;end; chdir(disk+':\'); if ioresult<>0 then begin gotoxy(25,8);write('Takyto disk neexistuje !'); kl:=readkey;if ord(kl)=0 then begin kl:=readkey;end;goto iov;end; if diskfree(ord(upcase(disk))-ord('A')+1)<4000000 then begin gotoxy(21,8); write('Malo volneho miesta na disku ! Potrebne : 4 Mb.'); kl:=readkey;if ord(kl)=0 then begin kl:=readkey;end;goto iov;end; end; end; procedure getcesta; label iov; begin textcolor(15);textbackground(1); gotoxy(15,10); write('Zadaj cestu pre hru Utek : '); textbackground(7);iov:textbackground(1); gotoxy(2,8); write(' '); textbackground(7);gotoxy(41,10); write(' '); gotoxy(41,10);write(cesta); sc;kl:=readkey;hc; if ord(kl)=0 then begin kl:=readkey;goto iov;end; if kl=#27 then begin textcolor(7);textbackground(0);sc;clrscr;textcolor(lightred); writeln('Instalacia predcasne ukoncena !!!'); sound(2000);delay(100);nosound;textcolor(7);chdir(diskces);halt(1); end; if kl<>#13 then begin if kl=#8 then delete(cesta,length(cesta),1); if length(cesta)>24 then begin gotoxy(30,8);goto iov;end; if upcase(kl) in ['A'..'Z'] then cesta:=cesta+kl; if (kl=':')or(kl='\') then cesta:=cesta+kl; if upcase(kl) in ['0'..'9'] then cesta:=cesta+kl; goto iov; end; if length(cesta)=0 then begin gotoxy(25,8);write('Zla cesta !');kl:=readkey;if ord(kl)=0 then begin kl:=readkey;end;goto iov; end; a:=1;temp:=''; repeat if cesta[a]='\' then begin chdir(temp);if ioresult<>0 then begin mkdir(temp);chdir(temp);end; if ioresult<>0 then begin gotoxy(25,8);write('Zla cesta !');kl:=readkey; if ord(kl)=0 then begin kl:=readkey;end;goto iov; end; temp:='';end else temp:=temp+cesta[a]; inc(a); until a=length(cesta);temp:=temp+cesta[a]; chdir(temp);if ioresult<>0 then begin mkdir(temp);chdir(temp);end; end; procedure getreg; label iov; var meno:string; begin meno:=''; textcolor(15);textbackground(1); gotoxy(10,10); write('Zadaj svoje meno a priezvisko :'); textbackground(7); iov:textbackground(1); gotoxy(2,8); write(' '); textbackground(7);gotoxy(41,10); write(' '); gotoxy(41,10);write(meno); sc;kl:=readkey;hc; if ord(kl)=0 then begin kl:=readkey;goto iov;end; if kl<>#13 then begin if kl=#8 then delete(meno,length(meno),1); if length(meno)>20 then begin gotoxy(30,8);goto iov;end; if upcase(kl) in ['A'..'Z'] then meno:=meno+kl; if upcase(kl)=' ' then meno:=meno+kl; goto iov; end; if (length(meno)=0)or(meno[1]=' ') then begin gotoxy(25,8);write('Zle meno !');kl:=readkey;if ord(kl)=0 then begin kl:=readkey;end;goto iov;end; chdir(disk+':\'+cesta); for a:=length(meno) to 20 do meno:=meno+' '; for a:=1 to 20 do meno[a]:=chr(ord(meno[a])+a*3+50); assign(f,'utek.exe'); reset(f,1); seek(f,30); for a:=30 to 50 do begin b:=ord(meno[a-29]);blockwrite(f,b,1);end; b:=$50;blockwrite(f,b,1); b:=$40;blockwrite(f,b,1); for a:=53 to 81 do begin b:=mem[$f000:$78+(a-53)]+120;blockwrite(f,b,1);end; close(f); chdir(diskces); end; procedure depack(p2,adr:string); var p3:string; f1:file; size,sizes:longint; begin assign(f,p2+'.HOE'); reset(f,1); assign(f1,adr+'\'+p2+'.hoe'); rewrite(f1,1); size:=filesize(f); repeat if size>60000 then begin size:=size-60000; sizes:=60000; end else sizes:=size; blockread(f,buf,sizes); blockwrite(f1,buf,sizes); until size=sizes; close(f);close(f1); if ioresult<>0 then begin textcolor(7);textbackground(0);sc;clrscr;textcolor(lightred); writeln('Instalacia predcasne ukoncena !!!'); sound(2000);delay(100);nosound;textcolor(7);chdir(diskces);halt(1); end; totratio:=0; XLAOutProc:=WriteFile; xLAInProc:=ReadFile; xstrupcase( p2 ); FSplit( p2, d, n, e ); if e = '' then e := '.hoe'; p2 := adr+'\'+d+n+e; p3 := '*.*'; xstrupcase( p3 ); if not XOpenArchive(p2) then begin textcolor(7);textbackground(0);sc;clrscr;textcolor(lightred); writeln('Instalacia predcasne ukoncena !!!'); sound(2000);delay(100);nosound;textcolor(7);chdir(diskces);halt(1); end; tmp := XLAFindFirst( p3, filename ); while tmp do begin assign(f,adr+'\'+filename); rewrite(f,1); if not XLAGet(filename) then begin textcolor(7);textbackground(0);sc;clrscr;textcolor(lightred); writeln('Instalacia predcasne ukoncena !!!'); sound(2000);delay(100);nosound;textcolor(7);chdir(diskces);halt(1); end; close( f ); tmp := XLAFindNext( filename ); end; XCloseArchive; assign(f1,p2); reset(f1,1); erase(f1); end; procedure testor; begin b:=ord(upcase(diskces[1]))-ord('A'); asm mov al,b mov dx,0 mov cx,1 lea bx,buf int 25h pop dx jc @chyba mov b,0 jmp @end @chyba: mov b,1 @end: end; if b=1 then begin textcolor(7);textbackground(0);sc;clrscr;textcolor(lightred); writeln('Instalacia predcasne ukoncena !!!'); sound(2000);delay(100);nosound;textcolor(7);chdir(diskces);halt(1); end; zal1:=buf[10]; zal2:=buf[11]; if (zal1<>ord(','))or(zal2<>ord('O')) then begin textcolor(7);textbackground(0);sc;clrscr;textcolor(lightred); writeln('Instalacia predcasne ukoncena !!!'); sound(2000);delay(100);nosound;textcolor(7);chdir(diskces);halt(1); end; end; begin textcolor(15);textbackground(0); clrscr; hc; textcolor(15);textbackground(1); write('ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»'); for a:=1 to 22 do begin write('º º'); end; write('ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ'); getdir(0,diskces); getdrive; cest: getcesta; testor; textcolor(15);textbackground(1); gotoxy(15,10); write(' '); mkdir('data'); mkdir('data2'); mkdir('data3'); mkdir('code'); mkdir('music'); mkdir('ende'); mkdir('uvod'); if ioresult<>0 then ;chdir(diskces); textcolor(15);textbackground(7); gotoxy(30,8); write('Cakaj prosim ... - 00%'); depack('data1',disk+':\'+cesta+'\data'); gotoxy(30,8); write('Cakaj prosim ... - 25%'); depack('data2',disk+':\'+cesta+'\data2'); gotoxy(30,8); write('Cakaj prosim ... - 45%'); depack('data3',disk+':\'+cesta+'\data3'); gotoxy(30,8); write('Cakaj prosim ... - 50%'); depack('base',disk+':\'+cesta); gotoxy(30,8); write('Cakaj prosim ... - 55%'); depack('uvod',disk+':\'+cesta+'\uvod'); gotoxy(30,8); write('Cakaj prosim ... - 60%'); depack('ende',disk+':\'+cesta+'\ende'); gotoxy(30,8); write('Cakaj prosim ... - 70%'); depack('code',disk+':\'+cesta+'\code'); gotoxy(30,8); write('Cakaj prosim ... - 75%'); gotoxy(29,10); write('Vloz prosim 2. disketu !'); repeat kl:=readkey;if kl=#0 then kl:=readkey; assign(f,'music.hoe'); reset(f,1);close(f); until ioresult=0; testor; textcolor(15);textbackground(1); gotoxy(29,10); write(' '); depack('music',disk+':\'+cesta+'\music'); textcolor(15);textbackground(7); gotoxy(30,8); write('Cakaj prosim ... - 100%'); if (zal1<>ord(','))or(zal2<>ord('O')) then begin textcolor(7);textbackground(0);sc;clrscr;textcolor(lightred); writeln('Instalacia predcasne ukoncena !!!'); sound(2000);delay(100);nosound;textcolor(7);chdir(diskces);halt(1); end; getreg; gotoxy(23,15); write('Instalacia kompletna - Potlac klavesu.'); kl:=readkey; if ord(kl)=0 then begin kl:=readkey;end; textcolor(7); textbackground(0); sc;clrscr;writeln('Instalacia kompletna !');chdir(diskces); end.