{  22/7/87  16:46   persons}

%include "sm:consts.inc"
%include "sm:formats.inc"


%include "sm:utils.inc"

!  This file contains the procedures for handling a file of names and
!  addresses and other details.

%constreal linewidth=3.341        ;!  Labelwidth-2*leftmargin.
%recordformat sourcef(%record(sourcef)%name next,prev,
%record(personf)%name atid)
%recordformat sourcelistf(%record(sourcef)%name head,tail)

%ownrecord(line80listf) departmentlist=0
%externalrecord(personlistf) dests1
%constinteger hhmax=55
%conststring(255)%array hh(0:hhmax)= %c
"This requires an address, line by line, ending with an asterisk(*)
on a line by itself.",    { 0}
"This requires the name of the addressee, complete with style, initials,
degrees and honours.
File-names may be included in the form @File. They will be expanded
when the list has been ended with '*' on a line by itself.",    { 1}
"This wants a copy-list of IDs or names, separated by semi-colons (spilling
over several lines), ending with an asterisk(*) on a line by itself.
This list will be printed in the letters.",                      { 2}
"This requires the name of a file containing control data to run the
program for testing.",    { 3}
"This requires the form of name to be used after ""Dear"".",    { 4}
"This requires the degrees and honours of the person, in the usual form
to follow the name.",    { 5}
"This requires the name of the Department. If the name given is CS then
the Department is filled in as Computer Science, the KB address and phone-
number are supplied and so is the University's telex number.",    { 6}
"This requires the senders extension on from 667-1081.",    { 7}
"This requires any comments or other unspecified information.",    { 8}
"This requires the forenames.",    { 9}
"This requires the name and any other information about the sender. It may
spill over several lines. It must end with an asterisk (*)
on a line by itself.",    {10}
"This requires an address in the usual form, ending with an asterisk(*)
on a line by itself.", {11}
"This requires the home telephone number.",    {12}
"This requires an identifier, such as the Vax user-name e.g. KBD.",    {13}
"This requires the interests of the person, one to a line. The sequence
must be ended with an asterisk(*) on a line by itself.",    {14}
"This requires a file-name for the body of the letter. If no file of the name
already exists a new file will be created, otherwise a new version will be
made. The new version can be put into a new file by presenting the form:-
"" oldfile/newfile.""",    {15}
"This requires the sender's reference for this letter.",    {16}
"This requires the name of a file containing details of addressees, as though
they were being presented at the console.",    {17}
"This requires the persons office address in the usual form, terminated
by an asterisk(*) on a line by itself.",    {18}
"This requires the telephone number of the person's office.",    {19}
"This requires the room-number of the person's office in the building in which
his Department is situated.",    {20}
"This requires the style that precedes the person's name.",    {21}
"This requires the person's surname.",    {22}
"This requires the person's telex number.",    {23}
"This requires a list identifying the people who are to receive copies of
the memorandum. The list must consist of IDs or names, separated by
semi-colons. The list may spill over several lines. It must end with an
asterisk(*) on a line by itself.",    {24}
"This requires the reference of the letter to which this is a reply.",    {25}
"This requires the dedication to follow ""Yours"" at the end of the
letter.", {26}
"This requires a file-name for the body of the memorandum. If no file of the
name already exists a new file will be created, otherwise a new version will be
made. The new version can be put into a new file by presenting the form:-
"" oldfile/newfile.""",    {27}
"This requires yes/no. Yes signifies that copies are to be sent to
only those people whose IDs or names have been found in name-file.",    {28}
"You may change any item other than the permanent heading by
answering ""yes"" to the next prompt and ""yes"" to the prompts
for those items you wish to change and ""no"" to the others.",    {29}
"You may decide not to send the documents to the laser-printer at
this late stage. If you answer ""yes"" they will be sent.",    {30}
"This requires the name or the ID of the originator of the memorandum.", {31}
"  The names, addresses, IDs etc that have just been typed will now be
sorted into the name-list. If the answer to this prompt is no, the list will
be closed, if the answer is yes, you will be promped for more information
about people.",                 {32}
"This skips until it finds ""@"" on a line by itself."      {33},
"This prints whatever you put on this line (apart from ""*"").",  {34}
"This will produce a file copy of the letter.",    {35}
"This requires the intials of the person.",    {36}
"This expects a list of recipients, each with the name to be used for the label,
the address, the name to be used after 'Dear' and the form to be used after
'Yours'. The list may be ended by typing '.end' instead of any item.",   {37}
"This expects yes, no or .end as the answer.",      {38}
"This expects the name of a file which contains the letter head ended by an
asterisk(*) on a line by itself.
The default is [sm.head]department.lay (b::office:department on APM)",    {39}
"This expects the heading for the top of the letter, with Layout directives,
ending at the first asterisk(*).",       {40}
"This expects the name of a file of names and addresses.",  {41}
"Do you wish to delete all the output so far created?",     {42}
"This requires the name of an input file of records. The result
will be put into the same file unless an output file is named.",    {43}
"This wants a copy-list of IDs or names, separated by semi-colons (spilling
over several lines), ending with an asterisk(*) on a line by itself.
This list will not be printed in the letters.",    {44}
"This requires the name of the firm with which this person is associated.",{45}
"This requires an answer yes, no or .end, the latter stopping the program.",{46}
"This is for your electronic mail address in the UK form,
e.g.    sm@uk.ac.edinburgh.ecsvax",         {47}
"This wants an answer yes or no. Yes will lead to the file of
names and addresses for labels being sent to the laser printer and
deleted.",           {48}
"This wants an answer yes or no. Yes will lead to the file of
names and addresses for labels being sent to the laser printer and
deleted.",           {49}
"This wants the name of the sender and his description, to be printed
beneath his signature.",   {50}
"This wants an answer yes or no. Yes wil lead to a file copy being
printed.",           {51}
"This wants an answer yes or no. Yes will lead to a file of labels being
created.",           {52}
"Type the number or name of the item you want to change,
or 0 to create letters.Type .end to abandon the program.",    {53}
""(*)
%ownrecord(line40listf) line40list=0
%ownrecord(line80listf) namelist=0
%externalstring(15)%array prt(0:hhmax)= %c
"Address: ",          { 0}
"Addressee: ",        { 1}
"Cc: ",               { 2}
"Datafile: ",         { 3}
"Dear ",              { 4}
"Degrees: ",          { 5}
"Department: ",       { 6}
"Extension: ",        { 7}
"Extra: ",            { 8}
"Forenames: ",        { 9}
"From: ",             {10} {For letters}
"Home address: ",     {11}
"Home phone: ",       {12}
"Id: ",               {13}
"Interests: ",        {14}
"Letter-file: ",      {15}
"My reference: ",     {16}
"Addressee-file:",    {17}
"Office address:",    {18}
"Office phone: ",     {19}
"Room: ",             {20}
"Style: ",            {21}
"Surname: ",          {22}
"Telex: ",            {23}
"To: ",               {24}
"Your reference:",    {25}
"Yours  ",            {26}
"Memo-file: ",        {27}
"Selective? ",        {28}
"Changes? ",          {29}
"Print letters? ",    {30}
"From: ",             {31}  {For memo}
"More people? ",      {32}
"Skip to @: ",        {33}
"Enclosure: ",        {34}
"File copy? ",        {35}
"Initials: ",         {36}
"Recipients: ",       {37}
"More recipients",    {38}
"Heading-file: ",     {39}
"Heading: ",          {40}
"Address-file: ",     {41}
"Delete all? ",       {42}
"Input/output: ",     {43}
"Bcc: ",              {44}
"Firm: ",             {45}
"Delete? ",           {46}
"Emailaddr: ",        {47}
"Print labels? ",     {48}
"Print memos? ",      {49}
"Sent by: ",          {50}
"File copy? ",        {51}
"Create labels? ",    {52}
"Item: ",             {53}
"Printer: ",           {54}
""(*)

