Viitenumerolaskenta
Pascal-kielinen ohjelma vuodelta 1995, joka laskee viitenumeron viimeisen tarkistenumeron.
program VIITENUMEROLASKENTA(input,output);
uses crt;
const l1='H';
l2='E';
l3='I';
l4='K';
l5='S';
l6='L';
l7='T';
l8='A';
var viite:array[1..20] of integer;
c:char;
vl:integer;
rullaa:boolean;
turha,tx,ty:integer;
saako:boolean;
procedure NOLLAA;
var l:integer;
begin
for l:=1 to 20 do
viite[l]:=-1;
end;
procedure RUUTU;
procedure HEIKKI;
begin
write(l1,l2,l3,l4,l4,l3);
end;
procedure SILTALA;
begin
write(' ',l5,l3,l6,l7,l8,l6,l8,' 1995');
end;
begin
writeln('VIITENUMERON TARKISTEEN LASKENTA');
write('COPYRIGHT ');
HEIKKI; SILTALA;
writeln;
writeln('Tätä ohjelmaa saa levittäää vapaasti.');
writeln;
writeln('<ESC> lopettaa, <ENTER> päättää viitteen');
writeln('<BACKSPACE> poistaa edellisen numeron');
writeln;
end;
procedure LUE;
var silmu:boolean;
var lask:integer;
begin
silmu:=true;
lask:=1;
while silmu do
begin
c:=readkey;
if c=#8 then
begin
if lask>1 then
begin
dec(lask);
viite[lask]:=-1;
write(c);
write(' ');
write(c);
c:=' ';
end
else
c:='h';
end;
if c=#27 then
begin
silmu:=false;
rullaa:=false;
c:=' ';
saako:=false;
end;
if c=#13 then
begin
if lask>1 then
silmu:=false
else
c:='h';
end
else
begin
val(c,vl,turha);
if (silmu)and(not(c in ['0','1','2','3','4','5','6','7','8','9'])) then
begin
if c<>' ' then begin
sound(5000);
delay(10);
nosound;
end
end
else
begin
if lask<19 then
begin
viite[lask]:=vl;
if saako then write(vl);
inc(lask);
end
else
begin
viite[lask]:=vl;
if saako then write(vl);
silmu:=false;
end;
end;
end;
end;
end;
procedure KOE;
var mat:integer;
begin
write(' ');
for mat:=1 to 20 do
begin
if viite[mat]>=0 then
write(viite[mat]);
end;
write(' ');
end;
procedure SIIRRA;
var alku:integer;
var paikka:integer;
begin
alku:=19;
while (viite[alku]<0) do
dec(alku);
if alku<>19 then
begin
paikka:=19;
while(alku>0) do
begin
viite[paikka]:=viite[alku];
viite[alku]:=-1;
dec(alku);
dec(paikka);
end;
end;
end;
procedure LASKE;
var summa:integer;
lask:integer;
arvo:integer;
tulos:integer;
procedure NEXT;
begin
if arvo=7 then arvo:=3
else
if arvo=3 then arvo:=1
else
if arvo=1 then arvo:=7;
end;
begin
summa:=0;
arvo:=7;
for lask:=19 downto 1 do
begin
if viite[lask]>=0 then
summa:=summa+(arvo*viite[lask]);
NEXT;
end;
tulos:=summa div 10;
tulos:=tulos*10;
tulos:=tulos+10;
tulos:=tulos-summa;
viite[20]:=tulos;
if viite[20]=10 then viite[20]:=0;
end;
procedure TULOSTA;
begin
if saako then begin
highvideo;
writeln(' ',viite[20]);
lowvideo;
end;
end;
begin
saako:=true;
clrscr;
RUUTU;
rullaa:=true;
while rullaa do
begin
NOLLAA;
LUE;
if rullaa then SIIRRA;
if rullaa then LASKE;
if rullaa then TULOSTA;
writeln;
end;
writeln;
end.