%source off
{!TITLE     Palindrome Finding Program                                         }
{                                                                              }
{      This program is designed for interactive terminal use. It takes a number}
{as input, reverses the digits, adds the two numbers together and tests the    }
{result to see if it is a palindrome. This process can be repeated until either}
{a palindrome is found or the capacity of the array holding the number is r    }
{reached.                                                                      }
{      Further documentation is contained withing the program.                 }
{      Due to the interactive nature of the program no input or output streams }
{should be defined.                                                            }
{                                                                              }
{                                                                              }

program pal(inp,output);

const
   progname   = 'PALINDROME PROGRAM     VERSION 18  ';
   sp         = ' ';
   maxlength  = 100;
   namelength = 30;

type
   ptr31=^string31;
   string31=packed array[1..31]of char;
   paramrec = record
      length:integer;
      data:packed array[1..17]of char
   end;
   numberelements = array[0..maxlength] of integer;
   longinteger = record
                    s          : integer;
                    d          : numberelements
                 end;
   namestring = array[0..namelength] of char;
   nametype   = record
                   s          : integer;
                   n          : namestring
                end;
   string15   = packed array[1..15] of char;

var
   inp                : text;
   printer,count      : integer;
   num        : longinteger;
   com        : char;
   just_starting,palfound,clockon,quit       : boolean;
   name       : nametype;

procedure pprompt(s:string15);
   extern;

procedure callmonitor;
begin
end;

procedure writename;

var
   i          : integer;

begin
   for i:=0 to name.s-1 do
      write(name.n[i]);
end;

procedure endfile;
begin
   writeln;
   writeln(chr(7),'INPUT TERMINATED BY END OF FILE CHARACTER !');
   writeln;
   write(chr(7),'I don''t know what you''ve done ');
   writename;
   writeln(' but you shouldn''t have!');
   writeln;
   writeln(chr(7),progname,' TERMINATING IMMEDIATELY');
   halt('arrrggghhh!!!!!! ');
end;

PROCEDURE pdefine(k:integer;addr:ptr31);extern;

PROCEDURE define_inp;
CONST
   magic = 402653440;
   paramstring=' INP,.IN                       ';
   paramlength=7;
VAR
   pdefstring:string31;
   pdefptr:ptr31;
   i:integer;
BEGIN
   new(pdefptr);
   pdefstring:=paramstring;
   pdefstring[1]:=chr(paramlength);
   pdefptr^:=pdefstring;
   pdefine(magic,pdefptr);
   dispose(pdefptr);
END;

procedure getname;

var
   ch         : char;
   toolong    : boolean;

begin
   pprompt('Your name:     ');
   if just_starting then begin
      define_inp;
      reset(inp);
      just_starting:=false;
   end else begin
      while not(eoln(inp)or eof(inp)) do get(inp);
      if not eof(inp) then get(inp);
   end;
   if EOF(INP) then
      endfile;
   with name do begin
      s := 0;
      while ((not (EOLN(INP) or EOF(INP))) and (s<namelength)) do begin
         if EOF(INP) then
            endfile
         else
            read(INP,ch);
         n[s] := ch;
         s := s+1;
      end;
      toolong := (s=namelength) and not EOLN(INP);
      if toolong then begin
         s := 0;
         writeln('That''s more than I can remember,');
      end;
   end;
   if name.s>0 then begin
      write('Pleased to meet you ');
      writename;
      writeln;
   end
   else begin
      writeln('I''ll just have to call you Sir');
      name.s := 3;
      name.n[0] := 'S';
      name.n[1] := 'i';
      name.n[2] := 'r';
   end;
   while not EOLN(INP) or EOF(INP) do
      read(INP,ch);
end;

procedure friendly(com:char);

type
   field      = 1..8;
   alfa2      = packed array[1..2] of char;
   alfa9      = packed array[1..9] of char;

var
   day,d,t          : alfa8;
   pm,st         : alfa2;
   mth        : alfa9;
   yr,mt,dy,hr,mn,sc         : integer;
   quittime   : boolean;
   ch         : char;

procedure conv(a:alfa8;f:field;var r:integer);
begin
   r := (ord(a[f])-ord('0'))*10+ord(a[f+1])-ord('0');
end;

procedure convert(d,t:alfa8;var yr,mt,dy,hr,mn,sc:integer);

var
   r          : integer;

begin
   conv(d,1,yr);
   conv(d,4,mt);
   conv(d,7,dy);
   conv(t,1,hr);
   conv(t,4,mn);
   conv(t,7,sc);
