Palindromic numbers

(*
    This program tries to compute a palindromic number starting with a
    number the user has to type in (use 65465241 for a test).
    To compile run "fpc palzahl.pas".
    Copyright (C) <December 27, 1995> Henning Polzer, h underscore polzer at gmx dot de

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*)


PROGRAM palindromzahlen;
CONST   max = 300;      (* Palindrom darf maximal "max" Stellen haben *)
    maxstellen = 30;    (* Zahl, von der aus gesucht wird, kann maximal "ausgangswert" Stellen haben *)
TYPE    Tganzzahl = integer;
    Tfeld = ARRAY[1..max] OF Tganzzahl;

VAR ausgangswert:   string[maxstellen];
    i, k, schritte: Tganzzahl;
    verlassen:      boolean;


PROCEDURE palindrom;
VAR leer, v, nv, erg: Tfeld;

  PROCEDURE loesche_feld;
  BEGIN
    FOR i := 1 TO max DO
    BEGIN
      leer[i] := 0;
      v[i] := 0;
      nv[i] := 0;
      erg[i] := 0
    END (* for *)
  END; (* loesche_feld *)


  PROCEDURE eingabe;
  VAR hilf, laenge, zahlwert, fehler: Tganzzahl;

  BEGIN
    loesche_feld;
    ausgangswert := '';

    REPEAT
      write ('Zahl: ');
      readln (ausgangswert);

      laenge := length (ausgangswert);
      hilf := max;
      fehler := 0;

      FOR i := laenge DOWNTO 1 DO
      BEGIN
        val (ausgangswert[i], zahlwert, fehler);
        v[hilf] := zahlwert;
        dec (hilf)
      END (* for *)
    UNTIL (length(ausgangswert) > 1) AND (fehler = 0)
  END; (* eingabe *)


  PROCEDURE kehre_um;
  VAR beginn, hilf: Tganzzahl;

  BEGIN
    beginn := 1;
    WHILE (v[beginn] = 0) DO
      inc (beginn);

    hilf := 0;
    FOR i := beginn TO max DO
    BEGIN
      nv[max-hilf] := v[i];
      inc(hilf)
    END (* for *)
  END; (* kehre_um *)


  PROCEDURE tausche;
  BEGIN
    v := erg
  END; (* tausche *)


  PROCEDURE addiere;
  VAR anfang, zaehler: Tganzzahl;

  BEGIN
    anfang := 1;
    WHILE (v[anfang] = 0) DO
      inc (anfang);

    FOR zaehler := max DOWNTO anfang DO
    BEGIN
      inc (erg[zaehler], v[zaehler] + nv[zaehler]);
      IF erg[zaehler] >= 10 THEN
      BEGIN
        dec (erg[zaehler],10);
        inc (erg[zaehler-1])
      END (* if erg >=... *)
    END (* for *)
  END; (* addiere *)


  FUNCTION gleich: boolean;
  VAR anfang, hilf: Tganzzahl;
      ent: boolean;

  BEGIN
    ent := true;

    anfang := 1;
    WHILE (v[anfang] = 0) DO
      inc (anfang);

    IF anfang < 2 THEN verlassen := true ELSE
    BEGIN (* Zahl nicht zu gross: Auf Uebereinstimmung testen *)
      hilf := anfang;

      REPEAT
        IF v[hilf] <> nv[hilf] THEN ent := false;
        inc (hilf)
      UNTIL (NOT ent) OR (hilf = max);

      gleich := ent
    END (* if *)
  END; (* gleich *)


  PROCEDURE ausgabe;
  VAR hilf: Tganzzahl;

  BEGIN
    hilf := 1;
    WHILE (v[hilf] = 0) DO
      inc (hilf);

    writeln;
    FOR k := hilf TO max DO
      write (v[k]);

    write (' [', max-hilf+1, ' Stellen]')
  END; (* ausgabe *)


  PROCEDURE loeschen;
  BEGIN
    nv := leer;
    erg := leer
  END; (* loeschen *)


BEGIN (* palindrom *)
  verlassen := false;
  schritte := 0;

  eingabe;
  kehre_um;
  REPEAT
    addiere;
    tausche;
    loeschen;
    kehre_um;
    inc (schritte)
  UNTIL gleich OR verlassen;

  writeln (schritte, ' Schritt(e) berechnet.');

  IF verlassen THEN write ('Palindromzahl nicht zu ermitteln.')
    ELSE ausgabe;
  writeln
END; (* palindrom *)


BEGIN (* Hauptprogramm *)
  palindrom
END.