Pascal/Turbo Pascal - Estructura tipo hashing

uses crt;

var

palabra:string;

i:integer;

begin

writeln ('introduzca un texto');

readln (palabra);

for i:=1 to length (palabra) do

writeln (palabra[i],' = ',ord (palabra[i]));

readln;

end.

{A ver si esto te ayuda un poco}

program ejemplo_hashing;

 uses

    crt;

  const

     max = 200;

   var

     nombre : array[0..max - 1] of string[20];

     entra : string;

     nent, x, y : integer;

     f : text;

   function clave(ss : string) : integer;

   var

     k : integer;

     begin

        k := ord(ss[1]) * 23;

        k := k shl 1;

        k := k + ord(ss[2]) * 19;

        k := k mod max;

        clave := k;

     end;

    procedure buscaposicion(var kt : integer);

    var

      k : integer;

      begin

         k := 0;

        while (nombre[kt] <> ' ') and (k <= max) do

        begin

          k := k + 1;

          kt := kt + 1;

          if kt >= max then

          kt := 0;

        end;

      if k > max then

      kt := max + 1;

    end;

   procedure inicio;

   begin

      for x := 0 to max - 1 do

      nombre[x] := ' ';

   end;

   procedure entradadatos;

   var

     fin : boolean;

     tec : char;

   begin

      y := 0;

      nent := 1;

   repeat

      write('Nombre : ');

      readln(entra);

      x := clave(entra);

      buscaposicion(x);

      writeln(x);

      if (x >= 0) and (x <= max - 1) then

      nombre[x] := entra;

      writeln('Desea Entrar Mas Nombres [S/N]');

      repeat

          tec := upcase(readkey);

      until tec in['S','N'];

      if tec = 'N' then

      fin := true

    else

      nent := nent + 1;

    until fin = true;

  end;

  procedure guardanombres;

  var

    tc : char;

    i : integer;

  begin

      assign(f,'tempo.dat');

   {$I-} reset(f); {$I+}

   if ioresult = 0 then

   begin

      writeln('El archivo Existe Desea Cambiarlo [S/N]');

      repeat

      tc := upcase(readkey);

      until tc in['S','N'];

      rewrite(f);

      for x := 0 to max - 1 do

      begin

        writeln(f,nombre[x]);

      end;

   end

  else

     begin

      rewrite(f);

      for x := 0 to max - 1 do

      begin

        writeln(f,nombre[x]);

     end;

   end;

      close(f);

   end;

  procedure carganombres;

  begin

     assign(f,'tempo.dat');

  {$I-} reset(f); {$I+}

  if ioresult <> 0 then

  begin

      writeln('Archivo No Encontrado pulse [Enter]');

      readln;

      halt(1);

  end;

     y := 0;

     while not eof(f) do

     begin

        readln(f,nombre[y]);

        y := y + 1;

     end;

     close(f);

 end;

  procedure busquedanombre;

  var

    pp : integer;

    salir : boolean;

   begin

      write('Entre Nombre : ');

      readln(entra);

      x := clave(entra);

      pp := x;

      salir := false;

     repeat

        if nombre[pp] = entra then

        salir := true

      else

        pp := max + 1;

     until (salir = true) or (pp > max);

     if salir = true then

     writeln('Nombre encontrado : ',nombre[pp],' = ',x)

   else

     writeln('El Nombre no se encuentra');

   readln;

 end;

 procedure menu;

 var

   tecla : char;

   aca : boolean;

   begin

      aca := false;

   repeat

      clrscr;

      writeln('**** Menu General ****');

      writeln;

      writeln('   1 : Entrada Nombres');

      writeln('   2 : Guardar Entradas');

      writeln('   3 : cargar Entradas');

      writeln('   4 : Buscar Nombre');

      writeln('   5 : Terminar');

      writeln;

      writeln('<<<< Elija Opcion >>>>');

      repeat

           tecla := readkey;

      until tecla in[#49..#53];

   case tecla of

 #49 : begin clrscr; entradadatos; end;

 #50 : begin clrscr; writeln('Guardando Datos'); delay(200); guardanombres;

          end;

 #51 : begin clrscr; writeln('Cargando Nombres'); delay(200);carganombres;

          end;

 #52 : begin clrscr; busquedanombre; end;

 #53 : aca := true;

   end;

 until aca = true;

 end;

 begin

    inicio;

    menu;

 end.

{Mira lo que tienes es que cambiar esto solo}

function clave(ss : string) : integer;

var

v, k : integer;

begin

  v := 0;

 for k := 1 to length(ss) do

  v := v + ord(ss[k]);

 clave := v mod max;

end;

{Si entras el nombre [juan andres] en minúsculas te dará 99 mientras si lo entras [Juan Andres] te

 dará 35 esto tendrás que realizar pruebas con una serie de nombres para ver que no colisionen

 las direcciones en el array suerte}