end;

procedure datend(var st:alfa2);

const
   s          = 'st';
   n          = 'nd';
   r          = 'rd';
   t          = 'th';

var
   dt         : integer;

begin
   dt := dy mod 10;
   case dt of
   1:
      st := s;
   2:
      st := n;
   3:
      st := r;
   4,5,6,7,8,9,0:
      st := t
   end;
end;

procedure month(var mth:alfa9);

const
   jan        = 'January  ';
   feb        = 'February ';
   mar        = 'March    ';
   apr        = 'April    ';
   may        = 'May      ';
   jun        = 'June     ';
   jul        = 'July     ';
   aug        = 'August   ';
   sep        = 'September';
   oct        = 'October  ';
   nov        = 'November ';
   dec        = 'December ';

begin
   case mt of
   1:
      mth := jan;
   2:
      mth := feb;
   3:
      mth := mar;
   4:
      mth := apr;
   5:
      mth := may;
   6:
      mth := jun;
   7:
      mth := jul;
   8:
      mth := aug;
   9:
      mth := sep;
   10:
      mth := oct;
   11:
      mth := nov;
   12:
      mth := dec
   end;
end;

procedure findday(var day:alfa8);

const
   sun        = '     Sun';
   mon        = '     Mon';
   tue        = '    Tues';
   wed        = '  Wednes';
   thu        = '   Thurs';
   fri        = '     Fri';
   sat        = '   Satur';

var
   i          : integer;

begin
   for i:=1 to 8 do
      day[i]:=' ';
   case mt of
   1,10:
      i := 1;
   5:
      i := 2;
   8:
      i := 3;
   2,3,11:
      i := 4;
   6:
      i := 5;
   9,12:
      i := 6;
   4,7:
      i := 0
   end;
   i := ((yr+(yr div 4))+i+dy)mod 7;
   case i of
   1:
      day := sun;
   2:
      day := mon;
   3:
      day := tue;
   4:
      day := wed;
   5:
      day := thu;
   6:
      day := fri;
   0:
      day := sat
   end;
end;

procedure antepost(var hr:integer;var pm:alfa2);

const
   a          = 'am';
   p          = 'pm';

begin
   if hr>=12 then
      pm := p
   else
      pm := a;
   hr := hr mod 12;
end;

procedure getvalues;
begin
   dateandtime(d,t);
   convert(d,t,yr,mt,dy,hr,mn,sc);
   datend(st);
   month(mth);
   findday(day);
   antepost(hr,pm);
end;

procedure writetime;
begin;
   getvalues;
   if mn<10 then
      write('It is now ',hr:2,':0',mn:1,' ',pm,' on',day,'day the ')
   else
      write('It is now ',hr:2,':',mn:2,' ',pm,' on',day,'day the ');
   write(dy:2,st,' of ',mth,' 19',yr:2);
   writeln;
end;

procedure welcome;
begin
   writeln;
   writeln(progname,'  IS RUNNING');
   writeln;
   writeln('Hi there human! Welcome to the wonderful world of palindromes!!!');
   writeln('My name''s Pal. What''s your name?');
   getname;
   writeln;
   writeln('This program is brought to you courtesy of Sirius Cybernetics ');
   writeln('Unlimited (Unlimited incompetence that is.)');
   writeln('                                          But enough about me.');
   writetime;
   writeln('I sure hope you enjoy this, I know I do!.  If you have any problems');
   writeln('just type the pleasantly reassuring word help!! and push the return');
   writeln('key.   You will then be able to read some fascinating information');
   writeln('about me, your friendly palindrome program.');
   writeln('You can call me "Pal" because I''m you''re pal! SHARE AND ENJOY!');
   writeln;
end;

procedure goodbye;
begin
   getvalues;
   writeln;
   writetime;
   writeln('and well, if you''ve got to go then I suppose you''ve got to go.');
   writeln('I hope it wasn''t anything I said.    SHARE AND ENJOY!.');
   writeln;
   writeln(progname,  '   IS TERMINATED ');
   writeln;
   write(' OCP Time = ',clock:7,'     ',d,'     ',t);
   write('  Goodbye ');
   writename;
   writeln('!');
end;
begin
   case com of
   'w':
      welcome;
   't':
      writetime;
   'q':
      goodbye
   end;
   writeln;
end;

procedure help;

var
   hc         : integer;
   ch         : char;
   quithelp   : boolean;

