old/PAS/delit.pas

var
   inp          : file of char;
   chislo       : array [1..1000] of byte;
   num,pos      : word;
function GetByte(i:word):byte;
begin
 GetByte:=(chislo[i div 8 + 1] and (1 shl (8 - i mod 8)));
end;
procedure AddByte(bt:char);
begin
 if (bt='1') then
  chislo[pos div 8 + 1] := chislo[pos div 8 + 1] or (1 shl (8 - pos mod 8));
 inc(pos);
end;
Function GetPair(i:word):byte;
var ret:byte;
begin
 ret:=0;
 if GetByte(i) <> 0 then ret := 2;
 if GetByte(i+1) <> 0 then inc(ret);
 GetPair:=ret;
end;
Function IfModul(l,r:word):boolean;
var i:word;flag:boolean;sum:integer;
begin
  i := r-l+1;
  i := i and 1;
  if (i<>0) then
   begin
    i:=1;
    sum := GetByte(l);
    if (sum<>0) then sum:=1;
   end
  else
   begin
    sum:=GetPair(l);
    i:=2;
   end;
  flag:=false;
  while (l+i)<>(r+1) do
   begin
    if flag then sum := sum + GetPair(i+l)
    else sum := sum - GetPair(i+l);
    flag := not flag;
    inc(i,2);
   end;
  while sum > 0 do sum := sum-5;
  if (sum=0) then ifModul:=true
  else ifModul:=false;
end;
var
 ch:char;
 i,j:word;
 count : longint;
 flag:boolean;
BEGIn
  Assign(inp,'num.txt');
  Reset(inp);
  pos:=1;
  num:=0;
  while not EOF(inp) do
   begin
     read(inp,ch);
     if flag or (ch<>'0') then
      begin
        flag := true;
        Addbyte(ch);
        inc(num);
      end
   end;
  count:=0;
  for i := 1 to num-2 do
    for j := i+2 to num do
      if IfModul(i,j) then inc(count);
   Write('Число подстрок, кратных 5: ',count);
   ReadLn;
END.