%routine trace(%string(255) s)
%owninteger first=yes
%integer oldout
  %if first=yes %thenstart
    open output(2,"trace")
    first=no
  %finish
  oldout=outstream
  select output(2)
  print string(s)
  newline
  select output(oldout)
%end

%routine trace record(%record(*)%name a,%string(255) s)
%integer i,j,k,l
%conststring(1)%array hex(0:15)= "0","1","2","3","4","5","6","7","8","9",
"A","B","C","D","E","F"
  s=s.ssp.ssp.itoh(addr(a))
  %for i=0,1,3 %cycle
    s=s.ssp
    %for j=0,1,1 %cycle
      s=s.ssp
      %for k=0,1,1 %cycle
        l=byteinteger(addr(a)+4*i+2*j+k)
        s=s.hex((l>>4)&16_f).hex(l&16_f)
      %repeat
    %repeat
  %repeat
  trace(s)
%end

%routine praddr(%name a,%string(255) s)
%integer i
  print string(s)
  i=addr(a)
  print string(itoh(i))
  newline
%end

%externalrecord(interestf)%map newinterest
%record(interestf) pattern
%record(interestf)%name p
  p==new(pattern)
  p_next==nil; p_prev==nil
  p_line==nil
  %result==p
%end

%externalrecord(interestlistf)%map newinterestlist
%record(interestlistf) pattern
%record(interestlistf)%name p
  p==new(pattern)
  p_head==nil; p_tail==nil
  %result==p
%end

%externalrecord(line40f)%map newline40
%record(line40f) pattern
%record(line40f)%name p
  p==new(pattern)
  p_next==nil; p_prev==nil
  p_line=""
  %result==p
%end

%externalrecord(line40listf)%map newline40list
%record(line40listf) pattern
%record(line40listf)%name p
  p==new(pattern)
  p_head==nil; p_tail==nil
  %result==p
%end

%externalrecord(line80f)%map newline80
%record(line80f) pattern
%record(line80f)%name p
  p==new(pattern)
  p_next==nil; p_prev==nil
  p_line=""
  %result==p
%end

%externalrecord(line80listf)%map newline80list
%record(line80listf) pattern
%record(line80listf)%name p
  p==new(pattern)
  p_head==nil; p_tail==nil
  %result==p
%end

%externalroutine clear person(%record(personf)%name a)
  a=0
  a_homeaddr_head==nil; a_homeaddr_tail==nil
  a_initials=""
  a_interests==newinterestlist
  a_id=end
  a_next==nil
  a_officeaddr_head==nil; a_officeaddr_tail==nil
  a_prev==nil
  a_extra_head==nil; a_extra_tail==nil
%end

%externalrecord(personf)%map newperson
%record(personf) personpattern
%record(personf)%name p
  p==new(personpattern)
  clear person(p)
  %result==p
%end

%externalrecord(personlistf)%map newpersonlist
%record(personlistf) personlistpattern
%record(personlistf)%name p
  p==new(personlistpattern)
  p_head==nil; p_tail==nil
  %result==p
%end

%externalrecord(sourcef)%map newsource
%record(sourcef) sourcepattern
%record(sourcef)%name p
  p==new(sourcepattern)
  p=0
  p_next==nil; p_prev==nil
  %result==p
%end

%externalrecord(sourcelistf)%map newsourcelist
%record(sourcelistf) sourcelistpattern
%record(sourcelistf)%name p
  p==new(sourcelistpattern)
  p_head==nil; p_tail==nil
  %result==p
%end

%routine out(%string(255) s)
  print string(s.snl)
%end

%externalroutine prec(%record(personf)%name p)
  out(p_id)
  out(p_style)
  out(p_initials)
  out(p_forenames)
  out(p_surname)
%end

%externalroutine preclist(%record(personlistf)%name l,%string(255) s)
%record(personf)%name p
%integer oldout
  message(s,"")
  oldout=outstream
  select output(1)
  out(s.snl)
  %if l_head==nil %then out("L_head points at nil.") %elsestart
    p==l_head
    %while p##nil %cycle
      prec(p)
      newline
      p==p_next
    %repeat
  %finish
  out("L_tail points at nil.") %if l_tail==nil
  out("End of list.".snl)
  select output(oldout)
%end

%externalrecord(interestf)%map insert interest(%record(interestf)%name a,
%record(interestlistf)%name l)
%record(interestf)%name p
  message("Null interest","mon") %if a==nil
  message("Null interest list","mon") %if l==nil
  p==l_head
  p==p_next %while p##nil %and p_line_line<a_line_line
  %result==p %if p##nil %and p_line==a_line
  insert cell before(a,p,l)
  %result==a
%end

