aleanum1.pas

{ ppc386 -va -vh *.pas }
{ COMIENZO DE DESCRIPCION
  C\'alculo de todas las constantes $k$ admisibles para una 
  dada cubeta $B$ (potencia de 2), cuando se efect\'ua una 
  b\'usqueda sistem\'atica desde $k=1$, tarea anidada en un 
  lazo sobre las potencias de 2, desde $Bmin=2$ hasta
  $Bmax>2$. La suma m\'odulo 2, bit a bit, se hace mediante
  la operaci\'on l\'ogica ``xor'', que da verdadero
  \'unicamente cuando ambas entradas son distintas.
  FIN DE DESCRIPCION }
{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
{$ Id: aleanum1.pas 2001/06/11 15:32 jdelia  Exp jdelia $ }
program aleanum1 ;
const
  base =   2 ; {base} 
  bmin =   2 ; {minima base (potencia de 2)}
  bmax =  16 ; {maxima base (potencia de 2)}
  pmin =   1 ; {minimo exponente : 2^1}
  eco  = true ;
  nada = ' ' ;
type
  vectint = array [1..bmax] of longint ;
var
  B  : longint ;
  p  : longint ;
  d  : vectint ;
  a1 : text    ;
{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
procedure  ERROR (s : string) ;
begin
  write ('ERROR: ');
  writeln (s);
  halt ;
end ; 

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
procedure IMPRES (B, k : longint ; d : vectint) ;
var
  j, l : longint ;
begin
  writeln ;
  writeln (' constante       ;   k = ', k) ;
  writeln (a1, nada, B : 6, nada, k : 6) ;
  if  ( eco ) then begin
     writeln (' desplazamientos ; d_i = ') ;
     l := 0 ;
     for j := 1 to (B - 1) do begin
       l := l + 1 ;
       if  l > 10 then  begin
         writeln ;
         l := 0 ;
       end ; {if}
       write (nada, d [j] : 6) 
     end ; { j } 
     writeln ;
  end ; { if }
end ;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
{ verifica que en la sucesion $(d_1, d_2, .., d_k, .., d_i)$}
{ no hayan valores $d_k$ repetidos, sino invalida proseguir }
{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
function NO_REPET (i: longint; var d: vectint): boolean;
var
  j    : longint ;
  siga : boolean ;
begin
  j    := 1;
  siga := true ;
  while (j < i) and (siga) do begin
    if ( d [j] = d [i] ) then siga := false ;
    j := j + 1 ;
  end ; {while}
  NO_REPET := siga ;
end ;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
{ dado una base $B$, obtiene las constantes $k$ admisibles: }
{ va calculando los desplazamientos $ d_i $ para el par     }
{ $ (B,k) $, para ir verificando simultaneamente la ausencia}
{ de repeticion en dicha sucesion                           }
{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
procedure  KADMISIBLE (var  d : vectint ; B : longint ) ;
var
  i, k  : longint ;
  n, t  : longint ;
  q, r  : longint ;
  siga  : boolean ;
begin 
  {primero verifica que B sea una potencia de 2 }
  q := B ;
  while ( q mod 2 = 0 ) and (q > 2) do q := q div 2 ;
  if (q <> 2) or (q < 2) then ERROR (' B no es potencia de 2');
  { ahora busca k_i admisibles para i=1,2,..(B-1) }
  n := B - 1 ;
  for k := 1 to (n) do begin
    for i := 1 to b do d [i] := 0 ;
    d [1] := 1    ; {semilla para los d_i a calcular}
    siga  := true ; {si en la secuencia d_i no hay repeticion}
    i     := 2 ;
    while (i <= n) and (siga) do begin 
       t := 2 * d [i - 1] ;
       if  ( t < B ) then
         d [i] := t
       else begin
         r := t - B ;
         d [i] := (r) xor (k) ;
         siga := NO_REPET (i, d) ;
       end ; {* if *}
       i := i + 1 ;
    end ; { while }
    {imprime solo si en la secuencia d_i no hay repeticion}
    if ( siga ) then IMPRES (B, k, d) ;
  end ; { k }
end ; { procedure }

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
begin
  writeln ;
  assign  (a1, 'admisi1.res') ;
  rewrite (a1);
  writeln ;
  writeln (' minimo cubeta (potencia de 2) = ', bmin );
  writeln (' maximo cubeta (potencia de 2) = ', bmax ) ;
  p := pmin ;
  B := bmin ;
  while  (B <= Bmax) do begin
    writeln ;
    writeln (' exponente  ; p = ', p);
    writeln (' cubeta     ; B = ', B) ;
    KADMISIBLE (d, B) ;
    p := p + 1 ;
    B := base * B ;
  end ; {for}
  close (a1) ;
  writeln ;
end . 
{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}