%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.