%record(line40f)%map insert line40(%record(line40f)%name a,
%record(line40listf)%name l)
%record(line40f)%name p
  message("Null line40","mon") %if a==nil
  message("Null line40list","mon") %if l==nil
  p==l_head
  p==p_next %while p##nil %and p_line<a_line
  %result==p %if p##nil %and p_line=a_line
  insert cell before(a,p,l)
  %result==a
%end

%record(line80f)%map insert line80(%record(line80f)%name a,
%record(line80listf)%name l)
%record(line80f)%name p
  message("Null line80","mon") %if a==nil
  message("Null line80list","mon") %if l==nil
  p==l_head
  p==p_next %while p##nil %and p_line<a_line
  %result==p %if p##nil %and p_line=a_line
  insert cell before(a,p,l)
  %result==a
%end

%routine trim leading spaces(%string(*)%name a)
%integer i,j
  i=1
  i=i+1 %while i<=length(a) %and charno(a,i)=sp
  length(a)=length(a)-i+1
  %for j=1,1,length(a) %cycle
    charno(a,j)=charno(a,i)
    i=i+1
  %repeat
%end

%routine trim trailing spaces(%string(*)%name a)
  length(a)=length(a)-1 %while length(a)>0 %and charno(a,length(a))=sp
%end

%routine trim trailing commas(%string(*)%name a)
  length(a)=length(a)-1 %while length(a)>0 %and charno(a,length(a))=','
%end

%routine trim trailing commas and spaces(%string(*)%name a)
  length(a)=length(a)-1 %while length(a)>0 %c
  %and (charno(a,length(a))=',' %or charno(a,length(a))=sp)
%end

%routine tidy line(%string(*)%name a)
  trim leading spaces(a)
  trim trailing commas and spaces(a)
%end

!  This discards leading spaces.
!  It trims trailing spaces and commas.
!  It trims trailing full stops from the last line.

%routine trim address(%record(line80listf)%name address)
%record(line80f)%name p,q
  p==address_head
  %while p##nil %cycle
    trim trailing commas and spaces(p_line)
    q==p
    p==p_next
    excise cell(q,address) %and dispose(q) %if q_line=""
  %repeat
  %if address_tail##nil %thenstart
    p==address_tail
    length(p_line)=length(p_line)-1 %while length(p_line)>0 %c
    %and charno(p_line,length(p_line))='.'
  %finish
%end

%externalroutine prune and lower(%string(*)%name a)
%integer i,j,k
%constinteger conv='A'-'a'
  %return %if a=""
  j=0
  %for i=1,1,length(a) %cycle
    k=charno(a,i)
    %if k#' ' %thenstart
      j=j+1
      k=k-conv %if 'A'<=k<='Z'
      charno(a,j)=k
    %finish
  %repeat
  length(a)=j
%end

%externalroutine copy address(%record(line80listf)%name a,b)
!  This copies list a to list b.
%record(line80f)%name p,q
 b_head==nil; b_tail==nil
  p==a_head
  %while p##nil %cycle
    q==newline80
    q_line=p_line
    %if b_tail==nil %thenstart
      b_head==q
      b_tail==q
    %finishelsestart
      q_prev==b_tail
      b_tail_next==q
      b_tail==q
    %finish
    p==p_next
  %repeat
%end

%string(255)%fn initials(%string(255) x)
%string(255) y,z
%integer i,j
  z=""
  %while x#"" %cycle
    i=1
    i=i+1 %while i<=length(x) %and letterd(charno(x,i))=no
    %exit %if i>length(x)
    charno(x,j-i+1)=charno(x,j) %for j=i,1,length(x)
    length(x)=length(x)-i+1
    y=x %and x="" %unless x->y.(",").x
    z=z.tostring(charno(y,1))."."
  %repeat
  %result=z
%end

%externalroutine sort persons(%record(personf)%array(1)%name X,%integer n)
%record(personf) temp
%integer i

%routine adjust heap(%integer father,end)
%integer son
  son=2*father
  %return %if son>end
  son=son+1 %if son<end %and (X(son+1)_id>X(son)_id %or %c
  (X(son+1)_id=X(son)_id %and (X(son+1)_surname>X(son)_surname %or %c
  (X(son+1)_surname=X(son)_surname %and X(son+1)_forenames>X(son)_forenames))))
  %if X(father)_id<X(son)_id %or %c
  (X(father)_id=X(son)_id %and (X(father)_surname<X(son)_surname %or %c
  (X(father)_surname=X(son)_surname %and X(father)_forenames<X(son)_forenames))) %thenstart
    temp=X(son); X(son)=X(father); X(father)=temp
    adjust heap(son,end)
  %finish
%end

  %return %if n<=1
  adjust heap(i,n) %for i=n//2,-1,1
  %for i=n,-1,2 %cycle
    temp=X(1); X(1)=X(i); X(i)=temp
    adjust heap(1,i-1)
  %repeat
%end

%externalroutine prune(%string(*)%name a)
  length(a)=length(a)-1 %while length(a)>0 %and (charno(a,length(a))=',' %c
  %or charno(a,length(a))='.' %or charno(a,length(a))=sp)
%end

%externalroutine prune lines(%record(line80listf)%name a)
%record(line80f)%name p,q
  %return %if a_head==nil
  p==a_head
  %while p##nil %cycle
    prune(p_line)
    %if p==nil %thenstart
      q==p
      p==p_prev
      excise cell(q,a)
    %finish
    %if p==nil %then p==a_head %else p==p_next
  %repeat
%end

%string(255)%fn despace(%string(255) a)
%integer i,j
  prune and lower(a)
  j=0
  %for i=1,1,length(a) %cycle
    j=j+1 %and charno(a,j)=charno(a,i) %unless charno(a,i)=sp
  %repeat
  length(a)=j
  %result=a
%end

%routine h(%integer n)
  %if 0 <=n<= hhmax %thenstart
    newline
    print string(hh(n).snl)
    print string( %c
    "This item can be omitted from the letter by replying to the prompt". %c
    " with an asterisk(*).".snl) %unless n=1 %or n=15 %or n=24 %or n=27 %c
    %or n=28 %or n=29 %or n=30 %or n=31
  %finishelse print string("There is no help available for this item.".snl)
%end

%routine read word(%string(*)%name a)
%integer j
  skip symbol %while next symbol=sp %or next symbol=nl
  a=""
  read symbol(j) %and a=a.tostring(j) %while sp#next symbol#nl