procedure helpintro;
begin
   writeln;
   writeln('pal>help>                  Help With Palindromes');
   writeln;
   write('It looks as if you need some help, ');
   writename;
   writeln;
   writeln('information is available on the following topics:');
   writeln;
   writeln('  0)General         1)Getstarter        2)Revadds ');
   writeln('  3)Quit            4)Help              5)Time   ');
   writeln('  6)Name            7)Printer           8)Clock');
   writeln;
   writeln;
   writeln('Type the number of the section you want to see and then <return>.');
   writeln;
   write('Type q then return to get back to the palindrome');
   write(' program where you left it.');
   writeln;
   writeln;
end;

procedure helpgeneral;
begin
   writeln;
   writeln('Pal>help>                    General                                    0');
   writeln;
   writeln('The purpose of the palindrome program is to:');
   writeln('            1)read a number');
   writeln('            2)reverse it');
   writeln('            3)add it to its reverse');
   writeln('            4)check if the result is a palindrome');
   writeln('            5)repeat steps 2-4 for a set number of times,');
   writeln('              stopping if a palindrome is reached.');
   writeln;
   writeln('A palindrome is a number that reads the same starting at either end.');
   writeln;
   writeln('eg)        123                          96');
   writeln('          +321                         +69');
   writeln('         ------                      ------');
   writeln('           444                         165');
   writeln('         ======                       +561');
   writeln('                                     ------');
   writeln('                                       726');
   writeln('                                      +627');
   writeln('                                     ------');
   writeln('                                      1353');
   writeln('                                     +3531');
   writeln('                                     ------');
   writeln('                                      4884');
   writeln('                                     ======');
   writeln;
   write('This program was developed as an exercise for');
   write(' Computer Science 1 in December 81.');
   writeln;
   writeln;
   write('It was designed for use by schoolchildren and');
   write(' should not "crash" when given');
   writeln;
   write('incorrect instructions. ("control-y" indicating');
   write(' end of input is one exception)');
   writeln;
   writeln;
   writeln('Any comments (or complaints) about its operation should be sent to ');
   write('Graham Rule (ECZU94) by the mail system or by');
   write(' post c/o 16 Chambers St,Edinburgh.');
   writeln;
   writeln;
end;

procedure helpgetstarter;
begin
   writeln;
   writeln('Pal>help>                   Getstarter                             1');
   writeln;
   write('The command "Getstarter" (or "g") followed by a space and a');
   write(' positive integer');
   writeln;
   write('of not more than',maxlength+1:4,' digits is needed to get');
   write(' the program working');
   writeln;
   writeln('on the starting number indicated.');
   writeln;
   write('This command must be followed by the command "Revadds"');
   write(' before the calculation');
   writeln;
   writeln('will be done.');
end;

procedure helprevadd;
begin
   writeln;
   writeln('Pal>help>                     Revadds                                2');
   writeln;
   writeln('This command or its abbreviation ("r") should be followed  by the number');
   writeln('of times which the computer is to reverse and add the number previously');
   writeln('put in with the command "getstarter".');
   writeln;
   writeln('The number must be a positive integer of not more than 9 digits.');
   write('Anything else after this command will result in an error message being');
   write(' displayed');
   writeln;
   writeln('(but will not affect the number put in with the command getstarter).');
   writeln;
   writeln('If, after a number of "revadds", a palindrome has not been found, putting');
   writeln('in a larger number will cause the system to continue.');
   writeln;
end;

procedure helpquit;
begin
   writeln;
   writeln('Pal>help>                     Quit                               3');
   writeln;
   writeln('The command "quit" (or "q") typed in response to the prompt "Pal>" will');
   writeln('cause the program to stop and the user will be returned to the');
   writeln(' "Command"level. ALL INFORMATION NOT ALREADY PRINTED OUT WILL BE LOST.');
   writeln;
   writeln('The same command typed in response to the prompt "Pal>help>" will');
   writeln('take the user back to where they were when they entered the "help"');
   writeln('system. (This will not effect information in the computer).');
   writeln;
end;

procedure helphelp;
begin
   writeln;
   writeln('Pal>help>                       Help                                4');
   write('The command "help" (or "h") or any invalid command will remove');
   write(' the user from the ');
   writeln;
   write('main palindrome program and give the first page of the');
   write(' "help" information.');
   writeln;
   writeln;
   writeln('To return to where you were in the program type "quit" now.');
   writeln('To get back to the top page (and index) type "top".');
   writeln;
