Viitenumerolaskenta

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.