%end

%externalintegerfn panswer(%integer n)
%string(255) a
  %on %event 9,15 %start
    message("Input ended while answering ".prt(n),"mon") %if event_event=9
    message(a." found while answering ".prt(n),"stop") %c
    %if event_sub=1
    %signal %event 15,2 %unless event_sub=0
    h(n)
  %finish
  %cycle
    prompt("yes or no: ")
    read word(a)
    lower(a)
    %signal %event 15,1 %unless ".end"#a#"@"
    %signal %event 15,0 %if a="?"
    %result=no %if charno(a,1)=no
    %result=yes %if charno(a,1)=yes
  %repeat
%end

%routine collect(%string(*)%name a,%integer n,skipnl)
%string(255) x
%integer j
  %on %event 15 %start
    %signal %event 15,1 %unless event_sub=0
    h(n)
  %finish

  prompt(prt(n))
  a=""
  skip symbol %while next symbol=sp %or (skipnl=yes %and next symbol=nl)
  %cycle
    read symbol(j)
    %exit %if j=nl
    a=a.tostring(j)
  %repeat
  x=a
  prune and lower(x)
  prune(x)
  %signal %event 15,0 %if x="?"
  a=end %and %signal %event 15,1 %if x=end
%end

!  This deletes leading spaces.
!  It returns "*" if it reads a blank line.

%externalroutine get(%string(*)%name a,%integer n)
  collect(a,n,no)
  a="*" %if a=""
%end

!  This discards leading spaces and leading blank lines.
!  It returns ".end" if it reads ".end" on a line by itself in any
!  combination of cases.

%externalroutine input(%string(*)%name a,%integer n)
  collect(a,n,yes)
%end

%routine outline(%string(7) prefix,%string(80) x,%string(7) postfix,
%string(15) use)
  x="*" %if x="" %and use="file"
  print string(prefix) %if use="layout"
  print string(x)
  print string(postfix) %if use=":tt" %or use="layout"
  newline
%end

!  This looks for a nil link to end an address and then prints a blank line.
!  It prints '*' if the argument record is nil or points at nil.

%externalroutine print address(%record(line80listf)%name address,
%string(15) use)
%record(line80f)%name p
%string(80) x
%string(7) b,c,d
  %if address==nil %or address_head==nil %or address_head_line="" %thenstart
    %if use="file" %then x="*" %else x=""
    outline("",x.snl,"",use)
    %return
  %finish
  %if use="layout" %or use="centre" %then b="$B0 " %else b=""
  %if use="centre" %then use="layout" %and c="$B^0" %else c=""
  p==address_head
  %while p##nil %and p_line#"*"%cycle
    d=""
    %if use="layout" %or use=":tt" %thenstart
!  To end last line of address with full stop.
      %if ','#charno(p_line,length(p_line))#'.' %thenstart
        %if p_next==nil %or p_next_line="*" %then d="." %else d=","
      %finish
    %finish
    outline(b,p_line,d.c,use) %if "*"#p_line#""
    p==p_next
  %repeat
  %if use="file" %then outline("","*","",use) %else newline
%end

!  This prints the non-null and non-asterisk (* alone) lines. It looks
!  for a nil pointer to terminate printing.

%externalroutine print lines(%record(line80listf)%name l)
%record(line80f)%name p
  p==l_head
  %while p##nil %cycle
    print string(p_line.snl)
    p==p_next
  %repeat
%end