end;

procedure helptime;
begin
   writeln;
   writeln('Pal>help>                    Time                                 5 ');
   writeln('This command (or "t") in response to the prompt "Pal>" will return ');
   writeln('the current date and time.');
   writeln;
   friendly('t');
   writeln;
end;

procedure helpname;
begin
   writeln;
   writeln('Pal>help>                    Name                              6');
   writeln;
   write('The command ''name'' (or ''n'') can be used in response to the prompt');
   writeln(' Pal> to');
   writeln(' change the name by which the user is known to the program.');
   writeln;
   write('The name must be no more than ',namelength:3,' characters long ');
   writeln('including spaces. If anything ');
   write('else is given the system will (chauvanist that it is) ');
   writeln('call the user "Sir"');
   writeln;
   write('You are identified as "');
   writename;
   writeln('" at the moment');
   writeln;
end;

procedure helpprinter;
begin
   writeln('Help info for printer not yet available');
end;

procedure helpclock;
begin
   writeln('Help info for clock not yet available');
end;

begin
   pprompt('Pal>help>      ');
   quithelp := false;
   helpintro;
   hc := -1;
   repeat
      readln(INP);
      while ((inp^=sp)and not EOF(INP)) do
         read(INP,ch);
      if not EOF(INP) then
         read(INP,ch)
      else
         endfile;
{***********}
      if (ch>='0')and(ch<='8')then
         hc := ord(ch)-ord('0')
      else if (ch='q')or(ch='Q') then
         hc := 999
      else
         hc := -1;
      if (ch='t')or(ch='T') then
         hc := -1;
      case hc of
      -1:
         helpintro;
      0:
         helpgeneral;
      1:
         helpgetstarter;
      2:
         helprevadd;
      3:
         helpquit;
      4:
         helphelp;
      5:
         helptime;
      6:
         helpname;
      7:
        helpprinter;
      8:
        helpclock;
      999:
         quithelp := true;
      end;
      while not EOLN(INP) or EOF(INP) do
         read(INP,ch);
      if EOF(INP) then
         endfile;
   until quithelp;
end;

procedure writenumber(var num:longinteger);

var
   i          : integer;

begin
   with num do begin
      for i:=0 to s-1 do begin
         write(d[i]:1);
         if ((i+1)mod 70)=0 then
            writeln;
      end;
      writeln;
   end;
end;

function pal(num:longinteger): boolean;

var
   r,l          : integer;
   p          : boolean;

begin
   with num do begin
      p := true;
      r := s-1;
      l := 0;
      while (r>l) and p do begin
         p := d[l]=d[r];
         r := r-1;
         l := l+1;
      end;
   end;
   pal := p;
end;

procedure add(var num:longinteger);

var
   i          : integer;
   tot        : longinteger;

begin
   for i:=0 to maxlength do
      tot.d[i]:=0;
   for i:=0 to num.s-1 do begin
      tot.d[maxlength-i] := num.d[i]+num.d[num.s-1-i];
      tot.s := num.s;
   end;
   with tot do begin
      for i:=maxlength downto 1 do begin
         d[i-1] := d[i-1]+d[i] div 10;
         d[i] := d[i] mod 10;
      end;
      s := maxlength+1;
      if d[0]=0 then
         repeat
            s := s-1;
            for i:=1 to maxlength do begin
               d[i-1] := d[i];
            end;
            d[maxlength] := -1;
         until d[0]<>0;
   end;
   num := tot;
end;

function digit: boolean;
begin;
   digit := (ord('0')<=ord(inp^))and((ord('9'))>=ord(inp^));
end;

procedure findtarget(var target:integer);

var
   ch         : char;
   int,length     : integer;
   fail       : boolean;

begin
   int := 0;
   length := 0;
   fail := false;
   while (not (digit or EOLN(INP))) and not EOF(INP) do
      read(INP,ch);
   if EOF(INP) then
      endfile;
   if ch='-' then
      fail := true;
   while digit and (length<=8) do begin
      int := int * 10;
      length := length+1;
      if not EOF(INP) then
         read(INP,ch)
      else
         endfile;
      int := int+ord(ch)-ord('0');
   end;
   if not (((inp^=sp) or EOLN(INP)) and (int>=0)) then
      fail := true;
   if fail then begin
      writeln('Look you vegetable!! No more than NINE DIGITS. O.K.??!',chr(7));
      writeln;
      while not(EOLN(INP) or EOF(INP)) do
         read(INP,ch);
      if EOF(INP) then
         endfile;
      target := -1;
   end
   else
      target := int;
end;

procedure revcount(var num:longinteger);

var
   t1,cl1,cl2,cl,target     : integer;

begin
   writeln;
   findtarget(target);;
   palfound := pal(num);
   if target>0 then
      if num.d[0]<1 then
         writeln(chr(7),'no starter yet')
   else begin
      if palfound then
         writeln(chr(7),'It already is a palindrome, you twit!')
      else if (num.d[0]>9) then
         writeln(chr(7),'I''ve already told you, my memory is full!')
      else if (count>=target) then
         writeln(chr(7),'I''ve already done it',count:5,' times!');
   end;
   cl1 := clock;
   t1 := count;
   while (not pal(num)) and (count<target) and (not (num.d[0]>=10)) do begin
      add(num);
      count := count+1;
      palfound := pal(num);
      if palfound or (num.d[0]>9)or(count mod printer=0)or(count=target) then begin
         write('after ',count:1,' revadds, the number is: ');
         writeln;
         writenumber(num);
         if palfound then begin
            writeln;
            writeln('Which is a palindrome!');
         end;
         if (num.d[0]>9) then
            writeln(chr(7),'The system has reached it''s capacity');
      end;
      cl2 := clock;
      cl := cl2-cl1;
      if (clockon and ((target=count) or palfound or (num.d[0]>9)))or palfound then
         writeln(count-t1:8,' revadds took ',cl:6,' milliseconds OCP time');
   end;
end;

procedure readnumber(var num:longinteger);

var
   ch         : char;
   i          : integer;
   fail       : boolean;

begin
   count := 0;
   fail := false;
   with num do begin
      while not(digit or EOLN(INP)) do
         read(INP,ch);
      s := 0;
      while digit and (s<maxlength+1) do begin
         if not EOF(INP) then
            read(INP,ch)
         else
            endfile;
         d[s] := ord(ch)-ord('0');
         s := s+1;
      end;
      for i:=s to maxlength do
         d[s]:=0;
   end;
   if not((inp^=sp) or EOLN(INP)) then
      fail := true;
   if fail then
      writeln(chr(7),' only integers of up to ',maxlength+1:3,' digits please ')
   else if num.s=0 then
      writeln(chr(7),'How about letting me know the starting number?')
   else begin
      writeln('starting number is:');
      writenumber(num);
      writeln;
   end;
   writeln;
   readln(INP);
end;

procedure changeclock;
begin
   clockon := not clockon;
   write('Whatever you say, ');
   writename;
   if clockon then
      write('.   The clock is now ON')
   else
      write('.   The clock is now OFF');
   writeln;
end;

procedure findprinter;
begin
   findtarget(printer);
   if printer<0 then
      printer := 1;
   if printer=0 then begin
      printer := maxint;
      write('The number will not be printed at all ');
   end
   else
      write('The number will be printed after every ',printer:4,' revadd(s) ');
   writename;
   writeln;
   writeln;
end;

procedure docommand(com:char);
begin
   case com of
   'g':
      readnumber(num);
   'r':
      revcount(num);
   't':
      friendly(com);
   'q':
      quit := true;
   'n':
      getname;
   'h':
      help;
   'p':
      findprinter;
   'c':
      changeclock;
   'm':
      callmonitor;
   end;
end;

procedure getcommand(var com:char);

var
   ch         : char;

begin
   pprompt('Pal>           ');
   while (inp^=sp) and (not EOF(INP)) do
      read(INP,ch);
   if not EOF(INP) then
      read(INP,ch)
   else
      endfile;
   if (ch='g')or(ch='G') then
      com := 'g'
   else if (ch='r')or(ch='R') then
      com := 'r'
   else if (ch='q')or(ch='Q') then
      com := 'q'
   else if (ch='t')or(ch='T') then
      com := 't'
   else if (ch='n')or(ch='N') then
      com := 'n'
   else if (ch='c')or(ch='C') then
      com := 'c'
   else if (ch='p')or(ch='P') then
      com := 'p'
   else if (ch='m')or(ch='M') then
      com := 'm'
   else
      com := 'h';
end;
begin
   quit := false;
   clockon := false;
   printer := 1;
   just_starting:=true;
   friendly('w');
   repeat
      getcommand(com);
      docommand(com);
   until quit;
   friendly('q');
end.