%externalroutine print label style
%integer i
%constreal labeldepth=1.575    ;!  Depth of a label in inches.
%constreal labelwidth=3.741    ;!  Width of a label in inches.
%constreal left=0.342        ;!  Margin at left of page of labels.
%constreal leftmargin=0.2    ;!  Margin at left of a label.
%constreal linewidth=3.341    ;!  Labelwidth-2*leftmargin
%constreal top=0.342           ;!  Margin at top of page.
%constreal topmargin=0.2       ;!  Margin at top of label.
%constinteger vertlabels=7     ;!  Maximum number of labels down the page.
  print string("$D.var loc".snl)
  print string("$J0".snl)
  print string("$D.FORMAT Labelpage".snl)
  %for i=0,1,vertlabels-1 %cycle
    print string("=$O".rtod(leftmargin,1,3).""",". %c
    rtod(topmargin+i*labeldepth,1,3).""",3.341"",1.175""[]".snl)
    print string("=$O".rtod(leftmargin+labelwidth,1,3).""",". %c
    rtod(topmargin+i*labeldepth,1,3).""",3.341"",1.175""[]".snl)
  %repeat
  print string("=$C".snl)
  print string("=$Labelpage".snl)
  print string( %c
  "$M".rtod(left,1,3).""",".rtod(top,1,3).""",". %c
  rtod(8.2-2*left,1,3).""",".rtod(11.5-2*top,1,3)."""".snl)
  print string("$Labelpage".snl)
%end

%externalrealfn printlength(%string(255) s,%string(31) font)
%constinteger fontno=1
%conststring(31)%array fontname(1:fontno)="hershey"
%constbyteintegerarray scalable(1:fontno)=yes
%realarrayname h
%constrealarray hersheywidth(0:255)= %c
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
866,600,866,1000,1066,1133,1200,533,
733,733,733,1266,600,1266,600,1066,
933,933,933,933,933,933,933,933,
933,933,600,600,1133,1266,1133,933,
1200,1000,1133,1000,1133,1066,1000,1133,
1200,666,866,1133,933,1333,1133,1066,
1066,1066,1133,1066,1066,1200,1000,1266,
1066,933,933,733,1066,733,1133,866,
533,1000,1066,866,1066,866,800,933,
1200,666,666,1133,666,1733,1200,933,
1066,1000,933,933,800,1200,1000,1266,
1000,1000,866,733,466,733,1133,0,
0(*)
%string(31) y
%real x
%integer i,flag,n
  lower(font)
  flag=no
  %for i=1,1,fontno %cycle
    flag=yes %and %exit %if font->(fontname(i)).y
  %repeat
  %if flag=no %thenstart
    font="hershey"
    n=10
    h==hersheywidth
  %finishelsestart
    %if scalable(i)=yes %thenstart
      n=dtoi(y)
      h==hersheywidth
    %finishelsestart
!  A fudge until IMP V3 is available.
      n=10
      h==hersheywidth
    %finish
  %finish
  x=0
  %for i=1,1,length(s) %cycle
    x=x+Hersheywidth(charno(s,i))
  %repeat
  x=x*n/100000
  %result=x
%end

%externalroutine print label(%record(line80listf)%name b)
%record(line80listf) a,aa
%real c,d
%ownstring(31) font
%owninteger horizlabels=2    ;!  Maximum number of labels across the page.
%integer i,j,k,l
%owninteger labelno=1        ;!  Number of label across the page.
%integer m
%constinteger maxpts=14      ;!  Largest type size for labels.
%constinteger minpts=6       ;!  Smallest type size for labels.
%record(line80f)%name p
%ownreal pagewidth=7.48      ;!  Width of the page in inches.
%ownreal pagedepth=11.7      ;!  Depth of the page in inches.
%constreal printdepth=1.175  ;!  Labeldepth-2*topmargin
%record(line80f)%name q
%owninteger rowno=1          ;!  Number of label down the page.
%ownreal slope=0.00          ;!  Indentation per line of address.
%string(255) u

%routine set max(%record(line80listf)%name b,%realname chars,
%integername lines,%integer points)
%real x
%record(line80f)%name p,q
  p==b_tail
  %while p##nil %cycle
    %if p_line="" %thenstart
      q==p
      p==p_prev
      excise cell(q,b)
      dispose(q)
    %finishelse p==p_prev
  %repeat
  chars=0
  p==b_head
  lines=0
  %while p##nil %cycle
    x=printlength(p_line,"hershey".itod(points))
    chars=x %if chars<x
    lines=lines+1
    p==p_next
  %repeat
%end

%integerfn split lines(%record(line80listf)%name b,aa,%integer s)
%record(line80f)%name p,q,r
%real xx
%integer breaks,charsj,k,m
  aa_head==nil; aa_tail==nil
  breaks=no
  p==b_head
  %while p##nil %cycle
!  Create marker for line.
    r==newline80
    append cell(r,aa)
    xx=printlength(p_line,"hershey".itod(s))
    %while xx>linewidth %cycle
      breaks=yes
!  Fix alignment point for rest of line.
{      r_line="$loc=X"}
      r_line=""
!  Locate break-point in line.
      m=length(p_line)
      q==newline80
      q_line=p_line
      %cycle
        m=m-1 %until m=0 %or charno(q_line,m)=sp
        length(q_line)=m
        xx=printlength(q_line,"Hershey".itod(s))
      %repeat %until m=0 %or xx<linewidth
      %if m=0 %thenstart
!  No space to use as break-point.
        %for m=length(p_line),-1,1 %cycle
          length(q_line)=m
          %exit %if printlength(q_line,"hershey".itod(s))<linewidth
        %repeat
      %finish
!  Move first line's worth to become previous line.
      p_line->(q_line).p_line
!  Trim first part of line and insert.
      length(q_line)=length(q_line)-1 %while charno(q_line,length(q_line))=sp
      insert cell before(q,p,b)
!  Align last fragment to fix-point from previous line.
      r==newline80
{      r_line="$X>loc"}
      r_line="$B>0"
      append cell(r,aa)
    %repeat
    p==p_next
  %repeat
  %result=breaks
%end

%integerfn scale(%record(line80listf)%name b,aa)
%record(line80listf) a
%record(line80f)%name p
%integer breaks,i,j,s
  %for s=maxpts,-1,minpts-1 %cycle
    copy address(b,a)
    breaks=split lines(a,aa,s)
    i=0; p==a_head
    %while p##nil %cycle
      i=i+1
      p==p_next
    %repeat
!  Hershey(10) has a line-depth of 0.14".
    %exit %if i*s<=printdepth*70 %and (breaks=0 %or s<=10)
    delete list(a)
    delete list(aa)
  %repeat
  %if s<minpts %thenstart
    select input(0); select output(0)
    print address(b,":t")
    message("is too large for a label.","stop")
  %finish
  delete list(b)
  copy address(a,b)
  %result=s
%end

  %return %if b==nil
!  Remove trailing blank lines.
  p==b_tail
  %return %if p==nil
  %while p_prev##nil %and (p_line="*" %or p_line="") %cycle
    q==p
    p==p_prev
    dispose(q)
  %repeat
  %if p_line="*" %or p_line="" %then %c
  b_head==nil %and b_tail==nil %and dispose(p) %else b_tail==p
!  Deal with 'D/-'.
  p==b_head
  u=p_line
  lower(u)
  %if u="d/-" %then u=p_line."$B>0" %else u=""
!  Punctuate lines.
  p==b_head
  %while p##nil %cycle
    %if '.'#charno(p_line,length(p_line))#',' %thenstart
      %if p_next==nil %then p_line=p_line."." %else p_line=p_line.","
    %finish
    p==p_next
  %repeat
!  Replace 'D/-'.
  p==b_head
  p_line=u %unless u=""
!  Plant font and size.
  aa_head==nil; aa_tail==nil
  font="$Hershey(".itod(scale(b,aa)).")"
  print string(font.snl)
  p==b_head; q==aa_head
  %while p##nil %cycle
    %if p==b_head %then u="" %else u="$B0 "
    u=u.p_line.q_line.snl
    print string(u)
    p==p_next; q==q_next
  %repeat
  print string("$C".snl)
%end

!  This looks for an asterisk(*) to end an address. It replaces it with a 
!  nil pointer 'next' on the last line stored.
!  If the whole address is "*", it is replaced by nil in both the head and tail
!  of the head-cell.
!  It skips leading spaces in each line.

%externalroutine get lines(%record(line80listf)%name lines,%integer n)
%record(line80f)%name p
%string(80) a,x
  lines_head==nil; lines_tail==nil
  %cycle
    get(a,n)
    message("Stopped while getting ".prt(n),"stop") %if a=end
    a="*" %if a="" %or a="@"
    %exit %if a="*"
    p==newline80
    p_line=a
    append cell(p,lines)
  %repeat
%end

%externalroutine input lines(%record(line80listf)%name lines,%integer n)
%record(line80f)%name p
%string(80) a
  lines_head==nil; lines_tail==nil
  input(a,n)
  %cycle
    message("Stopped while inputting ".prt(n),"stop") %if a=end
    a="*" %if a="" %or a="@"
    %exit %if a="*"
    p==newline80
    p_line=a
    append cell(p,lines)
    get(a,n)
  %repeat
%end

%externalroutine get address(%record(line80listf)%name address,%integer n)
%record(line80f)%name p
  get lines(address,n)
  trim address(address)
%end

%externalroutine input address(%record(line80listf)%name address,%integer n)
  input lines(address,n)
  trim address(address)
%end

%externalroutine print person(%record(personf)%name a,%string(15) use)
%record(interestf)%name b
%string(255) x
  %return %if a_id=end
  %if use=":tt" %thenstart
    print string(a_style." ") %if ""#a_style#"*"
    %if ""#a_forenames#"*" %then x=a_forenames." " %else x=a_initials
    print string(x) %if ""#x#"*"
    print string(a_surname)
    print string(",".a_degrees) %if ""#a_degrees#"*"
    newline
  %finishelsestart
!  Surname.
    outline("",a_surname,"",use)
!  Style.
    outline("",a_style,"",use)
!  Forenames.
    outline("",a_forenames,"",use)
!  Initials.
  outline("",a_initials,"",use)
!  Degrees.
    outline("",a_degrees,"",use)
  %finish
!  Home address.
  print address(a_homeaddr,use)
!  Home Telephone number.
  outline("",a_homephone,"",use)
!  ID.
  outline("",a_id,"",use)
!  Firm.
  outline("",a_firm_line,"",use)
!  Department.
  outline("",a_department_line,"",use)
!  Room.
  outline("",a_room,"",use)
!  Office address.
  print address(a_officeaddr,use)
!  Office Telephone number.
  outline("",a_officephone,"",use)
!  Extension.
  outline("",a_ext,"",use)
!  Mail address.
  outline("",a_emailaddr,"",use)
!  Telex number.
  outline("",a_telex,"",use)
!  Interests.
  %if a_interests##nil %thenstart
    b==a_interests_head
    %while b##nil %cycle
      %exit %unless ""#b_line_line#"*"
      outline("",b_line_line,"",use)
      b==b_next
    %repeat
  %finish
  print string("*") %if use="file"
  newline
!  Extra.
  print lines(a_extra)
!  Terminate record.
  outline("",snl."@".snl.snl,"",use)
%end

!  This returns a cleared record if '.end' is the only word on a line.
!  It assumes that each address ends with an asterisk(*) on a line by itself.
!  It assumes that each record is followed by '@'.

%externalroutine read person(%record(personf)%name a)
%record(interestf)%name b
%record(line40f)%name c
%record(line80f)%name d
%string(80) x
%integer i

  %on %event 9,15 %start
    clear person(a)
    %return
  %finish

  clear person(a)
!  Surname.
  input(a_surname,22)
  prune(a_surname)
  a_surname="*" %if a_surname=""
  clear person(a) %and %return %if a_surname="@"
!  Style.
  get(a_style,21)
  a_style="*" %if a_style=""
!  Forenames.
  get(a_forenames,9)
  a_forenames="*" %if a_forenames=""
!  Initials.
  get(a_initials,36)
  a_initials="*" %if a_initials=""
!  Degrees.
  get(a_degrees,5)
  a_degrees="*" %if a_degrees=""
!  Home address.
  get address(a_homeaddr,11)
!  Home Telephone number.
  get(a_homephone,12)
  a_homephone="*" %if a_homephone=""
!  ID.
  get(a_id,13)
  a_id="*" %if a_id=""
!  Firm.
  get(a_firm_line,45)
  a_firm_line="*" %if a_firm_line=""
!  Department.
  get(a_department_line,6)
  a_department_line="*" %if a_department_line=""
!  Room.
  get(a_room,20)
  a_room="*" %if a_room=""
!  Office address.
  x=a_department_line; prune and lower(x)
  %if x="cs" %thenstart
    %for i=1,1,6 %cycle
      d==newline80
      d_line=univaddr(i)
      append cell(d,a_officeaddr)
    %repeat
    a_officephone="(031) 667 1081"
  %finishelsestart
    get address(a_officeaddr,18)
!  Office Telephone number.
    get(a_officephone,19)
    a_officephone="*" %if a_officephone=""
  %finish
!  Extension.
  get(a_ext,7)
  a_ext="*" %if a_ext=""
!  Mail address.
  get(a_emailaddr,47)
  a_emailaddr="*" %if a_emailaddr=""
!  Telex number.
  %if x="cs" %then a_telex="727442 (UNIVED G)" %and %c
  a_department_line="Computer Science" %else get(a_telex,23)
  a_telex="*" %if a_telex=""
!  Interests, up to an asterisk(*).
    a_interests==newinterestlist
  %cycle
    b==newinterest
    c==newline40
    get(c_line,14)
    c_line="*" %if c_line="" %or c_line="@"
    %exit %if c_line="*"
    b_line==insert line40(c,line40list)
    b==insert interest(b,a_interests)
  %repeat
!  Extra. This must end with an asterisk(*) on a line by itself.
  get lines(a_extra,8)
!  Skip to "@".
  input(x,33) %until x="@"
%end

!  This appends b to a and sets b to nil.

%externalroutine concatpersonlists(%record(personlistf)%name a,b)
  b==nil %and %return %if b==nil %or b_head==nil
  a==b %and b==nil %and %return %if a==nil %or a_head==nil
  a_tail_next==b_head
  b_head_prev==a_tail
  a_tail==b_tail
  b==nil
%end

%externalroutine concatsourcelists(%record(sourcelistf)%name a,b)
  b==nil %and %return %if b==nil %or b_head==nil
  a==b %and b==nil %and %return %if a==nil %or a_head==nil
  a_tail_next==b_head
  b_head_prev==a_tail
  a_tail==b_tail
  b==nil
%end

%externalroutine exciseinterest(%record(interestf)%name p,
%record(interestlistf)%name l)
  %return %if p==nil %or l==nil %or l_head==nil
  %if l_head==p %thenstart
    l_head==l_head_next
    %if l_head==nil %then l_tail==nil %else l_head_prev==nil
    p_next==nil; p_prev==nil
    %return
  %finish
  %if l_tail==p %thenstart
    l_tail==l_tail_prev
    %if l_tail==nil %then l_head==nil %else l_tail_next==nil
    p_next==nil; p_prev==nil
    %return
  %finish
  p_prev_next==p_next
  p_next_prev==p_prev
  p_next==nil; p_prev==nil
%end

%externalroutine exciseline40(%record(line40f)%name p,
%record(line40listf)%name l)
  %return %if p==nil %or l==nil %or l_head==nil
  %if l_head==p %thenstart
    l_head==l_head_next
    %if l_head==nil %then l_tail==nil %else l_head_prev==nil
    p_next==nil; p_prev==nil
    %return
  %finish
  %if l_tail==p %thenstart
    l_tail==l_tail_prev
    %if l_tail==nil %then l_head==nil %else l_tail_next==nil
    p_next==nil; p_prev==nil
    %return
  %finish
  p_prev_next==p_next
  p_next_prev==p_prev
  p_next==nil; p_prev==nil
%end

%externalroutine exciseline80(%record(line80f)%name p,
%record(line80listf)%name l)
  %return %if p==nil %or l==nil %or l_head==nil
  %if l_head==p %thenstart
    l_head==l_head_next
    %if l_head==nil %then l_tail==nil %else l_head_prev==nil
    p_next==nil; p_prev==nil
    %return
  %finish
  %if l_tail==p %thenstart
    l_tail==l_tail_prev
    %if l_tail==nil %then l_head==nil %else l_tail_next==nil
    p_next==nil; p_prev==nil
    %return
  %finish
  p_prev_next==p_next
  p_next_prev==p_prev
  p_next==nil; p_prev==nil
%end

%externalroutine exciseperson(%record(personf)%name p,
%record(personlistf)%name l)
  %return %if p==nil %or l==nil %or l_head==nil
  %if l_head==p %thenstart
    l_head==l_head_next
    %if l_head==nil %then l_tail==nil %else l_head_prev==nil
    p_next==nil; p_prev==nil
    %return
  %finish
  %if l_tail==p %thenstart
    l_tail==l_tail_prev
    %if l_tail==nil %then l_head==nil %else l_tail_next==nil
    p_next==nil; p_prev==nil
    %return
  %finish
  p_prev_next==p_next
  p_next_prev==p_prev
  p_next==nil; p_prev==nil
%end

%externalroutine excisesource(%record(sourcef)%name p,
%record(sourcelistf)%name l)
  %return %if p==nil %or l==nil %or l_head==nil
  %if l_head==p %thenstart
    l_head==l_head_next
    l_head_prev==nil %unless l_head==nil
    p_next==nil; p_prev==nil
    %return
  %finish
  %if l_tail==p %thenstart
    l_tail==l_tail_prev
    l_tail_next==nil
    p_next==nil; p_prev==nil
    %return
  %finish
  p_prev_next==p_next
  p_next_prev==p_prev
  p_next==nil; p_prev==nil
%end

!  This inserts list a before item p in b.

%externalroutine insertpersonlistbefore(%record(personlistf)%name a,b,
%record(personf)%name p)
  %return %if a==nil %or a_head==nil
  %if b==nil %thenstart
    b==newpersonlist
    b=a
    %return
  %finish
  %if b_head==nil %then b=a %and %return
  %if p==nil %or p_prev==nil %thenstart
    a_tail_next==b_head
    b_head_prev==a_tail
    b_head==a_head
    %return
  %finish
  a_head_prev==p_prev
  a_tail_next==p
  p_prev_next==a_head
  p_prev==a_tail
%end

!  This inserts list a before item p in b.

%externalroutine insertsourcelistbefore(%record(sourcelistf)%name a,b,
%record(sourcef)%name p)
  %return %if a==nil %or a_head==nil
  %if b==nil %thenstart
    b==newsourcelist
    b=a
    %return
  %finish
  %if b_head==nil %then b=a %and %return
  %if p==nil %or p_prev==nil %thenstart
    a_tail_next==b_head
    b_head_prev==a_tail
    b_head==a_head
    %return
  %finish
  a_head_prev==p_prev
  a_tail_next==p
  p_prev_next==a_head
  p_prev==a_tail
%end

%externalroutine insert line80list before(%record(line80listf)%name a,b,
%record(line80f)%name p)
  %return %if a==nil %or a_head==nil
  message("Cannot insert in an unassigned list.","mon") %if b==nil
  %if b_head==nil %then b=a %and %return
  %if p==nil %or p_prev==nil %thenstart
    a_tail_next==b_head
    b_head_prev==a_tail
    b_head==a_head
    a_head==nil; a_tail==nil
    %return
  %finish
  a_head_prev==p_prev
  a_tail_next==p
  p_prev_next==a_head
  p_prev==a_tail
  a_head==nil; a_tail==nil
%end


%externalroutine print personlist(%record(personlistf) a,%string(80) s)
%record(personf)%name p
%integer oldout
  oldout=outstream
  select output(0)
  print string(s.snl)
  print string("Personlist empty".snl) %and %return %if %c
  a==nil %or a_head==nil
  p==a_head
  %while p##nil %cycle
    print person(p," ")
    p==p_next
  %repeat
  print string(snl."End of list of persons.".snl)
  select output(oldout)
%end

%externalroutine reedit person(%record(personf)%name a)
%record(line80f)%name p,q
%record(interestf)%name b
%record(line40f)%name c
%integer n
  %on %event 15 %start
    message("Stopped from input while Changing ".prt(n),"stop")
  %finish
  message( %c
  "For each item that may be changed you will be shown the prompt and".snl.%c
  "the current value. Respond with yes if you wish to change its value,".snl. %c
  "respond with no otherwise.","")
!  Style.
  n=21
  print string(prt(21).a_style.snl)
  get(a_style,21) %if panswer(21)=yes
!  Forenames.
  n=9
  %if a_forenames="" %then print string("No forename.".snl) %c
  %else print string(prt(9).a_forenames.snl)
  get(a_forenames,9) %if panswer(9)=yes
!  Initials.
  %if a_initials="" %then print string("No initials".snl) %c
  %else print string(prt(36).a_initials.snl)
  get(a_initials,36) %if panswer(36)=yes
!  Surname.
  n=22
  print string(prt(22).a_surname.snl)
  input(a_surname,22) %if panswer(22)=yes
  prune(a_surname)
!  Degrees.
  n=5
  print string(prt(5).a_degrees.snl)
  get(a_degrees,5) %if panswer(5)=yes
!  Home address.
  n=11
  print string(prt(11).snl)
  print address(a_homeaddr,":tt")
  %if panswer(11)=yes %thenstart
    p==a_homeaddr_head
    %while p##nil %cycle
      q==p_next
      dispose(p)
      p==q
    %repeat
    get address(a_homeaddr,11)
  %finish
!  Home Telephone number.
  n=12
  print string(prt(12).a_homephone.snl)
  get(a_homephone,12) %if panswer(12)=yes
!  ID.
  n=13
  print string(prt(13).a_id.snl)
  get(a_id,13) %if panswer(13)=yes
!  Department.
  n=6
  print string(prt(6).a_department_line.snl)
  get(a_department_line,6) %if panswer(6)=yes
!  Room.
  n=20
  print string(prt(20).a_room.snl)
  get(a_room,20) %if panswer(20)=yes
!  Office address.
  n=18
  print string(prt(18).snl)
  print address(a_officeaddr,":tt")
  %if panswer(18)=yes %thenstart
    p==a_officeaddr_head %and exciseline80(p,a_officeaddr) %and dispose(p) %c
    %while a_officeaddr_head##nil
    get address(a_officeaddr,18)
  %finish
!  Office Telephone number.
  n=19
  print string(prt(19).a_officephone.snl)
  get(a_officephone,19) %if panswer(19)=yes
!  Extension.
  n=7
  print string(prt(7).a_ext.snl)
  get(a_ext,7) %if panswer(7)=yes
!  Telex number.
  n=23
  print string(prt(23).a_telex.snl)
  get(a_telex,23) %if panswer(23)=yes
!  Interests, up to asterisk (*).
  n=14
  print string(prt(14).snl)
  b==a_interests_head
  %while b##nil %cycle
    %exit %if b_line_line=""
    outline("",b_line_line,"",":tt")
    b==b_next
  %repeat
  %if panswer(14)=yes %thenstart
    b==a_interests_head %and exciseinterest(b,a_interests) %and dispose(b) %c
    %while a_interests_head##nil
    %cycle
      b==newinterest
      c==newline40
      get(c_line,14)
      c_line="" %if c_line="@"
      %exit %if c_line=""
      b_line==insert line40(c,line40list)
      b==insert interest(b,a_interests)
    %repeat
  %finish
!  Extra. This must end with an asterisk(*) on a line by itself.
  n=8
  print string(prt(8).snl)
  print lines(a_extra)
  get lines(a_extra,8) %if panswer(8)=yes
%end

%externalroutine identify(%record(personlistf)%name noname,
%string(255) namelist,%integer control)
%record(personf)%name p
%record(personf) person
%string(255) u,v,w,x,y,z
%integer ct
  %return %if noname_head==nil %or namelist=""
  open input(3,namelist)
  select input(3)
  ct=0
  p==noname_head
  %while p##nil %cycle
    ct=ct+1
    p==p_next
  %repeat
  %while ct>0 %cycle
    read person(person)
    z=despace(person_id)
    %exit %if z=end
    x=despace(person_surname)
    y=despace(person_initials).x
    w=despace(person_style).y
!  Match person id and name against IDs and names in noname.
    p==noname_head
    %while p##nil %cycle
      u=despace(p_surname)
      v=despace(p_id)
      %if (u#"" %and ( u=z %or u=y %or u=x %or u=w)) %c
      %or (v#"" %and ( v=z %or v=y %or v=x %or v=w)) %thenstart
!  Noname record recognised. Fill details into record in 'noname'.
        p_id=person_id; p_surname=person_surname
        p_style=person_style; p_forenames=person_forenames
        p_initials=person_initials; p_degrees=person_degrees
        p_department=person_department; p_room=person_room
        p_officeaddr=person_officeaddr
        ct=ct-1
        %exit
      %finish
      p==p_next
    %repeat
  %repeat
  close input
  select input(control)
%end

!  The values of n are: 2 for Cc with letters, 24 for To with memoranda.
%externalroutine isolate ids(%record(line80listf)%name l)
%record(line80f)%name p,q
%string(80) s
  p==l_head
  %while p##nil %cycle
    s=p_line
    %while s#"" %cycle
      q==newline80
      q_line=s %and s="" %unless s->q_line.(";").s
      insert cell before(q,p,l)
    %repeat
    q==p; p==p_next
    excise cell(q,l)
    dispose(q)
  %repeat
%end

%integerfn pick up files(%record(line80listf)%name l,%integer n,control)
%record(line80listf) x
%record(line80f)%name p,q
%string(80) s
%integer flag
  flag=no
  p==l_head
  %while p##nil %cycle
    %if p_line->("@").s %thenstart
      %cycle
        %exit %if exists(s)
        message( %c
        s." does not exist. Do you want to replace it?","")
        %if panswer(41)=yes %then get(s,41) %else s=""
        %exit %if s=""
      %repeat
      %if s="" %then p==p_next %elsestart
        flag=yes
        q==p_prev
        open input(3,s)
        select input(3)
        get lines(x,n)
        close input
        select input(control)
        %if x_head##nil %thenstart
          isolate ids(x)
          insert line80list before(x,l,p)
          excise cell(p,l)
          dispose(p)
        %finish
        %if q==nil %then p==l_head %else p==q_next
      %finish
    %finishelse p==p_next
  %repeat
  %result=flag
%end

%externalroutine get recipients( %c
%record(personlistf)%name noname,%integer n,control)
%record(line80listf) x
%record(line80f)%name p,q
%record(personf)%name r
%integer flag
!  Get top level of names of recipients.
  select input(control)
  get lines(x,n)
  isolate ids(x)
  flag=pick up files(x,n,control) %until flag=no
!  Copy to Dests1 for use in file-copies.
  dests1_head==nil; dests1_tail==nil
  p==x_head
  %while p##nil %cycle
    r==newperson
    r_id=p_line
    q==newline80
    q_line=p_line
    append cell(q,r_extra)
    append cell(r,dests1)
    p==p_next
  %repeat
!  Copy to Noname.
  noname_head==nil; noname_tail==nil
  p==x_head
  %while p##nil %cycle
    r==newperson
    r_id=p_line
    q==newline80
    q_line=p_line
    append cell(q,r_extra)
    append cell(r,noname)
    p==p_next
  %repeat
  delete list(x)
%end


%endoffile